C THIS ROUTINE IS THE MAIN PROGRAM FOR MOLSCAT VERSION 14 C WITH DYNAMIC SPACE ALLOCATION CAPABILITY. C C INCREASE MXDIM AS NECESSARY TO PROVIDE SUFFICIENT WORKSPACE. C IXNEXT,NIPR ARE INITIALIZED IN DRIVER C IVLFL IS ALSO SET IN DRIVER; COULD BE CHANGED BY BASIN ROUTINES C PARAMETER (MXDIM=250000) DOUBLE PRECISION X DIMENSION X(MXDIM) COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X C MX=MXDIM C C CALL PRINCIPAL MOLSCAT/BOUND SUBROUTINE C CALL DRIVER STOP END SUBROUTINE DRIVER C*********************************************************************** C C ------ MOLSCAT - J.M. HUTSON AND S.GREEN - VERSION 14 - JUL 94 ----- C C MAIN DRIVER FOR QUANTUM MOLECULAR SCATTERING PROGRAM C C REVISION HISTORY SINCE VERSION 7 OF SHELDON GREEN'S QCPE PROGRAM C (MAY 79): C C VARIOUS NEW PROPAGATORS HAVE BEEN ADDED SINCE EARLY VERSIONS. C THE COMPLETE LIST IN VERSION 12 IS: C C INTFLG =-1 : WKB METHOD FOR SINGLE CHANNEL, SINGLE TURNING POINT C INTFLG = 2 : DEVOGELAERE'S PROPAGATOR C INTFLG = 3 : WALKER-LIGHT R-MATRIX PROPAGATOR C INTFLG = 4 : HYBRID LOG-DERIVATIVE / VIVS (VIVAS) PROPAGATOR C INTFLG = 5 : JOHNSON'S LOG-DERIVATIVE PROPAGATOR C INTFLG = 6 : MANOLOPOULOS'S DIABATIC MODIFIED C LOG-DERIVATIVE PROPAGATOR C INTFLG = 7 : MANOLOPOULOS'S QUASIADIABATIC MODIFIED C LOG-DERIVATIVE PROPAGATOR C INTFLG = 8 : ALEXANDER-MANOLOPOLOUS MODIFIED LOG-DERIVATIVE C AIRY PROPAGATOR (HIBRIDON) C VERSION 8: CHANGES MADE BY CHRIS ASHTON (1982) AND JEREMY HUTSON C (1982-4) AT WATERLOO AND CAMBRIDGE UNIVERSITIES. C C (1) ENTIRE PROGRAM CONVERTED TO DOUBLE PRECISION C C (2) GORDON ALGORITHM (INTFLG=1) REMOVED. C C (3) LOOP OVER "PARITY CASES" IN DRIVER HAS BEEN MADE EXPLICIT C FOR CLARITY. C C (4) EIGENPHASE SUM CALCULATION AND RESONANCE SEARCH OPTION C INCORPORATED. NEW OUTPUT CHANNEL (KSAVE) WITH OPTIONAL C UNFORMATTED OUTPUT ON CHANNEL ISAVEU. C C (5) COLLISION TYPE ITYPE=10*N+7 HAS BEEN ADDED, C FOR AN ATOM HITTING A DIATOMIC VIB-ROTOR, WHERE THE C POTENTIAL MATRIX IS CONSTRUCTED BY DOING PROPERLY THE C AVERAGING OF POTENTIAL TERMS OVER (V,J) AND (V',J') DIATOM C INTERNAL STATES. C C (6) COLLISION TYPE ITYPE=8 ADDED, FOR ELASTIC SCATTERING OF ATOMS C FROM CORRUGATED SURFACES. USES SUBROUTINE SURBAS TO SET UP C THE BASIS SET. THE LOOPS IN DRIVER OVER JTOT AND M ARE USED C TO LOOP OVER ANGLES THETA AND PHI RESPECTIVELY. C C (7) THE STORAGE OF THE COUPLING ARRAY VL HAS BEEN REARRANGED. THE C METHOD OF CONSTRUCTING POTENTIAL MATRICES FROM IT HAS BEEN C CHANGED, AND IN PARTICULAR A NEW INDEXING ARRAY IV HAS BEEN C INTRODUCED. C C*********************************************************************** C C VERSION 9 (APR 86): JMH AND SG CODES UNIFIED C C (9) IOS CODE RE-INCORPORATED FROM SG'S PROGRAM. C IT IS ACCESSED BY SETTING ITYPE = 100 + 'ITYPE' C C (10) MANOLOPOULOS'S DIABATIC AND ADIABATIC MODIFIED LOG-DERIVATIVE C PROPAGATORS ADDED (INTFLG=6 AND 7 RESPECTIVELY). C C*********************************************************************** C C SG VERSION 10 (AUG 91): C C (10) NEW PRBR/IOSPB FOR OFF-DIAGONAL LINESHAPE CROSS SECTIONS, C WITH HAS IN-CORE SIMULATION OF DIRECT ACCESS FILES. C OUTPUT CROSS-SECTIONS NOW MULTIPLIED BY JSTEP (FOR JTOT). C C (11) ALEXANDER/MANOLOPOULOS MODIFIED LOG-DERIVATIVE/AIRY PROPAGATOR C ADDED AS INTFLG=8. INTERFACED BY TIM PHILLIPS (NASA/GISS) C C VERSION 11 (JUN 92): JMH AND SG CODES INTEGRATED AGAIN. C C (12) LOOP OVER ENERGY IN DRIVER MODIFIED TO SIMPLIFY PARALLELISATION C C (13) ISAVEU OUTPUT MODIFIED TO USE UNFORMATTED WRITES C C (14) USAGE OF LINEAR ALGEBRA AND BLAS ROUTINES UNIFIED C C AND THE FOLLOWING ENHANCEMENTS ADDED FROM JMH'S CODE: C C (15) BASE9 INTERFACE ADDED C C (16) POTENL ENHANCED TO EVALUATE RADIAL STRENGTH FUNCTIONS BY C QUADRATURE FOR ITYPE=1, 2, 5 AND 6. C C (17) CODE ADDED TO CALCULATE ASYMMETRIC TOP ENERGIES AND WAVEFUNCTION C FROM ROTATIONAL CONSTANTS. MECHANISM FOR SELECTING ASYMMETRIC C TOP STATES TO BE INCLUDED GENERALISED C C (18) CODE FOR ATOM-SPHERICAL TOP SCATTERING ADDED C C*********************************************************************** C C VERSION 12 (MAY 93) C C (19) DYNAMIC STORAGE HANDLING COMPLETELY REORGANIZED. C C (20) VECTOR/MATRIX ROUTINES RATIONALIZED TO USE LAPACK AND BLAS. C C (21) IV() ARRAY USED ONLY FOR 'NON-TRIVIAL' CASES. C C (22) OPTION TO WRITE VL ARRAY TO DISC TO AVOID EXCESSIVE MEMORY USE. C C (23) SOME CODE FOR COUPLING VL MATRIX ELEMENTS MODIFIED TO AVOID C UNNECESSARY RECALCULATION OF NJ COEFFICIENTS C C*********************************************************************** C C VERSTION 13 (SG EXPERIMENTAL VERSION) APR 94, BUT CONTAINED IN V14 C C (24) IV ARRAY INTRODUCED FOR ITYPE=2 CASES C C (25) EXPANDED POTENL CAPABILITIES C C (26) BIGGER DIMENSIONS: /CMBASE/ ...ELEVEL(1000),...,JLEVEL(4000),... C ALSO ADD ISYM(10),ISYM2(10); REORGANIZED ORDERING C C (27) CHANGES TO CALLING SEQUENCE FOR OUTINT/OUTPCH; IEXCH NOW CORRECT C ON ISAVEU TAPE; BASE/OUTPCH RECOGNIZE CS SIGMA WHICH ARE C NOT COMPLETE. C C*********************************************************************** C C VERSION 14 (JUL 94) C C (28) ISAVEU TAPE FORMAT CHANGE: NOPEN WITH JTOT,INRG,...,M,NOPEN REC C C (29) FILE='FILENAME' REMOVED FROM OPEN STATEMENTS C C (30) FLAG FOR NCAC,DTOL,OTOL INCREASED TO JTOTU=999999 C C (31) RESTART ABILITIES (IRSTRT) FROM ISAVEU C C (32) ITYPE=4 CODE (ASYMMETRIC TOP - LINEAR ROTOR) ADDED C C (33) COMMON /CMBASE/ ALTERED TO ALLOW MORE SPACE FOR LEVELS AND C INTRODUCE EXTRA INPUT VARIABLES FOR HANDLING FUTURE EXTENSIONS. C THIS CHANGE REQUIRES SIMILAR CHANGES IN BASE9 ROUTINES. C C (34) HANDLING OF TOTAL ENERGIES CHANGED IN PRESSURE BROADENING WITH C IFEGEN=2 OPTION: AVOID CALCULATING S MATRICES THAT ARE NOT USED. C C*********************************************************************** C C EXTERNAL UNITS FOR MASSES ARE ATOMIC MASS UNITS (CARBON MASS/12) C EXTERNAL UNITS FOR ENERGIES ARE WAVENUMBERS C EXTERNAL UNITS FOR LENGTH RM ARE ANGSTROMS C ALL OTHER LENGTHS ARE IN UNITS OF RM C C INTFLG CONTROLS METHOD OF SOLVING EQUATIONS. NPOTL AND MXLAM C FOR SUM OVER ANGULAR DEPENDENCE OF POTENTIAL, NQN IS NO. OF C QUANTUM NUMBERS NECESSARY TO DESCRIBE COLLISION PARTNERS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ***** PROGRAM DIMENSION LIMITATIONS ***** C ENERGY,TEMP,LINE DIMENSIONS LIMITED BY VALUES ... PARAMETER(MXNRG=100,MXLN=200,MXTEMP=5) C INTEGER EUNITS,PRNTLV,PRINT,SHRINK C C ARRAY TO HOLD TIME AND DATE C INTEGER CTIME(2),CDATE(4) CHARACTER CTIME*9,CDATE*11 C C TYPES FOR COMMON/LDVVCM/ LOGICAL IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM LOGICAL LCALC,ALDONE LOGICAL IREAD,IWRITE LOGICAL LWARN C C DOUBLE PRECISION LABEL(10) CHARACTER*80 LABEL CHARACTER*80 LABL CHARACTER*1 TITLE(80),TIT(120),TIT2(120),BL CHARACTER*8 PDATE CHARACTER*8 CWD(2) EQUIVALENCE (LABL,TITLE(1)) C C FOLLOWING ARRAYS ALL HAVE DIMENSION MXNRG. MXNRG IS THE MAXIMUM C ALLOWED NUMBER OF TOTAL ENERGIES PER RUN. DIMENSION ENERGY(MXNRG) DIMENSION IECONV(MXNRG),ISST(MXNRG),MINJT(MXNRG),MAXJT(MXNRG) C C VARIABLES DIMENSIONED FOR NO. OF LINES IN PRES. BROAD. CALC. C N.B. PRBRIN STILL MAX NO. LINES = 2*MXLN DESPITE OFF-DIAG CHANGES DIMENSION LINE(2*MXLN),LTYPE(MXLN) EQUIVALENCE (ILSU,IPRBRU), (NLPRBR,IFLS) C DIMENSION TEMP(MXTEMP) C C VARIABLES TO TEST PARTIAL WAVE CONVERGENCE DIMENSION TEST(2) EQUIVALENCE (TEST(1),DTOL),(TEST(2),OTOL) C DIMENSION NLABV(9) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY C IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINPER W/ VL ARRAY. C NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2. C E.G. FOR IBM R*8/I*4, NIPR=2. AN INTEGER ARRAY OF DIM. N C CAN BE STORED IN A REAL ARRAY OF DIMENSION (N+NIPR-1)/NIPR. C C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RSTART,RSTOP,XEPS, 1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, 2 NOPEN,JKEEP,ISCRU,MAXSTP C C EXTRA COMMON BLOCK FOR LDVIVS COMMON/LDVVCM/XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP, 1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE C C COMMON BLOCK FOR WKB INTEGRATOR COMMON/WKBCOM/NGMP(3) C C COMMON BLOCK TO SUBROUTINE OUTPUT FOR USE IN RESONANCE SEARCHES COMMON/EIGSUM/EPSM(5) C C COMMON BLOCK FOR AIRPRP ARGUMENTS IN MANOLOPOLOUS/ALEXANDER C PROPAGATOR COMMON/HIBRIN/POWRX,DRAIRY,IABSDR C COMMON/VLSAVE/IVLU C NAMELIST /INPUT/ LABEL,RMIN,RMAX,IRMSET,IRXSET,URED,ISCRU,ISIGPR 1 ,ITHROW,STEST,NNRG,ENERGY,DNRG,JTOTL,JTOTU,JSTEP,MSET,MHI,NCAC 2 ,PRNTLV,INTFLG,MXSIG,STEPS,STABIL,NTEMP,NGAUSS,TEMP,EUNITS 3 ,ISIGU,IPARTU,ILSU,IPRBRU,IFLS,NLPRBR,LINE,IFEGEN,LTYPE,MAXSTP 4 ,TOLHI,RVIVAS,RVFAC,XSQMAX,ALPHA1,ALPHA2,IALPHA 5 ,IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM 6 ,ISAVEU,DTOL,OTOL,KSAVE,DR,DRNOW,DRMAX,RMID,VTOL,ICONV 7 ,THETLW,THETST,PHILW,PHIST,MXPHI,SHRINK,LASTIN 8 ,MMAX,LMAX,NGMP 9 ,VMAX,TMAX,TOLLO,CTOL,UTEST,TOLER,TOL,MXXX,MNNN A ,POWRX,DRAIRY,IABSDR,NNRGPG,IRSTRT C EQUIVALENCE (MXPAR,MXPHI), (RMID,RVIVAS), (DR,DRNOW), 1 (TOL,TOLER,TOLHI) C C NGPT,LMAX, MMAX, AND NGMP(3) ARE VARIABLES ADDED FOR C COMPATIBILITY WITH THE IOS PROGRAMS C VARIABLES VMAX,...,MNNN ADDED FOR COMPATIBILITY WITH S.GREEN CODE C (MOSTLY GORDON INTEGRATOR). ALSO TOL, TOLER, DRNOW C C RMIN IS THE RADIUS AT WHICH THE INTEGRATION IS BEGUN C RMAX IS THE OUTER RADIUS TO WHICH THE INTEGRATION MUST EXTEND C MAXSTP IS MAX NO. OF STEPS IN RADIAL INTEGRATION (INTFLG=3 ONLY) C C ARRAYS FOR NAMELIST SIMULATOR C CHARACTER*6 INAMES C DIMENSION INAMES(88),LOCN(88),INDX(88) C C DATA INAMES/'LABEL','RMIN','RMAX','IRMSET','IRXSET', C 1 'URED','ISCRU','ISIGPR', C 1 'ITHROW','STEST','NNRG','ENERGY','DNRG', C 2 'JTOTL','JTOTU','JSTEP','MSET','MHI','NCAC', C 2 'PRNTLV','INTFLG','MXSIG','STEPS','STABIL', C 3 'NTEMP','NGAUSS','TEMP','EUNITS','ISIGU','IPARTU','ILSU', C 4 'IPRBRU','IFLS','NLPRBR','LINE','IFEGEN','LTYPE','MAXSTP', C 4 'TOLHI','RVIVAS','RVFAC','XSQMAX','ALPHA1','ALPHA2','IALPHA', C 5 'IALFP','IV','IVP','IVPP','NUMDER','ISHIFT','IDIAG','IPERT', C 6 'ISYM','ISAVEU','DTOL','OTOL','KSAVE','DR','DRNOW','DRMAX', C 7 'RMID','VTOL','ICONV','THETLW','THETST','PHILW','PHIST', C 8 'MXPHI','SHRINK','LASTIN','MMAX','LMAX','NGMP','VMAX', C 9 'TMAX','TOLLO','CTOL','UTEST','TOLER','TOL','MXXX','MNNN' C A 'PWRX','DRAIRY','IABSDR','NNRGPG','IRSTRT'/ C DATA INDX/88*0/ C C DATA LABEL/10*' '/ DATA CWD/' ','(8-BYTE)'/ DATA CTIME/' '/,CDATE/' '/ DATA IPROGM/14/, PDATE/'(AUG 94)'/ DATA TITLE/80*' '/, BL/' '/ DATA TIT/120*'='/, TIT2/120*'-'/ C DATA LTYPE/MXLN*-1/ C C NLABV ARRAY CONTAINS NUMBER OF LABELS PER SYMMETRY TERM FOR EACH C VALUE OF ITYPE (ITYPE=4 ADDED JUL 94 TRP/SG) DATA NLABV/1,3,3,4,2,2,5,2,1/ C C THE PHYSICAL CONSTANTS USED ARE COMBINED IN THE SINGLE NUMBER BFCT. C BFCT IS 0.5*(HBAR**2) IN UNITS OF (ATOMIC MASS UNITS)*(WAVENUMBERS) C *(ANGSTROMS**2). C THE FOLLOWING VALUE IS FROM THE 1973 PHYSICAL CONSTANTS. DATA BFCT/16.857630D0/ C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C CALL ROUTINE TO MASK FLOATING-POINT UNDERFLOW. CALL MASK C C STORE VALUE OF MX IN CASE IT NEEDS TO BE RESET; C NEEDED IN FUTURE CODE WHICH USES MAXMAX/MX TO ALLOCATE C 'PERMANENT' STORAGE FOR A RUN W/ MULTIPLE (LASTIN=0) INPUT DECKS MXSAVE=MX C 100 MX=MXSAVE CALL GCLOCK(TFIRST) CALL GDATE(CDATE) CALL GTIME(CTIME) WRITE(6,110) IPROGM,PDATE,CDATE,CTIME,IPROGM,PDATE 110 FORMAT(2X,8('----MOLSCAT----')/' |',120X,'|'/' |',24X, 1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ', 2 'AND S. GREEN',23X,'|'/' |',29X,'VERSION 1 BY S. GREEN ', 3 '(NOV 1973); THIS IS VERSION',I3,1X,A8,29X,'|'/ 4 ' |',120X,'|'/' |',44X,'RUN ON ',A11,2X, 5 'AT ',A9,44X,'|'/' |',120X,'|'/2X,8('----MOLSCAT----')// 6 2X,'PUBLICATIONS RESULTING FROM THE USE OF THIS PROGRAM SHOULD ', 7 'REFER TO'/2X,'J. M. HUTSON AND S. GREEN, MOLSCAT COMPUTER ', 8 'CODE, VERSION',I3,1X,A8 / 9 2X,'DISTRIBUTED BY COLLABORATIVE COMPUTATIONAL PROJECT NO. 6 ', A 'OF THE SCIENCE AND ENGINEERING RESEARCH COUNCIL (UK)') C C INITIALIZE STORAGE PARAMETERS IN /MEMORY/ NIPR=2 IXNEXT=1 C SET IVLFL TO 1 TO ENSURE STORAGE COMPATIBILITY W/ VERSION 11 IVLFL=1 C SET NUSED.LT.0 AND CALL CHKSTR TO RESET COUNTER FOR EACH &INPUT. NUSED=-1 CALL CHKSTR(NUSED) C C SET INITIAL VALUES BEFORE READ(5,INPUT) . . . C LWARN=.FALSE. IOSFLG=0 NGMP(1)=8 NGMP(2)=1 NGMP(3)=16 NNRG=0 NNRGPG=1 DNRG=0.D0 NTEMP=0 NGAUSS=3 JSTEP=1 JTOTL=-1 JTOTU=-1 MSET=0 MHI=0 MXSIG=0 ISIGPR=0 ITHROW=0 DTOL=0.3D0 OTOL=.005D0 NCAC=4 ISIGU = 0 IPARTU=0 ISAVEU=0 KSAVE=0 ILSU=11 IFLS=0 IFEGEN=0 ICONV=0 INTFLG=4 RMIN=0.8D0 RMAX=10.D0 STEST=1.D-4 STEPS=10.D0 STABIL=5.D0 ISCRU=0 IRMSET=9 IRXSET=1 DR=2.D-2 RMID=9999.D0 RVFAC=0.D0 DRMAX=5.D0 VTOL=1.D-06 MAXSTP=10000 TOLHI=0.001D0 XSQMAX=1.D04 ALPHA1=1.D0 ALPHA2=1.5D0 IALPHA=6 IALFP=.FALSE. IV=.TRUE. IVP=.FALSE. IVPP=.FALSE. NUMDER=.FALSE. ISHIFT=.FALSE. IDIAG=.FALSE. IPERT=.TRUE. ISYM=.TRUE. EUNITS=0 PRNTLV=0 MXPHI=1 THETLW=0.D0 THETST=0.D0 PHILW=0.D0 PHIST=0.D0 SHRINK=1 LASTIN=1 PI=ACOS(-1.D0) POWRX=3.D0 DRAIRY=-1.D0 IABSDR=0 IRSTRT=0 C C READ &INPUT DATA. C OPEN(5,STATUS='OLD',SHARED,READONLY) C---------------------------------------------------------------- C ARRAYS FOR NAMELIST SIMULATOR C LOCN(1)=LOC(LABEL) C LOCN(2)=LOC(RMIN) C LOCN(3)=LOC(RMAX) C LOCN(4)=LOC(IRMSET) C LOCN(5)=LOC(IRXSET) C LOCN(6)=LOC(URED) C LOCN(7)=LOC(ISCRU) C LOCN(8)=LOC(ISIGPR) C LOCN(9)=LOC(ITHROW) C LOCN(10)=LOC(STEST) C LOCN(11)=LOC(NNRG) C LOCN(12)=LOC(ENERGY) C LOCN(13)=LOC(DNRG) C LOCN(14)=LOC(JTOTL) C LOCN(15)=LOC(JTOTU) C LOCN(16)=LOC(JSTEP) C LOCN(17)=LOC(MSET) C LOCN(18)=LOC(MHI) C LOCN(19)=LOC(NCAC) C LOCN(20)=LOC(PRNTLV) C INDX(20)=4 C LOCN(21)=LOC(INTFLG) C LOCN(22)=LOC(MXSIG) C LOCN(23)=LOC(STEPS) C LOCN(24)=LOC(STABIL) C LOCN(25)=LOC(NTEMP) C LOCN(26)=LOC(NGAUSS) C LOCN(27)=LOC(TEMP) C LOCN(28)=LOC(EUNITS) C INDX(28)=4 C LOCN(29)=LOC(ISIGU) C LOCN(30)=LOC(IPARTU) C LOCN(31)=LOC(ILSU) C LOCN(32)=LOC(IPRBRU) C LOCN(33)=LOC(IFLS) C LOCN(34)=LOC(NLPRBR) C LOCN(35)=LOC(LINE) C LOCN(36)=LOC(IFEGEN) C LOCN(37)=LOC(LTYPE) C LOCN(38)=LOC(MAXSTP) C LOCN(39)=LOC(TOLHI) C LOCN(40)=LOC(RVIVAS) C LOCN(41)=LOC(RVFAC) C LOCN(42)=LOC(XSQMAX) C LOCN(43)=LOC(ALPHA1) C LOCN(44)=LOC(ALPHA2) C LOCN(45)=LOC(IALPHA) C LOCN(46)=LOC(IALFP) C LOCN(47)=LOC(IV) C LOCN(48)=LOC(IVP) C LOCN(49)=LOC(IVPP) C LOCN(50)=LOC(NUMDER) C LOCN(51)=LOC(ISHIFT) C LOCN(52)=LOC(IDIAG) C LOCN(53)=LOC(IPERT) C LOCN(54)=LOC(ISYM) C DO 115 I=46,54 C 115 INDX(I)=3 C LOCN(55)=LOC(ISAVEU) C LOCN(56)=LOC(DTOL) C LOCN(57)=LOC(OTOL) C LOCN(58)=LOC(KSAVE) C LOCN(59)=LOC(DR) C LOCN(60)=LOC(DRNOW) C LOCN(61)=LOC(DRMAX) C LOCN(62)=LOC(RMID) C LOCN(63)=LOC(VTOL) C LOCN(64)=LOC(ICONV) C LOCN(65)=LOC(THETLW) C LOCN(66)=LOC(THETST) C LOCN(67)=LOC(PHILW) C LOCN(68)=LOC(PHIST) C LOCN(69)=LOC(MXPHI) C LOCN(70)=LOC(SHRINK) C INDX(70)=4 C LOCN(71)=LOC(LASTIN) C LOCN(72)=LOC(MMAX) C LOCN(73)=LOC(LMAX) C LOCN(74)=LOC(NGMP) C LOCN(75)=LOC(VMAX) C LOCN(76)=LOC(TMAX) C LOCN(77)=LOC(TOLLO) C LOCN(78)=LOC(CTOL) C LOCN(79)=LOC(UTEST) C LOCN(80)=LOC(TOLER) C LOCN(81)=LOC(TOL) C LOCN(82)=LOC(MXXX) C LOCN(83)=LOC(MNNN) C LOCN(84)=LOC(POWRX) C LOCN(85)=LOC(DRAIRY) C LOCN(86)=LOC(IABSDR) C LOCN(87)=LOC(NNRGPG) C LOCN(88)=LOC(IRSTRT) C C CALL NAMLIS('&INPUT',INAMES,LOCN,INDX,88,IEOF) C IF(IEOF.EQ.1) GOTO 1040 C-------------------------------------------------------------- READ(5,INPUT,END=1040) C WRITE(6,120) 120 FORMAT(//' /INPUT/ DATA ARE --') WRITE(LABL,'(A80)') LABEL WRITE(6,130) LABL 130 FORMAT(/' RUN LABEL = ',A80) DO 140 IST=1,80 IF(TITLE(IST).NE.BL) GOTO 150 140 CONTINUE GOTO 190 150 DO 160 IND=1,80 IF(TITLE(81-IND).NE.BL) GOTO 170 160 CONTINUE GOTO 190 170 IND=81-IND NST=(119-IND+IST)/2 TIT(NST)=BL TIT2(NST)=BL DO 180 I=IST,IND NST=NST+1 TIT(NST)=TITLE(I) TIT2(NST)=TITLE(I) 180 CONTINUE TIT(NST+1)=BL TIT2(NST+1)=BL C 190 AMXKB=MX/128.D0 IF (NIPR.EQ.1.OR.NIPR.EQ.2) THEN WRITE(6,200) MX,CWD(NIPR),AMXKB 200 FORMAT(/' SCRATCH CORE STORAGE ALLOCATION IS',I10,A8, 1 ' WORDS (',F10.2,' KBYTES)') WRITE(6,202) NIPR 202 FORMAT(2X,I1,' INTEGER(S) CAN BE STORED IN EACH WORD.') ELSE WRITE(6,204) NIPR 204 FORMAT(/' *** ILLEGAL NIPR =',I10) ENDIF C PRINT=PRNTLV C C PROCESS INTFLG -- REQUESTED PROPAGATOR -- AND ITS INPUT DATA. C WRITE(6,210) INTFLG 210 FORMAT(/' INTEGRATOR REQUESTED BY INPUT VALUE INTFLG =',I3) 220 FORMAT(/' ***** ERROR - NO IMPLEMENTATION FOR THIS INTFLG' 1 ,' - RUN HALTED.') 240 FORMAT(/' COUPLED EQUATIONS SOLVED BY METHOD OF DEVOGELAERE.') 250 FORMAT(/' INTEGRATION PARAMETERS ARE RMIN =',F7.2/ 1 30X,'RMAX =',F7.2/30X,'STEST =',D11.2/30X,'STEPS =', 2 F6.1,' (PER WAVELENGTH)'/30X,'STABIL =',F6.1,' (STEPS PER', 3 ' STABILIZATION)') 270 FORMAT(/' COUPLED EQUATIONS SOLVED BY WALKER-LIGHT R-MATRIX', 1 ' PROPAGATOR ALGORITHM'//' PARAMETERS ARE',5X,'RMIN =', 2 F7.2,8X,'DR = ',G8.2/21X,'RMAX =',F7.2,8X, 3 'VTOL =',D9.2/21X,'RMID =',F7.2,8X,'MAXSTP =',I9) 271 FORMAT(/' RVFAC =',F7.2,' OVERRIDES INPUT RMID') 300 FORMAT(/' COUPLED EQUATIONS SOLVED BY LOG DERIVATIVE METHOD ', 1 'OF JOHNSON') 310 FORMAT(/' INTEGRATION PARAMETERS ARE RMIN =',F7.2,8X, 1 'STEPS = ',F7.1/33X,'RMAX =',F7.2) 320 FORMAT(/' CHANGING TO VARIABLE INTERVAL / VARIABLE STEP METHOD', 1 ' AT LONG RANGE'//' INTEGRATION PARAMETERS ARE RVIVAS =', 2 F7.2,8X,'DR =',G8.2/ 3 33X,'RMAX =',F7.2,8X,'DRMAX =',F8.2/ 4 56X,'ALPHA1 = ',F7.2/33X,'XSQMAX =',G7.1,8X,'ALPHA2 = ',F7.2/ 5 33X,'TOLHI =',G7.1,8X,'IALPHA =',I8/33X,'ISHIFT =',L7,8X, 6 'IV =',L8/33X,'IPERT =',L7,8X,'IVP =',L8/33X, 7 'IALFP =',L7,8X,'IVPP =',L8/33X,'ISYM =',L7,8X, 8 'NUMDER =',L8) 340 FORMAT(/' COUPLED EQUATIONS SOLVED BY DIABATIC ', 1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS') 350 FORMAT(/' COUPLED EQUATIONS SOLVED BY QUASIADIABATIC ', 1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS') 352 FORMAT(33X,'IABSDR =',I4) 353 FORMAT(33X,'OVERRIDES STEPS PARAMETER WITH DR =',F9.3) 354 FORMAT(/' AIRY PARAMETERS ','RMID =',F10.4/ 2 33X,'DRAIRY=',F10.4/33X,'TOLHI=',F13.6/ 3 33X,'POWRX =',F8.2) 355 FORMAT(/' DRAIRY.LT.0 TAKES INITIAL AIRY STEP SIZE FROM' 1 ,' MODIFIED LOG-DERIVATIVE VALUE.') 356 FORMAT(/' TOLHI.GE.1 -- AIRY STEP SIZE INCREASED BY' 1 ,' FACTOR OF TOLHI AT EACH STEP') 357 FORMAT(/' TOLHI.LT.1 -- AIRY STEPS ADJUSTED TO MAINTAIN' 1 ,' APPROX. ACCURACY VIA PERTURBATION THEORY AND POWRX.') 370 FORMAT(/' EQUATIONS SOLVED BY WKB APPROXIMATION WITH GAUSS-' 1 ,'MEHLER INTEGRATION. SEE R. T PACK, JCP 60, 633 (1974).'/ 2 /' NOTE THAT THIS IS IMPLEMENTED ONLY FOR ONE CHANNEL', 3 ' CASES, E.G., IOS CALCULATIONS.'/ 4 /' INTEGRATION PARAMETERS ARE RMIN =',D15.4/ 5 30X,'STEST =',D14.4/30X,'NGMP =',I6,' (',I2,')',I3) C IF(INTFLG.EQ.2) THEN WRITE(6,240) C STABIL=MIN(STABIL,STEPS/2.D0) WRITE(6,250) RMIN,RMAX,STEST,STEPS,STABIL GO TO 380 ENDIF C IF(INTFLG.EQ.3) THEN WRITE(6,270) RMIN,DR,RMAX,VTOL,RMID,MAXSTP IF(RVFAC.GT.0.D0 .AND. IRMSET.GT.0) WRITE(6,271) RVFAC GO TO 380 ENDIF C IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN IF(IDIAG) THEN IV=.TRUE. IVP=.TRUE. IVPP=.TRUE. ISHIFT=.TRUE. IPERT=.TRUE. ENDIF IF(INTFLG.EQ.5) RVIVAS=RMAX WRITE(6,300) WRITE(6,310) RMIN,STEPS,RVIVAS IF(INTFLG.EQ.4) WRITE(6,320) RVIVAS,DR,RMAX,DRMAX,ALPHA1,XSQMAX, 1 ALPHA2,TOLHI,IALPHA,ISHIFT,IV,IPERT,IVP,IALFP,IVPP,ISYM,NUMDER GO TO 380 ENDIF C IF(INTFLG.EQ.6) THEN WRITE(6,340) WRITE(6,310) RMIN,STEPS,RMAX GO TO 380 ENDIF C IF(INTFLG.EQ.7) THEN WRITE(6,350) WRITE(6,310) RMIN,STEPS,RMAX GO TO 380 ENDIF C IF(INTFLG.EQ.8) THEN CALL MHAACK(6) WRITE(6,310) RMIN,STEPS,RMAX WRITE(6,352) IABSDR IF(IABSDR.EQ.1) WRITE(6,353) DR WRITE(6,354) RMID,DRAIRY,TOLHI,POWRX IF(RVFAC.GT.0.D0.AND.IRMSET.GT.0) WRITE(6,271) RVFAC IF(DRAIRY.LT.0.D0) WRITE(6,355) IF(TOLHI.GE.1.D0) THEN WRITE(6,356) ELSE WRITE(6,357) ENDIF GO TO 380 ENDIF C IF(INTFLG.EQ.-1) THEN WRITE(6,370) RMIN,STEST,NGMP GO TO 380 ENDIF C WRITE(6,220) STOP C 380 JKEEP=-1 XEPS=-1.D0 DEEP=1.D30 IF(IRXSET.GT.0) WRITE(6,381) IRXSET 381 FORMAT(/' IRXSET =',I3,' OPTION. RMAX ADJUSTED AUTOMATICALLY ', 1 'FOR EACH NEW JTOT,MVAL') IF(IRMSET.LE.0) GOTO 420 WRITE(6,390) IRMSET 390 FORMAT(/' IRMSET =',I3,' OPTION. RMIN CHOSEN AUTOMATICALLY ', 1 'FOR EACH NEW JTOT') C C XEPS IS SUCH THAT AIRY(XEPS) APPROX. EQUALS 10**(-IRMSET) C XEPS=(-1.5D0*LOG(4.D0*SQRT(PI)* 1 10.D0**(-IRMSET)))**(2.D0/3.D0) C>>SG 1/18/93 BELOW REMOVED AT SUGGESTION OF JMH C IF(ISCRU.EQ.0 .AND. NNRG.NE.1) SHRINK=0 IF(INTFLG.NE.3 .OR. SHRINK.NE.1) GOTO 420 DEEP=2.D0+XEPS**1.5D0/1.5D0 WRITE(6,400) 400 FORMAT(22X,'AND DEEPLY CLOSED CHANNELS ', 1 'DROPPED IN LONG-RANGE REGION') IF(NNRG.NE.1 .AND. ISCRU.NE.0) WRITE(6,410) 410 FORMAT(22X,'NOTE THAT BASIS SET CONTRACTION IS PERFORMED FOR ', 1 'ENERGY(1),'/22X,'SO THAT SUBSEQUENT ENERGIES MUST NOT BE ', 2 'SIGNIFICANTLY HIGHER.') C 420 ISAV=0 IF(JTOTL.EQ.JTOTU .AND. MSET.GT.0) ISAV=1 IF(ISCRU.LT.0) ISAV=-ISAV ISCRU=IABS(ISCRU) C IF(ISCRU.EQ.0) THEN IF(NNRG.GT.1.OR.NTEMP.GT.0) WRITE(6,430) 430 FORMAT(/' ***** WARNING - NO SCRATCH FILE SPECIFIED BY ISCRU ', 1 'PARAMETER - FULL CALCULATION WILL BE DONE AT EACH ENERGY') ELSE IF(ISAV.EQ.-1) THEN WRITE(6,440) ISCRU 440 FORMAT(/' ENERGY-INDEPENDENT MATRICES SAVED FROM A ', 1 'PREVIOUS RUN WILL BE READ FROM UNIT',I3) OPEN(ISCRU,FORM='UNFORMATTED',STATUS='OLD') ELSE WRITE(6,450) ISCRU 450 FORMAT(/' ENERGY-INDEPENDENT MATRICES WILL BE SAVED ', 1 'TEMPORARILY ON UNIT',I3) OPEN(ISCRU,FORM='UNFORMATTED',STATUS='UNKNOWN') ENDIF ENDIF C WRITE(6,470) URED 470 FORMAT(/' REDUCED MASS FOR COLLISION =',F14.9,' A.M.U.') IF(JTOTL.LT.0) JTOTL=0 IF(JTOTU.LT.JTOTL) JTOTU=999999 WRITE(6,480) JTOTL,JTOTU,JSTEP 480 FORMAT(/' CONTROL DATA FOR TOTAL ANGULAR MOMENTUM IS'/ 1 7X,'JTOT FROM',I4,' TO',I6,' IN STEPS OF',I4) IF(JTOTU.GE.999999) WRITE(6,490) NCAC,DTOL,OTOL 490 FORMAT(/' JTOT SERIES WILL BE TERMINATED WHEN MAX CHANGE IN ', 1 'CROSS SECTIONS IS LESS THAN TOLERANCE FOR NCAC =',I3, 2 ' CONSECUTIVE JTOT'/25X, 3 'DIAGONAL (DTOL) AND OFF-DIAGONAL (OTOL) TOLERANCES ARE',2F9.5) IF(JTOTU.GE.999999.AND.NNRGPG.GT.1) WRITE(6,491) NNRGPG 491 FORMAT(/' N.B. CONVERGENCE CHECKING IS DONE FOR ENERGY GROUPS', 1 ' OF NNRGPG =',I4) IF(MSET.GT.0 .AND. MHI.LE.0) MHI=MSET IF(MSET.GT.0) WRITE(6,500) MSET,MHI 500 FORMAT(/' CALCULATIONS WILL BE FOR SYMMETRY BLOCK ("PARITY ', 1 'CASES")',I4,' TO',I4) C C PROCESS TOTAL ENERGIES C CALL ECNV(EUNITS,EFACT) IF(NNRG.GT.0 .AND. DNRG.EQ.0.D0 .AND. ABS(EFACT-1.D0).GT.1.D-3 1 .AND. ICONV.EQ.0) WRITE(6,510) (ENERGY(I),I=1,NNRG) 510 FORMAT(/' INPUT ENERGY LIST IS'/(16X,7D16.6)) IF(NTEMP.LE.0) GOTO 520 C OVERRIDE ENERGY INPUT WITH TEMP INPUT NTEMP=MIN0(NTEMP,MXTEMP) CALL EAVG(NTEMP,TEMP,NGAUSS,ENERGY,NNRG,MXNRG) NPR=NNRG GOTO 590 520 ISRCH=0 NPR=NNRG C C PROCESS A NEGATIVE INPUT NNRG FOR RESONANCE SEARCH OPTION C IF(NNRG.GE.0 .OR. DNRG.EQ.0.D0 .OR. JTOTL.NE.JTOTU .OR. 1 MSET.LE.0 .OR. KSAVE.LE.0) GOTO 530 ISRCH=1 NNRG=5*(IABS(NNRG)/5) MXN=5*(MXNRG/5) NNRG=MIN0(NNRG,MXN) NNRGPG=5 NPR=5 C 530 NNRG=MIN0(MXNRG,NNRG) NPR=MIN0(MXNRG,NPR) IF(NNRG.GT.0) GOTO 550 WRITE(6,540) 540 FORMAT(/' ***** ERROR - NO INPUT ENERGIES SPECIFIED - RUN HALTED') STOP 550 IF(NNRG.LE.1 .OR. (DNRG.EQ.0.D0 .AND. ICONV.EQ.0)) GOTO 570 DO 560 I=2,NPR 560 ENERGY(I)=ENERGY(1)+(I-1)*DNRG 570 DO 580 I=1,NPR 580 ENERGY(I)=ENERGY(I)*EFACT 590 WRITE(6,600) NNRG 600 FORMAT(/' CONTROL DATA FOR TOTAL ENERGIES. CALCULATIONS WILL ', 1 'BE PERFORMED FOR',I4,' VALUES') DO 610 I=1,NPR ENEV=ENERGY(I)/8065.5410D0 610 WRITE(6,620) I,ENERGY(I),ENEV 620 FORMAT(7X,'ENERGY NO.',I4,' =',F17.9,' (1/CM) =',F17.12,' E.V.') C IF(ISRCH.EQ.1) WRITE(6,630) 630 FORMAT(/' RESONANCE SEARCH OPTION. ONLY FIRST 5 ENERGIES ', 1 'GIVEN. OTHERS WILL BE DETERMINED INTERACTIVELY.') C IF(IFLS.GT.0 .AND. IFEGEN.GT.0) WRITE(6,640) 640 FORMAT(/' THESE ENERGY VALUES WILL BE USED AS RELATIVE (CENTER', 1 ' OF MASS) VALUES AND LIST MAY BE MODIFIED ACCORDINGLY.') C IF(NUMDER) WRITE(6,641) 641 FORMAT(/' NUMDER=.TRUE. POTENTIAL DERIVATIVE WILL BE COMPUTED', & ' NUMERICALLY FROM POTENTIAL.') WRITE(6,650) PRINT,ISIGPR,ITHROW 650 FORMAT(/' PRINT LEVEL (PRNTLV) =',I3,' OTHER PRINT CONTROLS', 1 ' ISIGPR =',I2,' ITHROW =',I2) WRITE(6,660) 660 FORMAT(/' ',30('====')) C C INITIALIZE BASIS (BASIN/IOSBIN) C COMBINED MOLSCAT (BASIN) AND IOS (IOSBIN) -- APR 86 C IOSBIN GRABS STORAGE IN ATAU=JLEV=X (ITYPE=6 ONLY). MAX AVAILABLE C PASSED INITIALLY IN NLEV; SET6I/IOSBIN MUST UPDATE C IC ACCORDINGLY. N.B. IOS CASE ALSO USES NLEV TO PASS 'NVC' C FROM BASIN/IOSBIN TO IOSDRV. C BASIN TAKES STORAGE FOR JLEV=X, AND ALSO RESETS IC ACCORDINGLY; C FOR THIS CASE, NLEV INITIALIZED TO MAXIMUM AVAILABLE IN X(). IXJLEV=IXNEXT NLEV=MX C IXNEXT REMOVED FROM ARGUMENT LIST: JMH, 10 NOV 93 CALL BASIN(NLEV,X(IXJLEV),URED,NQN,NLABV(9),MXPAR,ITYPE,IOSFLG) C BASE ROUTINE INCREMENTS IXNEXT BY AMOUNT OF STORAGE IN JLEV. CALL CHKSTR(NUSED) WRITE(6,660) C C INITIALIZE POTENTIAL. C ILAM=IXNEXT MXLAM=NIPR*(MX-ILAM+1) CALL POTENL(-1,MXLAM,NPOTL,X(ILAM),RM,EPSIL,ITYPE) C THIS READS (5, POTL). RM AND EPSIL ARE SET HERE. C RM IS A LENGTH PARAMETER (IN ANGSTROMS) C EPSIL IS AN ENERGY PARAMETER IN WAVENUMBERS. ITYP=MOD(ITYPE,10) C INCREMENT IXNEXT FOR STORAGE TAKEN FOR LAM(NLABV,MXLAM) IXNEXT=IXNEXT+(MXLAM*NLABV(ITYP)+NIPR-1)/NIPR CALL IVCHK(IVLFL,PRNTLV,ITYPE,NLABV,MXLAM,NPOTL,X(ILAM)) WRITE(6,660) C C COMPUTE SOME DIMENSIONLESS PARAMETERS C C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO DEBROGLIE WAVELENGTH RMLMDA=URED*RM*RM*EPSIL/BFCT C CINT IS THE FACTOR TO REDUCE THE ROTATIONAL CONSTANTS CINT = RMLMDA/EPSIL C C *** IF(IOSFLG.LE.0) GOTO 670 C *** C *** THIS IS WHERE IOS CODE DIVERGES - CALL IOS CODE AND SKIP TO EXIT C *** IF (IRSTRT.NE.0) THEN WRITE(6,*) ' *** RESTART REQUESTED WITH IOS RUN - NOT ALLOWED' WRITE(6,*) ' *** MODIFY INPUT DECK AND RESUBMIT' STOP ENDIF CALL IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC, 1 IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX, 2 IPROGM,URED,LABL,NUMDER, 3 X(ILAM),MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC, 4 DEEP,PRINT,NLEV,ISAVEU,TFIRST,RM,EPSIL,RMIN,RMAX) CALL GCLOCK(TLAST) TOTIME=TLAST-TFIRST GOTO 1020 C C PROCESS PRESSURE-BROADENING LINE-SHAPE INPUT PARAMETERS. C 670 IF(IFLS.GT.0) THEN CALL PRBRIN(IFLS,LINE,LTYPE,MXLN,ILSU,NNRG,ENERGY,MXNRG,IFEGEN, 1 X(IXJLEV),PRINT) IF(IFEGEN.GT.0) NPR=NNRG WRITE(6,660) IF(KSAVE.EQ.0) GOTO 690 WRITE(6,680) IFLS,KSAVE 680 FORMAT(/' ****** WARNING. IFLS =',I3,' AND KSAVE =',I3,' ARE ', 1 'INCOMPATIBLE. KSAVE IS RESET TO ZERO') KSAVE=0 ENDIF C C INITIALIZE OUTPUT ROUTINE. C OUTPUT TAKES AN ADDITIONAL AMOUNT OF STORAGE C FOR SIG AT X(IXNEXT) AND INCREASES IXNEXT ACCORDINGLY. C 690 IOUT=IXNEXT C NOTE THAT IXNEXT WILL BE CHANGED BY OUTINT CALL OUTINT(LABL,ENERGY,NNRG,NLEV,NQN,X(IXJLEV),X(IOUT),IXNEXT, 1 IECONV,URED,ITYPE,KSAVE,ISST,MINJT,MAXJT,ISIGU,IPARTU,ISAVEU, 2 IPROGM,MXSIG,ISIGPR,JSTEP,IRSTRT) CALL CHKSTR(NUSED) IC1=IXNEXT C PROCESS RESTART REQUEST ... MXP=0 CALL RESTRT(IRSTRT,ISAVEU,JTOTL,JSTEP,MXPAR,MSET,MHI, 1 LABEL,ITYPE,NLEV,NQN,URED,IPROGM, 2 X(IXJLEV),NNRG,ENERGY,MXNRG, 3 X(IOUT),ISST,IECONV,MINJT,MAXJT,ISIGU,IPARTU,KSAVE, 4 OTOL,DTOL,X(IC1),X(IC1),MRSTRT,IERST,MXP,PRINT) WRITE(6,660) C EFIRST=ENERGY(1)*CINT CALL GCLOCK(TITIME) TTIME=TITIME-TFIRST WRITE(6,700) TTIME,NUSED 700 FORMAT(/' INITIALIZATION DONE. TIME WAS',F7.2,' CPU SECS.',I10, 1 ' WORDS OF STORAGE USED.') IF(PRINT.LT.4) WRITE(6,710) TIT 710 FORMAT('1',120A1) IF(PRINT.GE.4.AND.ITHROW.EQ.0) WRITE(6,720) 720 FORMAT('1') C C ************** LOOP OVER JTOT VALUES BEGINS HERE. ****************** C DO 990 JTOT=JTOTL,JTOTU,JSTEP IF(PRINT.GE.1 .AND. PRINT.LE.4) WRITE(6,730) JTOT 730 FORMAT(/' ANGULAR MOMENTUM JTOT =',I4/2X,7('****')) THETA=THETLW+THETST*DBLE(JTOT) C C *************** LOOP OVER SYMMETRY BLOCKS BEGINS HERE ************** C DO 980 M=1,MXPAR PHI=PHILW+PHIST*DBLE(M-1) IF(MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) GO TO 980 IF (IRSTRT.GE.2.AND.JTOT.EQ.JTOTL.AND.M.LT.MRSTRT) THEN WRITE(6,736) M,IRSTRT 736 FORMAT(' *** SKIPPING MVALUE =',I3,' DUE TO IRSTRT =',I3) GO TO 980 ENDIF IF(PRINT.LT.4) GOTO 760 IF(ITHROW.NE.0) WRITE(6,710) TIT IF(ITHROW.EQ.0) WRITE(6,740) TIT 740 FORMAT(/' ',120A1) WRITE(6,750) JTOT,M 750 FORMAT(/' TOTAL ANGULAR MOMENTUM, JTOT =',I5,' SYMMETRY', 1 ' BLOCK =',I4) 760 CONTINUE C C CHOOSE BASIS FUNCTIONS C CALL BASE (JTOT,X(IXJLEV),N,X,X,CINT,X,X,X,X,MXLAM,NPOTL,X(ILAM), 1 X,WGHT,IEXCH,THETA,PHI,M,.TRUE.,EFIRST,NLEV,PRINT) C C MOLD IS A REMNANT OF THE PREVIOUS "PARITY CASE" PROCESSING. C MXP IS USED IN CONVERGENCE CHECKING, MOLD IS PASSED TO PRBR C MOLD=-M IF(M.EQ.MXPAR.AND.N.LE.0) MOLD=0 MXP=MAX0(MXP,IABS(MOLD)) IF(M.EQ.MXPAR) MOLD=0 C C N IS THE NUMBER OF BASIS FUNCTIONS C SKIP THIS JTOT,M IF NO CHANNELS C C IF(N.LE.0) GOTO 980 <<- SG: FIXES ISIGU BUG IF(N.LE.0) GOTO 770 NSQ = N*N C C ALLOCATE STORAGE FOR COUPLED EQUATION SOLVER. C C ALLOCATE STORAGE COMMON TO ALL SCATTERING. . . C IS0-IS9 ARE SREAL,SIMAG,K-MATRIX,VL,IV,EINT,CENT,WVEC,L,NBASIS C NOTE THAT INTEGER ARRAYS OF LENGTH N ARE NOT REDUCED BY NIPR C IC1 IS IXNEXT AFTER ALLOCATIONS OF BASIN, POTENL, OUTINT ... ISJ=IC1 IS0=ISJ+N IS1=IS0+NSQ IS2=IS1+NSQ IS3=IS2+NSQ NV=N*(N+1)/2 IF(IVLU.EQ.0) NV=NV*NPOTL IS4=IS3+NV IS5=IS4 IF(IVLFL.GT.0) IS5=IS4+(NV+NIPR-1)/NIPR IS6=IS5+N IS7=IS6+N IS8=IS7+N IS9=IS8+N IXNEXT=IS9+N C C SET UP SOME STORAGE POINTERS FOR LATER USE IN CONVRG C IF(ICONV.GT.0) THEN IS10=IXNEXT IS11=IS10+NSQ IXNEXT=IS11+NSQ ENDIF IC2=IXNEXT CALL CHKSTR(NUSED) C IXNEXT/IC2 REFLECT STORAGE ALWAYS NEEDED FOR THIS JTOT,PARITY. C C SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE C CALL BASE(JTOT,X(IXJLEV),N,X(ISJ),X(IS8),CINT,X(IS5),X(IS6), 1 X(IS3),X(IS4),MXLAM,NPOTL,X(ILAM),X(IS7),WGHT,IEXCH,THETA, 2 PHI,M,.FALSE.,EFIRST,NLEV,PRINT) C C CHECK THAT RMAX IS BEYOND CENTRIFUGAL BARRIER C CALL FINDRX(ENERGY,X(IS5),X(IS6),NPR,N,CINT,RMAX,RSTOP, 1 NOPMAX,IRXSET,PRINT) IF(INTFLG.EQ.5) RVIVAS=RSTOP RSTART=RMIN C C ****************** LOOP OVER ENERGIES BEGINS HERE ****************** C 770 NELOOP=(NNRG+NNRGPG-1)/NNRGPG JHI=0 ICODE=0 ALDONE=.TRUE. DO 966 IEL=1,NELOOP JLO=JHI+1 JHI=MIN(JHI+NNRGPG,NNRG) C C SEE WHETHER THIS BLOCK OF ENERGIES CAN BE SKIPPED C LCALC=.FALSE. DO 775 J=JLO,JHI IF(IECONV(J).LT.0 .AND. IECONV(J).GT.-2*MXP) THEN WRITE(6,772) JTOT,J 772 FORMAT(/' * * * WARNING. JTOT =',2I5,'-TH ENERGY PREVIOUSLY ', 1 'FAILED TO CONVERGE.') LCALC=.TRUE. ELSEIF(IECONV(J).EQ.0) THEN LCALC=.TRUE. ELSEIF(IECONV(J).GT.0) THEN IF(JTOTU.LT.999999 .OR. IECONV(J).LT.NCAC*MXP) LCALC=.TRUE. ENDIF 775 CONTINUE C IF(.NOT.LCALC) GOTO 966 ALDONE=.FALSE. DO 960 J=JLO,JHI IF(N.LE.0) THEN CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT)) GOTO 960 ENDIF C C IF THIS IS A PRESSURE BROADENING CALC AND THIS S-MATRIX C WILL NOT BE USED, SKIP IT C IF(IFLS.GT.0 .AND. IFEGEN.GE.2) THEN CALL PRBCNT(J,X(ISJ),N,IUSE) IF(IUSE.EQ.0) THEN LWARN=.TRUE. IF(PRINT.GE.2) WRITE(6,777) JTOT,M,J,ENERGY(J) 777 FORMAT(/' ****** S MATRIX FOR JTOT =',I5,' M =',I4,3X, 1 'ENERGY(',I3,') =',F18.9,/9X,'WILL NOT BE USED ', 2 'IN PRESSURE BROADENING CALCULATION: SKIPPING') IF(IECONV(J).GE.0) IECONV(J)=IECONV(J)+1 CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT)) GOTO 960 ENDIF ENDIF C IF (IRSTRT.EQ.3.AND.JTOT.EQ.JTOTL.AND.M.EQ.MRSTRT.AND.J.LT.IERST) 1 GO TO 960 ETOT=ENERGY(J) ERED=ETOT*CINT IF(ICODE.EQ.0) THEN EFIRST=ERED ICODE=1 ENDIF ESHIFT=ERED-EFIRST C C ICODE CONTROLS WHETHER POTENTIAL INFORMATION IS READ FROM CHANNEL C ICODE=1 CALCULATES INFORMATION AND STORES IT C ICODE=2 (SET AFTER 1ST ENERGY) READS STORED INFORMATION C IF(PRINT.GE.4) THEN IF(ITHROW.EQ.0) THEN WRITE(6,740) TIT2 ELSE WRITE(6,710) TIT2 ENDIF WRITE(6,780) JTOT,M,J,ETOT 780 FORMAT(/' JTOT =',I5,' SYMMETRY BLOCK =',I4,' ENERGY(', 1 I3,') =',F18.9,' (1/CM)') ENDIF C C FOR SURFACE SCATTERING AT SUBSEQUENT ENERGY, C GET CORRESPONDING THETA FOR PRINTING C IF(ITYPE.EQ.8 .AND. J.NE.1) THEN SINTH=SIN(THETA*PI/180.D0) SINTH=SINTH**2*ENERGY(1)/ETOT IF(SINTH.GT.1.D0) GOTO 960 THETJ=ASIN(SQRT(SINTH))*180.D0/PI WRITE(6,795) J,ETOT,THETJ 795 FORMAT(/' NOTE: K VECTORS PARALLEL TO SURFACE WERE ', 1 'CALCULATED FOR ENERGY(1)'/' SUBSEQUENT ENERGY(',I3,') =', 2 F10.4,' CORRESPONDS TO THETA =',F10.4,' DEGREES') ENDIF C C TEMPORARY STORAGE FOR HEADER, FINDRM C IT1=IXNEXT IT2=IT1+MXLAM IT3=IT2+N IT4=IT3+N IT5=IT4+N IXNEXT=IT5+N CALL CHKSTR(NUSED) C CALL HEADER(X(IS1),X(IS2),N,NSQ,X(IT1),X(IS3),X(IS4),X(IS5), 1 X(IS6),X(IT2),MXLAM,NPOTL,ICODE,ISAV,EFIRST) C IF(ICODE.EQ.1 .AND. IRMSET.GT.0) THEN C FOR IRMSET > 0 OPTION, CHOOSE APPROPRIATE RMIN RSTART=RMIN CALL FINDRM(X(IS1),N,RSTART,RTURN,IK,X(IT1),X(IS3),X(IS4),ERED, 1 X(IS5),X(IS6),RMLMDA,X(IT2),X(IT3),X(IT4),X(IT5),MXLAM,NPOTL, 2 IRMSET,ITYPE,PRINT) IF(RVFAC.NE.0.D0) THEN RMID=RVFAC*RTURN IF(PRINT.GE.3.AND.RSTOP.GT.RMAX) WRITE(6,799) RSTOP,RMAX 799 FORMAT(' RMID OBTAINED FROM RTURN EVEN THOUGH RSTOP.GT.RMAX', 1 2F8.2) IF(PRINT.GE.3) WRITE(6,800) RMID,RVFAC 800 FORMAT(/' RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3) ENDIF ELSE RTURN=RMIN IK=1 ENDIF C C RESET IXNEXT TO RECOVER TEMPORARY STORAGE FROM HEADER AND FINDRM C IXNEXT=IT1 C C SOLVE COUPLED EQUATIONS. C PROPAGATORS ARE CALLED FROM SUBROUTINE STORAG C CALL STORAG(INTFLG,N,MXLAM,NV,NPOTL, 1 ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9, 2 ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT,NUMDER) C CALL GCLOCK(TJTIME) TTIME=(TJTIME-TITIME) TITIME=TJTIME C IF(NOPEN.GT.0) THEN C RESET ICODE TO ALLOW "SUBSEQUENT ENERGY" CALCULATIONS ICODE=2 ELSE IF(PRINT.GE.4) WRITE(6,900) JTOT,M,J,ETOT,TTIME 900 FORMAT(/' ****** NO OPEN CHANNELS FOR JTOT =',I5,3X, 1 'M =',I4,' ENERGY(',I3,') =',F18.9,10X,'STEP TIME =', 2 F6.2,' SECS') IF(IECONV(J).GE.0) IECONV(J)=IECONV(J)+1 GOTO 960 ENDIF C C FORCE IRSTRT=0 SO THAT ISAVEU WILL BE UPDATED. IRSTRX=0 CALL OUTPUT(JTOT,X(IS9),X(ISJ),X(IS8),X(IS7),X(IS0),X(IS1), 1 X(IS2),CONV,NOPEN,M,MXPAR,WGHT,IEXCH,J,RM,PRINT,TTIME, 2 ENERGY,X(IOUT),X(IXJLEV),ISST,IECONV,MINJT,MAXJT, 3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRX) C IF(ICONV.GT.0) CALL CONVRG(J,X(IS0),X(IS1),X(IS10),X(IS11)) IF(IECONV(J).LT.0 .OR. IFLS.LE.0) GOTO 940 C C TEMPORARY STORAGE FOR PRBR -- THESE ARE INTEGERS, COULD USE NIPR IT1=IXNEXT IT2=IT1+N IT3=IT2+N IT4=IT3+N IXNEXT=IT4+N CALL CHKSTR(NUSED) CALL PRBR(JTOT,MOLD,NOPEN,J,RM, 1 X(IS9),X(ISJ),X(IS8),X(IS7), 2 X(IS0),X(IS1),X(IT1),X(IT2),X(IT3),X(IT4), 3 X(IXJLEV),MXPAR,WGHT,PRINT,ILSU) C RECOVER TEMPORARY STORAGE ... IXNEXT=IT1 C 940 IF(PRINT.GE.5) WRITE(6,950) JTOT,M,J,ETOT,TTIME 950 FORMAT(/' FINISHED JTOT =',I5,' M =',I4,' ENERGY(',I3, 1 ') =',F18.9,10X,'STEP TIME =',F8.2,' SECS') C 960 CONTINUE C C RESONANCE SEARCH OPTION - GENERATE NEXT 5 ENERGIES C IF(ISRCH.EQ.0) GOTO 964 CALL NEXTE(ENERGY(JLO),EPSM,ENEW,DNRG,KSAVE) IF(JHI.EQ.NNRG) GOTO 964 IF(ENEW.LE.0.D0) GOTO 1000 JST=JHI+1 JND=JHI+5 WRITE(6,600) NNRG DO 962 JJ=JST,JND ENERGY(JJ)=ENEW+(JJ-JST)*DNRG ENEV=ENERGY(JJ)/8065.541D0 WRITE(6,620) JJ,ENERGY(JJ),ENEV 962 CONTINUE 964 CONTINUE C 966 CONTINUE C C ******************** END OF LOOP OVER ENERGIES ********************* C IF(ALDONE) THEN WRITE(6,968) DTOL,OTOL,NCAC 968 FORMAT(///' CALCULATION TERMINATED BY CONVERGENCE OF TOTAL ', 1 'CROSS SECTIONS.'//' DIAGONAL AND OFF-DIAGONAL TOLERANCES ', 2 'WERE ',2F9.5,' NCAC =',I3) GOTO 1000 ENDIF C IF(PRINT.GE.2 .AND. PRINT.LT.5) WRITE(6,970) 970 FORMAT(/) C RESTORE ERED TO FIRST ENERGY VALUE. ERED = EFIRST 980 CONTINUE C C ****************** END OF LOOP OVER SYMMETRY BLOCKS **************** C IF(IFLS.GT.0) CALL PRBOUT(JSTEP) 990 CONTINUE C C ******************** END OF LOOP OVER JTOT VALUES ****************** C C END OF RUN BOOKKEEPING C 1000 CALL OUTPCH(X(IOUT),ENERGY,NNRG,MINJT,MAXJT,ISIGPR,LABL,ISIGU, 1 LWARN) IF(IFLS.GT.0) WRITE(6,710) TIT IF(IFLS.GT.0) CALL PRBOUT(JSTEP) IF(IFLS.GT.0) CALL DACLOS CALL GCLOCK(TLAST) TOTIME=TLAST-TFIRST C MAKE SURE WE HAVE NUSED FOR KSAVE BY CALLING CHKSTR CALL CHKSTR(NUSED) IF(KSAVE.GT.0) WRITE(KSAVE,1010) TOTIME,TTIME,NUSED 1010 FORMAT(/' TOTAL CPU =',F9.2,' SECS LAST CYCLE =', 1 F8.2,' SECS NUSED =',I8) C C *** IOS CALCULATION (IOSFLG.GT.0) REJOINS CODE BELOW C ASCERTAIN 'HIGH-WATER' MARK IN STORAGE FROM CHKSTR. C MX MAY HAVE BEEN REDUCED, SO USE MXSAVE FOR ALLOCATED STORAGE C 1020 CALL CHKSTR(NUSED) WRITE(6,1030) IPROGM,PDATE,TOTIME,NUSED,MXSAVE 1030 FORMAT(///' ',8('----MOLSCAT----')/' |',120X,'|'/' |',13X, 1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ', 2 'AND S. GREEN, VERSION',I3,1X,A8,13X,'|'/ 3 ' |',120X,'|'/' |',13X,'THIS RUN USED',F11.2,' CPU SECS ', 4 'AND',I10,' OF THE ALLOCATED',I10,' WORDS OF STORAGE',14X, 5 '|'/' |',120X,'|'/' ',8('----MOLSCAT----') ) IF(LASTIN.EQ.0) GOTO 100 1040 RETURN END SUBROUTINE AIRPRP (Z, W, TMAT, VECNOW, VECNEW, + EIGOLD, EIGNOW, HP, Y1, Y2, CC, Y4, XF, REND, DRNOW, EN, + TOLAI, POWR, ESHIFT, NCH, ITWO, IREAD, IWRITE, IPRINT, $ ISCRU, P, MXLAM, VL, IV, RMLMDA, EINT, CENT, NPOTL) C * AIRY ZEROTH-ORDER PROPAGATOR FROM R=XF TO R=REND * FOR REFERENCE SEE M. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS * J. CHEM. PHYS. 81, 4510 (1984) * AND M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR * REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..." * J. CHEM. PHYS. 86, 2044 (1987) * AUTHOR: MILLARD ALEXANDER * CURRENT REVISION DATE: 4-FEB-1991 * ---------------------------------------------------------------------- * ADAPTED TO MOLSCAT 4/91 BY TRP@NASAGISS * ADAPTED TO MOLSCAT VERSION 11 BY JMH, JUN 92 *----------------------------------------------------------------------- * DEFINITION OF VARIABLES IN CALL LIST: * Z: MATRIX OF MAXIMUM DIMENSION NCH*NCH * ON ENTRY Z CONTAINS THE INITIAL Z-MATRIX AT R=XF * ON RETURN Z CONTAINS THE Z-MATRIX AT R=REND * W, TMAT, VECNOW * , VECNEW: SCRATCH MATRICES OF DIMENSION AT LEAST NCH*NCH * EIGOLD, EIGNOW * , HP, Y1, Y2 * , CC, Y4: SCRATCH VECTORS OF DIMENSION AT LEAST NCH * XF: ON ENTRY: CONTAINS INITIAL VALUE OF INTERPARTICLE D * ON EXIT: CONTAINS FINAL VALUE OF INTERPARTICLE DIS * THIS IS EQUAL TO REND IF NORMAL TERMINATI * OTHERWISE AN ERROR MESSAGE IS PRINTED * DRNOW: ON ENTRY: CONTAINS INITIAL INTERVAL SIZE * ON EXIT: CONTAINS FINAL INTERVAL SIZE * EN: COLLISION ENERGY IN ATOMIC UNITS * TOLAI: PARAMETER TO DETERMINE STEP SIZES * IF TOLAI .LT. 1, THEN ESTIMATED ERRORS ARE USED TO * DETERMINE NEXT STEP SIZES FOLLOWING THE PROCEDURE O * IN M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGOR * IF TOLAI .GE. 1, THEN STEP SIZES ARE CONTROLLED BY * ALGORITHM: DRNEXT = TOLAI * DRNOW * POWR: POWER AT WHICH STEP SIZES INCREASE C C * LOGICAL VARIABLES: * ISYM: IF .TRUE., PROPAGATION ASSUMES SYMMETRY OF Y MATRIX * ---------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H, O-Z) LOGICAL ISYM INTEGER I, IEND, IERR, ITWO, IZERO, KSTEP, MAXSTP, : NCH, NPT, NSKIP * REAL CDIAG, CMAX, COFF, DRFIR, DRMID, DRNOW, EN, ESHIFT, FACT, * : ONE, POWR, REND, RLAST, RMIN, RNEW, RNEXT, RNOW, ROLD, * : SPCMN, SPCMX, TOLAI, XF, XLARGE, ZERO * REAL CC, EIGNOW, EIGOLD, HP,Y1, Y2, Y4 * REAL TMAT, VECNEW, VECNOW, W, Z EXTERNAL CORR, TRNSFM, OUTMAT, POTENT, DAXPY, DCOPY, : SYMINV, SPROPN, DSCAL, TRNSP, WAVEIG * MATRIX DIMENSIONS (ROW DIMENSION = NCH, MATRICES STORED COLUMN BY CO DIMENSION Z(1), W(1), TMAT(1), VECNOW(1), VECNEW(1) * VECTORS DIMENSIONED NCH DIMENSION EIGOLD(1), EIGNOW(1), HP(1), Y1(1), Y2(1), CC(1), Y4(1) DIMENSION P(1),VL(1),IV(1),EINT(1),CENT(1) C DATA IZERO, IONE, ZERO, ONE /0, 1, 0.D0, 1.D0/ DATA ISYM /.TRUE./ C * ---------------------------------------------------------------------- C ERED = EN RMIN = XF SPCMX = 0.D0 SPCMN = 0.D0 IF (ITWO .GT. 0) GO TO 60 SPCMN = REND - RMIN * DETERMINE LOCAL WAVEVECTORS AT RMIN TO USE IN ESTIMATING SECOND DERIV * HP AND Y1 ARE USED AS SCRATCH VECTORS HERE CALL WAVEIG (W, EIGOLD, HP, Y1, RMIN, NCH, P, MXLAM, VL, IV, 1 RMLMDA, ERED, EINT, CENT, NPOTL) * LOCAL WAVEVECTORS AT RMIN ARE RETURNED IN EIGOLD DRFIR = DRNOW DRMID = DRNOW * 0.5D0 RLAST = XF ROLD = XF RNOW = RLAST + DRMID RNEXT = RLAST + DRNOW * DEFINE LOCAL BASIS AT RNOW AND CARRY OUT TRANSFORMATIONS * VECNEW IS USED AS SCRATCH MATRIX AND Y1 IS USED AS SCRATCH VECTOR HER CALL POTENT (W, VECNOW, VECNEW, EIGNOW, HP, Y1, + RNOW, DRNOW, EN, XLARGE, NCH, $ P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL) * VECNOW IS TRANSFORMATION FROM FREE BASIS INTO LOCAL BASIS * IN FIRST INTERVAL * E.G. P1=VECNOW ; SEE EQ.(23) OF * M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." * STORE VECNOW IN TMAT CALL DCOPY (NCH*NCH, VECNOW, 1, TMAT, 1) * DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGONAL * CORRECTION TERMS CALL CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, CDIAG, : COFF, NCH) MAXSTP = ( (REND-XF) / DRNOW ) * 5 XF = REND IF (IPRINT.GT.40) THEN WRITE (6, 40) 40 FORMAT(/' ** AIRY PROPAGATION (NO DERIVATIVES):') WRITE (6, 50) 50 FORMAT(' STEP RNOW', 5X, 5HDRNOW, 5X, 5HCDIAG, 6X, 4HCOFF) END IF 60 IEND = 0 IF (ITWO .LT. 0) GO TO 70 IF (ITWO .EQ. 0) WRITE(ISCRU) MAXSTP IF (ITWO. GT. 0) READ(ISCRU) MAXSTP * WRITE OR READ RELEVANT INFORMATION CALL OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW, : NCH, NCH, ITWO, ISCRU) C C * START AIRY PROPAGATION C * ---------------------------------------------------------------------- 70 DO 200 KSTEP = 1, MAXSTP NSTEP=KSTEP C * TRANSFORM LOG-DERIV MATRIX FROM LOCAL BASIS IN LAST INTERVAL TO * LOCAL BASIS IN PRESENT INTERVAL. SEE EQ.(23) OF * M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." * W IS USED AS SCRATCH MATRIX HERE, AND Y1 IS SCRATCH ARRAY C CALL TRNSP ( TMAT, NCH) CALL TRNSFM ( TMAT, Z, W, NCH, .FALSE., ISYM ) C * TMAT IS NO LONGER NEEDED * SOLVE FOR LOG-DERIVATIVE MATRIX AT RIGHT-HAND SIDE OF * PRESENT INTERVAL. THIS USES NEW ALGORITHM OF MANALOPOULOS AND ALEXAN * NAMELY * (N) (N) -1 (N) (N) * Z = - Y [ Y + Z ] Y + Y * N+1 2 1 N 2 4 * WHERE Y , Y , AND Y ARE THE (DIAGONAL) ELEMENTS OF THE "IMBEDDING * 1 2 4 * PROPAGATOR DEFINED IN ALEXANDER AND MANOLOPOULOS * DETERMINE THESE DIAGONAL MATRICES FOR PROPAGATION OF LOG-DERIV MATRIX * EQS. (38)-(44) OF M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR * REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..." C CALL SPROPN ( DRNOW, EIGOLD, HP, Y1, Y4, Y2, NCH) C * SET UP MATRIX TO BE INVERTED * NSKIP IS SPACING BETWEEN DIAGONAL ELEMENTS OF MATRIX STORED COLUMN BY C NSKIP = NCH + 1 CALL DAXPY (NCH, ONE, Y1, 1, Z, NSKIP) C * INVERT (Y + Z ) * 1 N C CALL SYMINV (Z, NCH, NCH, IERR) CALL DSYFIL ('U', NCH, Z, NCH) IF (IERR .GT. NCH) THEN WRITE (6, 80) 80 FORMAT (' *** INSTABILITY IN SYMINV IN AIRPRP.') STOP END IF C * -1 * EVALUATE - Y ( Y + Z ) Y * 2 1 N 2 * IN THE NEXT LOOPS EVALUATE THE FULL, RATHER THAN LOWER TRIANGLE C NPT = 1 DO 85 I = 1, NCH FACT = Y2(I) CALL DSCAL (NCH, FACT, Z(NPT), 1) NPT = NPT + NCH 85 CONTINUE * -1 * Z NOW CONTAINS ( Y + Z ) Y , THIS IS G(N-1,N) IN THE LOCAL BASI * 1 N 2 C DO 110 I = 1, NCH FACT = - Y2(I) CALL DSCAL (NCH, FACT, Z(I), NCH) 110 CONTINUE C * ADD ON Y * 4 CALL DAXPY (NCH, ONE, Y4, 1, Z, NSKIP) C IF (ITWO .GT. 0) GO TO 160 C C * OBLIGATORY WRITE OF STEP INFORMATION IF DEVIATIONS FROM LINEAR * POTENTIAL ARE UNUSUALLY LARGE * THIS IS ONLY DONE IF TOLAI .LT. 1, IN WHICH CASE THE LARGEST CORRECTI * IS USED TO ESTIMATE THE NEXT STEP C IF (TOLAI .LT. 1.) THEN CMAX = MAX (CDIAG, COFF) IF (CMAX .GT. (5. * TOLAI)) THEN WRITE (6,125) 125 FORMAT : (' ** ESTIMATED CORRECTIONS LARGER THAN 5*TOLAI IN AIRPRP') IF (KSTEP .EQ. 1) THEN WRITE (6, 130) 130 FORMAT (' THE INITIAL VALUE OF DRNOW (SPAC*FSTFAC) IS', : ' PROBABLY TOO LARGE') ELSE WRITE (6, 140) 140 FORMAT : (' CHECK FOR DISCONTINUITIES OR UNPHYSICAL OSCILLATIONS', : /,' IN YOUR POTENTIAL') END IF IF (IPRINT.LT.41) THEN WRITE (6, 50) WRITE (6,150) KSTEP, RNOW, DRNOW, CDIAG, COFF END IF END IF END IF C C * WRITE OUT INFORMATION ABOUT STEP JUST COMPLETED C IF (IPRINT.GT.40) THEN WRITE (6,150) KSTEP, RNOW, DRNOW, CDIAG, COFF 150 FORMAT (I6, 4E10.3) END IF C C * GET SET FOR NEXT STEP C 160 IF (IEND .EQ. 1) GO TO 250 IF (ITWO .GT. 0) GO TO 180 C C * IF TOLAI .LT. 1, PREDICT NEXT STEP SIZE FROM LARGEST CORRECTION C IF (TOLAI .LT. 1.) THEN C * NOTE THAT THE FOLLOWING STATEMENT IS SLIGHTLY DIFFERENT FROM EQ. (30 * OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ... AND THA * THE STEP-SIZE ALGORITHM IS ONLY APPROXIMATELY RELATED TO ANY REAL * ESTIMATE OF THE ERROR COFF AND CDIAG SHOULD BE APPROXIMATELY TOLAI, S * FROM EQ. (27): * DRNOW(AT N+1) = (12 TOLAI/KBAR(N+1)W(N+1)-TILDA')**(1/3) * WHICH IS APPROXIMATELY = (12 TOLAI/KBAR(N)W(N)-TILDA')**(1/3) * = ((12 COFF/KBAR W-TILDA') (TOLAI/COFF))**(1/3 * = DRNOW(AT N) (TOLAI/COFF)**(1/3) * OR FROM EQ. (29): * DRNOW = DRNOW (TOLAI/CDIAG)**(1/3) * THEN, USING THE LARGER ERROR AND ALLOWING POW TO VARY: C CSG>> FACTOR=(TOLAI/CMAX) ** (1./POWR) CSG LIMIT INCREMENT/DECREMENT FOR STABILITY ... IF (FACTOR.GT.2.D0) FACTOR=2.D0 IF (FACTOR.LE.0.1D0) FACTOR=1.D-1 DRNOW = DRNOW * FACTOR CSG<< DRNOW = DRNOW * (TOLAI/CMAX) ** (1. / POWR) ELSE C * IF TOLAI .GE. 1, THEN * MINIMUM STEP SIZE IS FIRST INTERVAL WIDTH C IF (KSTEP .EQ. 1) SPCMN = DRNOW C * AND NEXT STEP SIZE IS TOLAI * PRESENT STEP SIZE C DRNOW = TOLAI * DRNOW END IF C * DRNOW IS STEP SIZE IN NEXT INTERVAL C RLAST = RNEXT RNEXT = RNEXT + DRNOW IF (RNEXT .LT. REND) GO TO 170 IEND = 1 RNEXT = REND DRNOW = RNEXT - RLAST 170 RNEW = RLAST + 0.5D0 * DRNOW IF (KSTEP .GT. 1 .AND. IEND .NE. 1) THEN IF (TOLAI .LT. 1) THEN IF (DRNOW .LT. SPCMN) SPCMN = DRNOW END IF IF (DRNOW .GT. SPCMX) SPCMX = DRNOW END IF DRMID = RNEW - RNOW C C * RESTORE EIGENVALUES C CALL DCOPY (NCH, EIGNOW, 1, EIGOLD, 1) C * DEFINE LOCAL BASIS AT RNEW AND CARRY OUT TRANSFORMATIONS * TMAT IS USED AS SCRATCH MATRIX AND Y1 IS USED AS SCRATCH VECTOR HERE C CALL POTENT (W, VECNEW, TMAT, EIGNOW, HP, Y1, + RNEW, DRNOW, EN, XLARGE, NCH, $ P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL) C C * DETERMINE MATRIX TO TRANSFORM LOG-DERIV MATRIX INTO NEW INTERVAL * SEE EQ. (22) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS C CALL DGEMUL(VECNEW, NCH, 'N', VECNOW, NCH, 'T', TMAT, NCH, 1 NCH, NCH, NCH) CALL DCOPY (NCH*NCH, VECNEW, 1, VECNOW, 1) C C * RESTORE RADIUS VALUES C RNOW = RNEW C C * DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGONAL * CORRECTION TERMS C CALL CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, CDIAG, : COFF, NCH) IF (ITWO .LT. 0) GO TO 200 IF (IEND .EQ. 1) RNOW = - RNOW C C * WRITE OR READ RELEVANT INFORMATION C 180 CALL OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW, : NCH, NCH, ITWO, ISCRU) IF (ITWO .EQ. 0) GO TO 200 C C * NEGATIVE RNOW IS CUE FOR LAST STEP IN SECOND ENERGY CALCULATION C IF (RNOW .GT. 0.D0) GO TO 200 RNOW = - RNOW IEND = 1 C C * GO BACK TO START NEW STEP C 200 CONTINUE C C * THE FOLLOWING STATEMENT IS REACHED ONLY IF THE INTEGRATION HAS * NOT REACHED THE ASYMPTOTIC REGION IN MAXSTP STEPS C WRITE (6,210) MAXSTP, RNEXT C IF(IPRINT.GT.40) WRITE(6,210) MAXSTP,RNEXT C 210 FORMAT (' *** AIRY PROPAGATION NOT FINISHED IN', I4, : ' STEPS: R-FIN SET TO', F8.4,' ***',/) XF = RNEXT 250 CONTINUE IF (ITWO .LT. 0) GO TO 260 CALL OUTMAT (VECNOW, EIGOLD, HP, ESHIFT, DRNOW, XF, NCH, : NCH, ITWO, ISCRU) C C * TRANSFORM LOG-DERIV MATRIX INTO FREE BASIS. TRANSFORMATION MATRIX IS * JUST VECNOW-TRANSPOSE; SEE EQ.(24) OF M.H. ALEXANDER, "HYBRID QUANTUM * SCATTERING ALGORITHMS ..." 260 CALL TRNSFM (VECNOW, Z, W, NCH, .FALSE., ISYM ) C IF (IPRINT.LT.41) GO TO 318 IF (ITWO .LT. 0) WRITE (6,280) IF (ITWO .EQ. 0) WRITE (6,290) IF (ITWO .GT. 0) WRITE (6,300) 280 FORMAT (' ** AIRY PROPAGATION - FIRST ENERGY;', : ' TRANSFORMATION MATRICES NOT WRITTEN') 290 FORMAT (' ** AIRY PROPAGATION - FIRST ENERGY;', : ' TRANSFORMATION MATRICES WRITTEN') 300 FORMAT (' ** AIRY PROPAGATION - SECOND ENERGY;', : ' TRANSFORMATION MATRICES READ') WRITE (6,305) RMIN, REND, TOLAI, NSTEP WRITE (6,310) SPCMN, SPCMX, POWR 305 FORMAT (' RBEGIN =', F7.3, ' REND =', F7.3, : ' TOLAI =', 1PE8.1, ' NINTERVAL =', I3) 310 FORMAT (' DR-MIN =', F7.3, ' DR-MAX =', F8.3, : ' POWER =', F4.1) C 318 CONTINUE IF(IPRINT.LT.35) GO TO 319 IF (ITWO .LT. 0) WRITE (6,280) IF (ITWO .EQ. 0) WRITE (6,290) IF (ITWO .GT. 0) WRITE (6,300) 319 CONTINUE C IF(IPRINT.LT.3) GO TO 320 WRITE (6, 315) RMIN, REND, SPCMN, SPCMX, NSTEP 315 FORMAT (' ** AIRY: RSTART =' ,F7.3,' REND =',F7.3, : ' DRMIN =',F7.3, ' DRMAX =',F7.3,' NSTEP =', I4) 320 CONTINUE RETURN END SUBROUTINE AIRYMP (X, FTHETA, FPHI, XMMOD, XNMOD) * SUBROUTINE TO RETURN THE MODULI AND PHASES OF THE AIRY FUNCTIONS AND * DERIVATIVES * AUTHOR: MILLARD ALEXANDER * CURRENT REVISION DATE: 23-SEPT-87 * ---------------------------------------------------------------------- * VARIABLES IN CALL LIST: * X ARGUMENT OF AIRY FUNCTIONS * FTHETA, XMMOD ON RETURN: CONTAIN THE (DOUBLE PRECISION) * PHASE AND MODULUS OF AI(X) AND BI(X) ( * BELOW). * FPHI, XNMOD ON RETURN: CONTAIN THE (DOUBLE PRECISION) * PHASE AND MODULUS OF AI'(X) AND BI'(X) * BELOW). * ---------------------------------------------------------------------- * FOR NEGATIVE X * ---------------------------------------------------------------------- * THE MODULI AND PHASES ARE DEFINED BY * AI(-X) = M(X) COS[THETA(X)] * BI(-X) = M(X) SIN[THETA(X)] * AI'(-X) = N(X) COS[PHI(X)] * BI'(-X) = N(X) SIN[PHI(X)] * IN OTHER WORDS * 2 2 2 * M(X) = SQRT[ AI(X) + BI(X) ] * 2 2 2 * N(X) = SQRT[ AI'(X) + BI'(X) ] * THETA(X) = ATAN [ BI(X) / AI(X) ] * PHI(X) = ATAN [ BI'(X) / AI'(X) ] * TO DETERMINE THESE MODULI AND PHASES WE USE THE SUBROUTINE * SCAIRY, WRITTEN BY D. MANOLOPOULOS (SEPT. 1986) * THIS SUBROUTINE RETURNS THE FOLLOWING QUANTITIES: * SCAI, SCBI, SCAIP, SCPIB, AND ZETA, WHERE C FOR X .LT. -5.0 C AI(X) = SCAI * COS(ZETA) + SCBI * SIN(ZETA) C BI(X) = SCBI * COS(ZETA) - SCAI * SIN(ZETA) C AI'(X) = SCAIP * COS(ZETA) + SCBIP * SIN(ZETA) C BI'(X) = SCBIP * COS(ZETA) - SCAIP * SIN(ZETA) C WHERE ZETA = (2/3) * (-X) ** (3/2) + PI/4 C C FOR -5.0 .LE. X .LE. 0.0 C C AI(X) = SCAI C BI(X) = SCBI C AI'(X) = SCAIP C BI'(X) = SCBIP C AND ZETA = 0 * ---------------------------------------------------------------------- * FOR POSITIVE X * ---------------------------------------------------------------------- * THE MODULI AND PHASES ARE DEFINED BY * AI(X) = M(X) SINH[THETA(X)] * BI(X) = M(X) COSH[THETA(X)] * AI'(X) = N(X) SINH[PHI(X)] * BI'(X) = N(X) COSH[PHI(X)] * IN OTHER WORDS * 2 2 2 * M(X) = SQRT[ BI(X) - AI(X) ] * 2 2 2 * N(X) = SQRT[ BI'(X) - AI'(X) ] * THETA(X) = ATANH [ AI(X) / BI(X) ] * PHI(X) = ATANH [ AI'(X) / BI'(X) ] * HERE THE THE EXPONENTIALLY SCALED AIRY FUNCTIONS * AI(X), AI'(X), BI(X), BI'(X) ARE: * AI(X) = AI(X) * EXP[ZETA] * AI'(X) = AI'(X) * EXP[ZETA] * BI(X) = BI(X) * EXP[-ZETA] * BI'(X) = BI'(X) * EXP[-ZETA] * TO DETERMINE THESE MODULI AND PHASES WE USE THE SUBROUTINE * SCAIRY, WRITTEN BY D. MANOLOPOULOS (SEPT. 1986) * THIS SUBROUTINE RETURNS THE FOLLOWING QUANTITIES: * SCAI, SCBI, SCAIP, SCPIB, AND ZETA * IN TERMS OF WHICH THE EXPONENTIALLY SCALED AIRY FUNCTIONS ARE DEFINED * AI(X) = SCAI * EXP(-ZETA) * BI(X) = SCBI * EXP(+ZETA) * AI'(X) = SCAIP * EXP(-ZETA) * BI'(X) = SCBIP * EXP(+ZETA) * WHERE ZETA = (2/3) * X ** (3/2) * * ---------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION X, FTHETA, FPHI, XMMOD, XNMOD, SCAI, : SCBI, SCAIP, SCBIP, ZETA, RATIO CALL SCAIRY (X, SCAI, SCBI, SCAIP, SCBIP, ZETA) IF ( X .LE. 0.D0) THEN XMMOD = SQRT( SCAI ** 2 + SCBI ** 2) XNMOD = SQRT( SCAIP ** 2 + SCBIP ** 2) FTHETA = ATAN2 (SCBI, SCAI) FPHI = ATAN2 (SCBIP, SCAIP) IF (X .LT. (-5.0D0) ) THEN FTHETA = FTHETA - ZETA FPHI = FPHI - ZETA END IF ELSE XMMOD = SQRT( - SCAI ** 2 + SCBI ** 2) XNMOD = SQRT( - SCAIP ** 2 + SCBIP ** 2) RATIO = SCAI / SCBI FTHETA = 0.5 * LOG ( (1.D0 + RATIO) / (1.D0 - RATIO) ) RATIO = SCAIP / SCBIP FPHI = 0.5 * LOG ( (1.D0 + RATIO) / (1.D0 - RATIO) ) END IF RETURN END SUBROUTINE ASROT(J,EVEC,H,EVAL,WKS,NH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL TD,EVLIST DIMENSION EVEC(NH,NH),H(NH,NH),EVAL(NH),WKS(NH) DIMENSION WT(2),ELEVEL(1000),JLEVEL(4000),ISYM(10),ISYM2(10), 1 ROTI(2) COMMON /CMBASE/ A(2),B(2),C(2),DJ,DJK,DK,DT,ROTI, 1 ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL,JMIN,JMAX,JSTEP,ISYM,J2MIN, 1 J2MAX,J2STEP,ISYM2,JHALF,IDENT,MXJL,MXEL DATA EVLIST/.FALSE./ C C DO THE ACTUAL CALCULATION FOR A GIVEN J C ALPHA=0.5D0*(A(1)+B(1)) BETA=C(1)-ALPHA GAMMA=0.25D0*(A(1)-B(1)) TD = A(1).EQ.B(1) .AND. B(1).EQ.C(1) C JJ=J*(J+1) NK=J+J+1 DO 100 IR=1,NK KR=IR-J-1 DO 100 IC=1,IR KC=IC-J-1 TERM=0.D0 IF(KR.EQ.KC) THEN TERM=ALPHA*DBLE(JJ)+BETA*DBLE(KC*KC) 1 -DJ*DBLE(JJ*JJ)-DJK*DBLE(JJ*KC*KC)-DK*KC**4 IF(TD) TERM=TERM+0.5D0*DT*DBLE(-3*JJ*(JJ-2)+30*(JJ-2)*KC*KC 1 -35*KC*KC*(KC*KC-1)) ELSEIF(KR-KC.EQ.2) THEN KMID=(KR+KC)/2 TERM=GAMMA*SQRT(DBLE((JJ-KR*KMID)*(JJ-KC*KMID))) ELSEIF(KR-KC.EQ.4 .AND. TD) THEN TERM=1.25D0*DT*SQRT(DBLE((JJ-KC*(KC+1))*(JJ-(KC+1)*(KC+2))) 1 *DBLE((JJ-(KC+2)*(KC+3))*(JJ-(KC+3)*(KC+4)))) ENDIF H(IR,IC)=TERM 100 CONTINUE IFAIL=0 CALL F02ABF(H,NH,NK,EVAL,EVEC,NH,WKS,IFAIL) C WRITE(6,603) J,(EVAL(IC),IC=1,NK) 603 FORMAT('0 CALCULATED ROTATIONAL LEVELS FOR J =',I3,' ARE'/ 1 (8X,9F12.5)) C C IF THE RAW EIGENVECTORS ARE DEGENERATE, THEY MAY NOT HAVE C PROPER SYMMETRY. SEEK DEGENERATE SETS AND FORCE SYMMETRY ON THEM. C ALSO PRINT SPHERICAL TOP SYMMETRY LABELS IF ANY DEGENERATE SETS C ARE PRESENT. C CALL DMSYM(J,NK,EVAL,EVEC,H,WKS) C IF(EVLIST) THEN WRITE(6,604) 604 FORMAT('0 EIGENVECTOR COEFFICIENTS:') DO 200 IR=1,NK KR=IR-J-1 WRITE(6,605) J,KR,(EVEC(IR,IC),IC=1,NK) 605 FORMAT(2I4,9F12.8/(8X,9F12.8)) 200 CONTINUE ENDIF RETURN END SUBROUTINE AXSCAT(N, NSQ, MXLAM, NPOTL, 1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB, 2 P, Y1, Y2, Y3, Y4, VECNOW, VECNEW, EIGOLD, EIGNOW, HP, 3 ICODE, IPRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C --------------------------------------------------------------- C THIS IS TIM PHILLIP'S INTERFACE OF ALEXANDER HIBRIDON C CODES TO MOLSCAT: SCATTERING CALC USING DAPROP AND THEN C AIRPRP. ON EXIT SR AND SI CONTAIN THE S-MATRIX. C SR IS USED INTERNALLY TO HOLD THE LOG DERIVATIVE MATRIX C ICODE.EQ.2 FOR SUBSEQUENT ENERGIES. C --------------------------------------------------------------- C REORGANIZED BY SG (2/2/93): CORRECTS NSTEPS=0 PROBLEM, BUT C ALSO CALCULATES SOMEWHAT DIFFERENT STEP SIZES FROM EARLIER CODE. C --------------------------------------------------------------- C C DIMENSION STATEMENTS FOR ARGUMENT LIST C DIMENSION U(NSQ),Y1(N),Y2(N),Y3(N),Y4(N) DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ), & EINT(N),CENT(N),WVEC(N),L(N),NB(N) DIMENSION VECNOW(NSQ),VECNEW(NSQ),EIGOLD(N),EIGNOW(N),HP(N) C LOGICAL IREAD,IWRITE, LLD,LAIRY C C COMMON BLOCKS TO COMMUNICATE WITH PROPAGATORS C THE FOLLOWING VARIABLES FROM COMMON/DRIVE/ ARE USED WITH THIS C PROPAGATOR: STEPS,RMIN,RMAX,ERED,RMLMDA,NOPEN,ISCRU,TOLHI,RMID, C AND SOMETIMES DR C COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR, 1 DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, 2 NOPEN,JKEEP,ISCRU,MAXSTP C COMMON/HIBRIN/POWRX,DRAIRY,IABSDR C C SET UP TO USE UNIT (ISCRU) IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 C --------------------------------------------------------------- IF((.NOT.IREAD) .AND. IWRITE) THEN ITWO = 0 ELSE IF(IREAD .AND. (.NOT.IWRITE)) THEN ITWO = 1 ELSE IF((.NOT.IREAD) .AND. (.NOT.IWRITE)) THEN ITWO = -1 ELSE WRITE(6,*) ' ILLEGAL IREAD/IWRITE COMBINATION ' WRITE(6,*) ' BOTH SIMULTANEOUSLY TRUE ' STOP END IF C-------------------------------------------------------------------- C C DECIDE WHICH CALCULATIONS TO DO. C ON THE ASSUMPTION THAT RMIN.LT.RMAX THERE ARE THREE CASES C 1) RMID.LE.RMIN.LT.RMAX C 2) RMIN.LT.RMID.LT.RMAX C 3) RMIN.LT.RMAX.LE.RMID C CODE BELOW SETS FOLLOWING LLD LAIRY RSWTCH C CASE 1 F T RMIN C CASE 2 T T RMID C CASE 3 T F RMAX C INTEGRATION RANGES ARE THEN DAPROP: RMIN -> RSWTCH C AIRY: RSWTCH -> RMAX C-------------------------------------------------------------------- RBEGIN=RMIN REND=RMAX LLD=RBEGIN.LT.RMID LAIRY=RMID.LT.REND RSWTCH=MIN(REND,RMID) RSWTCH=MAX(RSWTCH,RBEGIN) C C CALCULATE WAVEVECTORS AND STEP SIZE WMAX=0.D0 NOPEN=0 DO 20 I=1,N DIF=ERED-EINT(I) WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) WMAX=MAX(WMAX,WVEC(I)) NB(I)=I IF (DIF.GT.0.D0) NOPEN=NOPEN+1 20 CONTINUE IF (NOPEN.EQ.0) RETURN C IF (IREAD) GO TO 40 PI=ACOS(-1.D0) DRLD=PI/(WMAX*STEPS) IF (IABSDR .EQ. 1 .AND. DR .GT. 0.D0) DRLD=DR NSTEPS=(RSWTCH-RBEGIN)/DRLD IF (IWRITE) WRITE (ISCRU) RBEGIN,RSWTCH,REND,DRLD,NSTEPS GO TO 60 40 READ (ISCRU) RBEGIN,RSWTCH,REND,DRLD,NSTEPS 60 CONTINUE C C SET REND FOR YTOK, AND RESET RSWTCH IN CASE WE DON'T CALL AIRPRP RYON=REND REND=RSWTCH RSWTCH=RBEGIN C LLD=LLD .AND. NSTEPS.GT.0 IF (LLD) THEN RSWTCH=REND C PROPAGATE LOG DERIVATIVE THROUGH FIRST SEGMENT. C ISTART=0 REQUESTS INITIALIZATION OF LOG-DERIVATIVE MATRIX ISTART=0 CALL DAPROP(U, SR, N, 1 RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, 2 Y1, Y2, Y3, Y4, 3 P, VL, IV, ERED, EINT, CENT, RMLMDA, 4 MXLAM, NPOTL, ISTART, NODES) C ------------------------------------------------------------- IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,RSWTCH,NSTEPS 1000 FORMAT(' AXSCAT. LOG DERIVATIVE MATRIX INTEGRATED FROM ', & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') ELSE C INITIALIZE LOG-DERIVATIVE MATRIX IF DAPROP NO CALLED DO 42 I=1,NSQ 42 SR(I)=0.D0 DO 43 I=1,NSQ,N+1 43 SR(I)=1.D30 IF (IPRINT.GE.3) WRITE (6,1010) 1010 FORMAT(' AXSCAT. DAPROP NOT CALLED: LOG DERIVATIVE MATRIX ', & 'INITIALIZED.') ENDIF C C USE AIRY PROPAGATOR FOR THE REMAINDER OF THE SCATTERING REGION C IF (.NOT.LAIRY) GO TO 41 REND=RYON DRA=DRLD IF (DRAIRY .GT. 0.D0) DRA = DRAIRY CALL AIRPRP(SR,U,SI,VECNOW,VECNEW,EIGOLD,EIGNOW,HP, 1 Y1,Y2,Y3,Y4,RSWTCH, 2 REND,DRA,ERED,TOLHI,POWRX,ESHIFT,N, 3 ITWO,IREAD,IWRITE,IPRINT,ISCRU,P,MXLAM,VL,IV,RMLMDA, 4 EINT,CENT,NPOTL) C C SORT CHANNELS BY ASYMPTOTIC ENERGY C 41 CONTINUE IF (N.EQ.1) GO TO 100 NM1=N-1 DO 80 I=1,NM1 IP1=I+1 DO 80 J=IP1,N IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 80 IT=NB(I) NB(I)=NB(J) NB(J)=IT 80 CONTINUE C C CALCULATE K AND S MATRICES C 100 CALL YTOK(NB,WVEC,L,N,NOPEN,Y1,Y2,Y3,Y4,SR,SI,U,REND) CALL KTOS(U,SR,SI,NOPEN) RETURN END SUBROUTINE BAS9IN(PRTP,IBOUND) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE CHARACTER*8 PRTP(4),QNAME(10) LOGICAL LEVIN,EIN,LCNT DIMENSION ROTI(12),ELEVEL(1000),JLEVEL(4000), 1 ISYM(10),ISYM2(10),WT(2) DIMENSION JLEV(1),VL(1),IV(1),CENT(1),J(1),L(1),LAM(1) COMMON/CMBASE/ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL, 1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT 2 ,MXJL,MXEL C C BAS9IN IS CALLED ONCE FOR EACH SCATTERING SYSTEM (USUALLY ONCE C PER RUN) AND CAN READ IN ANY BASIS SET INFORMATION NOT CONTAINED C IN NAMELIST BLOCK &BASIS. IT MUST ALSO HANDLE THE FOLLOWING C VARIABLES AND ARRAYS: C C PRTP SHOULD BE RETURNED AS A CHARACTER STRING DESCRIBING THE C COLLISION TYPE C IDENT CAN BE SET>0 IF A COLLISION OF IDENTICAL PARTICLES IS C BEING CONSIDERED AND SYMMETRISATION IS REQUIRED. C HOWEVER, THIS WOULD REQUIRE EXTRA CODING IN IDPART. C IBOUND CAN BE SET>0 IF THE CENTRIFUGAL POTENTIAL IS NOT OF THE C FORM L(L+1)/R**2; IF IBOUND>0, THE CENT ARRAY MUST BE C RETURNED FROM ENTRY CPL9 C IBOUND=1 PRTP(1)=' BODY-F' PRTP(2)='IXED ATO' PRTP(3)='M-DIATOM' PRTP(4)=' ' RETURN C ENTRY SET9(LEVIN,EIN,NLEV,JLEV,NQN,QNAME,MXPAR,NLABV) C C SET9 IS CALLED ONCE FOR EACH SCATTERING SYSTEM. IT SETS UP: C MXPAR, THE NUMBER OF DIFFERENT SYMMETRY TYPES ("PARITY CASES") C NLEVEL AND JLEVEL, UNLESS LEVIN IS .TRUE.; C JLEV AND NLEV; C ELEVEL, UNLESS EIN IS .TRUE. C IF THE LOGICAL VARIABLES ARE .TRUE. ON ENTRY, THE CORRESPONDING C QUANTITIES WERE INPUT EXPLICITLY IN NAMELIST BLOCK &BASIS. C IF EIN IS .FALSE., THE MOLECULAR CONSTANTS MUST HAVE BEEN SUPPLIED C IN THE &BASIS ARRAY ROTI: THE PROGRAMMER MAY USE THESE IN ANY WAY C HE LIKES, BUT SHOULD OUTPUT THEM HERE FOR CHECKING. C NOTE THAT JLEVEL CONTAINS JUST THE QUANTUM NUMBERS NECESSARY TO C SPECIFY THE THRESHOLD ENERGY (AND ELEVEL CONTAINS THE CORRESPONDING C ENERGIES WHEREAS JLEV CONTAINS ALL THE CHANNEL QUANTUM NUMBERS EXCEPT C THE ORBITAL L, WHICH MAY BE A SUPERSET. THE LAST COLUMN OF THE JLEV C ARRAY CONTAINS A POINTER TO THE ENERGY IN THE ELEVEL ARRAY. C MXPAR=2 NLABV=1 IF(LEVIN) GOTO 220 NLEVEL=0 NLEV=0 DO 210 I=JMIN,JMAX,JSTEP NLEVEL=NLEVEL+1 JLEVEL(NLEVEL)=I C NL IS NUMBER OF SETS OF INTERNAL QUANTUM NUMBERS FOR THIS LEVEL NL=1+MIN(J2MAX,I) NLEV=NLEV+NL 210 CONTINUE GOTO 230 220 WRITE(6,602) 602 FORMAT('0 BASIS FUNCTIONS TAKEN FROM &BASIS (JLEVEL) INPUT') C C IF NLEV AND NLEVEL ARE DIFFERENT, IT MAY BE NECESSARY TO BUILD UP JLEV C IN A DIFFERENT ORDER AND REARRANGE IT LATER - SEE SET3 CODING IN SETBAS 230 NQN=3 QNAME(1)=' J ' QNAME(2)=' |K| ' C LOOP OVER LEVELS AGAIN, THIS TIME SETTING UP JLEV II=0 IJ=0 DO 250 I=JMIN,JMAX,JSTEP II=II+1 DO 250 K=0,MIN(J2MAX,I) IJ=IJ+1 JLEV(IJ)=I JLEV(NLEV+IJ)=K JLEV(NLEV*(NQN-1)+IJ)=II 250 CONTINUE C IF(EIN) GOTO 280 WRITE(6,604) ROTI(1) 604 FORMAT('0 ENERGY LEVELS CALCULATED FROM B =',F10.5) C DO 270 I=1,NLEVEL JI=JLEVEL(I) ELEVEL(I)=ROTI(1)*DBLE(JI*(JI+1)) 270 CONTINUE RETURN C 280 WRITE(6,605) 605 FORMAT('0 ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL) INPUT') RETURN C ENTRY BASE9(LCNT,N,JTOT,ICODE,JLEV,NLEV,NQN,J,L) C C BASE9 IS CALLED EITHER TO COUNT THE ACTUAL NUMBER OF CHANNEL BASIS C FUNCTIONS OR ACTUALLY TO SET THEM UP (IN THE J AND L ARRAYS). C IT IS CALLED FOR EACH TOTAL J (JTOT) AND PARITY CASE (ICODE). C IF LCNT IS .TRUE. ON ENTRY, JUST COUNT THE BASIS FUNCTIONS. OTHERWISE, SET C UP J (POINTER TO JLEV) AND L (ORBITAL ANGULAR MOMENTUM) FOR EACH CHANNEL. C THIS MUST TAKE INTO ACCOUNT JTOT AND ICODE. C ONE IMPORTANT OVERALL EFFECT IS THAT THE THRESHOLD ENERGY IS IN C ELEVEL(JLEV(NLEV*(NQN-1)+J(I)). CHECK THIS! C N=0 DO 320 I=1,NLEV K=JLEV(NLEV+I) IF(K.GT.JTOT) GOTO 320 IF(K.EQ.0 .AND. ICODE.EQ.1) GOTO 320 N=N+1 IF(LCNT) GOTO 310 J(N)=I L(N)=JTOT 310 CONTINUE 320 CONTINUE RETURN C ENTRY CPL9(N,ICODE,NPOTL,LAM,MXLAM,NLEV,JLEV,J,L,JTOT, 1 VL,IV,CENT,IBOUND,IEXCH,IPRINT) C C CPL9 IS CALLED AFTER BASE9 FOR EACH JTOT AND ICODE, TO SET UP THE C POTENTIAL COUPLING COEFFICIENTS VL. C IF IBOUND>0, IT ALSO SETS UP THE CENTRIFUGAL COEFFICIENTS CENT. C INDICES SPECIFYING THE MXLAM DIFFERENT POTENTIAL SYMMETRIES ARE IN C THE FIRST XX*MXLAM ELEMENTS OF LAM; THE STRUCTURE OF THE LAM ARRAY C (AND THE VALUE OF XX) IS CHOSEN BY THE PROGRAMMER, AND MUST C CORRESPOND WITH THAT USED IN SUBROUTINE POTENL. C NPOTL IS THE NUMBER OF DIFFERENT POTENTIAL TERMS WHICH CONTRIBUTE TO C EACH MATRIX ELEMENT (SEE SUBROUTINE WAVVEC). IT SOMETIMES SAVES C A SIGNIFICANT AMOUNT OF SPACE IF IT CAN BE LESS THAN MXLAM. C ROOT2=SQRT(2.D0) NPOTL=MXLAM DO 550 LL=1,MXLAM LM=LAM(LL) NNZ=0 I=LL DO 540 ICOL=1,N JC=JLEV(J(ICOL)) KC=JLEV(J(ICOL)+NLEV) DO 540 IROW=1,ICOL JR=JLEV(J(IROW)) KR=JLEV(J(IROW)+NLEV) VL(I)=0.D0 IV(I)=LL IF(KR.NE.KC) GOTO 510 ISUM=LM+JR+JC IF(ISUM-2*(ISUM/2).NE.0 .OR. LM.GT.JC+JR) GOTO 540 VL(I)=PARITY(KC)*SQRT(DBLE(JC*(JC+1)*JR*(JR+1)))*THREEJ(JC,LM,JR) 1 *THRJ(DBLE(JC),DBLE(LM),DBLE(JR),DBLE(KC),0.D0,DBLE(-KC)) IF(VL(I).NE.0.D0) NNZ=NNZ+1 GOTO 540 510 IF(LM.GE.0 .OR. JR.NE.JC .OR. IABS(KR-KC).GT.1) GOTO 540 VL(I)=SQRT(DBLE((JC*(JC+1)-KR*KC)*(JTOT*(JTOT+1)-KR*KC))) IF(JC.EQ.0 .NEQV. JR.EQ.0) VL(I)=ROOT2*VL(I) IF(VL(I).NE.0.D0) NNZ=NNZ+1 540 I=I+NPOTL IF(NNZ.EQ.0) WRITE(6,612) JTOT,LL 612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING', 1 ' COEFFICIENTS ARE 0.0 FOR POTENTIAL SYMMETRY',I4) 550 CONTINUE C C NOW THE CENTRIFUGAL POTENTIAL DO 570 I=1,N JC=JLEV(J(I)) KC=JLEV(J(I)+NLEV) CENT(I)=DBLE(JTOT*(JTOT+1)+JC*(JC+1)-2*KC*KC) 570 CONTINUE RETURN C ENTRY DEGEN9(J1,J2,RESULT) C C DEGEN9 IS CALLED TO OBTAIN THE DEGENERACY FACTOR FOR THE DENOMINATOR C OF A CROSS-SECTION CALCULATION; IT DOES NOT MATTER FOR BOUND STATES. C C JI=JLEVEL(J1) C RESULT=DBLE(2*JI+1) RETURN END SUBROUTINE BASE (JTOT, JLEV, N, J, L, CINT, EINT, CENT, VL, IV, & MXLAM, NPOTL, LAM, WVEC, WGHT, IEXCH, THETA, PHI, & ICODE, LCNT, ERED, NLEVV, PRINT) C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C . CHANGED APR 1986 TO COMBINE BASIN & IOSBIN HANDLING. C . CHANGED JAN 1988 TO ALLOW USER-DEFINED BASIS (ITYPE=9) C . CHANGED MAR 1993 TO SET MPLMIN=TRUE FOR ITYPE=23,IDENT=1 C . CHANGED NOV 1993 TO USE IXNEXT DIRECTLY IN PLACE OF IC. C . IC REMOVED FROM ARGUMENT LIST OF BASIN AND SET6. C . CHANGED JAN 1994 TO USE IV() INDEXING FOR ITYP=10*N + 2 C . APR 1994 TO INCLUDE IEXCH IN PARAMETER LIST C NEW ORDERING OF ITYPE=23 'PARITY CASES' C . CHANGED JUL 1994 FOR VERSION 14 C . AUG 1994 TO INTEGRATE ITYPE = 4 CODE TO VERSION 14 C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C BELOW IS BEGINNING OF A LIMITED SAVE LIST C SAVE ITP,ITYPE,IOFF,IBOUND,JZCSFL,EMAXK,WTM,IGO,IGODG,MJMX C IDENT,WT,JMAX,JMIN -- IN CMBASE C NLEV,NQN,MPLMIN -- IN PRBASE C C BASE HANDLES QUANTUM BASIS SETS FOR SCATTERING CALCULATION. C C ITYPE DESCRIBES TARGET-PROJECTILE TYPES. C CURRENT IMPLEMENTATION FOR C ITYPE=1 LINEAR RIGID ROTOR HIT BY AN ATOM C ITYPE=2 DIATOMIC VIB-ROTOR HIT BY AN ATOM C ITYPE=3 LINEAR RIGID ROTOR - LINEAR RIGID ROTOR C ITYPE=4 RIGID ASYMMETRIC TOP HIT BY LINEAR RIGID ROTOR C ITYPE=5 NEAR-SYMMETRIC TOP RIGID ROTOR HIT BY AN ATOM C ITYPE=6 ASYMMETRIC TOP RIGID ROTOR HIT BY AN ATOM. C ITYPE=7 DIATOMIC VIB-ROTOR HIT BY AN ATOM, WHERE A FULL C SET OF EXPECTATION VALUES OF THE INTERMOLECULAR C POTENTIAL BETWEEN (V,J) AND (V',J') DIATOM INTERNAL C STATES IS SUPPLIED C ITYPE=8 ATOM-SURFACE SCATTERING C C ITYPE=ITYPE+10 FOR EFFECTIVE POTENTIAL METHOD OF RABITZ. C ITYPE=ITYPE+20 FOR COUPLED STATES OF MCGUIRE-KOURI. C ITYPE=ITYPE+30 FOR DLD METHOD OF DEPRISTO AND ALEXANDER. C C C ENTRY BASIN C READS AND PROCESSES &BASIS DATA TO DESCRIBE ASYMPTOTIC LEVELS. C QUANTUM NOS. AND INDEXING ARE IN JLEVEL(NLEVEL) AND C JLEV(NLEV,NQN), IN DIFFERENT FORMATS. C ASYMPTOTIC ENERGIES ARE IN ELEVEL(NLEVEL). C C MAIN ENTRY BASE C SETS UP BASIS FOR EACH PARTIAL CALCULATION FROM ASYMPTOTIC C LEVELS (STORED IN JLEV) COUPLED WITH COLLISION ORBITAL ANGULAR C MOMENTUM. C LCNT=.TRUE. MEANS ONLY COUNT NUMBER OF CHANNELS C LCNT=.FALSE. MEANS SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE. C ICODE (=1...MXPAR) IS AN INDEX FOR THE CURRENT SYMMETRY BLOCK. C IPAR AND IEXCH SUBDIVIDE ICODE=1,MXPAR INTO C 1) PARITY, IPAR=0 (EVEN), 1 (ODD) C 2) EXCHANGE SYM., IEXCH=0 (NO EXCHANGE), 1 (ODD), 2 (EVEN). C IT IS NECESSARY TO SET FOLLOWING -- C ASYMPTOTIC LEVEL IN J, ORBITAL ANGULAR MOMENTUM IN L, C ASYMPTOTIC ENERGY IN EINT, CENTRIFUGAL ENERGY IN CENT, C AND COUPLING MATRIX ELEMENTS IN VL. C C EXTRA FEATURE ADDED AT UNIV. OF WATERLOO MAY 82. ARRAY IV C IS AN INDEX ARRAY SUCH THAT VL(I) IS A COEFFICIENT FOR C TERM NUMBER IV(I) IN THE POTENTIAL ARRAY RETURNED BY C SUBROUTINE POTENL. THE INTRODUCTION OF THIS ARRAY ONLY C MAKES ANY REAL DIFFERENCE FOR ITYPE=10*N+7, FOR WHICH IT C ENABLES LARGE ECONOMIES IN STORAGE FOR THE VL ARRAY. C ** 1/27/93 IV ARRAY USED IF AND ONLY IF IVLFL.GT.0 ** C NPOTL IS THE NUMBER OF "CHUNKS" OF SIZE N*(N+1)/2 WHICH C COMPRISE VL AND IV. NPOTL=MXLAM EXCEPT FOR ITYPE=10*N+7 AND 8. C FOR ITYPE=10*N+7, NPOTL IS EQUAL TO K+1, WHERE K IS THE C INDEX OF THE HIGHEST ORDER LEGENDRE POLYNOMIAL ACTUALLY C PRESENT IN THE POTENTIAL. C FOR ITYPE=8, NPOTL=1. C C ADDITIONAL CHANGE MADE MAY 82. THE VL ARRAY IS NOW STORED C SO THAT THE POTENTIAL SYMMETRY TERM IS MOST RAPIDLY VARYING, C RATHER THAN THE CHANNEL INDICES AS BEFORE. THIS IS TO KEEP C PAGING TO A MINIMUM IN SUBROUTINE WAVMAT. C C ENTRY DEGEN PROVIDES DEGENERACY INFORMATION FOR USE IN OUTPUT. C DIMENSION CENT(NLEVV),EINT(NLEVV),WVEC(NLEVV),VL(NLEVV),IV(NLEVV) LOGICAL LCNT,EIN,LEVIN,MPLMIN,LSIG INTEGER J(NLEVV),L(NLEVV),LAM(MXLAM),JLEV(NLEVV) INTEGER PRINT,EUNITS CHARACTER*8 QNAME(10),QTYPE(10),PRTP(4,9),PTP(2) DIMENSION WTM(2),IOSNGP(3) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C COMMON BLOCK FOR BASIS DATA C 2 AUG 94 V14 VERSION OF CMBASE; ISYM NO LONGER EQUIV J2MAX C DIMENSIONS OF JLEVEL,ELEVEL SET HERE AND HELD IN /CMBASE/MXJL,MXEL PARAMETER (MXJLVL=4000,MXELVL=1000) DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2), 1 WEXE(2),WT(2),ELEVEL(MXELVL),EEE(1016) DIMENSION JLEVEL(MXJLVL),ISYM(10),ISYM2(10) EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)), 1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),(JSTEP,J1STEP), 2 (ROTI(1),EEE(1)), (ROTI(7),WE(1),DJ ), (ROTI(8),DJK), 3 (ROTI(9),WEXE(1),DK), (J2MAX,KSET) COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC, NLEVEL,JLEVEL,JMIN, 1 JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT,MXJL,MXEL C COMMON /PRBASE/ ITYPX,NQN,NLEV,MVALUE,IPTY,MPLMIN C COMMON/VLSAVE/IVLU C C ARRAYS FOR NAMELIST &BASIS C CHARACTER*6 BNAMES(39) C DIMENSION LOCN(39),INDX(39) C C V14: ISYM2, JHALF ADDED TO NAMELIST NAMELIST /BASIS/ ROTI,JMIN,JMAX,JSTEP,ITYPE 1 ,NLEVEL,JLEVEL,ELEVEL,EMAX,EMAXK,BE,ALPHAE,DE,A,B,C,WE,WEXE 2 ,J1MAX,J1MIN,J2MAX,J2MIN,J1STEP,J2STEP 3 ,WT,IDENT,SPNUC,EUNITS,IASYMU,JZCSMX,IBOUND,JZCSFL 4 ,IOSNGP,IPHIFL,ISYM,ISYM2,KSET,IVLU,JHALF C DATA QTYPE/ ' J ', ' K ', 1 ' PRTY ', ' J1 ', ' J2 ', ' J12 ', 2 ' V ', ' TAU ',' ','SIG INDX'/ DATA PRTP/' LINEAR',' RIGID R','OTOR - ',' ATOM. ', 1 ' DIATOM','IC VIB-R','OTOR - ',' ATOM. ', 2 ' LINEAR',' ROTOR -',' LINEAR ','ROTOR. ', 3 ' ASYMME','TRIC TOP',' - LINEA','R ROTOR.', 4 'ATOM - N','EAR SYM.',' TOP RIG','ID ROTOR', 5 ' ASYMME','TRIC TOP',' - ATOM ',' ', 6 4*' ', 7 ' ATOM -',' CORRUGA','TED SURF','ACE ', 8 4*' '/ DATA PTP/', ODD ',', EVEN '/ C C C DATA BNAMES/'ROTI','JMIN','JMAX','JSTEP','ITYPE', C 1 'NLEVEL','JLEVEL','ELEVEL','EMAX','EMAXK', C 2 'BE','ALPHAE','DE','A','B','C','WE','WEXE', C 2 'J1MAX','J1MIN','J2MAX','J2MIN','J1STEP','J2STEP', C 3 'WT','IDENT','SPNUC','EUNITS','IASYMU','JZCSMX','IBOUND', C 4 'JZCSFL','IOSNGP','IPHIFL','ISYM','KSET','IVLU','ISYM2', C 5 'JHALF'/ C DATA INDX/39*0/ C C SET UP BASIS FUNCTIONS C IEXCH=0 IPAR=0 C IF (ITYPE.EQ.8) GO TO 5208 IF (ITP.EQ.9) GO TO 5209 IF (ITYPE.LE.10) GO TO 5201 IF (ITYPE.LE.20) GO TO 5202 IF (ITYPE.LE.30) GO TO 5203 C C CODE FOR DECOUPLED L-DOMINANT APPROX OF ALEXANDER C 5204 N=0 LAMBDA=ICODE-1 DO 4001 I=1,NLEV JI=JLEV(I) LI=JTOT+LAMBDA-JI IF (LI.LT.IABS(JTOT-JI) .OR. LI.GT.(JTOT+JI) ) GO TO 4001 N=N+1 IF (LCNT) GO TO 4001 J(N)=I L(N)=LI 4001 CONTINUE IF (LCNT) GO TO 5000 GO TO 8000 C C CODE BELOW FOR MCGUIRE-KOURI J-Z CONSERVING COUPLED STATES APPROX. C 5203 N=0 C>SG CODE BELOW IS REVISED APR 94 -- NEW ORDERING OF PARITY CASES IF (MPLMIN) THEN IF (IDENT.EQ.0) THEN MVALUE=ICODE-1 IF (ITYPE.EQ.25.AND.ISYM(1).NE.-1) THEN IBLOCK=1+MVALUE/(MJMX+1) MVALUE=MOD(MVALUE,MJMX+1) KREQ=IBLOCK-1 ENDIF ELSE IEXCH=2-MOD(ICODE,2) MVALUE=(ICODE+1)/2-1 IF (WT(IEXCH).EQ.0.D0) THEN IF (PRINT.GE.3) WRITE(6,690) JTOT,ICODE,PTP(IEXCH) GO TO 5000 ENDIF ENDIF ELSE C CODE BELOW IS FOR MPLMIN=.FALSE. (NOT USED, BUT COULD BE REVIVED) IF (IDENT.EQ.0) THEN WRITE(6,*) ' *** BASE (APR 94). MPLMIN=.FALSE. .AND. IDENT.' 1 ,'EQ.0 ARE NOT ALLOWED' STOP ELSE ICD=(ICODE+1)/2 MVALUE=ICD/2 IF (ICD-2*(ICD/2).EQ.0) MVALUE=-MVALUE ENDIF ENDIF C SET IPAR (=1 FOR MVALUE=0, =2 OTHERWISE) IPAR=1 IF (MVALUE.NE.0) IPAR=2 C VALUES NOT STORED. CALCULATE THEM 3800 DO 1511 LL=1,MXLAM LM=LAM(LL) XLM=LM NNZ=0 I=LL DO 1501 ICOL=1,N JCOL=JLEV(J(ICOL) ) XJCOL=JCOL DO 1501 IROW=1,ICOL JROW=JLEV(J(IROW) ) XJROW=JROW VL(I)=PM*SQRT(Z(JROW)*Z(JCOL))* & THREEJ(JROW,LM,JCOL)* & THRJ(XJROW,XLM,XJCOL,-XM,Z0,XM) IF (VL(I).NE.0.D0) NNZ=NNZ+1 1501 I=I+MXLAM IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVALUE,LL 1511 CONTINUE RETURN END SUBROUTINE CPL22(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,MVALUE, 1 IV,VL,PRINT,LFIRST) C C CS COUPLING MATRIX FOR VIBRATING ROTOR-ATOM (ITYPE=22) C SG (MAR 94) USES IV(), I.E., IVLFL=1 C SAVES COUPLING MATRIX FOR MV=0,MX IN UPPER X() ARRAY C USES J3J000 ROUTINE AS PER JMH CPL21 CODE C STORES ON J OR NLEV, DEPENDING ON WHICH IS SMALLER C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE NOMEM,NL12,IXMX,ISTART,IFIRST,LOGIX,JTOP C SPECIFICATIONS FOR ARGUMENTS DIMENSION LAM(3,MXLAM),JLEV(NLEV),J(N),VL(1),IV(1) INTEGER PRINT LOGICAL LFIRST C LOGICAL ODD,NOMEM,LOGIX DATA Z0/0.D0/ C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C STATEMENT FUNCTION DEFINITIONS Z(I)=DBLE(I+I+1) ODD(I)=I-2*(I/2).NE.0 C C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION IF (LFIRST) THEN IFIRST=-1 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF C XM=MVALUE PM=1.D0 IF (ODD(MVALUE)) PM=-1.D0 C IF (IFIRST.GT.-1) GO TO 3500 C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS. C LOGIX=.TRUE. IF JTOP IS SMALLER THAN NLEV (SO STORE ON J) JTOP=0 DO 3400 I=1,NLEV 3400 JTOP=MAX(JTOP,JLEV(I)) LOGIX=JTOP.LT.NLEV IF (LOGIX) THEN NL12=(JTOP+1)*(JTOP+2)/2 ELSE NL12=NLEV*(NLEV+1)/2 ENDIF IXMX=NL12*NPOTL ISTART=MX+1 C 3500 MVABS=IABS(MVALUE) C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE C IF NOT, TRY TO STORE THEM IN XCPL(). IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900 MV=IFIRST+1 C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. 3600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 3610 IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX*(IFIRST+1) 602 FORMAT(/' CPL22 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT', 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X, 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) NOMEM=.TRUE. GO TO 3900 C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL 3610 NAVAIL=MX-IXNEXT+1 IF (IXMX.LE.NAVAIL) GO TO 3601 IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL 692 FORMAT(/' CPL22 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES NOMEM=.TRUE. GO TO 3900 C C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING W/ MV=0) 3601 MX=MX-IXMX IX=MV*IXMX C PMV=1.D0 IF (ODD(MV)) PMV=-1.D0 C CODE BELOW FROM V12 (DEC 94) CPL21 CODE C EXCEPT LIMIT ON IL LOOP AND VALUE OF LM IF (LOGIX) THEN ITOP=JTOP+1 ELSE ITOP=NLEV ENDIF DO 3200 IL=1,NPOTL LM=IL-1 JSAV=-1 ITJ=IXNEXT IXNEXT=ITJ+LM+LM+1 NUSED=0 CALL CHKSTR(NUSED) DO 3201 I1=1,ITOP IF (LOGIX) THEN J1=I1-1 ELSE J1=JLEV(I1) ENDIF IF (J1.NE.JSAV) THEN CALL J3J000(DBLE(J1),DBLE(LM),IVALJ,X(ITJ),XJMIN) JMIN=IABS(J1-LM) JMAX=J1+LM JSAV=J1 ENDIF DO 3201 I2=1,I1 IF (LOGIX) THEN J2=I2-1 ELSE J2=JLEV(I2) ENDIF IX=IX+1 IF (J2.LT.JMIN .OR. J2.GT.JMAX 1 .OR. J1.LT.MV .OR. J2.LT.MV 1 .OR. ODD(J2+JMAX)) THEN X(ISTART-IX)=0.D0 ELSE INDJ=ITJ+(J2-JMIN)/2 IF (MV.EQ.0) THEN X(ISTART-IX)=PMV*SQRT(Z(J1)*Z(J2))*X(INDJ)**2 ELSE X(ISTART-IX)=PMV*SQRT(Z(J1)*Z(J2))*X(INDJ)* 1 THRJ(DBLE(J1),DBLE(LM),DBLE(J2),-DBLE(MV),0.D0,DBLE(MV)) ENDIF ENDIF 3201 CONTINUE 3200 IXNEXT=ITJ C IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL 693 FORMAT(/' CPL22 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) C C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. IFIRST=MV C C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. MV=MV+1 IF (MV.LE.MVABS) GO TO 3600 C C START BY ZEROING VL, IV ARRAYS 3900 NTOP=NPOTL*N*(N+1)/2 DO 3999 I=1,NTOP VL(I)=0.D0 3999 IV(I)=0 IF (MVABS.GT.IFIRST) GO TO 3800 C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL IXM=MVABS*IXMX DO 3513 LL=1,MXLAM NNZ=0 LM=LAM(1,LL) NV=LAM(2,LL) NV1=LAM(3,LL) C ICR COUNTS ICOL,IROW LOOP; NEEDED FOR IXVL (VL INDEX) ICR=0 DO 3503 ICOL=1,N I1=J(ICOL) J1=JLEV(I1) NVC=JLEV(NLEV+I1) DO 3503 IROW=1,ICOL I2=J(IROW) J2=JLEV(I2) NVR=JLEV(NLEV+I2) ICR=ICR+1 IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC)) 1 THEN C FIRST GET INDEX IN VL, IV IXVL=(ICR-1)*NPOTL+LM+1 C THEN GET INDEX OF STORED COUPLING COEFFICIENT, DEPENDING ON LOGIX IF (LOGIX) THEN IF (J1.GT.J2) THEN IX12=(J1+1)*J1/2+J2+1 ELSE IX12=(J2+1)*J2/2+J1+1 ENDIF ELSE IF (I1.GT.I2) THEN IX12=I1*(I1-1)/2+I2 ELSE IX12=I2*(I2-1)/2+I1 ENDIF ENDIF IX=IXM+LM*NL12+IX12 IV(IXVL)=LL VL(IXVL)=X(ISTART-IX) IF (VL(IXVL).NE.0.D0) NNZ=NNZ+1 C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NEC IF (MVALUE.LT.0.AND.ODD(J1+J2+LM)) VL(IXVL)=-VL(IXVL) ENDIF 3503 CONTINUE IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVALUE,LL 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', & 'COEFFICIENTS ARE 0.') 3513 CONTINUE RETURN C C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM 3800 DO 1511 LL=1,MXLAM LM=LAM(1,LL) NV=LAM(2,LL) NV1=LAM(3,LL) XLM=LM NNZ=0 C ICR COUNTS ICOL,IROW LOOP; NEEDED FOR IXVL (VL INDEX) ICR=0 DO 1501 ICOL=1,N JCOL=JLEV(J(ICOL) ) XJCOL=JCOL NVC=JLEV(NLEV+J(ICOL)) DO 1501 IROW=1,ICOL JROW=JLEV(J(IROW) ) XJROW=JROW NVR=JLEV(NLEV+J(IROW)) ICR=ICR+1 IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC)) 1 THEN IXVL=(ICR-1)*NPOTL+LM+1 IV(IXVL)=LL VL(IXVL)=PM*SQRT(Z(JROW)*Z(JCOL))* & THREEJ(JROW,LM,JCOL)* & THRJ(XJROW,XLM,XJCOL,-XM,Z0,XM) IF (VL(IXVL).NE.0.D0) NNZ=NNZ+1 ENDIF 1501 CONTINUE IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVALUE,LL 1511 CONTINUE RETURN END SUBROUTINE CPL23(N,MXLAM,LAM,NLEV,JLEV,J,L,MVALUE,IEX,VL,PRINT, 1 LFIRST) C CS COUPLING MATRIX FOR LINEAR ROTOR-LINEAR ROTOR (ITYPE=23) C SAVES M-INDEPENDENT PARTS USING NEW DYNAMIC STORAGE C AND IVLFL IN VERSION '12X' OF MOLSCAT. C VERSION 5. LINEAR XCPL NOW STORED BACKWARDS IN HI LOCS OF X(). C JAN 93 IVLFL CHECKED BEFORE CALL CPL23 AND IV NO LONGER USED C M-INDEPENDENT PARTS (9-J) STORED IROW.GE.ICOL. C M-DEPENDENT (3J) PARTS STORED IF MEMORY ALLOWS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE NOMEM,NL12,J12MX,NJ12,NXPM,NLM,IHL,IXEX,IXTJ,IXMX,ISTART 1 ,IFIRST C INTEGER PRINT INTEGER LAM(2),JLEV(NLEV,3),J(2),L(2) LOGICAL ODD,NOMEM,LFIRST DIMENSION VL(2) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA SQRTHF/.70710678118654753D0/, Z0/0.D0/ DATA PIFCT/2.24483902656458321D-2/ Z(I)=DBLE(I+I+1) ODD(I)=I-2*(I/2).NE.0 C C INITIALIZE IFIRST IF LFIRST IS SET TO TRUE IF (LFIRST) THEN IFIRST=-2 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF XM=MVALUE C PM=PARITY(MVALUE) IF (IFIRST.GT.-2) GO TO 3500 C FIRST TIME THROUGH EVALUATE MVALUE-INDEPENDENT PARTS OF VL() C SET-UP AND CHECK STORAGE ... NL12=NLEV*(NLEV+1)/2 IXMX=NL12*MXLAM IXEX=IXMX IF (IEX.GT.0) IXMX=2*IXMX NAVAIL=MX-IXNEXT+1 IF (IXMX.LE.NAVAIL) GO TO 3010 WRITE(6,601) NLEV,MXLAM,IEX,IXMX,NAVAIL 601 FORMAT(/' ***** MCGCPL (JAN 93) NLEV,MXLAM,IEX =',3I4 1 /' REQUIRED STORAGE MORE THAN AVAILABLE',2I9) STOP C C SET ISTART SO THAT X(ISTART-IX) IS XCPL(IX), REDUCE MX, C AND SET-UP THE NINEJ PARTS IN X(). 3010 ISTART=MX+1 MX=MX-IXMX DO 3100 LL=1,MXLAM LM1=LAM(3*LL-2) LM2=LAM(3*LL-1) LM=LAM(3*LL) IL12=0 DO 3100 I1=1,NLEV J1=JLEV(I1,1) J2=JLEV(I1,2) J12=JLEV(I1,3) DO 3100 I2=1,I1 IL12=IL12+1 J1P=JLEV(I2,1) J2P=JLEV(I2,2) J12P=JLEV(I2,3) FACTOR=PIFCT*Z(LM)*SQRT(Z(J12)*Z(J12P)*Z(J1)*Z(J1P)*Z(J2)*Z(J2P) 1 *Z(LM1)*Z(LM2))*PARITY(J1+J2+J12) C XCPL(IL12,LL,1) IX=(LL-1)*NL12+IL12 X(ISTART-IX)=THREEJ(J1,LM1,J1P)*THREEJ(J2,LM2,J2P)* 1 XNINEJ(J12P,J2P,J1P,J12,J2,J1,LM,LM2,LM1)*FACTOR IF (IEX.EQ.0) GO TO 3100 IF (J1.EQ.J2) THEN X(ISTART-IXEX-IX)=X(ISTART-IX) ELSE X(ISTART-IXEX-IX)=THREEJ(J2,LM1,J1P)*THREEJ(J1,LM2,J2P)* 1 XNINEJ(J12P,J2P,J1P,J12,J1,J2,LM,LM2,LM1)*FACTOR ENDIF 3100 CONTINUE IF (PRINT.GT.3) WRITE(6,691) IXMX,NAVAIL 691 FORMAT(/' CPL23 (JAN 93). 9-J PARTS STORED. USED, AVAILABLE=' 1 ,2I9) C RESET IFIRST TO INDICATE THAT NINE-J PARTS ARE STORED IFIRST=-1 C NOW CALCULATE PARMS NEEDED TO STORE M-DEPENDENT (THRJ) PARTS. IXTJ=IXMX J12MX=0 DO 3002 I=1,NLEV 3002 J12MX=MAX(J12MX,JLEV(I,3)) NJ12=(J12MX+1)*(J12MX+2)/2 LMAX=0 IHL=2 DO 3003 I=1,MXLAM IF (ODD(LAM(3*I))) IHL=1 3003 LMAX=MAX(LMAX,LAM(3*I)) NLM=LMAX/IHL+1 NXPM=NJ12*NLM C C SEE IF REQUIRED M-DEPENDENT VALUES (THRJ) ARE STORED. C IF NOT, TRY TO STORE THEM IN XCPL(). 3500 MVABS=IABS(MVALUE) IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900 MV=IFIRST+1 C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. 3600 IF (MX.EQ.ISTART-IXMX-1) GO TO 3610 IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX 602 FORMAT(/' CPL23 (JAN 93). HIGH MEMORY FRAGMENTED. CANNOT', 1 ' STORE 3-J VALUES FOR MVAL=',I3/ 19X, 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) NOMEM=.TRUE. GO TO 3900 C TEST FOR AVAILABLE STORAGE; NEED NXPM FOR THIS MVAL 3610 NAVAIL=MX-IXNEXT+1 IF (NXPM.LE.NAVAIL) GO TO 3601 IF (PRINT.GE.3) WRITE(6,692) MVABS,NXPM,NAVAIL 692 FORMAT(/' CPL23 (JAN 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES NOMEM=.TRUE. GO TO 3900 C UPDATE MEMORY POINTERS AND STORE 3-J VALUES FOR THIS MVAL 3601 IXMX=IXMX+NXPM MX=MX-NXPM XMV=MV LL=0 DO 3200 IL=1,NLM XLM=LL IXJ12=0 DO 3201 J12=0,J12MX XJ12=J12 DO 3201 J12P=0,J12 XJ12P=J12P C IXJ12=J12*(J12+1)/2+J12P+1 IXJ12=IXJ12+1 C IX=IXTJ+MV*NXPM+(IL-1)*NJ12+IXJ12 <==> (IXJ12,IL,MV+1) IX=MV*NXPM+(IL-1)*NJ12+IXJ12 3201 X(ISTART-IXTJ-IX)=THRJ(XJ12,XLM,XJ12P,XMV,Z0,-XMV) 3200 LL=LL+IHL IF (PRINT.GT.3) WRITE(6,693) MV,NXPM,NAVAIL 693 FORMAT(/' CPL23 (JAN 93). 3-J VALUES STORED FOR MVAL =',I3 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. IFIRST=MV C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. MV=MV+1 IF (MV.LE.MVABS) GO TO 3600 C C FILL VL() FROM XCPL 3900 DO 3513 LL=1,MXLAM NNZ=0 I=LL LM=LAM(3*LL) XLM=LM IL=LM/IHL+1 DO 3503 ICOL=1,N I1=J(ICOL) J1=JLEV(I1, 1) J2=JLEV(I1, 2) J12=JLEV(I1 ,3) XJ12=J12 DO 3503 IROW=1,ICOL I2=J(IROW) J1P=JLEV(I2,1) J2P=JLEV(I2,2) J12P=JLEV(I2 ,3) XJ12P=J12P C FIRST GET THRJ(J12,LM,J12P,M,0,-M) -- EITHER CALC OR FROM STORAG IF (MVABS.GT.IFIRST) THEN TJM=THRJ(XJ12,XLM,XJ12P,XM,Z0,-XM)*PM ELSE C NB WE HAVE STORED ON J.GE.J'; (J,L,J'/M,0,-M)=(J',L,J/M,0,-M) C ALSO, (J,L,J'/-M,0,M)=PARITY(J+L+J')*(J,L,J'/M,0,-M) IF (J12.GE.J12P) THEN IXJ12=J12*(J12+1)/2+J12P+1 ELSE IXJ12=J12P*(J12P+1)/2+J12+1 ENDIF IXM=MVABS*NXPM+(IL-1)*NJ12+IXJ12 TJM=X(ISTART-IXTJ-IXM)*PM IF (MVALUE.LT.0.AND.ODD(J12+J12P+LM)) TJM=-TJM ENDIF C THEN GET NINEJ() PARTS IF (I1.GE.I2) THEN IL12=I1*(I1-1)/2+I2 ELSE IL12=I2*(I2-1)/2+I1 ENDIF IX=(LL-1)*NL12+IL12 VL(I)=X(ISTART-IX)*TJM IF (IEX.EQ.0) GO TO 3593 C *** CODE BELOW ASSUMES THAT SYMMETRICALLY RELATED TERMS ARE BOTH C *** PRESENT IN POTENTIAL. C ((((((((((((((( EXCHANGE SHOULD BE CHECKED ))))))))))))))))))) IF (J1.NE.J2) GO TO 3594 T=VL(I) GO TO 3595 3594 T=X(ISTART-IXEX-IX)*TJM 3595 VL(I)=VL(I)+PARITY(IEX+J1+J2-J12+L(ICOL))*T IF (J1.EQ.J2) VL(I)=VL(I)*SQRTHF IF (J1P.EQ.J2P)VL(I)=VL(I)*SQRTHF 3593 IF (VL(I).NE.0.D0) NNZ=NNZ+1 3503 I=I+MXLAM IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVALUE,LL 612 FORMAT(' * * * NOTE. FOR MVALUE, LAM =',2I4,', ALL COUPLING ', & 'COEFFICIENTS ARE 0.') 3513 CONTINUE RETURN C END SUBROUTINE CPL25(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) C C CS COUPLING MATRIX FOR SYMMETRIC TOP ROTOR-ATOM (ITYPE=25) C SAVES COUPLING COEFFICIENTS USING NEW DYNAMIC STORAGE C N.B. IV() IS NO LONGER USED; CONTROLLED BY IVLFL IN /MEMORY/ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE NOMEM,NL12,IXMX,ISTART,IFIRST C C SPECIFICATIONS FOR ARGUMENTS DIMENSION LAM(MXLAM),JLEV(NLEV,3),J(N),VL(1) INTEGER PRINT LOGICAL LFIRST C LOGICAL ODD,NOMEM C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA Z0/0.D0/, HALF/0.5D0/, ONE/1.D0/ C C STATEMENT FUNCTION DEFINITIONS ODD(I)=I-2*(I/2).NE.0 C C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION IF (LFIRST) THEN IFIRST=-1 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF C SQRTHF=SQRT(HALF) XM=MVALUE C IF (IFIRST.GT.-1) GO TO 3500 C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS NL12=NLEV*(NLEV+1)/2 IXMX=NL12*MXLAM ISTART=MX+1 C 3500 MVABS=IABS(MVALUE) C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE C IF NOT, TRY TO STORE THEM IN XCPL(). IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900 MV=IFIRST+1 C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. 3600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 3610 IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX*(IFIRST+1) 602 FORMAT(/' CPL25 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT', 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/19X, 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) NOMEM=.TRUE. GO TO 3900 C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL 3610 NAVAIL=MX-IXNEXT+1 IF (IXMX.LE.NAVAIL) GO TO 3601 IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL 692 FORMAT(/' CPL25 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES NOMEM=.TRUE. GO TO 3900 C C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL 3601 MX=MX-IXMX C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0) IX=MV*IXMX DO 3200 IL=1,MXLAM LM=LAM(2*IL-1) MU=LAM(2*IL) DO 3201 I1=1,NLEV J1=JLEV(I1,1) K1=JLEV(I1,2) IS1=JLEV(I1,3) DO 3201 I2=1,I1 J2=JLEV(I2,1) K2=JLEV(I2,2) IS2=JLEV(I2,3) IX=IX+1 XCPL=Z0 IF (J1.LT.MV.OR.J2.LT.MV) GO TO 3201 PARFCT=(ONE+PARITY(J1+J2+IS1+IS2+LM+MU))*HALF IF (PARFCT.LE.1.D-5) GO TO 3201 IF (K1.EQ.0) PARFCT=PARFCT*SQRTHF IF (K2.EQ.0) PARFCT=PARFCT*SQRTHF KDIF=K2-K1 IF (IABS(KDIF).NE.MU) GO TO 3205 WPAR=ONE IF (KDIF.LT.0.AND.ODD(MU)) WPAR=-WPAR C CONTRIBUTION FROM (J1, K1, MVALUE / Y(LM,MU) / J2, K2, MVALUE) XCPL=PARFCT*WPAR*GSYMTP(J1,K1,J2,K2,MVALUE,LM,KDIF) 3205 KSUM=K2+K1 IF (IABS(KSUM).NE.MU) GO TO 3201 C CONTRIBUTION FROM (J1,-K1,MVALUE / Y(LM,MU) / J2,K2,MVALUE) XCPL=XCPL+PARFCT*PARITY(IS1)* & GSYMTP(J1,-K1,J2,K2,MVALUE,LM,KSUM) 3201 X(ISTART-IX)=XCPL 3200 CONTINUE IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL 693 FORMAT(/' CPL25 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. IFIRST=MV C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. MV=MV+1 IF (MV.LE.MVABS) GO TO 3600 C 3900 IF (MVABS.GT.IFIRST) GO TO 3800 C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL IXM=MVABS*IXMX DO 3513 LL=1,MXLAM NNZ=0 I=LL LM=LAM(LL) DO 3503 ICOL=1,N I1=J(ICOL) J1=JLEV(I1,1) DO 3503 IROW=1,ICOL I2=J(IROW) J2=JLEV(I2,1) IF (I1.GT.I2) THEN IX12=I1*(I1-1)/2+I2 ELSE IX12=I2*(I2-1)/2+I1 ENDIF IX=IXM+(LL-1)*NL12+IX12 VL(I)=X(ISTART-IX) C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY C FOR PARITY OF THRJ(J1,LM,J2,-MVAL,0,MVAL) IF (MVALUE.LT.0.AND.ODD(J1+J2+LM)) VL(I)=-VL(I) 3593 IF (VL(I).NE.Z0) NNZ=NNZ+1 3503 I=I+MXLAM IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVALUE,LL 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', & 'COEFFICIENTS ARE 0.') 3513 CONTINUE RETURN C C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM 3800 DO 5555 LL=1,MXLAM NNZ=0 I=LL LM=LAM(2*LL-1) MU=LAM(2*LL) DO 5565 ICOL=1,N J1=JLEV(J(ICOL),1) K1=JLEV(J(ICOL),2) IS1=JLEV(J(ICOL),3) DO 5565 IROW=1,ICOL J2=JLEV(J(IROW),1) K2=JLEV(J(IROW),2) IS2=JLEV(J(IROW),3) VL(I)=Z0 PARFCT=(ONE+PARITY(J1+J2+IS1+IS2+LM+MU))*HALF IF (PARFCT.LE.1.D-5) GO TO 5565 IF (K1.EQ.0) PARFCT=PARFCT*SQRTHF IF (K2.EQ.0) PARFCT=PARFCT*SQRTHF KDIF=K2-K1 IF (IABS(KDIF).NE.MU) GO TO 5575 WPAR=ONE IF (KDIF.LT.0.AND.ODD(MU)) WPAR=-WPAR C CONTRIBUTION FROM (J1, K1, MVALUE / Y(LM,MU) / J2, K2, MVALUE) VL(I)=VL(I) + PARFCT*WPAR*GSYMTP(J1,K1,J2,K2,MVALUE,LM,KDIF) 5575 KSUM=K2+K1 IF (IABS(KSUM).NE.MU) GO TO 5585 C CONTRIBUTION FROM (J1,-K1,MVALUE / Y(LM,MU) / J2,K2,MVALUE) VL(I)=VL(I)+PARFCT*PARITY(IS1)* & GSYMTP(J1,-K1,J2,K2,MVALUE,LM,KSUM) 5585 IF (ABS(VL(I)).GE.1.D-5) NNZ=NNZ+1 5565 I=I+MXLAM IF (NNZ.EQ.0) WRITE(6,612) MVALUE,LL 5555 CONTINUE RETURN END SUBROUTINE CPL3(N,MXLAM,LAM,NLEV,JLEV,J,L,JTOT,VL,IEX,PRINT, 1 LFIRST) C COUPLING MATRIX ELEMENTS FOR LINEAR ROTOR-LINEAR ROTOR (ITYPE=3) C JAN 93 CODE TO SAVE JTOT-INDEPENDENT PARTS IN DEDICATED STORAGE C WORKS W/ NEW DYNAMIC STORAGE CAPABILITIES. IVLFL CHECKED C BEFORE CALL CPL3 AND IV NO LONGER USED. C C LOWER DIAGONAL OF XCPL IS STORED FOR MAIN COUPLING ELEMENTS C BUT EXCHANGE PART REQUIRES FULL MATRIX (NLEV,NLEV) STORAGE. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE IXEX,ISTART,IFIRST LOGICAL ODD,LFIRST INTEGER PRINT DIMENSION LAM(1),JLEV(NLEV,3),J(1),L(1) DIMENSION VL(1) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C CONST IS FACTOR (4.*PI)**(-3/2) DATA CONST/2.24483902656458321D-2/, SQRTHF/.70710678118654753D0/ C STATEMENT FUNCTIONS ODD(I)=I-2*(I/2).NE.0 Z(I)=DBLE(I+I+1) C C INITIALIZE IFIRST IF LFIRST IS SET TRUE IF (LFIRST) THEN IFIRST=0 LFIRST=.FALSE. ENDIF C NLSQ=NLEV*NLEV NL12=NLEV*(NLEV+1)/2 IF (IFIRST.GT.0) GO TO 8030 C C FIRST TIME THROUGH EVALUATE JTOT-INDEPENDENT PARTS OF VL() IXMX=NL12*MXLAM IXEX=IXMX IF (IEX.GT.0) IXMX=IXEX+NLSQ*MXLAM NAVAIL=MX-IXNEXT+1 IF (IXMX.LE.NAVAIL) GO TO 3010 WRITE(6,699) NLEV,MXLAM,IEX,IXMX,NAVAIL 699 FORMAT(/' ***** CPL3 (JAN 93) NLEV,MXLAM,IEX =',3I4 1 /' REQUIRED STORAGE MORE THAN AVAILABLE',2I9) STOP C UPDATE STORAGE POINTERS. NB WE STORE XPCL BACKWARDS AT TOP OF X() 3010 ISTART=MX+1 MX=MX-IXMX DO 3100 LL=1,MXLAM LM1=LAM(3*LL-2) LM2=LAM(3*LL-1) LM=LAM(3*LL) IL12=0 DO 3100 I1=1,NLEV J1=JLEV(I1,1) J2=JLEV(I1,2) J12=JLEV(I1,3) DO 3100 I2=1,I1 IL12=IL12+1 J1P=JLEV(I2,1) J2P=JLEV(I2,2) J12P=JLEV(I2,3) C INDEX FOR XCPL(IL12,LL,1), I.E., SYMMETRIZED IX=(LL-1)*NL12+IL12 FACTOR=CONST*Z(LM)*SQRT((Z(LM1)*Z(LM2))*(Z(J1)*Z(J2)*Z(J12))* 1 (Z(J1P)*Z(J2P)*Z(J12P))) JSUM=J1+J2+J12P IF (ODD(JSUM)) FACTOR=-FACTOR X(ISTART-IX)=THREEJ(LM1,J1P,J1)*THREEJ(LM2,J2P,J2)* 1 XNINEJ(J12P,J2P,J1P,J12,J2,J1,LM,LM2,LM1)*FACTOR IF (IEX.EQ.0) GO TO 3100 C INDEX FOR XCPL(I2,I1,LL,2), I.E., UNSYMMETRIZED IE=(LL-1)*NLSQ+(I1-1)*NLEV+I2 IF (J1.EQ.J2) THEN X(ISTART-IXEX-IE)=X(ISTART-IX) ELSE X(ISTART-IXEX-IE)=THREEJ(LM1,J1P,J2)*THREEJ(LM2,J2P,J1)* 1 XNINEJ(J12P,J2P,J1P,J12,J1,J2,LM,LM2,LM1)*FACTOR ENDIF IF (I1.EQ.I2) GO TO 3100 C ELSE WE NEED TO STORE I1<->I2 VALUES IE=(LL-1)*NLSQ+(I2-1)*NLEV+I1 IF (J1P.EQ.J2P) THEN X(ISTART-IXEX-IE)=X(ISTART-IX) ELSE X(ISTART-IXEX-IE)=THREEJ(LM1,J2P,J1)*THREEJ(LM2,J1P,J2)* 1 XNINEJ(J12P,J1P,J2P,J12,J2,J1,LM,LM2,LM1)*FACTOR ENDIF 3100 CONTINUE IF (PRINT.GT.3) WRITE(6,697) NLEV,MXLAM,IEX,IXMX,NAVAIL 697 FORMAT(/' CPL3 (JAN 93). ', 1 ' JTOT-INDEPENDENT PARTS OF COUPLING MATRIX STORED', 2 '. NLEV, MXLAM, IEX =',3I4/ 3 19X,'REQUIRED AND AVAILABLE STORAGE =',2I9) C RESET IFIRST IFIRST=1 C C EVALUATE VL() USING STORED JTOT-INDEPENDENT PARTS 8030 DO 1513 LL=1,MXLAM NNZ=0 I=LL LM=LAM(3*LL) DO 1503 ICOL=1,N LV=L(ICOL) I1=J(ICOL) J1=JLEV(I1,1) J2=JLEV(I1,2) J12=JLEV(I1,3) DO 1503 IROW=1,ICOL LVP=L(IROW) I2=J(IROW) J1P=JLEV(I2,1) J2P=JLEV(I2,2) J12P=JLEV(I2,3) C GET JTOT-DEPENDENT PARTS XFACT=SQRT(Z(LV)*Z(LVP))*THREEJ(LM,LVP,LV) 1 *SIXJ(LVP,LV,J12P,J12,LM,JTOT) IF (ODD(JTOT)) XFACT=-XFACT C GET JTOT-INDEPENDENT PARTS FROM XCPL. C BELOW IS FOR SYMMETRIZED MAIN PART IF (I1.GE.I2) THEN IL12=I1*(I1-1)/2+I2 ELSE IL12=I2*(I2-1)/2+I1 ENDIF IX=(LL-1)*NL12+IL12 VL(I)=XFACT*X(ISTART-IX) IF (IEX.EQ.0) GO TO 1593 C *** C *** N.B. CODE BELOW ASSUMES THAT SYMMETRICALLY RELATED POTENTIAL TERMS C *** I.E. A(LM1,LM2,LM) AND A(LM2,LM1,LM) ARE BOTH PRESENT IN POTL. C *** C BELOW IS FOR XCPL(I2,I1,LL,IEX) STORAGE ORDER IE=(LL-1)*NLSQ+(I1-1)*NLEV+I2 IF (J1.NE.J2) GO TO 1594 T=VL(I) GO TO 1595 1594 T=XFACT*X(ISTART-IXEX-IE) 1595 JSUM=IEX+J1+J2-J12+LV IF (ODD(JSUM)) T=-T VL(I)=VL(I)+T IF (J1.EQ.J2) VL(I)=VL(I)*SQRTHF IF (J1P.EQ.J2P) VL(I)=VL(I)*SQRTHF 1593 IF (VL(I).NE.0.D0) NNZ=NNZ+1 1503 I=I+MXLAM IF (NNZ.LE.0.AND.PRINT.GE.4) WRITE(6,612) JTOT, LL 612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING ', 1 'COEFFICIENTS ARE 0.0 FOR SYMMETRY',I4) 1513 CONTINUE RETURN END SUBROUTINE CPL4(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,ATAU,NLEV, 1 PRINT,LFIRST) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE IFIRST,NOMEM,NL12,IXMX,ISTART C COUPLING MATRIX ELEMENTS FOR ITYPE=4 (CPL4) & ITYPE=24 (CPL24) C SPECIFICATIONS FOR PARAMETER LIST INTEGER J(N),L(N),LAM(2),JLEV(2) INTEGER PRINT DIMENSION ATAU(2),VL(2) LOGICAL LFIRST C INTEGER P1,Q1,P2,P LOGICAL ODD,NOMEM C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C COMMON /VLSAVE/ IVLU C DATA PI/3.141592653589793D0/ DATA EPS/1.D-8/, Z0/0.D0/ C C STATEMENT FUNCTIONS ... F(NN) = DBLE(NN+NN+1) ODD(I) = I-2*(I/2).NE.0 C IF (LFIRST) THEN IFIRST=-1 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF IF (IFIRST.GT.-1) GO TO 5500 IF (NOMEM) GO TO 5900 NL12=NLEV*(NLEV+1)/2 IXMX=NL12*MXLAM ISTART=MX+1 NAVAIL=ISTART-IXNEXT IF (IXMX.LE.NAVAIL) GO TO 5100 IF (PRINT.GE.3) WRITE(6,694) IXMX,NAVAIL 694 FORMAT(/' CPL4 (JUL 93). UNABLE TO STORE JTOT-INDEPENDENT PART' 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) NOMEM=.TRUE. GO TO 5900 5100 IX=0 DO 5200 LL=1,MXLAM P1 = LAM(4*LL-3) Q1 = LAM(4*LL-2) P2 = LAM(4*LL-1) P = LAM(4*LL) XP1 = P1 XQ1 = Q1 DO 5201 IC=1,NLEV JC=JLEV(IC) J1C = JLEV(IC + 2*NLEV) J2C = JLEV(IC + NLEV) XJC = JC XJ1C = J1C XJ2C = J2C ISTC = JLEV(IC + 5*NLEV) NKC = JLEV(IC + 6*NLEV) DO 5201 IR=1,IC IX=IX+1 JR=JLEV(IR) J1R = JLEV(IR + 2*NLEV) J2R = JLEV(IR + NLEV) XJR=JR XJ1R = J1R XJ2R = J2R ISTR=JLEV(IR+5*NLEV) NKR=JLEV(IR+6*NLEV) XCPL=Z0 KKC=-J1C DO 5300 KC=1,NKC C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 5300 XKC=KKC KKR=-J1R DO 5400 KR=1,NKR C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 5400 XKR=KKR C AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)*PARITY(KKR) AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) IF (ODD(KKR)) AF=-AF IF (KKR-KKC.NE.Q1) GO TO 5401 XCPL=XCPL+AF*THRJ(XJ1R,XP1,XJ1C,-XKR,XQ1,XKC) IF (Q1.EQ.0) GO TO 5400 5401 IF (KKC-KKR.NE.Q1) GO TO 5400 C ADJUST FOR (-1)**MU IN POTENTIAL. . . AF=AF*PARITY(P1+Q1+P2+P) XCPL=XCPL+AF*THRJ(XJ1R,XP1,XJ1C,-XKR,-XQ1,XKC) 5400 KKR=KKR+1 5300 KKC=KKC+1 C NOW GET 'CONSTANT FACTORS' XFCT=PARITY(JR-J1C+J2C) 1 *SQRT(F(J2R)*F(J2C)*F(P)*F(P2)*F(JR)*F(JC)*F(J1C)*F(J1R)) 2 *THREEJ(J2R,P2,J2C)*XNINEJ(JC,JR,P,J1C,J1R,P1,J2C,J2R,P2) 3 /4.D0/PI 5201 X(ISTART-IX)=XCPL*XFCT 5200 CONTINUE IF (PRINT.GT.3) WRITE(6,695) IXMX 695 FORMAT(/' CPL4 (JUL 93). JTOT-INDEPENDENT PARTS OF COUPLING', 1 ' MATRIX STORED.'/ 2 ' REQUIRED STORAGE =',I8) C RESET MX, IFIRST TO REFLECT STORED VALUES MX=MX-IXMX IFIRST=0 C C NOW GET COUPLING MATRIX ELEMENTS FROM STORED PARTS 5500 PJT=PARITY(JTOT) IF (IVLU.GT.0) REWIND IVLU DO 5600 LL=1,MXLAM P1 = LAM(4*LL-3) Q1 = LAM(4*LL-2) P2 = LAM(4*LL-1) P = LAM(4*LL) C PPP = PARITY(P) IX1=(LL-1)*NL12 NNZ=0 IF (IVLU.EQ.0) THEN IX=LL ELSE IX=1 ENDIF C DO 5700 IC=1,N INJ12P = J(IC) JC=JLEV(INJ12P) LC=L(IC) C DO 5700 IR=1,IC INJ12=J(IR) JR=JLEV(INJ12) LR=L(IR) C XFACT = PJT*PPP*THREEJ(LR,P,LC)*SIXJ(LR,JR,LC,JC,JTOT,P) 1 *SQRT(F(LR)*F(LC)) IF (INJ12.GE.INJ12P) THEN IX2=INJ12*(INJ12-1)/2+INJ12P ELSE IX2=INJ12P*(INJ12P-1)/2+INJ12 ENDIF INDX=IX1+IX2 C IF (X(ISTART-INDX).EQ.0.D0) THEN VL(IX) = 0.D0 ELSE VL(IX)=XFACT*X(ISTART-INDX) ENDIF IF (VL(IX).NE.0.D0) NNZ=NNZ+1 IF (IVLU.EQ.0) THEN IX=IX+MXLAM ELSE IX=IX+1 ENDIF 5700 CONTINUE IF (NNZ.EQ.0.AND.PRINT.GT.3) WRITE(6,697) P1,Q1,P2,P IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) 5600 CONTINUE RETURN C C IF WE CANNOT STORE PARTIAL COUPLING MATRIX, RECALCULATE. 5900 ASSIGN 3001 TO IGO1 ASSIGN 3011 TO IGO2 GO TO 3000 C ENTRY CPL24(N,MXLAM,LAM,NLEV,JLEV,ATAU,J,MVAL,VL,PRINT,LFIRST) C C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION IF (LFIRST) THEN IFIRST=-1 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF C IF (IFIRST.GT.-1) GO TO 4500 C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS NL12=NLEV*(NLEV+1)/2 IXMX=NL12*MXLAM ISTART=MX+1 C 4500 MVABS=IABS(MVAL) C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE C IF NOT, TRY TO STORE THEM IN XCPL(). IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 4900 MV=IFIRST+1 C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. 4600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 4610 IF (PRINT.GE.1) WRITE(6,642) MV,ISTART-1,MX,IXMX*(IFIRST+1) 642 FORMAT(/' CPL24 (JUL 93). HIGH MEMORY FRAGMENTED. CANNOT', 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X, 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) NOMEM=.TRUE. GO TO 4900 C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL 4610 NAVAIL=MX-IXNEXT+1 IF (IXMX.LE.NAVAIL) GO TO 4601 IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL 692 FORMAT(/' CPL24 (JUL 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES NOMEM=.TRUE. GO TO 4900 C C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL 4601 MX=MX-IXMX C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0) IX=MV*IXMX DO 4200 LL=1,MXLAM P1 = LAM(4*LL-3) Q1 = LAM(4*LL-2) P2 = LAM(4*LL-1) P = LAM(4*LL) DO 4201 IC=1,NLEV JC=JLEV(IC) J1C = JLEV(IC+2*NLEV) J2C = JLEV(IC+ NLEV) ISTC=JLEV(IC+5*NLEV) NKC=JLEV(IC+6*NLEV) DO 4201 IR=1,IC JR=JLEV(IR) J1R = JLEV(IR+2*NLEV) J2R = JLEV(IR+ NLEV) ISTR=JLEV(IR+5*NLEV) NKR=JLEV(IR+6*NLEV) IX=IX+1 XCPL=Z0 KKC=-J1C DO 4300 KC=1,NKC C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 4300 KKR=-J1R DO 4400 KR=1,NKR C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 4400 AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) IF (KKR-KKC.NE.Q1) GO TO 4401 XCPL=XCPL+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, 1 JR,JC,MVAL,P1,Q1,P2,P) IF (Q1.EQ.0) GO TO 4400 4401 IF (KKC-KKR.NE.Q1) GO TO 4400 C ADJUST FOR (-1)**MU IN POTENTIAL. . . C AF=AF*PARITY(MU) IF (ODD(P1+Q1+P2+P)) AF = -AF XCPL=XCPL+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, 1 JR,JC,MVAL,P1,-Q1,P2,P) 4400 KKR=KKR+1 4300 KKC=KKC+1 4201 X(ISTART-IX)=XCPL 4200 CONTINUE IF(PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL 693 FORMAT(/' CPL24 (JUL 93). 3J VALUES STORED FOR MVALUE =',I3, 1 /,' REQUIRED AND AVAILABLE STORAGE =',2I9) IFIRST = MV C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. MV=MV+1 IF (MV.LE.MVABS) GO TO 4600 C 4900 IF (MVABS.GT.IFIRST) GO TO 4800 C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL IXM=MVABS*IXMX IF (IVLU.GT.0) REWIND IVLU DO 4513 LL=1,MXLAM P1 = LAM(4*LL-3) Q1 = LAM(4*LL-2) P2 = LAM(4*LL-1) P = LAM(4*LL) NNZ=0 IF (IVLU.EQ.0) THEN IX=LL ELSE IX=1 ENDIF DO 4503 ICOL=1,N I1=J(ICOL) JC=JLEV(I1) DO 4503 IROW=1,ICOL I2=J(IROW) JR=JLEV(I2) IF (I1.GT.I2) THEN IX12=I1*(I1-1)/2+I2 ELSE IX12=I2*(I2-1)/2+I1 ENDIF IXX=IXM+(LL-1)*NL12+IX12 VL(IX)=X(ISTART-IXX) C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY C FOR PARITY OF THRJ(JR,P ,JC, MVAL,0,-MVAL) IF (MVAL.LT.0.AND.ODD(JC+JR+P )) VL(IX)=-VL(IX) IF (VL(IX).NE.Z0) NNZ=NNZ+1 IF (IVLU.EQ.0) THEN IX=IX+MXLAM ELSE IX=IX+1 ENDIF 4503 CONTINUE IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVAL,LL 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', & 'COEFFICIENTS ARE 0.') IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) 4513 CONTINUE RETURN C C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM VIA OLD CODE 4800 ASSIGN 3002 TO IGO1 ASSIGN 3022 TO IGO2 GO TO 3000 C C -------------------- OLD CODE REJOINS HERE --------------------- C 3000 IF (IVLU.GT.0) REWIND IVLU C C ----- LOOP OVER RADIAL SURFACES ----- C DO 3100 LL=1,MXLAM P1 = LAM(4*LL-3) Q1 = LAM(4*LL-2) P2 = LAM(4*LL-1) P = LAM(4*LL) NNZ=0 IF (IVLU.EQ.0) THEN IX=LL ELSE IX=1 ENDIF C DO 3200 IC=1,N JC = JLEV(J(IC) ) J1C = JLEV(J(IC) + 2*NLEV) J2C = JLEV(J(IC) + NLEV) ISTC = JLEV(J(IC) + 5*NLEV) NKC = JLEV(J(IC) + 6*NLEV) C DO 3200 IR=1,IC JR = JLEV(J(IR) ) J1R = JLEV(J(IR) + 2*NLEV) J2R = JLEV(J(IR) + NLEV) ISTR = JLEV(J(IR) + 5*NLEV) NKR = JLEV(J(IR) + 6*NLEV) C VL(IX)=0.D0 KKC=-J1C C C ----- LOOP OVER EXPANSION COEFFICIENTS. ----- C ----- SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. ----- C DO 3300 KC=1,NKC IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 3300 KKR=-J1R C DO 3400 KR=1,NKR IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 3400 AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) IF (KKR-KKC.NE.Q1) GO TO 3500 GO TO IGO1,(3001,3002) 3001 VL(IX)=VL(IX)+AF 1 *QSYMTP(J1R,KKR,J1C,KKC,J2R,J2C,L(IR),L(IC), 2 JR,JC,JTOT,P1,Q1,P2,P) GO TO 3009 3002 VL(IX)=VL(IX)+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, 1 JR,JC,MVAL,P1,Q1,P2,P) 3009 IF (Q1.EQ.0) GO TO 3400 3500 IF(KKC-KKR.NE.Q1) GO TO 3400 AF = AF*PARITY(P1+P2+P+Q1) GO TO IGO2(3011,3022) 3011 VL(IX)=VL(IX)+AF 1 *QSYMTP(J1R,KKR,J1C,KKC,J2R,J2C,L(IR),L(IC), 2 JR,JC,JTOT,P1,-Q1,P2,P) GO TO 3400 3022 VL(IX)=VL(IX)+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, 1 JR,JC,MVAL,P1,-Q1,P2,P) 3400 KKR=KKR+1 C 3300 KKC=KKC+1 C IF (VL(IX).NE.0.D0) NNZ=NNZ+1 IF(IVLU .EQ. 0) THEN IX = IX + MXLAM ELSE IX = IX + 1 ENDIF 3200 CONTINUE IF (NNZ.EQ.0.AND.PRINT.GT.3) WRITE(6,697) P1,Q1,P2,P 697 FORMAT(' * * * NOTE. ALL COUPLING COEFFICIENTS ARE ZERO FOR P1, & Q1, P2, P = ', 4I4) 3100 CONTINUE RETURN END SUBROUTINE CPLOUT(IV,V,N,NPOTL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION IV(1), V(1) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C THIS ROUTINE PRINTS OUT THE COUPLING MATRIX ELEMENTS. WRITE(6,602) NPOTL 602 FORMAT('0 COUPLING MATRIX ELEMENTS BETWEEN CHANNELS FOR',I4, 1 ' SYMMETRIES.') IF (IVLFL.GT.0) THEN IMAX=0 DO 1000 I=1,N DO 1000 J=1,I IMIN=IMAX+1 IMAX=IMAX+NPOTL WRITE(6,600) I,J 600 FORMAT('0 FOR CHANNEL ',I3,' TO CHANNEL',I4) WRITE(6,601) (IV(IJ),V(IJ),IJ=IMIN,IMAX) 601 FORMAT(' ',7(I3,1X,F12.5)) 1000 CONTINUE ELSE IMIN=0 DO 2000 I=1,N DO 2000 J=1,I WRITE(6,600) I,J WRITE(6,601) (LL,V(IMIN+LL),LL=1,NPOTL) 2000 IMIN=IMIN+NPOTL ENDIF RETURN END SUBROUTINE DAPROP(U, Y, N, & RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, & Y14, Y23, ESHIFT, DIAG, & P, VL, IV, ERED, EINT, CENT, RMLMDA, & MXLAM, NPOTL, ISTART, NODES) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ROUTINE TO SOLVE THE CLOSE COUPLED EQUATIONS USING AN C IMPROVED LOG DERIVATIVE ALGORITHM. THE DIAGONAL OF THE C COUPLING MATRIX EVALUATED AT THE MIDPOINT OF EACH SECTOR C IS USED AS A REFERENCE POTENTIAL FOR THE SECTOR. C LOGICAL IREAD,IWRITE DIMENSION U(N,N),Y(N,N),Y14(N),Y23(N),ESHIFT(N),DIAG(N) DIMENSION P(MXLAM),VL(2),IV(2),EINT(N),CENT(N) C NODES=0 ESAVE=ERED DO 20 I=1,N ESHIFT(I)=EINT(I)-ERED EINT(I)=0.D0 20 CONTINUE ERED=0.D0 C C THIS VERSION USES A CONSTANT STEP SIZE THROUGHOUT THE C INTEGRATION RANGE, WITH NSTEPS STEPS BETWEEN RBEGIN AND REND. C H=(REND-RBEGIN)/DBLE(2*NSTEPS) D1=H*H/3.D0 D2=2.D0*D1 D4=-D1/16.D0 HALF=0.5D0*H C IF (IREAD) GO TO 60 NSAVE=0 R=RBEGIN CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) DO 40 J=1,N DO 40 I=J,N U(I,J)=D1*U(I,J) 40 CONTINUE IF (IWRITE) WRITE (ISCRU) DIAG,U GO TO 80 60 READ (ISCRU) DIAG,U 80 CONTINUE C C ISTART=0/1 MEANS THAT INITIAL LOG DERIVATIVE MATRIX ISN'T/IS C ALREADY IN Y. DEFAULT IS 0. C IF(ISTART.EQ.1) GO TO 140 SGN=1.D0 IF(REND.LT.RBEGIN) SGN=-1.D0 DO 120 J=1,N DO 100 I=J,N 100 Y(I,J)=0.D0 WREF=DIAG(J)+ESHIFT(J) Y(J,J)=SGN*1.D30 IF(WREF.GT.0.D0) Y(J,J)=SGN*SQRT(WREF) 120 CONTINUE 140 CONTINUE C DO 160 J=1,N DO 160 I=J,N Y(I,J)=H*Y(I,J)+U(I,J) 160 CONTINUE C DO 500 KSTEP=1,NSTEPS IF (IREAD) GO TO 260 R=R+H CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) DO 200 J=1,N DO 200 I=J,N U(I,J)=D4*U(I,J) 200 CONTINUE DO 220 I=1,N U(I,I)=0.125D0 220 CONTINUE CALL SYMINV(U,N,N,KOUNT) IF (KOUNT.GT.N) GO TO 900 NSAVE=NSAVE+KOUNT DO 240 I=1,N U(I,I)=U(I,I)-8.D0 240 CONTINUE IF (IWRITE) WRITE (ISCRU) DIAG,U GO TO 280 260 READ (ISCRU) DIAG,U 280 CONTINUE C DO 300 I=1,N WREF=DIAG(I)+ESHIFT(I) ARG=HALF*SQRT(ABS(WREF)) IF (WREF.LT.0.D0) THEN TN=TAN(ARG) Y14(I)=ARG/TN-ARG*TN Y23(I)=ARG/TN+ARG*TN ELSE C IF (WREF.GT.0.D0) THEN TH=TANH(ARG) Y14(I)=ARG/TH+ARG*TH Y23(I)=ARG/TH-ARG*TH ENDIF U(I,I)=U(I,I)+2.D0*Y14(I) Y14(I)=Y14(I)-D1*DIAG(I) Y14(I)=MAX(Y14(I),0.D0) Y(I,I)=Y(I,I)+Y14(I) 300 CONTINUE C CALL SYMINV(Y,N,N,KOUNT) IF (KOUNT.GT.N) GO TO 900 NODES=NODES+KOUNT DO 320 J=1,N DO 320 I=J,N Y(I,J)=U(I,J)-Y23(I)*Y(I,J)*Y23(J) 320 CONTINUE CALL SYMINV(Y,N,N,KOUNT) IF (KOUNT.GT.N) GO TO 900 NODES=NODES+KOUNT C IF (IREAD) GO TO 360 R=R+H CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) IF (KSTEP.EQ.NSTEPS) D2=D1 DO 340 J=1,N DO 340 I=J,N U(I,J)=D2*U(I,J) 340 CONTINUE IF (IWRITE) WRITE (ISCRU) U GO TO 380 360 READ (ISCRU) U 380 CONTINUE C DO 400 J=1,N DO 400 I=J,N Y(I,J)=U(I,J)-Y23(I)*Y(I,J)*Y23(J) 400 CONTINUE DO 420 I=1,N Y(I,I)=Y(I,I)+Y14(I) 420 CONTINUE 500 CONTINUE C HI=1.D0/H DO 520 J=1,N DO 520 I=J,N Y(I,J)=HI*Y(I,J) Y(J,I)=Y(I,J) 520 CONTINUE C DO 540 I=1,N EINT(I)=ESHIFT(I)+ESAVE 540 CONTINUE ERED=ESAVE IF(IWRITE) WRITE(ISCRU) NSAVE IF(IREAD) READ (ISCRU) NSAVE NODES=NODES-NSAVE RETURN C 900 WRITE (6,1000) KSTEP 1000 FORMAT('0***** MATRIX INVERSION ERROR IN DAPROP AT ', & 'STEP K = ',I6,' RUN HALTED.') STOP END SUBROUTINE DASCAT(N, NSQ, MXLAM, NPOTL, 1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB, 2 P, Y1, Y2, Y3, Y4, 3 ICODE, IPRINT, IC) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C *** --------------------------------------------------------------- C *** ROUTINE TO PERFORM A SCATTERING CALCULATION USING DAPROP. C *** ON EXIT SR AND SI CONTAIN THE S MATRIX. C *** SR IS USED INTERNALLY TO HOLD THE LOG DERIVATIVE MATRIX C *** IN ORDER TO ECONOMISE ON WORKSPACE. C *** --------------------------------------------------------------- C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGIES. C *** C DIMENSION STATEMENTS FOR ARGUMENT LIST DIMENSION U(NSQ),Y1(N),Y2(N),Y3(N),Y4(N) DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ), & EINT(N),CENT(N),WVEC(N),L(N),NB(N) C COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR, 1 DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, 2 NOPEN,JKEEP,ISCRU,MAXSTP C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C THE FOLLOWING VARIABLES FROM COMMON/DRIVE/ ARE USED WITH THIS C PROPAGATOR: STEPS,RMIN,RMAX,ERED,RMLMDA,NOPEN,ISCRU C LOGICAL IREAD,IWRITE C ---------------------------------------------------------------- C SET UP TO USE UNIT (ISCRU) IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 C --------------------------------------------------------------- C C CALCULATE WAVEVECTORS AND STEP SIZE C WMAX=0.D0 NOPEN=0 DO 20 I=1,N DIF=ERED-EINT(I) WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) WMAX=MAX(WMAX,WVEC(I)) NB(I)=I IF (DIF.GT.0.D0) NOPEN=NOPEN+1 20 CONTINUE IF (NOPEN.EQ.0) RETURN C IF (IREAD) GO TO 40 PI=ACOS(-1.D0) NSTEPS=WMAX*STEPS*(RMAX-RMIN)/PI RBEGIN=RMIN REND=RMAX IF (IWRITE) WRITE (ISCRU) RBEGIN,REND,NSTEPS GO TO 60 40 READ (ISCRU) RBEGIN,REND,NSTEPS 60 CONTINUE ISTART=0 C C PROPAGATE LOG DERIVATIVE MATRIX THROUGH THE SCATTERING REGION C --------------------------------------------------------------- IF(N.EQ.1) GOTO 90 CALL DAPROP(U, SR, N, & RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, & Y1, Y2, Y3, Y4, & P, VL, IV, ERED, EINT, CENT, RMLMDA, & MXLAM, NPOTL, ISTART, NODES) C --------------------------------------------------------------- IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,REND,NSTEPS 1000 FORMAT('0 DAPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ', & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') C C SORT CHANNELS BY ASYMPTOTIC ENERGY C NM1=N-1 DO 80 I=1,NM1 IP1=I+1 DO 80 J=IP1,N IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 80 IT=NB(I) NB(I)=NB(J) NB(J)=IT 80 CONTINUE GOTO 100 C C SPECIAL CASE FOR EFFICIENT SINGLE CHANNEL CALCULATIONS C 1/21/93 CHANGES TO DYNAMIC STORAGE: N.B IT5 FROM STORAG IS C PASSED AS ARGUMENT IC TO FOLLOW CODING IN EARLIER VERSIONS. C 90 NPT=NSTEPS+1 ISVMEM=IXNEXT IT1=IC IT2=IT1+NPT IT3=IT2+NPT IT4=IT3+NPT IT5=IT4+NPT IC1=IT5+NPT ITP=IT3 IC2=ITP+NPT*MXLAM IXNEXT=MAX0(IC1,IC2) NUSED=0 CALL CHKSTR(NUSED) CALL ODPROP(SR, X(IT1), X(IT2), X(IT3), X(IT4), X(IT5), & RBEGIN, REND, NPT, IREAD, IWRITE, ISCRU, & X(ITP), VL, IV, ERED, EINT, CENT, RMLMDA, & MXLAM, NPOTL, ISTART, NODES) C RESTORE STORAGE POINTER TO RECOVER TEMPORARY STORAGE. IXNEXT=ISVMEM C --------------------------------------------------------------- IF (IPRINT.GE.3) WRITE (6,1010) RBEGIN,REND,NSTEPS 1010 FORMAT('0 ODPROP. LOG DERIVATIVE INTEGRATED FROM ', & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') C C CALCULATE K AND S MATRICES C 100 CALL YTOK(NB,WVEC,L,N,NOPEN,Y1,Y2,Y3,Y4,SR,SI,U,REND) CALL KTOS(U,SR,SI,NOPEN) RETURN END SUBROUTINE DASIZE(ILSU,MXREC) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE MXUSED,IX PARAMETER (NREC=20000) DIMENSION IX(6,NREC) DIMENSION IR2(2),IS2(2) EQUIVALENCE (R,IR1,IR2(1)),(S,IS1,IS2(1)) COMMON /ASSVAR/IDA C C DYNAMIC STORAGE COMMON BLOCK ... C NEEDED FOR NIPR; PREVIOUSLY PASSED IN COMMON /INTPAC/ COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA MAX/NREC/ C MXREC=MAX ILSU=999 WRITE(6,601) MAX 601 FORMAT( ' *** *** NUMBER OF SIMULATED RECORDS =',I7) RETURN C ENTRY DAOPEN MXUSED=0 WRITE(6,600) 600 FORMAT(/' *** *** IN-CORE DA SIMULATION ROUTINE HAS CONTROL.', 1 /' *** *** DA FILE WILL NOT BE USED.') C IF(NIPR.EQ.1 .OR. NIPR.EQ.2) GOTO 1000 WRITE(6,602) NIPR 602 FORMAT(' *** ERROR IN DASIZE/DAOPEN: NIPR =',I3,' INVALID') STOP 1000 RETURN C ENTRY DARD1(I1,I2,I3,I4,I5,I6) I1=IX(1,IDA) I2=IX(2,IDA) I3=IX(3,IDA) I4=IX(4,IDA) I5=IX(5,IDA) I6=IX(6,IDA) RETURN C ENTRY DAWR1(I1,I2,I3,I4,I5,I6) MXUSED=MAX0(MXUSED,IDA) IX(1,IDA)=I1 IX(2,IDA)=I2 IX(3,IDA)=I3 IX(4,IDA)=I4 IX(5,IDA)=I5 IX(6,IDA)=I6 RETURN C ENTRY DARD2(I1,I2,X1,X2) I1=IX(1,IDA) I2=IX(2,IDA) IF(NIPR.EQ.1) THEN IR1=IX(3,IDA) IS1=IX(4,IDA) ELSE IR2(1)=IX(3,IDA) IR2(2)=IX(4,IDA) IS2(1)=IX(5,IDA) IS2(2)=IX(6,IDA) ENDIF X1=R X2=S RETURN C ENTRY DAWR2(I1,I2,X1,X2) MXUSED=MAX0(MXUSED,IDA) IX(1,IDA)=I1 IX(2,IDA)=I2 R=X1 S=X2 IF(NIPR.EQ.1) THEN IX(3,IDA)=IR1 IX(4,IDA)=IS1 ELSE IX(3,IDA)=IR2(1) IX(4,IDA)=IR2(2) IX(5,IDA)=IS2(1) IX(6,IDA)=IS2(2) ENDIF RETURN C ENTRY DACLOS WRITE(6,610) MXUSED,MAX 610 FORMAT(/' *** IN-CORE DA SIMULATOR USED',I10,' OF THE',I10, 1 ' ALLOCATED RECORDS') RETURN END SUBROUTINE DELRD(DR,CDIAG,COFF,TOL,DRMAX,E1,EN,RNOW,RMAX) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C------------------------------------------------------------------- C THIS ROUTINE IS MODIFIED VERSION OF ROY GORDON'S QCPE PROGRAM. C THIS VERSION FOR SCATTERING CALCULATION C------------------------------------------------------------------- C ADJUST THE STEP SIZE TO TRY TO KEEP MAX(CDIAG,COFF) = TOL RTOL = 0.80D0*TOL C------------------------------------------------------------------- C FIND CORRECTION FACTOR FROM DIAGONAL PERTURBATIONS C------------------------------------------------------------------- IF (CDIAG .NE. 0.D0) GO TO 100 C------------------------------------------------------------------- C CASE IN WHICH DIAGONAL PERTURBATIONS VANISH C------------------------------------------------------------------- DFACT = 2.5D0 GO TO 110 C------------------------------------------------------------------- C DIAGONAL PERTURBATIONS VARY ROUGHLY AS THE FIFTH POWER OF STEP SIZE C------------------------------------------------------------------- 100 DFACT = (RTOL/CDIAG)**0.333D0 C------------------------------------------------------------------- C FIND CORRECTION FACTOR FROM OFF-DIAGONAL PERTURBATIONS C------------------------------------------------------------------- 110 IF (COFF .NE. 0.D0) GO TO 120 C------------------------------------------------------------------- C CASE IN WHICH OFF-DIAGONAL PERTURBATIONS VANISH C------------------------------------------------------------------- OFACT = 2.5D0 GO TO 130 C------------------------------------------------------------------- C OFF-DIAGONAL PERTURBATIONS VARY ROUGHLY AS CUBE OF STEP SIZE C------------------------------------------------------------------- 120 OFACT = (RTOL/COFF)**0.333D0 C------------------------------------------------------------------- C FIND MINIMUM FACTOR C------------------------------------------------------------------- 130 FACTOR = MIN(DFACT,OFACT) IF (EN .GT. 0.D0) GO TO 150 IF (E1 .GT. 0.D0) GO TO 140 C------------------------------------------------------------------- C THIS IS REACHED ONLY WHEN ALL CHANNELS ARE IN THEIR CLASSICALLY C FORBIDDEN REGIONS. THEN ACCURACY IS QUITE SENSITIVE TO CHANGES C IN STEP SIZE. C HENCE IN THIS REGION MAKE ONLY CAUTIOUS CHANGES IN STEP SIZE C------------------------------------------------------------------- IF (FACTOR .GT. 1.15D0) FACTOR = 1.15D0 GO TO 170 C------------------------------------------------------------------- C THIS IS REACHED WHEN SOME CHANNELS ARE CLASSICAL AND OTHERS NOT C------------------------------------------------------------------- 140 IF (FACTOR .GT. 1.20D0) FACTOR = 1.20D0 GO TO 170 C------------------------------------------------------------------- C THIS IS REACHED WHEN ALL CHANNELS ARE CLASSICAL. C THEN THE STEP SIZE IS OFTEN INCREASING RAPIDLY, AND ALSO THE C ACCURACY VARIES MORE SLOWLY WITH STEP SIZE. C THUS WE MAKE BOLDER INCREASES IN THE STEP SIZE, TO KEEP THE C CORRECTIONS OF THE SAME ORDER OF MAGNITUDE AS BEFORE C TEST TO SEE HOW FAR WE HAVE INTEGRATED C------------------------------------------------------------------- 150 IF (RNOW .GT. (0.10D0*RMAX)) GO TO 160 IF (FACTOR .GT. 1.6D0) FACTOR = 1.6D0 GO TO 170 C------------------------------------------------------------------- C CHOOSE FACTOR IN FAR AYSMPTOTIC REGION C------------------------------------------------------------------- 160 IF (FACTOR .GT. 2.5D0) FACTOR = 2.5D0 C------------------------------------------------------------------- C SET NEW STEP SIZE C------------------------------------------------------------------- 170 DR = DR*FACTOR C------------------------------------------------------------------- C CHECK AGAINST DRMAX AND EXCESSIVE GROWTH OF CLOSED CHANNELS C------------------------------------------------------------------- IF (EN .GE. 0.D0) GO TO 175 DREXP = 4.D0/SQRT(-EN) IF (DR .GT. DREXP) DR = DREXP 175 IF (DR .GT. DRMAX) DR = DRMAX IF (DR .LT. 1.0D-06*DRMAX) GO TO 180 RETURN 180 WRITE (6,1000) DR,CDIAG,COFF,TOL,DRMAX,E1,EN,RNOW,RMAX STOP C------------------------------------------------------------------- C FORMATS C------------------------------------------------------------------- 1000 FORMAT('0 * * * ERROR IN DELRD. STEP SIZE =',E20.6, 1 ' IS TOO SMALL'/'0',24X,'PARAMETERS PASSED ARE', 2 ' CDIAG, COFF, TOL, DRMAX, E1, EN, RNOW, RMAX'/ 4 25X,9(E10.3,1X)) C----------------***END-DELRD***------------------------------------ END SUBROUTINE DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA, 1 MXLAM,NPOTL,NUMDER) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RSAVE LOGICAL NUMDER C C EVALUATES THE IDER'TH DERIVATIVE OF THE POTENTIAL MATRIX AT RADIUS C W = VCOUPL + VCENT C ORDER OF THE REAL SYMMETRIC MATRIX W IS N C THE FULL MATRIX IS COMPUTED C VL IS THE PREVIOUSLY COMPUTED MATRIX OF THE COUPLING POTENTIAL C IV IS AN INDEX ARRAY MAPPING P ONTO VL, SUCH THAT VL(I) IS C A COEFFICIENT TO MULTIPLY P(IV(I)) C CENT(I) IS L*(L+1) FOR THE I-TH CHANNEL C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO THE DEBROGLIE C WAVELENGTH AT RELATIVE ENERGY EPSILON C RMLMDA = 2.*URED*RM**2*EPSIL/HBAR**2 C RMLMDA MULTIPLIES THE POTENTIAL IN UNITS OF EPSIL C DIMENSION W(N,N),VL(1),IV(1),CENT(N),P(MXLAM) DATA DEL/1.D-3/, RSAVE/-999.D0/ C IF(NUMDER) GOTO 5 C C COMPUTE THE RADIAL PARTS OF THE POTENTIAL ANALYTICALLY CALL POTENL(IDER,MXLAM,NPOTL,IDUM1,R,P,IDUM2) C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE. GOTO 14 C C NUMERICAL DERIVATIVE OPTION. C NOTE THAT IF IDER = 2 THIS ASSUMES THAT C THE POTENTIAL ITSELF IS ALREADY IS ALREADY IN THE FIRST C MXLAM ELEMENTS OF P. THIS IS NOT TRUE IF DERMAT HAS BEEN C CALLED MORE RECENTLY THAN WAVMAT, SO THE IDER = 2 CALL C MUST PRECEDE THE IDER = 1 CALL. C C FIRST SEE WHETHER DERMAT HAS BEEN CALLED BEFORE FOR THIS C VALUE OF R, AND IF SO SKIP POTENTIAL EVALUATIONS C 5 IF(R.EQ.RSAVE) GOTO 8 RSAVE=R RR=R-DEL CALL POTENL(0,MXLAM,NPOTL,IDUM1,RR,P(MXLAM+1),IDUM2) RR=R+DEL CALL POTENL(0,MXLAM,NPOTL,IDUM1,RR,P(2*MXLAM+1),IDUM2) C 8 DO 10 I=1,MXLAM P1=P(MXLAM+I) P2=P(2*MXLAM+I) IF(IDER.EQ.1) P(I) = (P2-P1)/(2.D0*DEL) 10 IF(IDER.EQ.2) P(I) = (P2+P1-2.D0*P(I)/RMLMDA)/(DEL*DEL) C 14 DO 15 I=1,MXLAM 15 P(I)=RMLMDA*P(I) C CALL WAVVEC(VL,P,IV,W,N,NPOTL) C C NOW COMPUTE THE DIAGONAL CONTRIBUTIONS W(I,I). C IF(IDER.EQ.1) RSQ=-2.D0/R**3 IF(IDER.EQ.2) RSQ= 6.D0/R**4 DO 20 I=1,N W(I,I) = W(I,I) + RSQ*CENT(I) 20 CONTINUE RETURN END SUBROUTINE DGEMUL(A,LDA,TRANSA,B,LDB,TRANSB,C,LDC,L,M,N) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*1 TRANSA,TRANSB CALL DGEMM(TRANSA,TRANSB,L,N,M,1.D0,A,LDA,B,LDB,0.D0,C,LDC) RETURN END SUBROUTINE DMSYM(J,NK,EVAL,EVEC,EVEC2,WKS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE SYMPRT PARAMETER (IDMAX=3) LOGICAL SYMPRT CHARACTER*1 CSUB,REPNAM(3) DIMENSION SMAT(IDMAX,IDMAX),SVEC(IDMAX,IDMAX),SIG(IDMAX) DIMENSION EVAL(NK),EVEC(-J:J,NK),EVEC2(-J:J,NK),WKS(NK) DATA SYMPRT/.FALSE./ DATA REPNAM/'A','E','F'/ DATA TOL/1.D-8/ C C THE MATRIX DIAGONALISATION MAY RETURN EIGENVECTORS THAT ARE C AWKWARD LINEAR COMBINATIONS OF DEGENERATE PAIRS/SETS. C THIS ROUTINE FINDS SYMMETRISED COMBINATIONS C THAT ARE EITHER EVEN OR ODD WITH RESPECT TO K -> -K C BY CONSTRUCTING AND DIAGONALISING THE MATRIX REPRESENTATION C OF SIGMA(XZ) FOR EACH DEGENERATE SET. C IMAX=0 DO 1000 IC=1,NK IF(IC.LE.IMAX) GOTO 1000 C C LOOK FOR DEGENERATE EIGENVECTORS C DO 200 JC=IC,NK IF(ABS(EVAL(JC)-EVAL(IC)).GT.TOL) GOTO 200 IMAX=JC 200 CONTINUE C IDEG=1+IMAX-IC IF(IDEG.GT.IDMAX) GOTO 1100 IF(IDEG.EQ.1) GOTO 920 IF(IDEG.GE.3) SYMPRT=.TRUE. C C NOW CONSTRUCT THE MATRIX REPRESENTATION C DO 400 L=1,IDEG LC=IC+L-1 DO 400 M=1,IDEG MC=IC+M-1 SMAT(M,L)=0.D0 DO 400 K=-J,J SMAT(M,L)=SMAT(M,L)+EVEC(K,MC)*EVEC(-K,LC) 400 CONTINUE C IFAIL=0 CALL F02ABF(SMAT,IDMAX,IDEG,SIG,SVEC,IDMAX,WKS,IFAIL) C C COPY OLD EIGENVECTORS INTO SIG AND CONSTRUCT NEW ONES C DO 500 L=1,IDEG LC=IC+L-1 DO 500 K=-J,J EVEC2(K,L)=EVEC(K,LC) 500 CONTINUE C DO 600 L=1,IDEG LC=IC+L-1 DO 600 K=-J,J EVEC(K,LC)=0.D0 DO 600 M=1,IDEG EVEC(K,LC)=EVEC(K,LC)+SVEC(M,L)*EVEC2(K,M) 600 CONTINUE C C THERE IS STILL A POSSIBILITY THAT EVEN AND ODD K ARE MIXED, C BUT ONLY FOR TWO ADJACENT EIGENVECTORS. CHECK FOR THIS C AND FIX IT IF IT IS FOUND C DO 900 L=1,IDEG-1 LC=IC+L-1 DO 700 K=-J,J-1 IF(ABS(EVEC(K,LC)*EVEC(K+1,LC)).LT.TOL) GOTO 700 THETA=ATAN2(EVEC(K,LC),EVEC(K,LC+1)) CO=COS(THETA) SI=SIN(THETA) GOTO 800 700 CONTINUE GOTO 900 800 CONTINUE C C ARRIVE HERE IF THERE IS MIXING C DO 850 K=-J,J TEMP =CO*EVEC(K,LC)-SI*EVEC(K,LC+1) EVEC(K,LC)=SI*EVEC(K,LC)+CO*EVEC(K,LC+1) EVEC(K,LC+1)=TEMP 850 CONTINUE 900 CONTINUE C C SPECIAL CODE TO WORK OUT SYMMETRY LABEL FOR SPHERICAL TOP C 920 IF(.NOT.SYMPRT) GOTO 1000 CSUB=' ' IF(IDEG.EQ.2) GOTO 950 CSUB='1' IF(J.LT.2) GOTO 950 DO 940 L=1,IDEG LC=IC+L-1 IF(EVEC(2,LC)**2.GT.TOL) CSUB='2' 940 CONTINUE C 950 WRITE(6,601) EVAL(LC),REPNAM(IDEG),CSUB 601 FORMAT(' ENERGY LEVEL AT',F12.5,' HAS SYMMETRY ',2A1) C 1000 CONTINUE RETURN C 1100 WRITE(6,699) IDEG,IDMAX STOP 699 FORMAT('0*** ERROR IN DMSYM: DEGENERACY',I3,' IS TOO LARGE ', 1 'FOR DIMENSION IDMAX =',I3) END SUBROUTINE DSYFIL(UPLO, N, A, LDA) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*1 UPLO DIMENSION A(LDA,N) C C SUBROUTINE TO FILL IN THE SECOND TRIANGLE OF A SYMMETRIC MATRIX. C IF UPLO='L', THE LOWER TRIANGLE IS FILLED IN C IF UPLO='U', THE UPPER TRIANGLE IS FILLED IN C IF(UPLO.EQ.'L') THEN DO 10 J=1,N-1 10 CALL DCOPY(N-J,A(J,J+1),LDA,A(J+1,J),1) ELSEIF(UPLO.EQ.'U') THEN DO 20 J=1,N-1 20 CALL DCOPY(N-J,A(J+1,J),1,A(J,J+1),LDA) ENDIF C RETURN END SUBROUTINE DVFREE(UJ,UJP,UN,UNP,WRONS,L,N,WV,R,NB) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C DOUBLE PRECISION ASYMPTOTIC FUNCTIONS FOR MATCHING TO S-MATRIX. DIMENSION UJ(N),UJP(N),UN(N),UNP(N),WRONS(N),WV(N) DIMENSION L(N),NB(N) DO 3000 I=1,N NX=NB(I) DW=WV(NX) DARG=DW*R CALL RBES(L(NX),DARG,UJ(NX),UJP(NX),UN(NX),UNP(NX)) UJP(NX)=UJP(NX)*DW UNP(NX)=UNP(NX)*DW 3000 WRONS(NX)=(UJ(NX)*UNP(NX)-UJP(NX)*UN(NX))/SQRT(DW) RETURN END SUBROUTINE DVSCAT(N,NSQ,MXLAM,NPOTL, 1 SR,SI,A,VL,IV,EINT,CENT,WV,L,NB, 2 P,Y,YP,F,XM,YM,DIAG,ESHIFT,ICODE,PRINT) C C DEVOGELAERE INTEGRATION (DOUBLE PRECISION) C INCLUDING START ROUTINE, SUPPRESSION OF CLOSED-CHANNEL GROWTH C AND S-MATRIX DETERMINATION IN ASYMPTOTIC LIMIT. C FOLLOWS OUTLINE OF PAUL MCGUIRE'S PROGRAM. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL IREAD,IWRITE,END INTEGER L(N),NB(N),IV(1) INTEGER PRINT DIMENSION Y(NSQ,4),YP(NSQ,2),F(NSQ,4),A(NSQ),XM(NSQ),YM(NSQ), 1 DIAG(N),P(MXLAM),SR(NSQ),SI(NSQ),VL(2),EINT(N),CENT(N),WV(N) DIMENSION R(4) C C INDICES ON Y, YP, F ARE (ITH SOLN. COMP, NTH SOLN, KTH R-VALUE) C C COMMON FROM DRIVER COMMON/DRIVE/STEST,STEPS,STAB,CONV,RMIN,RMAX,DUMMY(8), 1 ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP C C STEPS IS NO. OF STEPS PER (SHORTEST) WAVELENGTH. C STAB IS NUMBER OF STEPS TAKEN BEFORE STABILIZATION. C C MAX. NUMBER OF TRIALS TO CONVERGE S-MATRIX IN ASYMPTOTIC REGION. DATA MXSTRY/20/ C IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 IF(IREAD .AND. PRINT.GE.5) WRITE(6,668) 668 FORMAT('0 DEVOGELAERE PROPAGATION WILL USE STORED INITIAL R,', 1 ' STEP SIZE AND POTENTIAL MATRICES') C C ZERO STORAGE . . . C NP1=N+1 DO 800 IJ=1,NSQ SR(IJ)=0.D0 800 SI(IJ)=0.D0 DO 900 I=1,2 DO 900 IJ=1,NSQ 900 YP(IJ,I)=0.D0 DO 1000 I=1,4 DO 1000 IJ=1,NSQ Y(IJ,I)=0.D0 1000 F(IJ,I)=0.D0 C NSTRY=0 RMSAVE=RMAX C C ********** START INTEGRATION ********** CALL DVSTRT(RMIN,STEPS,ERED,RMLMDA,N,MXLAM,NPOTL,NOPEN,PRINT, & A,DIAG,P,VL,IV,EINT,CENT,NB,WV,Y(1,2),YP(1,1),HH, & ISCRU,IREAD,IWRITE) IF (NOPEN.LE.0) GOTO 9000 NSTAB=STAB NSTAB=MAX0(NSTAB,1) H2=HH/2.D0 R(2)=RMIN NSTEP=1 C GET F(,,2) FROM Y(,,2) R4=R(2) IF(.NOT.IREAD) GOTO 1200 READ(ISCRU) A DO 1100 IJ=1,NSQ,NP1 1100 A(IJ)=A(IJ)-ESHIFT GOTO 1300 1200 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IF(IWRITE) WRITE(ISCRU) A 1300 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,2),N,0.D0,F(1,2),N) CALL DAXPY(NSQ,1.D0,F(1,2),1,Y(1,2),1) CALL DAXPY(NSQ,-H2,YP(1,1),1,Y(1,1),1) CALL DAXPY(NSQ,0.5D0*H2*H2,F(1,2),1,Y(1,1),1) C GET F(,,1) FROM THIS Y(,,1). NEEDS POTENTIAL AT R(1) R(1)=R(2)-H2 R4=R(1) IF(.NOT.IREAD) GOTO 1800 READ(ISCRU) A DO 1700 IJ=1,NSQ,NP1 1700 A(IJ)=A(IJ)-ESHIFT GOTO 1900 1800 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IF(IWRITE) WRITE(ISCRU) A 1900 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,1),N,0.D0,F(1,1),N) C C ********** MAIN BODY OF ITERATION ********** C PROPAGATE FROM (-1/2) AND (0) TO (1/2) AND (1). 2000 CONTINUE CALL DAXPY(NSQ,1.D0,Y(1,2),1,Y(1,3),1) CALL DAXPY(NSQ,H2,YP(1,1),1,Y(1,3),1) CALL DAXPY(NSQ,H2*H2*4.D0/6.D0,F(1,2),1,Y(1,3),1) CALL DAXPY(NSQ,-H2*H2/6.D0,F(1,1),1,Y(1,3),1) R(3)=R(2)+H2 R4=R(3) IF(.NOT.IREAD) GOTO 2200 READ(ISCRU) A DO 2100 IJ=1,NSQ,NP1 2100 A(IJ)=A(IJ)-ESHIFT GOTO 2300 2200 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) 2300 IF(IWRITE) WRITE(ISCRU) A CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,3),N,0.D0,F(1,3),N) CALL DAXPY(NSQ,1.D0,Y(1,2),1,Y(1,4),1) CALL DAXPY(NSQ,HH,YP(1,1),1,Y(1,4),1) CALL DAXPY(NSQ,HH*HH/6.D0,F(1,2),1,Y(1,4),1) CALL DAXPY(NSQ,HH*HH/3.D0,F(1,3),1,Y(1,4),1) R(4)=R(3)+H2 R4=R(4) IF(.NOT.IREAD) GOTO 2700 READ(ISCRU) A DO 2600 IJ=1,NSQ,NP1 2600 A(IJ)=A(IJ)-ESHIFT GOTO 2800 2700 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IF(IWRITE) WRITE(ISCRU) A 2800 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,4),N,0.D0,F(1,4),N) CALL DAXPY(NSQ,1.D0,YP(1,1),1,YP(1,2),1) CALL DAXPY(NSQ,HH/6.D0,F(1,2),1,YP(1,2),1) CALL DAXPY(NSQ,HH/6.D0,F(1,4),1,YP(1,2),1) CALL DAXPY(NSQ,HH*4.D0/6.D0,F(1,3),1,YP(1,2),1) NSTEP=NSTEP+1 C C ********** THIS ENDS DEVOGELAERE CYCLE ********** C NOPLOC=0 DO 2900 I=1,NSQ,NP1 2900 IF(A(I).LT.0.D0) NOPLOC=NOPLOC+1 C END=R4.GT.RMAX .AND. NOPLOC.GE.NOPEN IF(IREAD) READ(ISCRU) END IF(END) GOTO 3000 C C ********** STABILIZATION EVERY NSTAB STEPS ********** 4000 IF(NSTEP-NSTAB*(NSTEP/NSTAB).NE.0) GOTO 5000 IF (PRINT.GT.12) WRITE(6,673) R(4) 673 FORMAT(' STABILIZATION DONE AT R =',E12.4) C FIRST 2 COLS OF Y AND F AND ALSO A USED AS SCRATCH IN STABIL. CALL STABIL(N,NB,Y(1,4),YP(1,2),F(1,3),F(1,4), & A,Y(1,1),Y(1,2),F(1,1),F(1,2)) C C ********** RE-INITIALIZE FOR NEXT CYCLE OF INTEGRATION ********* 5000 R(1)=R(3) R(2)=R(4) IF(IWRITE) WRITE(ISCRU) IREAD CALL DCOPY(NSQ,YP(1,2),1,YP(1,1),1) CALL DCOPY(NSQ,Y(1,3),1,Y(1,1),1) CALL DCOPY(NSQ,Y(1,4),1,Y(1,2),1) CALL DCOPY(NSQ,F(1,3),1,F(1,1),1) CALL DCOPY(NSQ,F(1,4),1,F(1,2),1) DO 5200 IJ=1,NSQ YP(IJ,2)=0.D0 Y(IJ,3)=0.D0 5200 Y(IJ,4)=0.D0 GOTO 2000 C 3000 CONTINUE IF ((PRINT.GE.2.AND.NSTRY.LE.0) .OR. PRINT.GE.12) & WRITE(6,601) NSTEP,R(4) 601 FORMAT(' INTEGRATION REACHED ASYMPTOTIC LIMIT IN', & I5,' STEPS. R =',D12.4) C C ********** ASYMPTOTIC REGION - CALCULATE S-MATRIX ********** NOPSQ=NOPEN*NOPEN C USE FIRST 2 COLS OF Y AND F FOR REGULAR AND IRREGULAR BESSEL FNS. C AND DERIVATIVES - UJ, UJP, UN, AND UNP. C USE FIRST COL. OF A FOR WRONSKIAN/SQRT(WV). CALL DVFREE(Y(1,1),Y(1,2),F(1,1),F(1,2),A,L,NOPEN,WV,R(4),NB) C FORM TRANSPOSE OF X- AND Y- MATRICES DO 3200 J=1,NOPEN IJ=J DO 3100 I=1,NOPEN NX=NB(I) NY=NX+N*(J-1) XM(IJ)=(F(NX,2)*Y(NY,4)-F(NX,1)*YP(NY,2)) / A(NX) YM(IJ)=(Y(NX,2)*Y(NY,4)-Y(NX,1)*YP(NY,2)) / A(NX) 3100 IJ=IJ+NOPEN 3200 CONTINUE C GET K-MATRIX FROM SOLN TO LINEAR EQNS,REPLACES RHS DO 3300 I=1,NOPSQ 3300 A(I)=YM(I) CALL DGESV(NOPEN,NOPEN,XM,NOPEN,Y,A,NOPEN,IER) IF (IER.EQ.0) GOTO 3400 WRITE(6,688) 688 FORMAT('0 * * * WARNING. LOSS OF ACCURACY IN SOLVING FOR K.') CALL OUTERR(11) C C FORCE SYMMETRY ON K-MATRIX AND CALCULATE S MATRIX C 3400 CALL RSYM(NOPEN, A, STEST, PRINT) CALL KTOS(A,XM,YM,NOPEN) C C TEST FOR CONVERGENCE OF SR, SI C TEST=0.D0 DO 3500 I=1,NOPSQ TEST=MAX(TEST,ABS(SR(I)-XM(I)),ABS(SI(I)-YM(I))) SR(I)=XM(I) 3500 SI(I)=YM(I) C IF(IREAD) GOTO 9000 IF(TEST.GT.STEST) GOTO 3600 IF(PRINT.GE.2) WRITE(6,686) NSTRY,R(4),TEST 686 FORMAT(' S-MATRIX CONVERGED AFTER',I3,' TRIES IN ', & 'ASYMPTOTIC REGION. R =',D12.4,'. TEST =',E12.4) GOTO 9000 3600 IF(NSTRY.GT.0 .AND. PRINT.GE.2) WRITE(6,687) NSTRY,R(4),TEST 687 FORMAT(' S-MATRIX NOT CONVERGED AFTER',I3, & ' TRIES. R =',D12.4,'. LARGEST CHANGE =',D12.4) IF (NSTRY.LT.MXSTRY) GOTO 3700 C SET 'CONV' FLAG FOR OUTPUT ROUTINE. . . CONV=-1.D0 GOTO 9000 3700 NSTRY=NSTRY+1 RMAX=RMAX+STEPS*HH GOTO 5000 C C COMMON RETURN POINT C RESTORE RMAX 9000 RMAX=RMSAVE IF(IWRITE) WRITE(ISCRU) IWRITE RETURN END SUBROUTINE DVSTRT(R,STEPS,ERED,RMLMDA,N,MXLAM,NPOTL,NOPEN,PRINT, & W,DIAG,P,VL,IV,EINT,CENT,NB,WV,U,UP,HH,ISCRU,IREAD,IWRITE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER PRINT LOGICAL SURF,IREAD,IWRITE DIMENSION W(N,N),DIAG(N),P(2),VL(2),IV(1),EINT(N),CENT(N),NB(N), & WV(N),U(N,N),UP(N,N) C C PROVIDE STARTING SOLUTION AND DERIVATIVE FOR DEVOGELAERE. C ALSO PICK STEP SIZE, HH. C STEPS IS NO. OF STEPS PER (SHORTEST) WAVELENGTH. C THIS IS SIMPLEST VERSION, SIMILAR TO THAT OF MCGUIRE. C RSAVE=R SURF=R.LT.0.D0 DRMIN=ABS(R/STEPS) C C * * * * * ORDER BASIS FUNCTIONS ON INCREASING INTERNAL ENERGY. DO 3000 I=1,N 3000 NB(I)=I IF (N.LE.1) GO TO 1000 NM1=N-1 DO 3100 I=1,NM1 IP1=I+1 DO 3100 J=IP1,N IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 3100 IT=NB(I) NB(I)=NB(J) NB(J)=IT 3100 CONTINUE C C * * * * * SEE THAT ALL CHANNELS (IN FREE BASIS) ARE CLOSED. IF(IREAD) GOTO 2000 1000 CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IF(PRINT.GT.12) WRITE(6,698) R,(P(I),I=1,MXLAM) 698 FORMAT('0 POTENTIAL ARRAY AT R =',F10.4/(10(1X,D12.5))) DO 1100 I=1,N IF (PRINT.GT.12) WRITE(6,699) I,W(I,I) 699 FORMAT(' FOR CHANNEL',I4, ' V(RMIN) - E =',D13.4) IF (W(I,I).GT.0.D0) GO TO 1100 R=R-DRMIN IF(SURF .OR. R.GT.0.D0) GO TO 1000 WRITE(6,600) 600 FORMAT('0 * * * ERROR. RMIN LESS THAN ZERO IN DVSTRT.', 1 ' POTENTIAL MAY BE UNPHYSICAL') STOP 1100 CONTINUE C IF(R.NE.RSAVE) WRITE(6,602)RSAVE,R 602 FORMAT('0 * * * WARNING. DVSTRT HAS CHANGED RMIN FROM ',F6.2, & ' TO ',F6.2,' TO ENSURE THAT ALL CHANNELS ARE LOCALLY CLOSED') C C * * * * * INITIALIZE U, UP. 2000 DO 4000 I=1,N DO 4000 J=1,N U(I,J)=0.D0 UP(I,J)=0.D0 IF (I.EQ.NB(J)) UP(I,J)=1.D-8 4000 CONTINUE C * * * * * INITIALIZE NOPEN, WV. PICK STEP SIZE. NOPEN=0 BIG=0.D0 DO 5000 I=1,N DIF=ERED-EINT(I) IF (DIF.LE.0.D0) GO TO 5100 NOPEN=NOPEN+1 5100 WV(I)=SIGN(SQRT(ABS(DIF)),DIF) 5000 BIG=MAX(BIG,WV(I)) IF (NOPEN.LE.0) RETURN C CALCULATE STEP SIZE FROM LARGEST WVEC. HH=3.1416D0/(BIG*STEPS) IF(IWRITE) WRITE(ISCRU) R,HH IF(IREAD) READ(ISCRU) R,HH IF (PRINT.GE.2) WRITE(6,601) R,HH 601 FORMAT('0 INTEGRATION STARTED AT RMIN =',D12.4, & '. STEP SIZE =',D12.4) RETURN END SUBROUTINE EAVG(NT,T,NGP,E,NNRG,MXNRG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION E(1),T(1) DIMENSION A(20),W(20) C THIS ROUTINE SETS UP ENERGIES FOR NGP-POINT GAUSS-LAGUERRE INTEG. C AT SPECIFIED TEMPERATURES (DEG. KELVIN). DATA XK/.6950305D0/ DATA A/.585786437627D0, 3.414213562373D0, 2 0.415774556783D0, 2.294280360279D0, 6.289945082937D0, 3 0.322547689619D0, 1.745761101158D0, 4.536620296921D0, 4 9.395070912301D0, 0.263560319718D0, 1.413403059107D0, 5 3.596425771041D0, 7.085810005859D0, 12.640800844276D0, 6 6*0.D0/ DATA W/ 0.853553390593D0, 0.146446609407D0, 0.711093009929D0, 8 0.278517733569D0, 0.103892565016D-1, 0.603154104342D0, 9 0.357418692438D0, 0.388879085150D-1, 0.539294705561D-3, A 0.521755610583D0, 0.398666811083D0, 0.759424496817D-1, B 0.361175867992D-2, 0.233699723858D-4, 6*0.D0/ NGP=MAX0(2,MIN0(6,IABS(NGP))) IST=NGP*(NGP-1)/2-1 WRITE(6,600) NGP 600 FORMAT('0 ENERGY VALUES WILL BE GENERATED TO FACILITATE',I4, 1 '-POINT GAUSS-LAGUERRE INTEGRATION OVER BOLTZMANN DISTRIBUTION') NN=0 DO 1000 I=1,NT IF (NN+NGP.LE.MXNRG) GO TO 1010 WRITE(6,601) I,T(I) 601 FORMAT('0 * * * WARNING. NOT ENOUGH SPACE IN ENERGY() TO PROCESS 1TEMP(',I3,' ) =',F8.2) GO TO 1000 1010 XT=XK*T(I) WRITE(6,602) T(I),XT 602 FORMAT('0 FOR TEMP =',F8.2,' DEG. K =',F8.2,' (1/CM), THE 1AVERAGE IS APPROXIMATELY THE SUM OF') DO 1100 J=1,NGP EN=XT*A(IST+J) WT=A(IST+J)*W(IST+J) NN=NN+1 E(NN)=EN 1100 WRITE(6,603) WT,EN 603 FORMAT(15X,F13.8, ' * SIG( E =',F12.4,' ) ') 1000 CONTINUE NNRG=MIN0(MXNRG,MAX0(NNRG,NN)) RETURN END SUBROUTINE ECNV(EUNITS,TOCM) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C THIS ROUTINE ACCEPTS A 4 BYTE INPUT - EUNITS - AND DETERMINES C A UNITS TYPE AND ACCORDINGLY A CONVERSION FACTOR TO (1/CM). C C IMPLEMENTED UNITS ARE C 1) 1/CM 2) DEG. K 3) MHZ 4) GHZ 5) EV 6) ERG 7) A.U. C 8) KJ/MOL 9) KCAL/MOL C INPUT MUST BE AN INTEGER (1-9) SPECIFYING THE CORRESPONDING UNIT C OR A CHARACTER CODE CORRESPONDING TO UNIT. C C ENERGY CONVERSION FACTORS TAKEN FROM E. R. COHEN AND B. N. TAYLOR, C JOURNAL OF RESEARCH OF THE NBS 92, 85 (1987). C INTEGER EUNITS CHARACTER*8 LTYP(9) DIMENSION ECONV(9) DATA LTYP/' 1/CM',' K ',' MHZ',' GHZ',' EV ',' ERG', ' AU', 1 'KJ/MOL','KCAL/MOL'/ DATA ECONV/1.D0,0.6950387D0, 3.335640952D-5,3.335640952D-2, 1 8065.5410D0,5.0341125D+15,219474.63067D0, 2 83.593461D0,349.9891D0/ DATA MXUNIT/9/ C IVAL=EUNITS IF (IVAL) 2000,1000,1001 1000 WRITE(6,600) 600 FORMAT('0 INPUT ENERGY VALUES ASSUMED TO BE IN UNITS OF 1/CM BY ', 1 'DEFAULT.') TOCM=1.D0 RETURN C 1001 IF (IVAL.GT.MXUNIT) GO TO 2000 WRITE(6,601) LTYP(IVAL),IVAL 601 FORMAT('0 INPUT ENERGY VALUES CONVERTED FROM ',A8,' TO INTERNAL ', 1 'WORKING UNITS OF 1/CM DUE TO INTEGER INPUT =',I4) TOCM=ECONV(IVAL) RETURN C C IF ALPHAMERICS CANNOT BE SUPPORTED, BELOW SHOULD PRINT ERROR C MESSAGE AND TERMINATE. C 2000 CALL ECNVX(EUNITS,IVAL) TOCM=ECONV(IVAL) RETURN END SUBROUTINE ECNVX(EUNITS,IVAL) C C THIS ROUTINE CONVERTS A 4 CHARACTER INPUT -- EUNITS -- C INTO THE CORRESPONDING INTEGER VALUE -- IVAL. C IMPLEMENTED UNITS ARE C 1) 1/CM 2) DEG. K 3) MHZ 4) GHZ 5) EV 6) ERG 7) A.U. C 8) KJ/MOL 9) KCAL/MOL C LOGICAL STSRCH CHARACTER*1 L4(4),C,M,K,H,Z,E,V,R,G,A,U,L,J CHARACTER*4 LTYP(9),EUNITS DATA MX/9/ DATA LTYP/'1/CM',' K ',' MHZ','GHZ ',' EV ','ERG', 'A.U.', 1 'KJ/M','KCAL'/ DATA C/'C'/,M/'M'/,K/'K'/,H/'H'/,Z/'Z'/,E/'E'/,V/'V'/, 2 R/'R'/, G/'G'/, A/'A'/, U/'U'/, L/'L'/, J/'J'/ C PUT CHARACTERS OF EUNITS INTO ARRAY L4 L4(1)=EUNITS(1:1) L4(2)=EUNITS(2:2) L4(3)=EUNITS(3:3) L4(4)=EUNITS(4:4) C 2000 DO 2001 II=1,4 C SEARCH FOR ONE OF ALLOWED 1ST LETTERS. . . IF (L4(II).EQ.C) GO TO 3001 IF (L4(II).EQ.K) GO TO 3002 IF (L4(II).EQ.M) GO TO 3003 IF (L4(II).EQ.G) GO TO 3004 IF (L4(II).EQ.E) GO TO 3005 2001 IF (L4(II).EQ.A) GO TO 3006 GO TO 2991 C FOR EACH ALLOWED FIRST LETTER, SEARCH FOR NEXT IN KEYWORDS. . . 3001 IF(.NOT.STSRCH(M,L4(II+1),4-II,IF)) GO TO 2991 IT=1 GO TO 5000 C 3002 IF (.NOT.STSRCH(C,L4(II+1),4-II,IF)) GO TO 3012 IFN=II+IF IF (.NOT.STSRCH(A,L4(IFN+1),4-IFN,IF)) GO TO 2991 IFN=IFN+IF IF (.NOT.STSRCH(L,L4(IFN+1),4-IFN,IF)) GO TO 2991 IT=9 GO TO 5000 3012 IF (.NOT.STSRCH(J,L4(II+1),4-II,IF)) GO TO 3022 IT=8 GO TO 5000 3022 IT=2 GO TO 5000 3003 IF(.NOT.STSRCH(H,L4(II+1),4-II,IF)) GO TO 2991 IF (.NOT.STSRCH(Z,L4(II+IF+1),4-II-IF,IF)) GO TO 2991 IT=3 GO TO 5000 3004 IF(.NOT.STSRCH(H,L4(II+1),4-II,IF)) GO TO 2991 IF (.NOT.STSRCH(Z,L4(II+IF+1),4-II-IF,IF)) GO TO 2991 IT=4 GO TO 5000 3005 IF (.NOT.STSRCH(V,L4(II+1),4-II,IF)) GO TO 3015 IT=5 GO TO 5000 3015 IF (.NOT.STSRCH(R,L4(II+1),4-II,IF)) GO TO 2991 IF (.NOT.STSRCH(G,L4(II+IF+1),4-II-IF,IF)) GO TO 2991 IT=6 GO TO 5000 3006 IF (.NOT.STSRCH(U,L4(II+1),4-II,IF)) GO TO 2991 IT=7 GO TO 5000 2991 CONTINUE C WRITE(6,699) EUNITS,(LTYP(I),I=1,MX) 699 FORMAT('0*** WARNING. EUNITS INPUT = ',A4,' CANNOT BE PROCESSED.' 1 , ' ALLOWED TYPES ARE'/'0',13X,9(2X,A4)) STOP 5000 IVAL=IT WRITE(6,602) LTYP(IT),EUNITS 602 FORMAT('0 INPUT ENERGY VALUES CONVERTED FROM ',A4,' TO INTERNAL WO &RKING UNITS OF 1/CM DUE TO ALPHAMERIC INPUT =',A4) RETURN END FUNCTION EPSUM(R,N,E,EVEC,WKS) C C FUNCTION TO EVALUATE THE EIGENPHASE SUM FROM THE R-MATRIX. C F02ABF DIAGONALISES THE N X N REAL SYMMETRIC R-MATRIX, C RETURNING THE EIGENVALUES IN E. C THE EIGENPHASE SUM IS THEN OBTAINED BY SUMMING ARCTANGENTS C OF THE EIGENVALUES. C THE RESULT IS RETURNED IN UNITS OF PI, AND IS SHIFTED TO BE C AS CLOSE AS POSSIBLE TO THE PREVIOUS EIGENPHASE SUM CALCULATED C (STORED IN SMLAST) C SEE ASHTON, CHILD AND HUTSON, J. CHEM. PHYS. 78, 4025 (1983). C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE SMLAST DIMENSION R(N,N), E(N), EVEC(N,N), WKS(N) DATA PI/3.141592653589793238462643D0/ DATA SMLAST/10.D0/ C IF(N.EQ.1) GOTO 200 IFAIL=0 CALL F02ABF(R,N,N,E,EVEC,N,WKS,IFAIL) EPSUM=0.D0 DO 100 I=1,N X=ATAN(E(I)) EPSUM=EPSUM+X 100 CONTINUE GOTO 300 200 EPSUM=ATAN(R(1,1)) 300 EPSUM=EPSUM/PI DELTA=SMLAST-EPSUM+0.5D0 IF(DELTA.LE.0.D0) DELTA=DELTA-1.D0 IDEL=INT(DELTA) EPSUM=EPSUM+DBLE(IDEL) SMLAST=EPSUM RETURN END FUNCTION ESYMTP(J1,K1,J2,K2,LM,MU) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA CON15/.282094791773878209D0/ Z(X)=2.D0*X+1.D0 ESYMTP=0.D0 XJ1=J1 XJ2=J2 XK1=K1 XK2=K2 XLM=LM XMU=MU E=THRJ(XJ1,XLM,XJ2,-XK1,-XMU,XK2) IF (ABS(E).LE.1.D-8) RETURN ESYMTP=E*PARITY((IABS(J2-J1)+J2+J1)/2-MU-K1)* & CON15*SQRT(SQRT(Z(XJ1)*Z(XJ2))) RETURN END SUBROUTINE F02AAF(A, IA, N, R, E, IFAIL) C C SIMULATES NAG DIAGONALISER F02AAF WITH LAPACK CALLS C JMH MAY 93 C IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DIMENSION A(IA,N), R(N), E(N) DIMENSION V(1) DATA IV/1/ DATA ZERO/0.D0/ C IT1=IXNEXT IT2=IT1+(5*N+1)/NIPR IT3=IT2+(N+1)/NIPR LWREQ=8*N LWORK=MX-IT3+1 IF(LWORK.LT.LWREQ) THEN WRITE(6,100) LWORK,N 100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE', 1 ' IN F02AAF.'/' LAPACK ROUTINE DSYEVX NEEDS AT LEAST 8*N,', 2 ' AND N =',I5,' ON THIS CALL.') STOP ENDIF C IXNEXT=IT3+LWREQ NUSED=0 CALL CHKSTR(NUSED) C C SAVE DIAGONAL ELEMENTS IN E C CALL DCOPY(N,A,IA+1,E,1) C C CALL LAPACK DIAGONALISER: DESTROYS LOWER TRIANGLE OF A C CALL DSYEVX('N','A','L',N,A,IA,DUM,DUM,IDUM,IDUM,ZERO,M,R,V,IV, 1 X(IT3),LWORK,X(IT1),X(IT2),INFO) C IF (INFO .NE. 0) THEN WRITE (6,120) INFO 120 FORMAT(' *** ERROR IN DSYEVX: INFO =',I3) END IF C IFAIL=INFO IXNEXT=IT1 C C RESTORE LOWER TRIANGLE FROM UNCHANGED UPPER TRIANGLE C AND DIAGONAL FROM E C CALL DSYFIL('L',N,A,IA) CALL DCOPY(N,E,1,A,IA+1) C RETURN END SUBROUTINE F02ABF(A, IA, N, R, V, IV, E, IFAIL) C C SIMULATES NAG DIAGONALISER F02ABF WITH LAPACK CALLS C JMH MAY 93 C IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DIMENSION A(IA,N), V(IV,N), R(N), E(N) DATA ZERO/0.D0/ C IT1=IXNEXT IT2=IT1+(5*N+1)/NIPR IT3=IT2+(N+1)/NIPR LWREQ=8*N LWORK=MX-IT3+1 IF(LWORK.LT.LWREQ) THEN WRITE(6,100) LWORK,N 100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE', 1 ' IN F02ABF.'/' LAPACK ROUTINE DSYEVX NEEDS AT LEAST 8*N,', 2 ' AND N =',I5,' ON THIS CALL.') STOP ENDIF C IXNEXT=IT3+LWREQ NUSED=0 CALL CHKSTR(NUSED) C C SAVE DIAGONAL ELEMENTS IN E C CALL DCOPY(N,A,IA+1,E,1) C C CALL LAPACK DIAGONALISER: DESTROYS LOWER TRIANGLE OF A C CALL DSYEVX('V','A','L',N,A,IA,DUM,DUM,IDUM,IDUM,ZERO,M,R,V,IV, 1 X(IT3),LWORK,X(IT1),X(IT2),INFO) C IF (INFO .NE. 0) THEN WRITE (6,120) INFO 120 FORMAT(' *** ERROR IN DSYEVX: INFO =',I3) END IF C IFAIL=INFO IXNEXT=IT1 C C RESTORE LOWER TRIANGLE FROM UNCHANGED UPPER TRIANGLE C AND DIAGONAL FROM E C CALL DSYFIL('L',N,A,IA) CALL DCOPY(N,E,1,A,IA+1) C RETURN END INTEGER FUNCTION FIND(I,J,IG,NG) C C FUNCTION TO FIND A PARTICULAR FOURIER COMPONENT IN A LIST C OF COMPONENTS, AND RETURN THE POSITION OF THE REQUIRED C COMPONENT. C DIMENSION IG(2,NG) C II=I JJ=J CALL ORDER(II,JJ) FIND=0 DO 10 N=1,NG IF(II.NE.IG(1,N) .OR. JJ.NE.IG(2,N)) GOTO 10 FIND=N GOTO 20 10 CONTINUE 20 RETURN END SUBROUTINE FINDRM(W,N,RSTART,RTURN,IK,P,VL,IV,ERED,EINT,CENT, 1 RMLMDA,DIAG,DIAG2,XK,PHASE,MXLAM,NPOTL,IRMSET,ITYPE,IPRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION W(N,N),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N),DIAG(N), 1 DIAG2(N),XK(N),PHASE(N) C C SUBROUTINE TO FIND A SUITABLE STARTING POINT FOR INTEGRATION C C FIND CLASSICAL TURNING POINT OF DIAGONAL POTENTIAL C IN LOWEST-LYING CHANNEL. C START FROM A GUESS BASED ON THE CENTRIFUGAL POTENTIAL C RMIN=RSTART RTURN=1.D30 NOPEN=0 DO 80 I=1,N DIF=ERED-EINT(I) IF (DIF.LT.0.D0) GOTO 80 NOPEN=NOPEN+1 RCENT=SQRT(CENT(I)/DIF) RCENT=MAX(RCENT,RMIN) RTURN=MIN(RTURN,RCENT) 80 CONTINUE C C FOR SURFACE SCATTERING, OVERRIDE THE CENTRIFUGAL GUESS C IF (ITYPE.EQ.8) RTURN=RMIN C IF (NOPEN.LE.0) THEN IF (IPRINT.GE.3) WRITE(6,*) ' *** FINDRM. NO OPEN CHANNELS' GOTO 300 ENDIF C ITRY=0 90 RSTART=RTURN IF (ITRY.GT.25) GOTO 140 CALL WAVMAT(W,N,RSTART,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) C C FIND LOWEST CHANNEL C IK=1 V1=DIAG(1) DO 100 I=1,N IF (DIAG(I).GE.V1) GO TO 100 IK=I V1=DIAG(I) 100 CONTINUE C RTURN=0.999D0*RSTART DO 120 II=1,100 CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG2, 1 MXLAM,NPOTL) C C CHECK THAT CHANNEL IK IS STILL LOWEST, AND CALCULATE ALL C THE DERIVATIVES FOR USE LATER C V2=DIAG2(IK) DO 110 I=1,N XK(I)=(DIAG2(I)-DIAG(I))/(RTURN-RSTART) DIAG(I)=DIAG2(I) IF (DIAG(I).LT.V2) THEN ITRY=ITRY+1 GOTO 90 ENDIF 110 CONTINUE DV1=XK(IK) C IF (IPRINT.GE.8) WRITE(6,602) RTURN,V2 602 FORMAT(' FINDRM: AT R =',F8.4,' SMALLEST V-E IS',F11.2) C C THERE MIGHT BE A WELL BEHIND THE BARRIER MAXIMUM. C PROVIDED IT IS ABOVE THE SCATTERING ENERGY, JUMP OVER IT C AND TRY AGAIN. ONLY DO THIS ONCE, THOUGH. C IF (DV1.GE.0.D0) THEN IF (V2.GT.0.D0) THEN ITRY=ITRY+10 IF (ITRY.LT.20) THEN RTURN=2.D0*RTURN GOTO 90 ELSE GOTO 140 ENDIF ELSE ITRY=ITRY+5 RTURN=0.9D0*RTURN GOTO 90 ENDIF ENDIF RSTART=RTURN V1=V2 DR=-V1/DV1 IF (DR.LT.-0.3D0*RTURN .AND. ITYPE.NE.8) DR=-0.3D0*RTURN RTURN=RTURN+DR IF (ITRY.GT.25 .OR. DR.GT.1.D3) GO TO 140 IF (RTURN.LE.0.D0 .AND. ITYPE.NE.8) GO TO 140 IF (ABS(DR/RTURN).LE.1.D-3) GO TO 160 120 CONTINUE C C ARRIVE HERE IF DR BECOMES HUGE, RTURN BECOMES NEGATIVE, C OR THERE IS NO CONVERGENCE IN 100 NEWTON-RAPHSON ITERATIONS. C IF THIS HAPPENS, JUST USE THE INPUT VALUE OF RMIN C 140 IF (IPRINT.GE.3) WRITE(6,*) ' *** FINDRM. ', 1 'UNABLE TO FIND CLASSICAL TURNING POINT' GOTO 300 C C ARRIVE HERE IF WE HAVE CONVERGED ON A CLASSICAL TURNING POINT C DIAG ARRAY CONTAINS DIAGONAL ELEMENTS C 160 IF (IPRINT.GE.3) WRITE(6,603) RTURN 603 FORMAT(' INNER CLASSICAL TURNING POINT AT R =',F8.4) C C SPECIAL CASE: CALLED TO FIND RTURN ONLY C IF (IRMSET.LE.0) THEN RSTART=RMIN RETURN ENDIF C C FIND NEW RSTART BY INTEGRATING PHASE INTEGRALS INWARDS. C WE WANT RSTART SUCH THAT C INT(RSTART,RTURN) SQRT(E-V) DR = 2.303 * IRMSET C TRY TO DO IT IN NSTEP ROUGHLY EQUAL STEPS C NSTEP=3+IRMSET/3 C TARGET=2.303D0*DBLE(IRMSET) DR=1.5D0*TARGET/SQRT(ABS(XK(IK)))/DBLE(NSTEP) C DO 210 I=1,N PHASE(I)=0.D0 XK(I)=SQRT(ABS(DIAG(I))) 210 CONTINUE C 220 CONTINUE C DO 240 ISTEP=1,NSTEP RNEXT=RSTART-DR IF (RNEXT.LT.0.D0 .AND. ITYPE.NE.8) THEN RSTART=0.D0 IF (IPRINT.GE.1) WRITE(6,*) ' *** FINDRM. REACHED ORIGIN ', 1 'WHILE ACCUMULATING PHASE INTEGRAL. ', 2 'PROPAGATION WILL START AT ORIGIN.' RETURN ENDIF C CALL WAVMAT(W,N,RNEXT,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) DRNEXT=0.D0 DO 230 I=1,N IF (DIAG(I).LE.0.D0) THEN IF (IPRINT.GE.3) 1 WRITE(6,*) ' *** FINDRM. INNER CLASSICALLY ALLOWED REGION ', 1 'ENCOUNTERED WHILE INTEGRATING INWARDS FROM TURNING POINT.' GOTO 260 ENDIF V1=SQRT(DIAG(I)) V2=0.5D0*(V1+XK(I)) PHASE(I)=PHASE(I)+DR*V2 DRNEXT=MAX(DRNEXT,(TARGET-PHASE(I))/V1) XK(I)=V1 230 CONTINUE C RSTART=RNEXT IF (ISTEP.LT.NSTEP) DR=DRNEXT/DBLE(NSTEP-ISTEP) C IF (IPRINT.GE.8) WRITE(6,604) ISTEP,RNEXT,DR,DIAG(IK) 604 FORMAT(' FINDRM: STEP',I3,' AT R =',2F8.4,F11.2) C IF (DRNEXT.LE.0.D0) GOTO 250 C C IF THE STEP SIZE SEEMS EXCESSIVE, TRY ACCUMULATING THE C PHASE INTEGRAL MORE CAUTIOUSLY C IF (ISTEP.LT.NSTEP .AND. ITYPE.NE.8 1 .AND. DR.GT.0.5D0*RSTART .AND. DR.GT.0.5D0*RMIN) THEN DR=0.02D0*RSTART GOTO 220 ENDIF C 240 CONTINUE C 250 IF (IPRINT.GE.3) WRITE(6,606) RSTART 606 FORMAT(' RADIAL INTEGRATION WILL START AT R =',F8.4) RETURN C C ARRIVE HERE IF THE INWARDS SEARCH ENTERED A CLASSICALLY ALLOWED C REGION. TRY TO FIND A BETTER STARTING POINT AND LOOK FOR THE C INNER TURNING POINT C 260 DR=0.1D0*RNEXT RTURN=RNEXT-DR DO 290 II=1,9 CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) DO 270 I=1,N IF (DIAG(I).LE.0.D0) GOTO 280 270 CONTINUE ITRY=ITRY+10 GOTO 90 280 RTURN=RTURN-DR 290 CONTINUE IF (IPRINT.GE.1) WRITE(6,*) ' *** FINDRM. ', 1 'UNABLE TO FIND INNER CLASSICAL TURNING POINT. ', 2 'PROPAGATION WILL START AT ORIGIN' RSTART=0.D0 RETURN C 300 RSTART=RMIN RTURN=2.D0*RMIN IF (IPRINT.GE.3) WRITE(6,608) 608 FORMAT(14X,'RSTART SET TO RMIN'/14X,'RTURN SET TO 2*RMIN') RETURN C END SUBROUTINE FINDRX(ENERGY,EINT,CENT,NNRG,N,CINT,RMAX,RSTOP, 1 NOPMAX,IRXSET,IPRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C SUBROUTINE TO SCAN INPUT ENERGIES AND THRESHOLDS TO DETERMINE C A SAFE RMAX WHICH IS OUTSIDE THE CENTRIFUGAL BARRIER FOR C ALL COMBINATIONS. ALSO FIND THE LARGEST VALUE OF NOPEN C TO SAFEGUARD AGAINST SHRINKING THE BASIS SET TOO FAR. C DIMENSION ENERGY(NNRG),EINT(N),CENT(N) C NOPMAX=0 RSTOP=RMAX DO 200 J=1,NNRG NOPEN=0 ERED=ENERGY(J)*CINT DO 100 I=1,N DIF=ERED-EINT(I) IF(DIF.LT.0.D0) GOTO 100 NOPEN=NOPEN+1 IF(IRXSET.LE.0) GOTO 100 RCENT=SQRT(CENT(I)/DIF) RSTOP=MAX(RSTOP,RCENT) 100 CONTINUE 200 NOPMAX=MAX0(NOPMAX,NOPEN) IF(RSTOP.GT.RMAX .AND. IPRINT.GE.3) WRITE(6,601) RSTOP 601 FORMAT('0 RMAX INCREASED TO',F7.2,' FOR THIS PARITY CASE', 1 ' TO ENSURE THAT OPEN CHANNEL MATCHING'/' OCCURS BEYOND', 2 ' THE CENTRIFUGAL BARRIER FOR ALL ENERGIES') RETURN END FUNCTION FSYMTP(J1,K1,L1,J2,K2,L2,JT,LAM,MU) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C CALCULATES MATRIX ELEMENT FOR SYMMETRIC TOP FUNCTIONS C (J1 K1 L1, JTOT / Y(LAM,MU) / J2 K2 L2, JTOT). C USES SUBROUTINES - C THRJ(XJ1,XJ2,XJ3,XM1,XM2,XM3) C THREEJ(J1,J2,J3) WHICH IS FOR M1=M2=M3=0 C SIXJ(J1,L1,J2,L2,JTOT,LAM) C DATA PI/3.14159265358979289D0/ C STATEMENT FUNCTION DEFINITION . . . Z(Y) = 2.D0 * Y + 1.D0 C IF (K1-K2+MU .NE. 0) GO TO 9000 F=THREEJ(L1,L2,LAM) IF (F.EQ.0.D0) GO TO 9000 XJ1=J1 XJ2=J2 XK1=K1 XK2= - K2 XL1=L1 XL2=L2 XLAM=LAM XMU=MU F=F * THRJ(XJ1,XJ2,XLAM,XK1,XK2,XMU) IF (F.EQ.0.D0) GO TO 9000 F=F * SIXJ(J1,L1,J2,L2,JT,LAM) IF (F.EQ.0.D0) GO TO 9000 PH=PARITY(J1+J2+K2-JT) F=F*PH*SQRT(Z(XJ1)*Z(XJ2)*Z(XL1)*Z(XL2)*Z(XLAM)/(4.D0*PI)) FSYMTP=F RETURN 9000 FSYMTP=0.D0 RETURN END SUBROUTINE GASLEG(N,Z,A) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C *** ROUTINE TO GENERATE GAUSS-LEGENDRE POINTS/WEIGHTS C *** TAKEN FROM AD VAN DER AVOIRD'S N2-N2 CODE (SG 11/7/91) C *** NEEDS FUNCTION ZBES DIMENSION P(301),PD(301),Z(1),A(1) DATA PI/3.14159 26535 89793 D0/ IF (N.LE.300) GO TO 20 WRITE (6,10) 10 FORMAT (/10X,31H***** GASLEG N TOO LARGE *****/) STOP 20 NN=N+1 IFIN=0 IODD=0 C=2.0D0/PI C=1.0D0-(C*C) IF (MOD(N,2).EQ.0) GO TO 30 NKNT=(N-1)/2 IODD=1 GO TO 40 30 NKNT=N/2 40 K=1 CHA=0.0D0 CHB=0.0D0 P(1)=1.0D0 DN=N+0.50D0 DN2=DN*DN DEN=SQRT(DN2+(C/4.0D0)) 50 BES=ZBES(K) X=COS(BES/DEN) PDX=1.0D0/(1.0D0-X*X) 60 CONTINUE P(2)=X DO 70 I=3,NN IN=I-1 IM=I-2 P(I)=((2.0D0*IN-1.0D0)*X*P(IN)-IM*P(IM))/IN PD(I)=IN*PDX*(P(IN)-X*P(I)) 70 CONTINUE IF (IFIN.EQ.1) GO TO 100 IF (ABS(P(NN)).LT.1.0D-12) GO TO 80 X=X-(P(NN)/PD(NN)) PDX=1.0D0/(1.0D0-X*X) GO TO 60 80 Z(K)=X TA=N*P(N) TA=TA*TA A(K)=(2.0D0*(1.0D0-X*X))/TA CHA=CHA+2.0D0*A(K) Z2=Z(K)*Z(K) CHB=CHB+2.0D0*A(K)*Z2 IF (K.EQ.NKNT) GO TO 90 K=K+1 GO TO 50 90 CONTINUE IF (IODD.EQ.0) GO TO 110 X=0.0D0 K=NKNT+1 Z(K)=X IFIN=1 GO TO 60 100 TA=N*P(N) TA=TA*TA A(K)=2.0D0/TA CHA=CHA+A(K) 110 CONTINUE RETURN END SUBROUTINE GAUSHP(NN,X,A) C CALCULATES THE ZEROS, X(I), AND WEIGHTS, A(I), I=1,NN, FOR C GAUSS-HERMITE QUADRATURE. C Approximates the integral from -infinity to infinity of f(x) C by the sum(i=1,nn) w(i)*f(x(i)). C ADAPTED BY S. GREEN FROM STROUD AND SECREST GAUSSIAN QUADRATURE FORMULAS. C VERSION OF 18 APRIL 94 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MXIT=15) DIMENSION X(NN),A(NN) DATA EPS/1.D-15/ C GAM(Y)=(((((((.035868343D0*Y-.193527818D0)*Y+.482199394D0)*Y- 1 .756704078D0)*Y+.918206857D0)*Y-.897056937D0)*Y+ 2 .988205891D0)*Y-.577191652D0)*Y+1.D0 C IF (NN.LE.0) THEN WRITE(6,*) ' *** GAUSHP CALLED FOR ILLEGAL NPT=',NN STOP ELSEIF (NN.EQ.1) THEN WRITE(6,*) ' *** GAUSHP. WARNING, SINGLE POINT REQUESTED.' X(1)=0.D0 A(1)=1.D0 RETURN ELSE FN=NN N1=NN-1 N2=(NN+1)/2 C COMPUTE GAMMA FN BY HASTINGS APPROX; 0.LE.X.LE.70. Z=FN IF (Z.LE.0.D0 .OR. Z.GE.7.D1) THEN WRITE(6,600) Z 600 FORMAT(' *** GAUSHP. CANNOT GET GAMMA FUNCTION FOR',F10.2) STOP ENDIF IF (Z.EQ.1.D0) THEN GAMMA=1.D0 GO TO 20 ELSEIF (Z.LT.1.D0) THEN GAMMA=GAM(Z)/Z GO TO 20 ELSE ZA=1.D0 10 Z=Z-1.D0 IF (Z-1.D0) 13,11,12 11 GAMMA=ZA GO TO 20 12 ZA=ZA*Z GO TO 10 13 GAMMA=ZA*GAM(Z) GO TO 20 ENDIF 20 CC=1.7724538509D0*GAMMA*(2.D0**(-N1)) S=(2.D0*FN+1.D0)**(1.D0/6.D0) DO 100 I=1,N2 IF (I.EQ.1) THEN C LARGEST ZERO XT=S**3-1.85575D0/S GO TO 50 ELSEIF (I.EQ.2) THEN C SECOND ZERO XT=XT-1.14D0*FN**.426D0/XT GO TO 50 ELSEIF (I.EQ.3) THEN C THIRD ZERO XT=1.86D0*XT-0.86D0*X(1) GO TO 50 ELSEIF (I.EQ.4) THEN C FOURTH ZERO XT=1.91D0*XT-0.91D0*X(2) GO TO 50 ELSE C ALL HIGHER ZERO'S XT=2.D0*XT-X(I-2) ENDIF C C IMPROVE THE APPROXIMATE ROOT XT AND OBTAIN C DPN = DERIVATIVE OF H(N) AT XT; PN1 = VALUE OF H(N-1) AT XT 50 IT=0 60 IT=IT+1 IF (IT.GT.MXIT) THEN WRITE(6,*) ' *** GAUSHP FAILED TO CONVERGE. ITERATIONS =' 1 ,MXIT STOP ENDIF CALL HRECUR(P,DP,PN1,XT,NN) D=P/DP XT=XT-D IF (ABS(D).GT.EPS) GO TO 60 DPN=DP X(I)=XT A(I)=CC/(DPN*PN1) NI=NN-I+1 X(NI)=-XT 100 A(NI)=A(I) ENDIF RETURN END SUBROUTINE GAUSSP(A,B,NPT,XPT,WHT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION XPT(NPT),WHT(NPT) C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C THIS ROUTINE SETS UP ABSCISSAE AND WEIGHTS FOR NPT-POINT * C GAUSS-LEGENDRE INTEGRATION IN THE INTERVAL (A,B). * C * C ON RETURN, THE FUNCTION TO BE INTEGRATED SHOULD BE EVALUATED * C AT THE POINTS XPT(I). INTEGRAL = SUM(I=1,NPT) F(XPT(I))*WHT(I)* C * C THIS VERSION (SG 11/7/91) CALCULATES POINTS/WEIGHTS FROM * C GASLEG/ZBES CODE OF AD VAN DER AVOIRD * C DOES ANY NUMBER OF PTS FROM 1 TO MXPT, WHERE LIMIT IS FROM * C DIMENSION STATEMENTS IN GASLEG (P,PD AT LEAST (MXPT+1) ) * C AND HERE W,X DIMENSIONED AT LEAST ((MXPT+1)/2) * C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DIMENSION X(128),W(128) DATA MXPT/256/ C T1=(B-A)/2.D0 T2=(B+A)/2 IF (NPT-1) 9999,9998,9997 9997 IF (NPT.LE.MXPT) GO TO 3100 WRITE(6,601) NPT,MXPT 601 FORMAT('0 * * * WARNING. GAUSS-LEGENDRE NPT =',I6,' REDUCED TO', 1 I4) NPT=MXPT 3100 CALL GASLEG(NPT,X,W) N2=(NPT+1)/2 I1=1 I2=NPT IC=1 DO 2000 I=1,N2 XPT(I1)=-X(IC)*T1+T2 XPT(I2)=X(IC)*T1+T2 WHT(I1)=W(IC)*T1 WHT(I2)=WHT(I1) I1=I1+1 I2=I2-1 2000 IC=IC+1 C N.B FOR NPT ODD, THE LAST (I.E. MIDDLE) TERM IS EVALUATED TWICE. RETURN 9999 WRITE(6,610) NPT 610 FORMAT('0 * * * WARNING. GAUSS-LEGENDRE REQUESTED WITH NPT =',I6) C REPLACE WITH SINGLE-POINT AT (A+B)/2 * (B-A) NPT=1 9998 XPT(1)=T2 WHT(1)=2.D0*T1 RETURN END SUBROUTINE GCLOCK(XTIME) DOUBLE PRECISION XTIME REAL TIME,TTIME DIMENSION TTIME(2) C C THIS ROUTINE IS MACHINE-DEPENDENT. C IT SHOULD RETURN THE ELAPSED CPU TIME IN UNITS OF SECONDS. C ONLY DIFFERENCES ARE USED, SO IT NEED NOT BE AN ABSOLUTE VALUE. C C DUMMY RESULT FOR VANILLA DISTRIBUTION XTIME=0.D0 C C CODE BELOW CALLS THE BSD UNIX TIMING ROUTINE. C A C VERSION OF etime FOR MOST OTHER UNIX SYSTEMS IS AVAILABLE FROM JMH. C TIME=etime(TTIME) C XTIME=DBLE(TIME) C C CODE BELOW IS THE GISS ROUTINE C CALL CLOCKS(ITIME) C XTIME=-ITIME C XTIME=XTIME*1.D-2 RETURN END SUBROUTINE GDATE(CDATE) C C THESE ROUTINES ARE MACHINE-DEPENDENT, AND MUST BE SIMULATED. C THEY SHOULD RETURN STRINGS CONTAINING THE CURRENT DATE & TIME. C CHARACTER CDATE*11, CTIME*9 CDATE='UNKNOWN ' RETURN ENTRY GTIME(CTIME) CTIME='UNKNOWN ' RETURN END SUBROUTINE GET102(MXLVL,NLEVEL,JLEVEL,ELEVEL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION JLEVEL(2,MXLVL),ELEVEL(MXLVL) WRITE(6,699) 699 FORMAT('0 GET102. DUMMY ROUTINE CALLED. TERMINAL ERROR.') STOP END FUNCTION GSYMTP(J1,K1,J2,K2,MVAL,LM,MU) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA Z0/0.D0/, PIFCT/.282094791773878209D0/ C STATEMENT FUNCTION . . . Z(X)=2.D0*X+1.D0 C XJ1=J1 XK1=K1 XJ2=J2 XK2=K2 XM=MVAL XLM=LM XMU=MU GSYMTP=0.D0 F=THRJ(XJ1,XLM,XJ2,XK1,XMU,-XK2) IF (ABS(F) .LE. 1.D-8) RETURN F=F*THRJ(XJ1,XLM,XJ2,-XM,Z0,XM) IF (ABS(F) .LE. 1.D-8) RETURN GSYMTP=F*PIFCT*SQRT(Z(XJ1)*Z(XJ2)*Z(XLM))*PARITY(K1+MVAL) RETURN END SUBROUTINE HEADER(W,WX,N,NSQ,P,VL,IV,EINT,CENT,DIAG,MXLAM,NPOTL, 1 ICODE,ISAV,EFIRST) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ROUTINE TO WRITE/CHECK A HEADER LABEL ON UNIT ISCRU FOR USE C WITH THE OPTION TO SAVE TRANSFORMATION MATRICES FOR A SUBSEQUENT C RUN. THE LABEL CONSISTS OF ALL INTEGRATION TOLERANCES AND C A SAMPLE POTENTIAL MATRIX. C C THE VARIOUS FLAGS ARE USED AS FOLLOWS: C ICODE=1, ISAV=1: FIRST ENERGY, WRITE HEADER C ICODE=1, ISAV=-1: FIRST ENERGY, CHECK HEADER C ICODE=2: SUBSEQUENT ENERGY, SKIP HEADER C C DIMENSION W(NSQ),WX(NSQ),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N), 1 DIAG(N),PAR(13),PARX(13) C COMMON BLOCK FROM DRIVER AND RMTPRP COMMON/DRIVE/STEST,STEPS,STAB,CONV,RMIN,RMAX,XEPS,DR, 1 DRMAX,RMID,TOLHI,RTURN, 2 VTOL,ESHIFT,ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP EQUIVALENCE(PAR(1),STEST) C IF(ISCRU.EQ.0) RETURN REWIND ISCRU IF(ISAV.EQ.0) RETURN IF(ICODE.EQ.1) GO TO 40 C C SUBSEQUENT ENERGY CALC. - SKIP OVER ANY HEADER C READ(ISCRU) READ(ISCRU) RETURN C 40 IF(ISAV.EQ.-1) GO TO 60 C C WRITE OUT A HEADER C RX=2.D0*RMIN CALL WAVMAT(W,N,RX,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM, 1 NPOTL) WRITE(ISCRU) N,EFIRST,RX,PAR WRITE(ISCRU) W RETURN C C READ AND VERIFY HEADER. SET NOPEN=-1 AS A FLAG THAT NO ACTUAL C SCATTERING CALCULATION IS TO BE DONE FOR THIS ENERGY. C SET ICODE=2 SO THAT A "SUBSEQUENT ENERGY" CALCULATION IS DONE C 60 READ(ISCRU) NX,EFIRST,RX,PARX IF(N.NE.NX) GO TO 999 DO 62 I=1,13 IF(PAR(I).NE.PARX(I)) GO TO 999 62 CONTINUE CALL WAVMAT(W,N,RX,P,VL,IV,EFIRST,EINT,CENT,RMLMDA,DIAG,MXLAM, 1 NPOTL) READ(ISCRU) WX DO 64 I=1,NSQ IF(W(I).NE.WX(I)) GO TO 998 64 CONTINUE ICODE=2 WRITE(6,603) ISCRU 603 FORMAT('0 HEADER LABEL ON UNIT',I3,' SUCCESSFULLY VERIFIED.') RETURN C C HEADER IS WRONG - RUN TERMINATED C 998 WRITE(6,600) ISCRU 600 FORMAT('0****** ERROR - HEADER ON UNIT',I3,' DOES NOT AGREE', 1 ' WITH DATA FOR CURRENT RUN'/) WRITE(6,601) (W(I),WX(I),I=1,NSQ) 601 FORMAT(2D24.15,10X,2D24.15) 999 WRITE(6,600) ISCRU WRITE(6,602) N,NX,(PAR(I),PARX(I),I=1,13) 602 FORMAT(2I8/(2D24.15)) STOP END SUBROUTINE HERM(H,N,X) C C SUBROUTINE TO GENERATE HERMITE POLYNOMIALS C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION H(N) P0=1.0D0 H(1)=P0 IF(N.LE.1) RETURN X2=X+X P1=X2 H(2)=P1 IF(N.LE.2) RETURN DO 100 K=3,N TEMP=X2*P1 - DBLE(K+K-4)*P0 P0=P1 P1=TEMP H(K)=P1 100 CONTINUE RETURN END SUBROUTINE HRECUR(PN,DPN,PN1,X,NN) C SG: ADAPTED FROM STROUD AND SECREST, GAUSSIAN QUADRATURE FORMULAS GREEN. IMPLICIT DOUBLE PRECISION (A-H,O-Z) P1=1.D0 P=X DP1=0.D0 DP=1.D0 DO 1 J=2,NN FJ=J FJ2=(FJ-1.D0)/2.D0 Q=X*P-FJ2*P1 DQ=X*DP+P-FJ2*DP1 P1=P P=Q DP1=DP 1 DP=DQ PN=P DPN=DP PN1=P1 RETURN END SUBROUTINE IDPART(ITYPE,IDENT,SPNUC,WT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION WT(2) C C THIS ROUTINE PROCESSES INPUT FOR IDENTICAL TARGET-PROJECTILE. C IDENT.NE.0 IMPLIES TARGET AND PROJECTILE ARE IDENTICAL. C OTHERWISE (IDENT.EQ.0) IEXCH=0 IN ALL CASES AND NO PROCESSING C WITH IEXCH OR WT WILL OCCUR. C CHARACTER*8 NAME(2) DATA NAME/' BOSE ',' FERMI '/ C IF (IDENT.EQ.0) RETURN WRITE(6,600) 600 FORMAT('0 IDENT PARAMETER SPECIFIES THAT TARGET AND PROJECTILE ARE 1 IDENTICAL. PROPERLY SYMMETRIZED FUNCTIONS WILL BE CONSTRUCTED.') IF (ITYPE.EQ.3.OR.ITYPE.EQ.13.OR.ITYPE.EQ.23) GO TO 1000 WRITE(6,601) ITYPE 601 FORMAT('0 * * * ERROR. FOR ITYPE =',I4,' IDENT PROCESSING NOT SUP 1PORTED. REQUEST CANCELLED.') IDENT=0 RETURN 1000 SPNUC=ABS(SPNUC) IF (WT(1).EQ.0.D0 .AND. WT(2).EQ.0.D0) GO TO 2000 WRITE(6,603) WT 603 FORMAT(' STATISTICAL WEIGHTS SPECIFIED AS WT IN &BASIS DATA. SPN 1UC IGNORED.'/10X,'ANTI-SYMMETRIC, WT(1) =',F7.4,', SYMMETRIC, WT( 22) =',F7.4) RETURN 2000 IST=INT(2.D0*SPNUC+0.0001D0) IST=IST-2*(IST/2) C IST=0 FOR BOSE STATISTICS, IST=1 FOR FERMI STATISTICS. DN=2.D0*SPNUC+1.D0 WT(2-IST)=(SPNUC+1.D0)/DN WT(IST+1)=SPNUC/DN WRITE(6,602) SPNUC,NAME(IST+1),WT 602 FORMAT(' FOR NUCLEAR SPIN =', F6.2,',',A8,' STATISTICAL WEIGHTS A 1RE'/10X,'ANTI-SYMMETRIC, WT(1) =',F7.4,', SYMMETRIC, WT(2) =', 2 F7.4) RETURN END SUBROUTINE IOSBIN(NVC,ITYPX,ATAU,MX,IASYMU,IPHIFX,IOSNG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C C *** MODIFIED FEB 92 TO CHANGE ITYPE=2 TO USE IV() INDEXING C *** MODIFIED MAY 92 TO HANDLE ITYPE=103 (SG) *** C *** MODIFIED JAN/FEB 92 TO GENERALIZE ITYPE=2 HANDLING C *** MODIFIED FEB 88 TO CORRECT 'IHOMO' HANDLING OF ITYPE=5,6 CASES C WHERE POTENTIAL IS SYMMETRIC ABOUT THETA=PI/2 C *** AUG 86 ADD LM,LMAX ARGUMENTS TO IXQLF C *** UPDATED APR 86 TO MERGE BASIN-IOSBIN PROCESSING C C THIS IS IOS 'BASIS' ROUTINE FOR COMBINED MOLSCAT/IOS APR 86 C MODIFICATIONS MAY 1978 FOR ITYPE=5. C MODIFICATIONS SEPT 1985 FOR ITYPE=6, C INCLUDING ADDITION OF MMAX TO &INPUT. C C-----ENTRY IOSBIN READS &BASIS AND SETS UP BASIS DATA. C PARAMETERS ARE NVC (NO. VIB. CHANNELS), ITYPX RETURNS ROTOR TYPE C AND ATAU(MX) WHICH WILL HOLD ROTOR COEFF. FOR ITYPE=6 C DIMENSION ATAU(MX) C C-----ENTRY IOSBGP GETS LAM(MXLAM) INFORMATION FROM &POTL. C CAN THEN CHOOSE NGPT, LMAX, MMAX, AND SET UP GAUSS PTS/WTS C SPECIFICATIONS FOR ENTRY IOSBGP . . . DIMENSION LAM(MXLAM) LOGICAL ODD C C-----ENTRY IOSB1, CALLED AFTER STORAGE IS ALLOCATED, SETS UP PWGHT, VLI C ALSO IXQL AND LM. C SPECIFICATIONS . . . DIMENSION PWGHT(NGPT,LMAX), VLI(NGPT,MXXXXL) DIMENSION IXQL(NIXQL,NQL),LM(3,LMAX) C BELOW (TEMPORARY) TO CONTROL FLOW OF ALTERNATE ITYPE=3 CODE LOGICAL LNEW C C-----ENTRY IOSB2 IS CALLED JUST BEFORE INTEGRATOR. SETS UP VL, ETC. C SPECIFICATIONS FOR ENTRY IOSB2 . . . DIMENSION CENT(NVC),EINT(NVC),WVEC(NVC),VL(2),IVIX(2) DIMENSION LORB(NVC),JJJ(NVC),NB(NVC) C COMMON TO PASS ANGLES TO VRTP FOR "UNEXPANDED" (MXLAM=0) POTL CASE C N.B. 3RD ANGLE FOR ITYPE=3. IH0,IC0 TO SET IHOMO,ICNSYM IN VRTP C FACTOR IS 1./(VALUE OF LOWEST ANGULAR TERM) - DEPENDS ON ITYPE COMMON/ANGLES/COSANG(7),FACTOR,IH0,IC0,IH1,IC1 LOGICAL LVRTP C C-----ENTRY IXQLF RETURNS INDEX IN IXQL OF AN INPUT L,M1,M2,ICDE SYM. C C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C TO CONTROL DEBUGGING OUTPUT OF COUPLING MATRIX C LDEBUG=.TRUE. CAN GIVE QUITE A BIT OF OUTPUT ! LOGICAL LDEBUG C C SPECIFICATIONS FOR MOLSCAT(&BASIS) COMPATIBILITY. . . DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2), 1 WEXE(2),WT(2),ELEVEL(1000) INTEGER JMIN,JMAX,NLEVEL,JLEVEL(4000),J1MIN,J1MAX,J2MIN,J2MAX, 1 IDENT,JSTEP,J1STEP,J2STEP,ISYM(10),ISYM2(10) EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)), 1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX), 2 (JSTEP,J1STEP), (ROTI(7),WE(1)),(ROTI(9),WEXE(1)) C COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL, 1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT, 2 MXJL,MXEL C C INTERNAL VERSION OF JLEVEL,ELEVEL IS ALSO USED; CF IOSOUT DIMENSION LEVV(4000),EV(1000) C C COMMON BLOCK TO COMMUNICATE WITH IOSOUT . . . COMMON /IOUTCM/ MAX,LEVV C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MXXX,IXNEXT,NIPR,IVLFL,X(1) C C IOS GAUSS POINT CONTROL DIMENSION IOSNGP(3),IOSNG(3) C C ****************************************************************** C ** PROGRAM LIMITATION ** C ** DIMENSIONS FOR GAUSS POINTS ** C ** ------- ---------- ** C ** COULD USE /MEMORY/ FOR DYNAMIC STORAGE, BUT BELOW SHOULD ** C ** SUFFICE FOR MOST FEASIBLE CALCULATIONS. ** C ****************************************************************** PARAMETER(MXGPT=400) DIMENSION COSA(MXGPT),GWT(MXGPT) C FOR ITYPE=3 TO HOLD PLM(LI,M,) AND COS(M*PHI) -- LNEW=.TRUE. CODE DIMENSION PL1(MXGPT),PL2(MXGPT),COSM(MXGPT) C C AND EQUIVALENT INTERNAL ARRAYS DATA NVCMX/1000/ DATA IZ/0/ DATA LNEW/.TRUE./,LDEBUG/.FALSE./ C C STATEMENT FUNCTION USED IN DETERMINING ITYPE=5,6 IHOMO SYMMETRY ODD(I,J)=(I-J)-2*((I-J)/2) .NE. 0 C C C SPECIFICATIONS FOR LEGENDRE STATEMENT FUNCTION . . . XLEG(I,TH)=SQRT(2.D0/DBLE(2*I+1))*PLM(I,0,TH) C N.B. PLM(L,M,COSTH) RETURNS A **NORMALIZED** ASSOC. LEG. POLY. C C NB. THE FOLLOWING VARIABLES ARE USED AS LIMITS (SOME ITYPE=5 ONLY) C MAX=HIGHEST J IN BASIS / MXK=HIGHEST K (SYM. TOP) IN BASIS. C LMBDMX=HIGHEST LAMBDA IN POTL / MUMX=HIGHEST MU IN POTL C LMMAX=HIGHEST 'L' IN SLLR,SLLI,QLT / MUMAX=HIGHEST 'M' C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C PI=ACOS(-1.D0) WRITE(6,666) 666 FORMAT('0 PROCESSED BY IOSBIN ROUTINE (FEB 94).') C C SET LOCAL (AND HENCE KEPT) VALUES FROM ARGUMENTS DO 1107 I=1,3 1107 IOSNGP(I)=IOSNG(I) IPHIFL=IPHIFX C INITIALIZE SIZE OF ATAU TO ZERO. MXA=MX MX=0 C SET DEFAULT IH0,IC0, IH1, IC1 WHICH MAY BE CHANGED IN VRTP IH0=0 IC0=0 IH1=0 IC1=0 C WRITE(6,620) ITYPX 620 FORMAT('0 INPUT ITYPE =',I4) C ITYP=ITYPX-10*(ITYPX/10) ITYPX=100+ITYP C SET IVLFL TO ZERO FOR MOST CASES; EXCEPTION IS ITYPE=102 (FEB 94) IVLFL=0 IF (ITYP.EQ.1) GO TO 1000 IF (ITYP.EQ.2) GO TO 2000 IF (ITYP.EQ.3) GO TO 3000 IF (ITYP.EQ.5) GO TO 5000 IF (ITYP.EQ.6) GO TO 6000 WRITE(6,699) ITYP 699 FORMAT('0 * * * ERROR. MOD(ITYPE,10) =',I3,' NOT SUPPORTED.') STOP C 1000 NVC=1 ASSIGN 6100 TO IGOTP EV(1)=0.D0 LEVV(1)=0 ILOFF=1 IF (NLEVEL.GT.0) GO TO 1200 WRITE(6,601) JMIN,JMAX,JSTEP 601 FORMAT('0 JLEVEL, NLEVEL CREATED FROM JMIN, JMAX, JSTEP =', & 3I5) JMIN=MAX0(JMIN,0) JMAX=MAX0(JMIN,JMAX) JSTEP=MAX0(JSTEP,1) MAX=0 NLEVEL=0 DO 1100 I=JMIN,JMAX,JSTEP IF (NLEVEL.GE.MXJL) GO TO 1109 NLEVEL=NLEVEL+1 JLEVEL(NLEVEL)=I 1100 MAX=MAX0(MAX,I) GO TO 9000 1109 WRITE(6,698) 698 FORMAT('0 * * * WARNING. OUT OF SPACE IN JLEVEL. ', 1 'BASIS TRUNCATED.') NLEVEL=MXJL GO TO 9000 1200 WRITE(6,602) NLEVEL,(JLEVEL(I),I=1,NLEVEL) 602 FORMAT('0 BASIS TAKEN FROM NLEVEL, JLEVEL INPUT. NO. OF LEVELS ', & '(NLEVEL) =',I4/(' ',20I5) ) MAX=0 DO 1300 I=1,NLEVEL IF (I.GT.MXJL) GO TO 1109 1300 MAX=MAX0(MAX,JLEVEL(I)) GO TO 9000 C C>>SG --------- CODE REWORKED FEB 92 (ANTICIPATING H2-H CALCULATIONS) 2000 ILOFF=3 C MODS FEB 94 TO USE IV() INDEXING FOR ITYPE=2 REQUIRE IVLFL=1 IVLFL=1 ASSIGN 6200 TO IGOTP C IF (NLEVEL.GT.0) GO TO 2100 C -------- GET 'VIBRATIONAL LEVELS' FROM SPECIAL SUBROUTINE ------- WRITE(6,697) 697 FORMAT('0 IOSBIN (FEB 92). NLEVEL.LT.0. AN APPROPRIATE', 1 ' SUBROUTINE MUST BE PROVIDED:'/ 2 35X,'GET102(MXJL,NLEVEL,JLEVEL,ELEVEL)'/) CALL GET102(MXJL,NLEVEL,JLEVEL,ELEVEL) NVC=NLEVEL MAX=0 DO 2190 I=1,NVC EV(I)=ELEVEL(I) LEVV(I)=JLEVEL(2*I) 2190 MAX=MAX0(MAX,JLEVEL(2*I-1)) C SKIP '2009' PRINT OUT OF LEVEL INFO/ DO IT IN GET102 IF DESIRED GO TO 9000 C C ----- GET 'VIBRATIONAL LEVELS' FROM JLEVEL ----- C CURRENT CODE DOES NOT ALLOW DUPLICATE VIB LEVELS. 2100 NVC=1 ITOP=2*NLEVEL WRITE(6,602) NLEVEL,(JLEVEL(I),I=1,ITOP) LEVV(1)=JLEVEL(2) MAX=JLEVEL(1) I=2 2102 IF (I.GT.NLEVEL) GO TO 2110 DO 2103 II=1,NVC IF (LEVV(II).NE.JLEVEL(2*I)) GO TO 2103 WRITE(6,693) I,JLEVEL(2*I-1),JLEVEL(2*I) 693 FORMAT(' IOSBIN (FEB 92). LEVEL',I4,' V,J =',2I4,' DUPLICATES' 1 ,' AN EARLIER VIB LEVEL.'/ 2 20X,'VIBRATIONAL VALUE IGNORED, HIGHER J-VALUE KEPT.') JXX=MAX0(JLEVEL(2*II-1),JLEVEL(2*I-1)) JLEVEL(2*II-1)=JXX MAX=MAX0(MAX,JXX) IF (I.LT.NLEVEL) GO TO 2120 C I.EQ.NLEVEL ==> REDUCE NLEVEL AND GET OUT NLEVEL=NLEVEL-1 GO TO 2110 C PULL DOWN LIST/ DECREASE NLEVEL/ GO BACK FOR NEW I-TH LEVEL 2120 DO 2121 J=I+1,NLEVEL ELEVEL(J-1)=ELEVEL(J) JLEVEL(2*J-3)=JLEVEL(2*J-1) 2121 JLEVEL(2*J-2)=JLEVEL(2*J) NLEVEL=NLEVEL-1 GO TO 2102 2103 CONTINUE C DUPLICATE VIB LEVEL NOT FOUND/ ADD THIS VIBRATIONAL LEVEL IF (NVC.LT.NVCMX) GO TO 2104 WRITE(6,694) NVCMX 694 FORMAT('0 ISOBIN -- ERROR. VIBRATIONAL LEVELS IN NLEVEL/JLEVEL' 1 ,' EXCEED NVCMX =',I4) STOP 2104 NVC=NVC+1 LEVV(NVC)=JLEVEL(2*I) MAX=MAX0(MAX,JLEVEL(2*I-1)) I=I+1 GO TO 2102 C 2110 WRITE(6,692) NVC 692 FORMAT('0 IOSBIN (FEB 92). NUMBER OF VIB. CHANNELS (NVC) =',I4) C C ----- GET ENERGY LEVELS ----- DO 2111 I=1,NVC IF (ELEVEL(I).EQ.0.) GO TO 2111 C IF ELEVEL() VALUES ARE SET (NON-ZERO), USE THEM GO TO 2290 2111 CONTINUE C IF WE REACH HERE, ALL ELEVEL ARE ZERO. C IF THERE IS ONLY ONE LEVEL, AND ENERGY()=0, WE ARE STILL OKEY IF (NVC.GT.1) GO TO 2280 C SET EV() FROM ELEVEL() AND WE ARE DONE. 2290 WRITE(6,691) 691 FORMAT('0 IOSBIN (FEB 92). VIBRATIONAL ENERGIES ', 1 'TAKEN FROM ELEVEL INPUT.') DO 2291 I=1,NVC 2291 EV(I)=ELEVEL(I) GO TO 2009 C OTHERWISE, SEE IF WE CAN CALCULATE ENERGIES FROM WE, WEXE 2280 IF (WE(1).GT.0.D0) GO TO 2200 WRITE(6,696) NVC,WE(1) 696 FORMAT('0 IOSBIN (FEB 92) CANNOT GET ENERGIES FROM ELEVEL ', & 'OR WE. NVC, WE =',I6,D14.4) STOP 2200 WRITE(6,603) WE(1) 603 FORMAT('0 TARGET ENERGY LEVELS (TAKING V = 0 AS ZERO ENERGY)', 1 ' COMPUTED FROM WE =',F10.4) IF (WEXE(1).NE.0.D0) WRITE(6,604) WEXE(1) 604 FORMAT(67X,'CORRECTED FOR WEXE =',F10.6) DO 2201 I=1,NVC FV=LEVV(I) EV(I)=WE(1)*FV-WEXE(1)*FV*(FV+1.D0) C STORE BACK IN JLEVEL,ELEVEL FOR ISAVEU OUTPUT PURPOSES. C>>SG JLEVEL(I)=LEVV(I) -->> THIS WAS USED FOR ISAVEU CAPABILITY IN C>>SG -->> IOSDRV AND WILL NO LONGER WORK THERE C ELEVEL() IS NEEDED IN IOSB2 TO GET EINT, ETC. 2201 ELEVEL(I)=EV(I) NLEVEL=NVC C ------ OUTPUT LEVV, EV ------ 2009 DO 2019 I=1,NVC 2019 WRITE(6,613) I,LEVV(I),EV(I) 613 FORMAT(' LEVEL',I4,' LEVV =',I4,' EV =',F12.4) GO TO 9000 C<>SG ----- ITYPE=3 CODE ADDED 5/6/92 (SG) 3000 ILOFF=3 ASSIGN 6300 TO IGOTP NVC=1 LEVV(1)=0 EV(1)=0. IF (NLEVEL.GT.0) GO TO 3901 WRITE(6,632) JMIN,JMAX,JSTEP,J2MIN,J2MAX,J2STEP 632 FORMAT('0 ROTATIONAL LEVELS FROM JMIN JMAX JSTEP'/ 1 ' ROTOR 1 -- ',3I5/' ROTOR 2 -- ',3I5) GO TO 3903 3901 ITOP=2*NLEVEL WRITE(6,633) NLEVEL,(JLEVEL(I),I=1,ITOP) 633 FORMAT('0 ROTATIONAL LEVELS FROM NLEVEL =',I4,' -- JLEVEL ='/ 1 (25I4)) DO 3902 I=1,NLEVEL JMIN=MIN0(JMIN,JLEVEL(2*I-1)) JMAX=MAX0(JMAX,JLEVEL(2*I-1)) J2MIN=MIN0(J2MIN,JLEVEL(2*I)) 3902 J2MAX=MAX0(J2MAX,JLEVEL(2*I)) 3903 MAX=MAX0(JMAX,J2MAX) IF (IDENT.GT.0) WRITE(6,634) IDENT 634 FORMAT('0 IDENTICAL PARTICLES SPECIFIED BY IDENT =',I3) GO TO 9000 C<>SG IN CASE ONLY LAMBDA=0 TERMS APPEAR IN THE POTENTIAL (E.G., IN C A BREATHING SPHERE TYPE VIBRATIONAL CALC) THE CODE BELOW WILL C (ERRONEOUSLY) SET LVRTP=.TRUE. HOWEVER, SINCE THE POTENTIAL C IS THEN SPHERICALLY SYMMETRIC, THIS OUGHT TO STILL WORK. ONE C MIGHT, WORRY, HOWEVER, ABOUT IHOMO SETTING, AND DOUBLE CHECK C BEFORE RUNNING SUCH A CASE C<>SG 5/11/92 C>>SG 5/11/92 N.B. THIS SHOULD BE REDONE TO TAKE ADVANTAGE OF NEW GAUSSP C>>SG 5/11/92 3500 IF (.NOT.LVRTP) GO TO 3540 IHOMO=1 IF (IH0.EQ.0) GO TO 3543 IHOMO=IH0 GO TO 3543 C ABOVE ALLOWS SETTING IN VRTP ROUTINE/ BELOW CHECKS INPUT L,M SYMS. 3540 IHOMO=2 DO 3542 L=1,MXLAM IF (ODD(LAM(2*L),LAM(2*L-1))) IHOMO=1 3542 CONTINUE 3543 THLO=-1.D0 THHI=1.D0 SFACT=1.D0 IF (IHOMO.EQ.1) GO TO 3541 WRITE(6,618) 618 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ', & 'THAT POTENTIAL IS SYMMETRIC ABOUT THETA=PI/2'/' * * * NOTE.') THLO=0.D0 SFACT=2.D0 C NEXT GET ICNSYM (OLD CODE SHOULD ALWAYS STILL WORK OKEY) 3541 LMBDMX=MXXXXL MUMX=0 DO 3501 L=1,MXLAM 3501 MUMX=MAX0(MUMX,IABS(LAM(2*L))) C FIND ICNSYM WHICH IS PHI EQUIVALENT OF IHOMO IF (MUMX.GT.1) GO TO 3502 C ALLOW SETTING OF ICNSYM FOR 'MXSYM=0' (UNEXPANDED POTL) CASE ICNSYM=1 IF (.NOT.LVRTP .OR. IC0.EQ.0) GO TO 3503 ICNSYM=IC0 WRITE(6,654) ICNSYM 654 FORMAT('0 * * * NOTE. ICNSYM TAKEN FROM VRTP ROUTINE =',I4) GO TO 3503 3502 ICNSYM=MUMX 3506 DO 3504 L=1,MXLAM M=IABS(LAM(2*L)) IF (M-(M/ICNSYM)*ICNSYM .NE. 0) GO TO 3505 3504 CONTINUE GO TO 3503 3505 ICNSYM=ICNSYM-1 IF (ICNSYM.GT.1) GO TO 3506 3503 PHILO=0.D0 PHIHI=PI/DBLE(ICNSYM) SFACT=SFACT*DBLE(ICNSYM)*2.D0 C N.B. WE USE HERE FACT THAT POTENTIAL IS EVEN IN PHI SO INTEGRAL C IS TWICE THAT FROM 0 TO PI. THIS IS REFLECTED IN HAVING ONLY C COS (M*PHI) AND NOT SIN (M*PHI) IN PWGHT, ETC. IF (ICNSYM.GT.1) WRITE(6,658) ICNSYM 658 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF',I4 & ,'-FOLD SYMMETRY ABOUT Z-AXIS.'/' * * * NOTE.') C DETERMINE NO. OF LAMBDA, MU SYMMETRIES (MXXXXL) MXXXXL=0 DO 3507 L=IZ,LMBDMX MTOP=MIN0(MUMX,L) DO 3507 M=IZ,MTOP,ICNSYM IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 3507 MXXXXL=MXXXXL+1 3507 CONTINUE C DETERMINE NO. OF GAUSSPOINTS FOR THETH(NGL) AND PHI (NGM) C ** N.B. SOME MANEUVERING IS NECESSARY SINCE GAUSSP MAY REDUCE NPT. WRITE(6,645) IPHIFL 645 FORMAT('0 * * * NOTE. IPHIFL (PHI INTEGRATION FLAG) =',I4) IPASS=0 IF (IOSNGP(1).GT.0) GO TO 3510 NGL=2*(MAX+LMBDMX) WRITE(6,656) NGL,MAX,LMBDMX 656 FORMAT('0 * * * NOTE. INPUT IOSNGP(1) .LE. 0 (DEFAULT). ', & 'NGL =',I4,' COMPUTED FROM MAX, LMBDMX =',2I4) GO TO 3531 3510 NGL=IOSNGP(1) WRITE(6,655) NGL,IOSNGP(1) 655 FORMAT('0 * * * NOTE. NGL =',I4,' TAKEN FROM', & ' &BASIS IOSNGP(1) =',I4) 3531 IF (IOSNGP(2).GT.0) GO TO 3532 NGM=MAX0(1,2*(MUMX+MXK)) WRITE(6,647) NGM,MXK,MUMX 647 FORMAT('0 * * * NOTE. INPUT IOSNGP(2) .LE. 0 (DEFAULT). NGM =', & I4, ' COMPUTED FROM MXK, MUMX =',2I4) GO TO 3511 3532 WRITE(6,646) IOSNGP(2) 646 FORMAT('0 * * * NOTE. NGM SET FROM &BASIS IOSNGP(2) =',I4) NGM=MAX0(1,IOSNGP(2)) 3511 CALL GAUSSP(THLO,THHI,NGL,COSA,GWT) IF (MUMX.GT.0 .OR. IPASS.GT.0 .OR.LVRTP) GO TO 3512 NGM=1 WRITE(6,650) 650 FORMAT('0 * * * NOTE.'/' * * * NOTE. POTENTIAL HAS NO PHI ', & 'DEPENDENCE. INTEGRAL DONE ANALYTICALLY.') 3512 IF (IPHIFL.NE.0) &CALL GAUSSP(PHILO,PHIHI,NGM,COSA,GWT) NGPT=NGM+NGL IF (NGPT.LE.MXGPT) GO TO 3513 WRITE(6,607) NGPT,MXGPT NGL=(DBLE(MXGPT)/DBLE(NGPT))*NGL NGM=(DBLE(MXGPT)/DBLE(NGPT))*NGM NGM=MAX0(NGM,1) IPASS=1 GO TO 3511 3513 CALL GAUSSP(THLO,THHI,NGL,COSA,GWT) WRITE(6,609) NGL,(COSA(I),GWT(I),I=1,NGL) IF (IPHIFL.EQ.0) GO TO 3515 CALL GAUSSP(PHILO,PHIHI,NGM,COSA(NGL+1),GWT(NGL+1)) WRITE(6,644) NGM,(COSA(NGL+I),GWT(NGL+I),I=1,NGM) 644 FORMAT('0 PHI INTEGRATION DONE BY ',I3,'-POINT GAUSSIAN ', & 'QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6))) GO TO 3516 3515 IX=NGL FACTL=(PHIHI-PHILO)/DBLE(NGM) TH=-FACTL/2.D0 DO 3514 I=1,NGM IX=IX+1 TH=TH+FACTL GWT(IX)=FACTL 3514 COSA(IX)=TH WRITE(6,651) NGM,(COSA(NGL+I),GWT(NGL+I),I=1,NGM) 651 FORMAT('0 PHI INTEGRATION DONE BY ',I3,'-POINT GAUSS-MEHLER ', & 'CHEBYSCHEV) QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6))) 3516 WRITE(6,653) SFACT 653 FORMAT('0 ABOVE WEIGHTS MULTIPLIED BY SYMMETRY FACTOR =',D16.8) NGPT=NGL*NGM C NEXT CHOOSE LMAX (LMMAX,MUMAX) IF (LMAX.LE.0) GO TO 3520 WRITE(6,610) LMAX LMMAX=LMAX GO TO 3523 3520 LMMAX=MIN0(NGL*IHOMO,2*MAX) WRITE(6,612) LMMAX C INPUT CAPABILITY ON MMAX ADDED IN VERSION 6. 3523 IF (MMAX.LE.0) GO TO 3525 MUMAX=MMAX WRITE(6,630) MMAX 630 FORMAT('0 MMAX TAKEN FROM &INPUT MMAX =',I5) GO TO 3524 3525 MUMAX=MIN0(NGM*ICNSYM,2*MXK,LMMAX) WRITE(6,631) MUMAX 631 FORMAT('0 * * * WARNING. MMAX=0 (DEFAULT). WILL USE HIGHEST', & ' VALUE CONSISTENT WITH IOSNGP(2), MMAX =',I4) C RESET LMAX TO REFLECT *NUMBER* OF LAMBDA,MU VALUES. C AND COUNT NQL (NUMBER OF QLT VALUES) 3524 LMAX=0 NQL=0 DO 3521 L=IZ,LMMAX MTOP=MIN0(MUMAX,L) DO 3521 M=IZ,MTOP,ICNSYM IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 3521 LMAX=LMAX+1 DO 3522 I=IZ,M,ICNSYM IF (IHOMO.EQ.2 .AND. ODD(L,I)) GO TO 3522 IX=2 IF (I.EQ.M) IX=1 NQL=NQL+IX 3522 CONTINUE 3521 CONTINUE NIXQL=3 RETURN C C ITYPE=3 CODE ADDED 5/6/92 (SG) C GET POTENL SYMS. (ITYPE=3 USES IHOMO,ICNSYM FOR IHOMO1,IHOMO2) 3330 L1MAX=0 L2MAX=0 LLMAX=0 IL=0 DO 3331 I=1,MXLAM L1MAX=MAX0(L1MAX,LAM(IL+1)) L2MAX=MAX0(L2MAX,LAM(IL+2)) LLMAX=MAX0(LLMAX,LAM(IL+3)) 3331 IL=IL+ILOFF MXXXXL=MAX0(MXXXXL,L1MAX,L2MAX,LLMAX) LVRTP=MXXXXL.LE.0 IF (.NOT.LVRTP) GO TO 3332 C ?? MXXXXL=1 THIS WILL BE TAKEN CARE OF IN 3336 LOOP IHOMO=1 ICNSYM=1 IF (IH0.EQ.0) GO TO 3333 IHOMO=IH0 WRITE(6,637) IHOMO 637 FORMAT('0 * * * NOTE. IHOMO (MOL 1) TAKEN FROM VRTP ROUTINE =',I4) 3333 IF (IC0.EQ.0) GO TO 3334 ICNSYM=IC0 WRITE(6,638) ICNSYM 638 FORMAT('0 * * * NOTE. IHOMO (MOL 2) TAKEN FROM VRTP ROUTINE =',I4) GO TO 3334 C FOR EXPANDED POTENTIAL (.NOT.LVRTP) GET IHOMO1,IHOMO2 FROM LAM 3332 IHOMO=2 ICNSYM=2 DO 3335 I=1,MXLAM IF (ODD(LAM(3*I-2),0)) IHOMO=1 3335 IF (ODD(LAM(3*I-1),0)) ICNSYM=1 3334 IM=1 IF (IHOMO.EQ.2) WRITE(6,639) IM 639 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ', & 'THAT POTENTIAL IS SYMMETRIC ABOUT PI/2 FOR MOLECULE',I3) IM=2 IF (ICNSYM.EQ.2) WRITE(6,639) IM C>>SG (5/18/92) STORE IHOMO,ICNSYM BACK IN IH0,IC0 FOR USE IN IOSOUT IH0=IHOMO IC0=ICNSYM C COUNT L1,L2,LL SYMMETRIES (MXXXXL) C FOR IDENT PARTICLES, L1,L2<->L2,L1 MUST BOTH BE IN POTL SYMS MXXXXL=0 DO 3336 L1=IZ,L1MAX,IHOMO L2TOP=L2MAX IF (IDENT.GT.0) L2TOP=L1MAX DO 3336 L2=IZ,L2TOP,ICNSYM LLO=ABS(L1-L2) LHI=L1+L2 DO 3336 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 3336 MXXXXL=MXXXXL+1 3336 CONTINUE C SET INTEGRATION LIMITS AND GET GAUSS POINTS C CURRENT GAUSSP (5/6/92) DOES *ARBITRARY* NO PTS; C IF REQUEST EXCEEDS DIMENSIONS (MXGPT) TERMINATE. SFACT=1.D0 IF (IOSNGP(1)*IOSNGP(2)*IOSNGP(3).GT.0 .AND. 1 IOSNGP(1)+IOSNGP(2)+IOSNGP(3).LE.MXGPT) GO TO 3337 WRITE(6,636) IOSNGP,MXGPT 636 FORMAT('0 IOSBGP. ERROR. IOSNGP INPUT, ',3I5,' ILLEGAL OR ', 1 'EXCEEDS STORAGE (MXGPT) =',I5) STOP 3337 NGP1=IOSNGP(1) THLO=-1.D0 THHI=1.D0 IF (IHOMO.EQ.2) THEN THLO=0.D0 SFACT=SFACT*2.D0 ENDIF CALL GAUSSP(THLO,THHI,NGP1,COSA(1),GWT(1)) WRITE(6,609) NGP1,(COSA(I),GWT(I),I=1,NGP1) NGP2=IOSNGP(2) IST2=NGP1 THLO=-1.D0 IF (ICNSYM.EQ.2) THEN THLO=0.D0 SFACT=SFACT*2.D0 ENDIF CALL GAUSSP(THLO,THHI,NGP2,COSA(IST2+1),GWT(IST2+1)) WRITE(6,609) NGP2,(COSA(IST2+I),GWT(IST2+I),I=1,NGP2) WRITE(6,645) IPHIFL PHILO=0.D0 C CAN ALWAYS USE SYMMETRY V(-PHI)=V(PHI) TO REDUCE INTEGRAL C FROM (0,2*PI) TO (0,PI) -- CORRECT SFACT ACCORDINGLY PHIHI=PI SFACT=SFACT*2.D0 IST3=IST2+NGP2 NGM=IOSNGP(3) IF (IPHIFL.EQ.0) GO TO 3338 CALL GAUSSP(PHILO,PHIHI,NGM,COSA(IST3+1),GWT(IST3+1)) WRITE(6,644) NGM,(COSA(IST3+I),GWT(IST3+I),I=1,NGM) GO TO 3339 3338 IX=IST3 FACTL=(PHIHI-PHILO)/DBLE(NGM) TH=-FACTL/2.D0 DO 3342 I=1,NGM IX=IX+1 TH=TH+FACTL GWT(IX)=FACTL 3342 COSA(IX)=TH WRITE(6,651) NGM,(COSA(IST3+I),GWT(IST3+I),I=1,NGM) C SET NGPT AS PRODUCT OF THETA-1, THETA-2, PHI GRIDS 3339 NGPT=NGP1*NGP2*NGM WRITE(6,653) SFACT C RESET LMAX AND NQL=LMAX TO REFLECT NUMBER OF L1,L2,LL VALUES C USE ITYP=5,6 VARIABLES: LMMAX FOR L1, MUMAX FOR L2 IF (LMAX.GT.0) GO TO 3340 LMMAX=(NGP1-1)*IHOMO WRITE(6,640) LMAX,LMMAX,NGP1,IHOMO 640 FORMAT('0 &INPUT LMAX =',I4,' -- L1MAX =',I4,' CALCULATED FROM ', 1 ' NGP1 AND (SYMMETRY) IHOMO =',2I4) GO TO 3344 3340 LMMAX=LMAX WRITE(6,641) LMAX 641 FORMAT(' L1MAX TAKEN FROM &INPUT LMAX =',I4) 3344 IF (MMAX.GT.0) GO TO 3343 MUMAX=(NGP2-1)*ICNSYM WRITE(6,642) MMAX,MUMAX,NGP2,ICNSYM 642 FORMAT('0 &INPUT MMAX =',I4,' -- L2MAX =',I4,' CALCULATED FROM ', 1 ' NGP2 AND (SYMMETRY) ICNSYM=',2I4) GO TO 3345 3343 MUMAX=MMAX WRITE(6,643) MMAX 643 FORMAT(' L2MAX TAKEN FROM &INPUT MMAX =',I4) 3345 LMAX=0 DO 3341 L1=IZ,LMMAX,IHOMO L2TOP=MUMAX C IDENTICAL PARTICLES KEEP ONLY L1.GE.L2 IN LM(,) IF (IDENT.GT.0) L2TOP=L1 DO 3341 L2=IZ,L2TOP,ICNSYM LLO=ABS(L1-L2) LHI=L1+L2 DO 3341 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 3341 LMAX=LMAX+1 3341 CONTINUE NQL=LMAX NIXQL=2 RETURN C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY IOSB1(PWGHT,VLI,IXQL,LM,NGPT,LMAX,MXXXXL,NIXQL,NQL) C IF (ITYP.EQ.3) GO TO 4300 IF (ITYP.EQ.5 .OR. ITYP.EQ.6) GO TO 4500 C C N.B. FOR ITYPE=1,2 LMAX=NQL C PWGHT MULTIPLY SL(COS(THETA)) TO GET LEGENDRE COEFFICIENTS FACTL=-.5D0 DO 4100 L=1,LMAX IXQL(1,L)=L IXQL(2,L)=0 LM1=L-1 LM(1,L)=LM1 FACTL=FACTL+1.D0 DO 4101 NX=1,NGPT C N.B. WE KEEP EVEN AND ODD L FOR HOMONUCLEARS, BUT SET TO 0. IF NEC PWGHT(NX,L)=0.D0 IF (IHOMO.EQ.2 .AND. L-2*(L/2).EQ.0) GO TO 4101 PWGHT(NX,L)=FACTL*GWT(NX)*XLEG(L-1,COSA(NX)) 4101 CONTINUE 4100 CONTINUE C NEXT COMPUTE VLI DO 4200 NX=1,NGPT L=0 DO 4201 IL=1,MXXXXL VLI(NX,IL)=XLEG(L,COSA(NX)) 4201 L=L+IHOMO 4200 CONTINUE RETURN C C ITYPE=3 -- SETUP VLI 4300 I=0 IF (LNEW) GO TO 4993 C>>SG 5/21/92 BELOW IS OLD CODE - BYPASSED FOR LNEW=.TRUE. DO 4301 IX1=1,NGP1 DO 4301 IX2=1,NGP2 DO 4301 IX3=1,NGM C I COUNTS GAUSS POINTS TO NGPT. I=I+1 IL=0 DO 4301 L1=IZ,L1MAX,IHOMO L2TOP=L2MAX IF (IDENT.GT.0) L2TOP=L1MAX DO 4301 L2=IZ,L2TOP,ICNSYM LLO=ABS(L1-L2) LHI=L1+L2 DO 4301 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 4301 C IL COUNTS SYMMETRIES IN POTENTIAL TO L1MAX,L2MAX IL=IL+1 VLI(I,IL)=YRR(L1,L2,LL,COSA(IX1),COSA(IST2+IX2),COSA(IST3+IX3)) 4301 CONTINUE PIFACT=2.D0*PI*SFACT IL=0 DO 4302 L1=IZ,LMMAX,IHOMO L2TOP=MUMAX IF (IDENT.GT.0) L2TOP=L1 DO 4302 L2=IZ,L2TOP,ICNSYM LLO=ABS(L1-L2) LHI=L1+L2 DO 4302 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 4302 XLFACT=1.D0/(2.D0*LL+1.D0) IL=IL+1 IXQL(1,IL)=IL IXQL(2,IL)=0 LM(1,IL)=L1 LM(2,IL)=L2 LM(3,IL)=LL I=0 DO 4303 IX1=1,NGP1 DO 4303 IX2=1,NGP2 DO 4303 IX3=1,NGM I=I+1 4303 PWGHT(I,IL)=GWT(IX1)*GWT(IST2+IX2)*GWT(IST3+IX3)* 1 YRR(L1,L2,LL,COSA(IX1),COSA(IST2+IX2),COSA(IST3+IX3)) 2 *PIFACT*XLFACT 4302 CONTINUE GO TO 4998 C>>SG 5/21/92 ------- END OF OLD CODE C C NEW CODE 5/21/92 MUCH MORE EFFICIENT. YRR() ASSEMBLED AS NEEDED C AVOIDING RECALCULATION OF THRJ, PLM, ETC. 4993 DEN=SQRT(4.D0*PI)*2.D0*PI DO 4310 IL=1,MXXXXL DO 4310 IX=1,NGPT 4310 VLI(IX,IL)=0.D0 MTOP=MIN0(L1MAX,L2MAX) DO 4311 M=IZ,MTOP PTM=PARITY(M) XM=M DO 4312 IX=1,NGM COSM(IX)=COS(XM*COSA(IST3+IX))/DEN IF (M.EQ.0) GO TO 4312 COSM(IX)=COSM(IX)*(2.D0*PTM) 4312 CONTINUE IL=0 DO 4313 L1=IZ,L1MAX,IHOMO IF (L1.LT.M) GO TO 4317 XL1=L1 PTL1=PARITY(L1) DO 4314 IX=1,NGP1 4314 PL1(IX)=PLM(L1,M,COSA(IX))*PTL1 4317 L2TOP=L2MAX IF (IDENT.NE.0) L2TOP=L1MAX DO 4313 L2=IZ,L2TOP,ICNSYM IF (L2.LT.M) GO TO 4318 XL2=L2 PTL2=PARITY(L2) DO 4315 IX=1,NGP2 4315 PL2(IX)=PLM(L2,M,COSA(IST2+IX))*PTL2 4318 LLO=ABS(L1-L2) LHI=L1+L2 DO 4313 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 4313 IL=IL+1 IF (L1.LT.M .OR. L2.LT.M) GO TO 4313 XL=LL TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*(2.D0*XL+1.D0) I=0 DO 4316 IX1=1,NGP1 DO 4316 IX2=1,NGP2 DO 4316 IX3=1,NGM I=I+1 4316 VLI(I,IL)=VLI(I,IL)+PL1(IX1)*PL2(IX2)*COSM(IX3)*TJ 4313 CONTINUE 4311 CONTINUE C C NOW SET UP IXQL, LM, AND PWGHT C N.B. PIFACT IS CONSISTENT WITH AGG & CLARY, EQS. (19)-(20) C AND W/ GOLDFLAM & KOURI, EQS. (68), (69), (89), (121). C I.E. T(ANGLES)=(4*PI)*SUM(L1,L2,L) T(L1,L2,L)*YRR(L1,L2,L/ANGLES) C NEW CODE 5/21/92 MUCH MORE EFFICIENT; CALC YRR() LOCALLY PIFACT=2.D0*PI*SFACT DO 4320 IL=1,LMAX DO 4320 IX=1,NGPT 4320 PWGHT(IX,IL)=0.D0 MTOP=MIN0(LMMAX,MUMAX) IF (IDENT.GT.0) MTOP=LMMAX DO 4321 M=0,MTOP PTM=PARITY(M) XM=M DO 4322 IX=1,NGM COSM(IX)=COS(XM*COSA(IST3+IX))/DEN IF (M.EQ.0) GO TO 4322 COSM(IX)=COSM(IX)*(2.D0*PTM) 4322 CONTINUE IL=0 DO 4323 L1=IZ,LMMAX,IHOMO IF (L1.LT.M) GO TO 4324 XL1=L1 PTL1=PARITY(L1) DO 4325 IX=1,NGP1 4325 PL1(IX)=PLM(L1,M,COSA(IX))*PTL1 4324 L2TOP=MUMAX IF (IDENT.GT.0) L2TOP=L1 DO 4323 L2=IZ,L2TOP,ICNSYM IF (L2.LT.M) GO TO 4326 XL2=L2 PTL2=PARITY(L2) DO 4327 IX=1,NGP2 4327 PL2(IX)=PLM(L2,M,COSA(IST2+IX))*PTL2 4326 LLO=ABS(L1-L2) LHI=L1+L2 DO 4323 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 4323 IL=IL+1 C STORE IXQL, LM ONLY FOR M=0 PASS ONLY. IF (M.GT.0) GO TO 4328 IXQL(1,IL)=IL IXQL(2,IL)=0 LM(1,IL)=L1 LM(2,IL)=L2 LM(3,IL)=LL 4328 IF (L1.LT.M .OR. L2.LT.M) GO TO 4323 XL=LL C TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*PIFACT/(2.D0*XL+1.D0) C 2*L+1 FACTOR CANCELS THAT IN DEF OF YRR ??? TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*PIFACT I=0 DO 4329 IX1=1,NGP1 DO 4329 IX2=1,NGP2 DO 4329 IX3=1,NGM I=I+1 4329 PWGHT(I,IL)=PWGHT(I,IL)+PL1(IX1)*PL2(IX2)*COSM(IX3)*TJ 4323 CONTINUE 4321 CONTINUE C END OF M-LOOP - PWGHT NOW CONTAINS YRR; NEED TO MULT BY GAUSS WTS I=0 DO 4330 IX1=1,NGP1 DO 4330 IX2=1,NGP2 DO 4330 IX3=1,NGM I=I+1 WTFACT=GWT(IX1)*GWT(IST2+IX2)*GWT(IST3+IX3) DO 4330 IL=1,LMAX 4330 PWGHT(I,IL)=PWGHT(I,IL)*WTFACT C 4998 WRITE(6,659) (I,LM(1,I),LM(2,I),LM(3,I),I=1,LMAX) 659 FORMAT('0 BI-SPHERICAL HARMONICS FOR EXPANDING S-MATRIX ARE ', 1'AS FOLLOWS'/'0 INDX L1 L2 LL'/(' ',4I4)) RETURN C C ITYPE=5,6 -- COMPUTE VLI 4500 I=0 DO 4501 NX=1,NGL DO 4501 IX=1,NGM I=I+1 IL=0 DO 4501 L=IZ,LMBDMX MTOP=MIN0(MUMX,L) DO 4501 M=IZ,MTOP,ICNSYM IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 4501 IL=IL+1 VLI(I,IL)=PLM(L,M,COSA(NX))/SQRT(2.D0*PI) IF (M.NE.0) VLI(I,IL)=VLI(I,IL)*2.D0*COS(DBLE(M)*COSA(NGL+IX)) 4501 CONTINUE C SETUP PWGHT FACTL=1.D0/SQRT(2.D0*PI) IL=0 DO 4502 L=IZ,LMMAX MTOP=MIN0(L,MUMAX) DO 4502 M=IZ,MTOP,ICNSYM IF (IHOMO.EQ.2 .AND.ODD(L,M)) GO TO 4502 IL=IL+1 IV=0 DO 4503 IX=1,NGL DO 4503 NX=1,NGM IV=IV+1 4503 PWGHT(IV,IL)=GWT(IX)*GWT(NGL+NX)*PLM(L,M,COSA(IX))* & COS(DBLE(M)*COSA(NGL+NX))* 2 (SFACT*FACTL) 4502 CONTINUE I=0 IX=0 DO 4505 L=IZ,LMMAX MTOP=MIN0(MUMAX,L) DO 4505 M=IZ,MTOP,ICNSYM IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 4505 I=I+1 LM(1,I)=L LM(2,I)=M DO 4504 IL=1,I IF (LM(1,IL).NE.L) GO TO 4504 IX=IX+1 IXQL(1,IX)=I IXQL(2,IX)=IL IF (I.NE.IL) GO TO 4506 IXQL(3,IX)=0 GO TO 4504 4506 IXQL(3,IX)=1 IX=IX+1 IXQL(1,IX)=I IXQL(2,IX)=IL IXQL(3,IX)=2 4504 CONTINUE 4505 CONTINUE WRITE(6,657) (I,LM(1,I),LM(2,I),I=1,LMAX) 657 FORMAT('0 SPHERICAL HARMONIC SYMMETRIES FOR EXPANDING S-MATRIX ', 1 'ARE AS FOLLOWS'/'0 INDX L M'/(' ',2I4,I3)) WRITE(6,649) 649 FORMAT('0 BELOW ARE INDICES TO SYMMETRIES IN QLT'/ &'0 IN QLT LM1 L M LM2 L M CODE') DO 4507 I=1,NQL IL=IXQL(1,I) IX=IXQL(2,I) 4507 WRITE(6,648) I,IL,LM(1,IL),LM(2,IL),IX,LM(1,IX),LM(2,IX),IXQL(3,I) 648 FORMAT(' ',I7,I6,2I3,I6,2I3,I6) RETURN C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY IOSB2(JTOT,LORB,JJJ,NB,CENT,EINT,CINT,WVEC,VL,IVIX,IP, & NVC,ERED,NPOTL,MXLAM,LAM,VLI,NGPT,MXXXXL) C XJ=JTOT XJ=XJ*(XJ+1.D0) DO 6666 I=1,NVC LORB(I)=JTOT JJJ(I)=I NB(I)=I CENT(I)=XJ EINT(I)=CINT*EV(I) DIF=ERED-EINT(I) WVEC(I)=SQRT(ABS(DIF)) IF (DIF.GE.0.D0) GO TO 6666 WVEC(I)=-WVEC(I) 6666 CONTINUE C GO TO IGOTP,(6100,6200,6300,6500) C C CHECK FOR CONSISTENT IVLFL 6100 IF (IVLFL.NE.0) GO TO 9999 DO 6101 I=1,MXLAM IL=LAM(I)/IHOMO + 1 C IVIX(I)=I 6101 VL(I)=VLI(IP,IL) C SET COSANG, FACTOR FOR MXLAM.LE.0 CASE COSANG(1)=COSA(IP) FACTOR=1.D0 GO TO 6900 C C>>SG -------------- NEW CODE --------------------->> C>>SG CHECK FOR NPOTL=1 (LVRTP) OR NPOTL=MXLAM (EXPANDED) C>>SG LATTER CASE UNCHANGED FROM VERSION 10 CODE C>>SG JAN 94: *ALL* ITYPE=2 NOW HAVE IVLFL=1; NPOTL.LE.MXLAM 6200 IF (IVLFL.LE.0) GO TO 9999 C ZERO IVIX,VL STORAGE ITOP=NVC*(NVC+1)*NPOTL/2 DO 6202 IX=1,ITOP IVIX(IX)=0 6202 VL(IX)=0.D0 IF (.NOT.LVRTP ) GO TO 6250 C C UNEXPANDED 'LVRTP' POTENTIAL (BELOW HAS A LOT OF 'DEBUGGING' TEST) IF (NPOTL.NE.1) THEN WRITE(6,670) NPOTL,MXLAM 670 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LVRTP INCONSISTENT WITH', 1 ' NPOTL, MXLAM',2I6) STOP ENDIF DO 6203 L=1,MXLAM LLL=LAM(3*L-2) IL=LLL/IHOMO+1 C N.B. WE SHOULD HAVE LLL=0 AND IL=1 *** DEBUGGING ONLY *** IF (LLL.NE.0 .OR. IL.NE.1) WRITE(6,672) LLL,IL 672 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LLL.NE.0 .OR IL.NE.1',2I6) IV=LAM(3*L-1) IVP=LAM(3*L) IVVP=0 DO 6204 IROW=1,NVC NV=LEVV(IROW) DO 6204 ICOL=1,IROW NVP=LEVV(ICOL) IVVP=IVVP+1 IF (.NOT.((NV.EQ.IV.AND.NVP.EQ.IVP).OR.(NV.EQ.IVP.AND.NVP.EQ.IV))) 1 GO TO 6204 C IF WE REACH BELOW, THIS ROW/COL CORRESPONDS TO CURRENT 'SYMMETRY' IX=(IVVP-1)*NPOTL+LLL+1 C SINCE NPOTL=1 AND LLL=0, SHOULD HAVE IX=IVVP *** DEBUGGING *** IF (IX.NE.IVVP) WRITE(6,673) IX,IVVP 673 FORMAT('0 IOSB2 (FEB 92) -- ERROR. IX.NE.IVVP FOR VL,IVIX',2I6) IVIX(IX)=L VL(IX)=VLI(IP,IL) 6204 CONTINUE 6203 CONTINUE C SET COSANG, FACTOR FOR VRTP CASE, AND RETURN COSANG(1)=COSA(IP) FACTOR=1.D0 GO TO 6900 C C CODE BELOW FOR POTENTIAL EXPANDED IN LEGENDRE POLY'S C MODIFIED TO USE IV() INDEXING C 6250 IF (MXXXXL.GT.NPOTL) THEN WRITE(6,*) ' IOSB2. MXXXXL.GT.NPOTL NOT ALLOWED',MXXXXL,NPOTL STOP ENDIF DO 6251 L=1,MXLAM IL=LAM(3*L-2)/IHOMO + 1 C DEBUGGING ... IF (IL.GT.MXXXXL) THEN WRITE(6,*) ' IOSB2. IL.GT.MXXXXL SHOULD NOT OCCUR',IL,MXXXXL ENDIF LV1=LAM(3*L-1) LV2=LAM(3*L) IVVP=0 DO 6252 IV=1,NVC DO 6252 IVP=1,IV IVVP=IVVP+1 IF (LEVV(IV).EQ.LV1 .AND. LEVV(IVP).EQ.LV2) GO TO 6253 IF (LEVV(IV).EQ.LV2 .AND. LEVV(IVP).EQ.LV1) GO TO 6253 GO TO 6252 6253 IX=(IVVP-1)*NPOTL+IL IVIX(IX)=L VL(IX)=VLI(IP,IL) 6252 CONTINUE 6251 CONTINUE GO TO 6900 C C CHECK FOR CONSISTENT IVLFL 6300 IF (IVLFL.NE.0) GO TO 9999 IL=0 DO 6301 L1=IZ,L1MAX,IHOMO L2TOP=L2MAX IF (IDENT.GT.0) L2TOP=L1MAX DO 6301 L2=IZ,L2TOP,ICNSYM LLO=ABS(L1-L2) LHI=L1+L2 DO 6301 LL=LLO,LHI IF (ODD(L1+L2,LL)) GO TO 6301 IL=IL+1 DO 6302 I=1,MXLAM IF (L1.NE.LAM(3*I-2)) GO TO 6302 IF (L2.NE.LAM(3*I-1)) GO TO 6302 IF (LL.NE.LAM(3*I )) GO TO 6302 C IVIX(I)=I VL(I)=VLI(IP,IL) IF (LDEBUG) WRITE(6,635) I,L1,L2,LL,IL 635 FORMAT(' IOSB2. DEBUG. I,L1,L2,LL,IL',5I5) 6302 CONTINUE 6301 CONTINUE C FOR 'VRTP' CASE NEED TO SET COSANG(), FACTOR =(4*PI)**(3/2) FACTOR=(4.D0*PI)*SQRT(4.D0*PI) C CALCULATE IX1,IX2,IX3 FROM IP (# OF GAUSS POINT) IX3=IP IX1=(IX3-1)/(NGP2*NGM)+1 IX3=IX3-(IX1-1)*(NGP2*NGM) IX2=(IX3-1)/NGM+1 IX3=IX3-(IX2-1)*NGM COSANG(1)=COSA(IX1) COSANG(2)=COSA(IST2+IX2) COSANG(3)=COSA(IST3+IX3) GO TO 6900 C<>SG N.B. ITYPE=3 VALUES DIFFER FROM GOLDFLAM-KOURI AND AGG-CLARY C ITYPE V AVGFCT C 1,2 1. 1. C 3 1/4*PI 1./SQRT(4*PI) C 5,6 1/4*PI 1./SQRT(4*PI) V=1.D0 IF (ITYPE.EQ.5.OR.ITYPE.EQ.6.OR.ITYPE.EQ.3) V=1.D0/(4.D0*PI) AVGFCT=SQRT(V) CINT=RMLMDA/EPSIL C INITIALIZE RSTART, IN CASE IRMSET.LE.0 AND FINDRM NOT CALLED RMINSV=RMIN RSTART=RMIN CALL GCLOCK (TITIME) C C PRINT LEVEL FOR SCATTERING CAN BE LESS THAN FOR IOS1 C IOSPR=MAX0(0,PRINT-10) C C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C LOOP OVER ENERGIES. C DO 2000 IE=1,NNRG ICODE=1 IF(IE.GT.1 .AND. ISCRU.GT.0) ICODE=2 IF(ISCRU.GT.0) REWIND ISCRU WRITE(6,622) IE,ENERGY(IE) 622 FORMAT('1 IOSCLC (MAY 92). ENERGY(',I3,') =',F12.4,' (1/CM).') ERED=ENERGY(IE)*CINT IF (IE.EQ.1) EFIRST=ERED ESHIFT=ERED-EFIRST C A MORE SOPHISTICATED WAY OF SAVING RTURN IS PROBABLY WANTED, C BUT BELOW SHOULD WORK AS A TEMPORARY MEASURE RTURN=RMINSV C ZERO STORAGE DO 2100 I=1,NQL 2100 IEC(I)=0 DO 2109 IV=1,NVC DO 2109 IVP=1,NVC QLS(IV,IVP)=0.D0 SIGAV(IV,IVP)=0.D0 DO 2101 I=1,NQL 2101 QLT(IV,IVP,I)=0.D0 DO 2102 I=1,NGPT 2102 SIGTH(IV,IVP,I)=0.D0 2109 CONTINUE C C LOOP OVER PARTIAL WAVES C DO 3000 JTOT=JTOTL,JTOTU,JSTEP IF (PRINT.GT.1) WRITE(6,626) JTOT,IE,ENERGY(IE) 626 FORMAT('0 ***** PARTIAL WAVE =',I5,' FOR ENERGY(',I3,') = ', & F12.4,' *****') C IF (JTOTU.LT.999999) GO TO 3001 C CHECK FOR CONVERGENCE C ONLY CHECK FOR QLT WHERE IXQL(NIXQL,IL).EQ.0 DO 3002 IL=1,LMAX IF (IXQL(NIXQL,IL).NE.0) GO TO 3002 IF (IEC(IL).LT.NCAC) GO TO 3001 3002 CONTINUE CALL GCLOCK(TJTIME) TIME=TJTIME-TITIME TITIME=TJTIME JTO=JTOT-JSTEP WRITE(6,620) IE,ENERGY(IE),LMAX,NCAC,TEST,JTOTL,JSTEP,JTO 620 FORMAT('1 ***** ***** ***** CALCULATION AT ENERGY(',I3,') =', 1 F10.2,' (1/CM) ', & ' TERMINATED DUE TO CONVERGENCE FOR',I4,' Q(L).'/ & 22X,'NCAC, TEST =',I4,2E12.4/ 2 22X,'PARTIAL WAVES',I4,' (',I4,' ) ',I5) WRITE(6,641) TIME 641 FORMAT('0 ***** ***** ***** TIME WAS',F9.2,' SEC.'/' ') GO TO 3009 3001 FACTL=(2*JTOT+1)*PI C C GET ANGLE-DEPENDENT SCATTERING / LOOP OVER GAUSS POINTS. DO 3100 IP=1,NGPT C C INITIALIZE SCAT VARIABLES VL, LORB, EINT, ETC. CALL IOSB2(JTOT,X(IXLORB),X(IXJJJ),NB,X(IXCENT),X(IXEINT),CINT, 1 WVEC,X(IXVL),X(IXIV),IP,NVC,ERED,NPOTL,MXLAM,LAMBDA,VLI, 2 NGPT,MXXXXL) C CONV=0.D0 RTURN=RSTART IF(ICODE.NE.1) GOTO 3005 CALL FINDRX(ENERGY(IE),X(IXEINT),X(IXCENT),1,NVC,CINT,RMAX,RSTOP, 1 NOPMAX,IRXSET,IOSPR) C IF(IRMSET.LE.0) GOTO 3005 C GET TEMPORARY STORAGE FOR FINDRM; MODIFED 23 AUG FOR NEW FINDRM (SG) IT1=ICX IT2=IT1+MXLAM IT3=IT2+NVC IT4=IT3+NVC IXNEXT=IT4+NVC CALL CHKSTR(NUSED) CALL FINDRM(X(IXSR),NVC,RSTART,RTURN,IK,X(IT1),X(IXVL),X(IXIV), 1 ERED,X(IXEINT),X(IXCENT),RMLMDA,X(IXSI),X(IT2),X(IT3),X(IT4), 2 MXLAM,NPOTL,IRMSET,ITYPE,IOSPR) C RELEASE TEMPORARY STORAGE IXNEXT=IT1 IF(RVFAC.EQ.0.D0) GOTO 3005 RMID=RVFAC*RTURN IF(IOSPR.GE.3) WRITE(6,3003) RMID,RVFAC 3003 FORMAT('0 RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3) C C NOW READY TO SOLVE 'COUPLED' EQUATIONS; DONE AS CALL TO STORAG. C 3005 NV=NPOTL*NVC*(NVC+1)/2 CALL STORAG( INTFLG,NVC,MXLAM,NV,NPOTL, 1 IXJJJ,IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT, 2 IXWV,IXLORB,IXNB, 3 ESHIFT,NOPMAX,DEEP,IK,ICODE,IOSPR, NUMDER) C C INITIALIZE TO UNIT S-MATRIX TO CLEAR 'NON-CLASSICAL' CHANNELS. C 4000 DO 4005 IV=1,NVC DO 4005 IVC=1,NVC DELVVP=0.D0 IF (IV.EQ.IVC) DELVVP=1.D0 SLR(IV,IVC,IP)=DELVVP 4005 SLI(IV,IVC,IP)=0.D0 IF (NOPEN.GT.0) GO TO 4009 WRITE(6,699) IP,NOPEN 699 FORMAT(' * * * NOTE. FOR ORIENTATION',I6,' NOPEN =',I3) GO TO 3100 4009 IF (NOPEN.LE.NVC) GO TO 4008 WRITE(6,698) IP,NOPEN,NVC 698 FORMAT(' * * * ERROR. FOR ORIENTATION',I6,' NOPEN.GT.NVC',2I6) GO TO 3100 4008 IF (CONV.GE.0.D0) GO TO 4007 WRITE(6,696) JTOT,IP 696 FORMAT('0 * * * WARNING. SLR,SLI,SIGTH NOT SET DUE TO LACK OF CON &VERGENCE FOR PART. WAVE',I4,' ORIENTATION',I5) GO TO 3100 C 4007 IF (PRINT.GE.15) WRITE(6,601) 601 FORMAT(' ') NNP=0 DO 4200 N=1,NOPEN IV=NB(N) WV=RM/WVEC(IV) C SET WVEC(IV) TO WAVENUMBER IN 1/ANGSTROMS FOR ISAVEU OUTPUT WVEC(IV)=1.D0/WV WV=WV*WV*FACTL DO 4200 NP=1,NOPEN IVP=NB(NP) NNP=NNP+1 DELVVP=0.D0 IF (IV.EQ.IVP) DELVVP=1.D0 C BELOW CHANGED APR 86 SINCE ONLY INDICES FOR SREAL,SIMAG ARE HERE SLR(IV,IVP,IP)=X(IXSR-1+NNP) SLI(IV,IVP,IP)=X(IXSI-1+NNP) C ACCUMULATE ANGLE-DEPENDENT TOTAL CROSS SECTION. ADD=DELVVP-SLR(IV,IVP,IP) ADD=(ADD*ADD+SLI(IV,IVP,IP)*SLI(IV,IVP,IP) )*WV SIGTH(IV,IVP,IP)=SIGTH(IV,IVP,IP)+ADD IF (PRINT.LT.15) GO TO 4200 WRITE(6,627) IP,IV,IVP,SLR(IV,IVP,IP),SLI(IV,IVP,IP), & ADD,SIGTH(IV,IVP,IP) 627 FORMAT(' FOR ORIENTATION',I6,' VIB LEVEL =',I2,' TO',I2, & ', SREAL, SIMAG =',2D14.6,' SIGTH ADD',D12.4,' = ',D12.4) 4200 CONTINUE 3100 CONTINUE C END OF LOOP OVER ORIENTATIONS C C INTEGRATE OVER ORIENTATIONS TO GET SLLR/SLLI C ** N.B. THESE ARE T-MATRIX COMPONENTS ** IF (PRINT.GE.20) WRITE(6,601) DO 3218 IV=1,NVC DO 3218 IVP=1,NVC DELVVP=0.D0 IF (IV.EQ.IVP) DELVVP=1.D0 DO 3218 L=1,LMAX SLLI(IV,IVP,L)=0.D0 SLLR(IV,IVP,L)=0.D0 DO 3208 NX=1,NGPT SLLR(IV,IVP,L)=SLLR(IV,IVP,L)+(DELVVP-SLR(IV,IVP,NX))*PWGHT(NX,L) 3208 SLLI(IV,IVP,L)=SLLI(IV,IVP,L)-SLI(IV,IVP,NX)*PWGHT(NX,L) IF (PRINT.GE.20) & WRITE(6,648) IV,IVP,L,SLLR(IV,IVP,L),SLLI(IV,IVP,L) 648 FORMAT(5X,3I5, 2D16.8) 3218 CONTINUE C C *** C>>SG MAY 92. CODE BELOW REPLACED BY CALL ISUTP AT STATEMENT NO. 3000 C SAVE SLLR/SLLI HRE / N.B. SLR/SLI MIGHT BE USEFUL LATER. C IF (ISU.LE.0) GO TO 3230 C WRITE(ISU,3231) JTOT,IE,ENERGY(IE) C3231 FORMAT(2I4,E16.8) C WRITE(ISU,3232) NOPEN,(NB(I),JTOT,WVEC(NB(I)),I=1,NOPEN) C3232 FORMAT(I4/(2I4,E16.8)) C WRITE(ISU,3233) (((SLLR(NB(IV),NB(IVP),L),IV=1,NOPEN),IVP=1,NOPEN) C & ,L=1,LMAX) C WRITE(ISU,3233) (((SLLI(NB(IV),NB(IVP),L),IV=1,NOPEN),IVP=1,NOPEN) C & ,L=1,LMAX) C3233 FORMAT(5E16.8) C *** C C COMPUTE QLS (QLOLD PREVIOUSLY) FOR 1ST (TOTALLY SYMMETRIC) CASE 3230 IF (PRINT.GE.10) WRITE(6,601) DO 3220 IV=1,NVC C SET WVEC(IV) TO (2*L+1)*PI/K**2 FOR USE IN GETTING QL'S C>>SG TRAP CLOSED CHANNELS (NEGATIVE WVEC) TO PREVENT ROUND-OFF PROBLEMS IF (WVEC(IV).LE.0.) GO TO 3220 WVEC(IV)=FACTL/(WVEC(IV)*WVEC(IV)) DO 3219 IVP=1,NVC DELVVP=0.D0 IF (IV.EQ.IVP) DELVVP=1.D0 SUMR=0.D0 SUMI=0.D0 DO 3209 NX=1,NGPT SUMR=SUMR+PWGHT(NX,1)*SLR(IV,IVP,NX) SUMI=SUMI+PWGHT(NX,1)*SLI(IV,IVP,NX) 3209 CONTINUE C>>SG BELOW SUFFERS FROM ROUND-OFF ERROR FOR IV=IVP CLOSED C>>SG TEST CASES GIVE V*(SUMR**2+SUMI**2)-DELVVP ABOUT 2.D-13 C>>SG BEST WAY TO FIX THIS IS PROBABLY TO TRAP *CLOSED* CHANNELS SUM2=(V*(SUMR*SUMR+SUMI*SUMI)-DELVVP)*WVEC(IV) QLS (IV,IVP)=QLS (IV,IVP)+SUM2 IF (PRINT.GE.10) WRITE(6,638) IV,IVP,SUM2, QLS(IV,IVP) 638 FORMAT(' FOR QLS( 0) VIB LEV =',I3,' TO',I3,15X, & 'ADD',D12.4,' =',D12.4) 3219 CONTINUE 3220 CONTINUE C C *** IN ACCUMULATING QL DIVERGENT CODE FOR ITYPE=1,2 AND ITYPE=5,6 C IF (ITYPE.EQ.1 .OR. ITYPE.EQ.2) GO TO 8881 IF (ITYPE.EQ.3) GO TO 8883 IF (ITYPE.EQ.5 .OR. ITYPE.EQ.6) GO TO 8885 STOP C C ACCUMULATE QL'S / TEST FOR CONVERGENCE 8881 BIGL=-1.D0 DO 3200 L=1,NQL LMP=L-1 BIGL=BIGL+2.D0 ITEST=0 IF (PRINT.GE.10 .AND. NVC.GT.1) WRITE(6,601) DO 3210 IV=1,NVC DO 3210 IVP=1,NVC TLLR=SLLR(IV,IVP,L) TLLI=SLLI(IV,IVP,L) TLLSQ=(TLLR*TLLR+TLLI*TLLI)*V*WVEC(IV)/BIGL QLT(IV,IVP,L)=QLT(IV,IVP,L)+TLLSQ XTEST=TEST(1) IF (L.GT.1 .OR. IV.NE.IVP) XTEST=TEST(2) IF (TLLSQ.GT.XTEST) ITEST=1 IF (PRINT.LT.10) GO TO 3210 WRITE(6,628) LMP,IV,IVP,TLLSQ,QLT(IV,IVP,L) 628 FORMAT(' FOR QLT(',I3,') VIB LEV =',I3,' TO',I3, & ' IOS T-MATRIX ADD',D12.4,' =',D12.4) 3210 CONTINUE C>>SG 5/12/92 STATEMENT BELOW SHOULD BE UNNECESSARY IF (JTOTU.LT.999999) GO TO 3200 C SUPPRESS CONVERGENCE CHECK FOR LOW PARTIAL WAVES. IF (JTOT.LE.3*JSTEP*NCAC) GO TO 3200 IF (IXQL(NIXQL,L).NE.0) GO TO 3200 IEC(L)=IEC(L)+1 IF (ITEST.GT.0) IEC(L)=0 3200 CONTINUE GO TO 3000 C 8883 DO 8873 IL=1,NQL BIGL=(2*LM(3,IL)+1) C N.B. NVC=1 FOR ITYPE=3 TLLR=SLLR(1,1,IL) TLLI=SLLI(1,1,IL) TLLSQ=(TLLR*TLLR+TLLI*TLLI)*V*WVEC(1) * BIGL QLT(1,1,IL)=QLT(1,1,IL)+TLLSQ IF (PRINT.GE.10) WRITE(6,652) IL,LM(1,IL),LM(2,IL),LM(3,IL), 2 TLLSQ,QLT(1,1,IL) 652 FORMAT(' FOR QLT(',I3,'), L1,L2,L =',3I3,' ADD', 1 D12.4,' =',D12.4) XTEST=TEST(MIN0(2,IL)) IF (JTOT.LE.3*JSTEP*NCAC) GO TO 8873 C IF (IXQL(NIXQL,IL).NE.0) GO TO 8875 --- SHOULD ALL = 0 IEC(IL)=IEC(IL)+1 IF (TLLSQ.GT.XTEST) IEC(IL)=0 8873 CONTINUE GO TO 3000 C 8885 DO 8875 IL=1,NQL C N.B. NVC=1 FOR ITYPE=5,6 TLLR=SLLR(1,1,IXQL(1,IL)) TLLI=SLLI(1,1,IXQL(1,IL)) TLLR1=SLLR(1,1,IXQL(2,IL)) TLLI1=SLLI(1,1,IXQL(2,IL)) IF (IXQL(3,IL).EQ.2) GO TO 8865 C BELOW FOR REAL PART / ALSO FOR DIAGONAL CASES TLLSQ=(TLLR*TLLR1+TLLI*TLLI1)*V*WVEC(1) GO TO 8855 C BELOW FOR IMAGINARY PART 8865 TLLSQ=(TLLI*TLLR1-TLLR*TLLI1)*V*WVEC(1) 8855 QLT(1,1,IL)=QLT(1,1,IL)+TLLSQ IF (PRINT.GE.10) WRITE(6,651) IL,LM(1,IXQL(1,IL)),LM(2,IXQL(1,IL)) 1 ,LM(2,IXQL(2,IL)),IXQL(3,IL), 2 TLLSQ,QLT(1,1,IL) 651 FORMAT(' FOR QLT(',I3,'), L,M,M1 =',3I4,', CODE =',I2,' ADD', 1 D12.4,' =',D12.4) XTEST=TEST(MIN0(2,IL)) IF (JTOT.LE.3*JSTEP*NCAC) GO TO 8875 IF (IXQL(3,IL).NE.0) GO TO 8875 IEC(IL)=IEC(IL)+1 IF (TLLSQ.GT.XTEST) IEC(IL)=0 8875 CONTINUE GO TO 3000 C 3000 CALL ISUTP(ISU,ENERGY(IE),JTOTL,JSTEP,JTOT,NVC,NQL,QLS,QLT) C END OF LOOP OVER PARTIAL WAVES C CALL GCLOCK(TJTIME) TIME=TJTIME-TITIME TITIME=TJTIME WRITE(6,631) ENERGY(IE),JTOTL,JSTEP,JTOTU 631 FORMAT('1 ***** ***** ***** END OF CALCULATION FOR ENERGY =', 1 F12.4,' (1/CM) ***** ***** *****'/ & 22X,'PARTIAL WAVES',I4,' (',I4,' ) ',I5) WRITE(6,641) TIME C C END OF CALCULATION FOR THIS ENERGY / OUTPUT CROSS SECTIONS C MAKE SURE WE HAVE NUSED BY CALLING CHKSTR 3009 CALL CHKSTR(NUSED) WRITE(6,684) NUSED,MX 684 FORMAT('0',2(' *****'),' STORAGE SO FAR USED',I10,' OF THE', 1 I10,' AVAILABLE WORDS.') C>>SG C>>SG N.B. NVC SHOULD BE LOWERED TO NOUT=NOPEN (AS IN IOSOUT) C>>SG DO 3305 NX=1,NGPT IV=1 WRITE(6,632) NX,(LEFT,IV,IVP,SIGTH(IV,IVP,NX),IVP=1,NVC) 632 FORMAT('0 FOR ORIENTATION',I6,3(5X,A4 ,I2,',',I2,') =',1PE12.4) & /(23X,3(5X,A4,I2,',',I2,') =',1PE12.4))) IF (NVC.LE.1) GO TO 3008 DO 3007 IV=2,NVC 3007 WRITE(6,642) (LEFT,IV,IVP,SIGTH(IV,IVP,NX),IVP=1,NVC) C>>SG FORMAT CHANGED 2/6/92 TO ELIMINATE APPARENT COMPILER BUG 642 FORMAT(23X,3(5X, A4, I2,',',I2,') =',1PE12.4)/ 1 (23X,3(5X, A4, I2,',',I2,') =',1PE12.4))) 3008 DO 3305 IV=1,NVC DO 3305 IVP=1,NVC 3305 SIGAV(IV,IVP)=SIGAV(IV,IVP)+PWGHT(NX,1)*SIGTH(IV,IVP,NX)*AVGFCT WRITE(6,643) 643 FORMAT('0 AVERAGE OVER ORIENTATIONS') DO 3004 IV=1,NVC 3004 WRITE(6,642) (LEFT,IV,IVP,SIGAV(IV,IVP),IVP=1,NVC) C C CALL IOSOUT/IOSPB TO GET STATE TO STATE AND PR. BR. CROSS SECTIONS C N.B. ATAU, NEEDED ONLY FOR SIG6, IS STORED IN X(1), I.E., JLEV. C THIS IS PRETTY BAD CODING; BETTER PASSING OF ATAU TO SIG6 NEEDED C IATAU=1 CALL IOSOUT(ENERGY(IE),QLT,QLS,NVC,ITYPE,X(IATAU),LM,IXQL, 1 LMAX,NIXQL,NQL,JSTEP) IF(IFLS.GT.0) 1CALL IOSPB(ENERGY(IE),QLT,QLS,IFLS,LINE,LTYPE,ITYPE,NVC,LM,IXQL, 1 LMAX,NIXQL,NQL) C 2000 CONTINUE C C END OF LOOP OVER ENERGIES. C RETURN END SUBROUTINE IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC, 1 IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX, 2 IPROGM,URED,LABEL,NUMDER, 3 LAMBDA,MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC, 4 DEEP,PRINT,NVC, ISAVEU,TITIME,RM,EPSIL,RMIN,RMAX) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C INTEGRATED MOLSCAT/IOS IMPLEMENTED APR 86 CAMBRIDGE, ENGLAND. C -- A GUTTED VERSION OF IOS1, INTERFACED TO CCP6 MOLSCAT. C THIS IS A DRIVER FOR THE IOS CODE; MOLSCAT/DRIVER CALLS C BASIN TO READ &BASIS, WHICH THEN CALLS IOSBIN. C DRIVER THEN CALLS POTENL TO GET &POTL DATA, C AND FINALLY CALLS IOSDRV TO SET UP AND PERFORM IOS CALCULATION. C INTEGER PRINT DIMENSION ENERGY(NNRG),TEST(2),LINE(2,MXLN),LTYPE(MXLN), 1 LAMBDA(MXLAM) LOGICAL NUMDER CHARACTER*80 LABEL C C LAST CHANGED 1/19/93. NEW DYNAMIC MEMORY HANDLING C ** VERSION 6 / OCT 85/ ADDS ITYPE=6 CAPABILITY C / ALSO ALLOWS "UNEXPANDED" POTL, V(R,ANGLES) C ** VERSION 5 / MAR 81/ ADDS INTFLG=4 (MOLSCAT V.8) C / JUNE 82/ REPLACES PLM WITH R. T PACK VERSION. C ** VERSION 4 / MAY. 78/ ADDS ITYPE=5 CODE. C / SEP. 78/ **TEMPORARY** ISAVEU CPABILITY C / APR. 79/ CHANGED FOR ISCRU (MOLSCAT V.7) COMPATABIL C ** VERSION 3 / DEC. 77/ IS TOTALLY NEW ORGANIZATION TO ACCOMMODATE C ITYPE=2 (VIBROTOR - ATOM) C ** VERSION 2 / OCT. 77/ ADDS WKB (R.T PACK) CAPABILITY ** C ** VERSION 1 / SEP. 77/ INTERFACE HOUSTON PROGRAM W/MOLSCAT. C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY C IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINTED W/ VL ARRAY. C NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2. C C CMBASE MODIFIED TO MATCH CURRENT SPECS IN MOLSCAT/BASIS C THIS IS USED ONLY TO GET LV,EV VALUES IN IOSBIN SO THEY CAN BE C WRITTEN TO ISAVEU HERE. DIMENSION EV(1000),LV(4000) COMMON /CMBASE/ DUM(1016),IDUM(4031) EQUIVALENCE (EV(1),DUM(13)),(LV(1),IDUM(2)) C C MUST INITIALIZE NUSED NON-NEGATIVE BEFORE CALL CHKSTR NUSED=0 WRITE(6,68) 68 FORMAT('0 IOSDRV ENTERED. SET-UP FOR INFINITE ORDER SUDDEN', 1 ' CALCULATION.') C C CONTINUE WITH SET-UP FOR IOS. PROCESS &POTL LAM(MXLAM) DATA C SET NGPT, LMAX AND GAUSS PTS/WTS. C N.B. LMAX/MMAX INITIALLY CONTAIN HIGHEST L,M VALUES C DESIRED FOR QLM. LMAX IS RESET TO EQUAL THE *NUMBER* OF L,M C VALUES IN LM,SLLR,SLLI,ETC. CALL IOSBGP(MXLAM,LAMBDA,MXXXXL,NGPT,LMAX,MMAX,NQL,NIXQL) C C RESERVE STORAGE FOR VARIABLES. IC HAS NEXT AVAIL LOC IN X() C STORAGE FOR SCATTERING VARIABLES . . . C SREAL(NVC,NVC),SIMAG(NVC,NVC),WVEC(NVC),EINT(NVC),CENT(NVC), C VL(NVC*(NVC+1)/2,MXLAM),JJJ(NVC),LORB(NVC),NB(NVC) C --ADDED APR 86-- KMAT(NVC,NVC),IV(NVC*(NVC+1)/2,MXLAM) C C V11 CODE EXPECTED IC TO BE STORAGE USED SO FAR ISVMEM=IXNEXT IC=IXNEXT-1 IXSR=IC+1 IXSR=IXNEXT IXSI=IXSR+NVC*NVC IXKMAT=IXSI+NVC*NVC IXWV=IXKMAT+NVC*NVC IXEINT=IXWV+NVC IXCENT=IXEINT+NVC IXVL=IXCENT+NVC NV=NVC*(NVC+1)*NPOTL/2 IXJJJ=IXVL+NV IXLORB=IXJJJ+NVC IXNB=IXLORB+NVC IXIV=IXNB+NVC IC=IXIV IF (IVLFL.GT.0) IC=IXIV+(NV+NIPR-1)/NIPR C C IOS VARIABLES C VLI(NGPT,MXXXXL),PWGHT(NGPT,LMAX),SLR(NVC,NVC,NGPT), C SLI(NVC,NVC,NGPT),SIGTH(NVC,NVC,NGPT),SIGAV(NVC,NVC), C QLS(NVC,NVC),QLT(NVC,NVC,NQL),IEC(NQL ),IXQL(NIXQL,NQL) C SLLR(NVC,NVC,LMAX),SLLI(NVC,NVC,LMAX),LM(3,LMAX) C IXVLI=IC IXPW=IXVLI+MXXXXL*NGPT IXSLR=IXPW+NGPT*LMAX IXSLI=IXSLR+NVC*NVC*NGPT IXSGTH=IXSLI+NVC*NVC*NGPT IXSGAV=IXSGTH+NVC*NVC*NGPT IXQLS=IXSGAV+NVC*NVC IXQLT=IXQLS+NVC*NVC IXSLLR=IXQLT+NVC*NVC*NQL IXSLLI=IXSLLR+NVC*NVC*LMAX IXIEC=IXSLLI+NVC*NVC*LMAX IXQL=IXIEC+(NQL+NIPR-1)/NIPR IXLM=IXQL+(NIXQL*NQL+NIPR-1)/NIPR IC=IXLM+(3*LMAX+1)/NIPR WRITE(6,681) NVC,NGPT,LMAX,MXXXXL,NQL,NIXQL,IC 681 FORMAT('0 STORAGE ALLOCATED FOR NVC (NO. VIB. CHANNELS) =',T60, 1 I4/25X,'NGPT (NO. GAUSS PTS.) =',T58,I6/ 2 25X,'LMAX (NO. LEGENDRE COEFFS.) =',T60,I4/ 3 25X,'MXXXXL (NO. SYMMETRIES IN POTL) =',T60,I4/ 4 25X,'NQL (NO. QLT) =',T60,I4/ 5 25X,'NIXQL (NO. INDICES IN IXQL) =',T60,I4/ 6 25X,'NEXT LOCATION =',T54,I10) C IC IS NOW 'NEXT STORAGE LOCATION' IXNEXT=IC CALL CHKSTR(NUSED) C C SET UP PWGHT, VLI TABLES - ALSO IXQL TABLE C CALL IOSB1(X(IXPW),X(IXVLI),X(IXQL),X(IXLM),NGPT,LMAX,MXXXXL, 1 NIXQL,NQL) C IF (ISAVEU.LE.0) GO TO 3000 C C *** ISAVEU OUTPUT -- MAY 92 VERSION C WRITE(6,3600) ISAVEU 3600 FORMAT('0'/'0 QLS/QLT SAVED (MAY 92 FORMAT) ON UNIT ISAVEU =',I3) IPOUT=100+IPROGM ITOUT=100+ITYPE-100*(ITYPE/100) WRITE(ISAVEU,3601) LABEL,ITOUT,NVC,NQL,URED,IPOUT 3601 FORMAT(A80/3I4,F8.4,I4) C WRITE(ISAVEU,3602) (LV(I),I=1,NVC) 3602 FORMAT(20I4) C WRITE(ISAVEU,3603) NVC,(EV(I),I=1,NVC) 3603 FORMAT(I4/(5E16.8)) C WRITE(ISAVEU,3603) NNRG,(ENERGY(I),I=1,NNRG) C 3000 CALL GCLOCK(TJTIME) TIME=TJTIME-TITIME WRITE(6,640) TIME 640 FORMAT('0 TIME TO SET UP CALCULATION WAS',F8.2, 1 ' SECONDS. EXIT IOSDRV') WRITE(6,69) 69 FORMAT('0',30('====')) C C PASS CONTROL TO IOSCLC TO DO CALCULATION. C CALL IOSCLC(NNRG,ENERGY,JTOTL,JTOTU,JSTEP,INTFLG,PRINT,ISAVEU, 1 ITYPE,RMIN,RMAX,DEEP,IRMSET,IRXSET,RVFAC,NUMDER, 2 NCAC,TEST,RM,EPSIL,NVC,LMAX,NGPT,NQL,NIXQL, 3 MXXXXL,LAMBDA,MXLAM,NPOTL,X(IXVLI), 4 X(IXPW),X(IXSLR),X(IXSLI),X(IXQLT),X(IXQLS), 5 X(IXSLLR),X(IXSLLI),X(IXQL), 6 X(IXSGTH),X(IXSGAV),X(IXIEC),X(IXLM), 7 IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT,IXWV, 8 IXJJJ,IXLORB,IXNB,X(IXWV),X(IXNB), 9 IFLS,MXLN,LINE,LTYPE) C C RELEAST STORAGE USED BY IOSDRV/IOSCLC/STORAG IXNEXT=ISVMEM RETURN END SUBROUTINE IOSOUT(ENERGY,QL,QLOLD,NVC,ITYPE,ATAU,LM,IXQL, 1 LMAX,NIXQL,NQL,JSTEP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C>>SG MODIFIED MAY 92 - ITYPE=3 / ADD JSTEP TO PARAMETER LIST. C>>SG MODIFIED FEB 92 C>>SG TO CORRECT APPARENT COMPILER BUG, IN FORMATS 615,616 C>>SG TO ALLOW FOR OUTPUT OF NOUT.LT.NVC VIB LEVELS IF SOME CLOSED C C AUG 86 IXQLF ADD LM,LMAX ARGUMENTS C *** TO CONTROL OPTIONAL 'DEBUGGING' OUTPUT *** LOGICAL PRNT C ALLOW FOR MXSIG OUTPUT LEVELS PARAMETER (MXSIG=200) CHARACTER*1 S(MXSIG),BLANK,STAR CHARACTER*4 LCODE(3),LQLT,LQLS DIMENSION QL(NVC,NVC,NQL),QLOLD(NVC,NVC) DIMENSION LM(3,LMAX),IXQL(NIXQL,NQL) DIMENSION ATAU(2) C STORAGE RESERVED FOR MAXIMUM OF MXSIG LEVELS DIMENSION SIG(MXSIG),SIG3(MXSIG) C C COMMON BLOCKS TO COMMUNICATE WITH IOSBIN(BASIS SET) ROUTINES COMMON /CMBASE/DUM(1016),IDUM(4031) DIMENSION JLEV(4000) EQUIVALENCE (NLEV,IDUM(1)), (JLEV(1),IDUM(2)), (IDENT,IDUM(4029)) COMMON /IOUTCM/ JMAX,LEVV(4000) C COMMON TO GET SYMMETRY INFORMATION (IHOMO1,IHOMO2) FOR ITYPE=3 COMMON/ANGLES/COSANG(7),FACTOR,IH1,IH2,IH3,IH4 C DATA IZERO/0/, ZTOL/1.D-8/ DATA BLANK/' '/, STAR/'*'/ DATA LCODE/' ','REAL','IMAG'/, LQLT/' QLT'/, LQLS/' QLS'/ DATA PRNT/.FALSE./ C C STATEMENT FUNCTION FOR NORMALIZATION XNORM . . . XNORM(EPSI)=1.D0/(1.D0+ABS(EPSI)) FUNC(I)=2.D0*DBLE(I)+1.D0 C WRITE(6,601) ENERGY 601 FORMAT('1 STATE-TO-STATE CROSS SECTIONS (IN ANG**2) FOR KINETIC ', & 'ENERGY =',F12.4,' (1/CM).'/'0 PROCESSED BY IOSOUT (FEB 92).') C XJSTEP=JSTEP IF(JSTEP.GT.1) WRITE(6,690) JSTEP 690 FORMAT('0 CROSS SECTIONS (BUT NOT QL) MULTIPLIED BY JSTEP =' 1 ,I3) IF (ITYPE.EQ.5 .OR.ITYPE.EQ.6) GO TO 5000 IF (ITYPE.EQ.3) GO TO 3000 C C CODE BELOW IS ITYPE=1,2 FROM VERSION 3. IT SHOULD STILL WORK C SINCE ALL QL (NOW QLT) ARE IN ORDER. WRITE(6,610) NVC,(LEVV(I),I=1,NVC) 610 FORMAT('0 NO. OF VIBRATIONAL LEVELS =',I4,'. LEVELS ARE'/ & (' ',13I10) ) IF (JMAX.LT.MXSIG) GO TO 2200 WRITE(6,692) JMAX,MXSIG 692 FORMAT('0 JMAX =',I6,' REDUCED BECAUSE OF MXSIG =',I5) JMAX=MXSIG-1 2200 WRITE(6,602) JMAX 602 FORMAT('0 MAXIMUM J-VALUE REQUESTED IS',I4) C>>SG ------------------------- >> CODE BELOW ADDED FEB 92 C>> DETERMINE IF ALL CHANNELS ARE OPEN. SINCE WE DON'T HAVE ACCESS C TO NOPEN HERE, SIMPLY FIND THE HIGHEST 'CHANNEL' FOR WHICH WE C HAVE NONZERO QL() OR QLOLD() NOUT=0 DO 2300 IV=1,NVC C FIRST CHECK QLOLD DO 2301 IVP=1,NVC IF (QLOLD(IV,IVP).NE.0.) GO TO 2390 2301 CONTINUE C THEN CHECK QL() DO 2302 IVP=1,NVC DO 2302 IL=1,NQL IF (QL(IV,IVP,IL).NE.0.) GO TO 2390 2302 CONTINUE GO TO 2300 2390 NOUT=IV 2300 CONTINUE IF (NOUT.NE.NVC) WRITE(6,620) NOUT 620 FORMAT('0 IOSOUT (FEB 92). ALL QL,QLOLD ZERO FOR SOME CHANNELS' 1 ,', PRESUMABLY CLOSED ENERGETICALLY.'/ 2 '0 OUTPUT LIMITED TO NOUT =',I3) C C<>SG ITYPE=3 CODE ADDED MAY 92. ASSUMES NVC=1 (ONE VIB CHANNEL) 3000 WRITE(6,630) 630 FORMAT('0'/'0 ACCUMULATED Q(L1,L2,L) ARE AS FOLLOWS') WRITE(6,651) LCODE(1),LQLS,LM(1,1),LM(2,1),LM(3,1),QLOLD(1,1) DO 3001 L=1,NQL 3001 WRITE(6,651) LCODE(1),LQLT,LM(1,L),LM(2,L),LM(3,L),QL(1,1,L) IF (LM(1,1).EQ.0.AND.LM(2,1).EQ.0.AND.LM(3,1).EQ.0) GO TO 3002 WRITE(6,639) 639 FORMAT(' IOSOUT *** ERROR. L1=L2=L=0 IS NOT FIRST SYMMETRY IN LM') 3002 L1MAX=0 L2MAX=0 DO 3003 IL=1,LMAX L1MAX=MAX0(L1MAX,LM(1,IL)) 3003 L2MAX=MAX0(L2MAX,LM(2,IL)) NL2=L2MAX/IH2+1 IX=0 DO 3100 L1=0,L1MAX,IH1 LTOP=L2MAX IF (IDENT.GT.0) LTOP=L1 DO 3100 L2=0,LTOP,IH2 IX=IX+1 NSIG=IX IF (NSIG.LE.MXSIG) GO TO 3109 WRITE(6,638) MXSIG 638 FORMAT(' *** ERROR. MXSIG (DIMENSION OF SIG3) EXCEEDED',I5) STOP 3109 SIG3(IX)=0. LLO=ABS(L1-L2) LHI=L1+L2 DO 3102 LL=LLO,LHI,2 C SEARCH LM(,IL) FOR L1,L2,LL DO 3101 IL=1,LMAX IF (L1.NE.LM(1,IL).OR.L2.NE.LM(2,IL).OR.LL.NE.LM(3,IL)) GO TO 3101 SIG3(IX)=SIG3(IX)+QL(1,1,IL) * XJSTEP GO TO 3102 3101 CONTINUE WRITE(6,631) L1,L2,LL 631 FORMAT(' IOSOUT *** ERROR. REQUIRED QL(',3I3,') NOT FOUND.') 3102 CONTINUE 3100 WRITE(6,632) L1,L2,SIG3(IX) 632 FORMAT(' SIG( 0 0 ->',2I3,') =',F10.3,' ANG**2') C IF (NLEV.LE.0) RETURN WRITE(6,633) (I,JLEV(2*I-1),JLEV(2*I),I=1,NLEV) 633 FORMAT('0'/'0 CROSS SECTIONS WILL BE COMPUTED AMONG FOLLOWING ', & 'LEVELS'/'0 LEVEL J1 J2 '/(' ',3I4)) IF (NLEV.GT.MXSIG) THEN WRITE(6,693) NLEV,MXSIG NLEV=MXSIG ENDIF IMSG=0 DO 3200 I=1,NLEV JI1=JLEV(2*I-1) JI2=JLEV(2*I) WRITE(6,634) I,JI1,JI2 634 FORMAT('0 INITIAL LEVEL =',I4,' J1, J2 =',3I4) DO 3201 IF=1,NLEV JF1=JLEV(2*IF-1) JF2=JLEV(2*IF) SIG(IF)=0. S(IF)=BLANK C IF (IF.EQ.I) GO TO 3200 L1LO=ABS(JI1-JF1) L1HI=JI1+JF1 L2LO=ABS(JI2-JF2) L2HI=JI2+JF2 DO 3202 L1=L1LO,L1HI,IH1 IX1=L1/IH1+1 DO 3202 L2=L2LO,L2HI,IH2 IX2=L2/IH2+1 IF (IDENT.NE.0) GO TO 3203 C INDEX FOR DISTINGUISHABLE PARTICLES IX=(IX1-1)*NL2+IX2 GO TO 3204 C BELOW FOR INDISTINGUISHABLE PARTICLES/ ASSUME IH2=IH1. 3203 IX1=MAX0(L1,L2)/IH1+1 IX2=MIN0(L1,L2)/IH1+1 IX=(IX1-1)*IX1/2+IX2 C SEE IF WE HAVE THIS (I.E., IX.LE.NSIG) 3204 IF (IX.LE.NSIG) GO TO 3205 S(IF)=STAR IMSG=1 GO TO 3202 3205 TJ1=THREEJ(JI1,L1,JF1) TJ2=THREEJ(JI2,L2,JF2) SIG(IF)=SIG(IF)+TJ1*TJ1*TJ2*TJ2*SIG3(IX) 3202 CONTINUE 3201 SIG(IF)=SIG(IF)*(2*JF1+1)*(2*JF2+1) 3200 WRITE(6,604) (IF,SIG(IF),S(IF),IF=1,NLEV) IF (IMSG.GT.0) WRITE(6,699) RETURN C C BELOW FOR ITYPE=5, INITIAL PROCESSING FOR ITYPE=6 ALSO C>>SG (FEB 92) N.B. CODE *ASSUMES* NVC=1 (ONE VIB CHANNEL). 5000 WRITE(6,650) 650 FORMAT('0'/'0 ACCUMULATED Q(L,M1,M2) ARE AS FOLLOWS') WRITE(6,651) LCODE(1),LQLS,IZERO,IZERO,IZERO,QLOLD(1,1) 651 FORMAT(' ',A4,2X,A4,'(',3I3,') =',1PE13.5) DO 5001 L=1,NQL 5001 WRITE(6,651) LCODE(IXQL(NIXQL,L)+1),LQLT,LM(1,IXQL(1,L)), & LM(2,IXQL(1,L)),LM(2,IXQL(2,L)),QL(1,1,L) IMSG=0 IF (NLEV.LE.MXSIG) GO TO 5109 WRITE(6,693) NLEV,MXSIG 693 FORMAT('0 NLEV =',I6,' REDUCED BECAUSE OF MXSIG =',I5) NLEV=MXSIG 5109 IF (ITYPE.EQ.6) GO TO 6000 WRITE(6,652) 652 FORMAT('0'/'0 CROSS SECTIONS WILL BE COMPUTED AMONG FOLLOWING ', & 'LEVELS'/'0 LEVEL J K PRTY') DO 5002 I=1,NLEV 5002 WRITE(6,653) I,JLEV(3*I-2),JLEV(3*I-1),JLEV(3*I) 653 FORMAT(' ',4I4) DO 5100 I=1,NLEV JI=JLEV(3*I-2) XJI=JI KI=JLEV(3*I-1) XKI=KI EPSI=PARITY(JLEV(3*I)) IF (KI.EQ.0) EPSI=0.D0 XNI=XNORM(EPSI) WRITE(6,654) I,JI,KI,JLEV(3*I) 654 FORMAT('0 INITIAL LEVEL =',I4,' J, K, PRTY =',3I4) DO 5101 IF=1,NLEV JF=JLEV(3*IF-2) XJF=JF KF=JLEV(3*IF-1) XKF=KF EPSF=PARITY(JLEV(3*IF)) IF (KF.EQ.0) EPSF=0.D0 XNF=XNORM(EPSF) LLO=IABS(JI-JF) LHI=JI+JF PJK=PARITY(JI+JF+KI+KF) MPLS=KI+KF MMIN=IABS(KI-KF) P2=1.D0 IF (KI-KF.LT.0) P2=PARITY(MMIN) SIG(IF)=0.D0 S(IF)=BLANK TMAX=0.D0 DO 5102 L=LLO,LHI XL=L PL=PJK*PARITY(L) C -----------------------TERM 1 ------------------- PP=1.D0+EPSI*EPSF*PL PP=PP*PP IF (PP.LE.ZTOL) GO TO 5200 TJ=THRJ(XJF,XL,XJI,XKF,XKI-XKF,-XKI) TJ=TJ*TJ IF (TJ.LE.ZTOL) GO TO 5200 CALL IXQLF(LM,LMAX,L,MMIN,MMIN,0,INDEX,IXQL,NIXQL,NQL) IF (INDEX.GT.0) GO TO 5110 IF (INDEX.EQ.-1) GO TO 5200 IMSG=1 S(IF)=STAR C IF ('PRINT'.GT.25) WRITE(6, ) MSG GO TO 5200 5110 TT=PP*TJ*QL(1,1,INDEX) TMAX=MAX(ABS(TT),TMAX) SIG(IF)=SIG(IF)+TT * XJSTEP C -----------------------TERM 2 ------------------- 5200 PP=(1.D0+EPSI*EPSF*PL)*(EPSF+EPSI*PL) IF (ABS(PP).LE.ZTOL) GO TO 5300 TJ=THRJ(XJF,XL,XJI,XKF,XKI-XKF,-XKI)* & THRJ(XJF,XL,XJI,-XKF,XKF+XKI,-XKI) IF (ABS(TJ).LE.ZTOL) GO TO 5300 CALL IXQLF(LM,LMAX,L,MPLS,MMIN,1,INDEX,IXQL,NIXQL,NQL) IF (INDEX.GT.0) GO TO 5210 IF (INDEX.EQ.-1) GO TO 5300 IMSG=1 S(IF)=STAR C ON HIGH PRNTLV WRITE MSG GO TO 5300 5210 TT=2.D0*P2*PP*TJ*QL(1,1,INDEX) TMAX=MAX(TMAX,ABS(TT)) SIG(IF)=SIG(IF)+TT * XJSTEP C -----------------------TERM 3 ------------------- 5300 PP=EPSF+EPSI*PL PP=PP*PP IF (PP.LE.ZTOL) GO TO 5102 TJ=THRJ(XJF,XL,XJI,-XKF,XKF+XKI,-XKI) TJ=TJ*TJ IF (TJ.LE.ZTOL) GO TO 5102 CALL IXQLF(LM,LMAX,L,MPLS,MPLS,0,INDEX,IXQL,NIXQL,NQL) IF (INDEX.GT.0) GO TO 5310 IF (INDEX.EQ.-1) GO TO 5102 S(IF)=STAR IMSG=1 C ON 'PRNTLV' WRITEN MSG GO TO 5102 5310 TT=PP*TJ*QL(1,1,INDEX) TMAX=MAX(ABS(TT),TMAX) SIG(IF)=SIG(IF)+TT * XJSTEP 5102 CONTINUE IF (ABS(SIG(IF)).GE.ZTOL*TMAX) GO TO 5101 IF (SIG(IF).EQ.0.D0) GO TO 5101 IF (PRNT) WRITE(6,697) IF,SIG(IF),TMAX 697 FORMAT(' * * * NOTE. ROUND-OFF ERROR FOR LEV(F) =',I3, & ', SIG(IF),TMAX =',2D12.4) SIG(IF)=0.D0 5101 SIG(IF)=SIG(IF)*XNI*XNF*FUNC(JF) 5100 WRITE(6,604) (IF,SIG(IF),S(IF),IF=1,NLEV) IF (IMSG.GT.0) WRITE(6,699) RETURN C C BELOW FOR ITYPE=6 6000 DO 6100 I=1,NLEV WRITE(6,664) I,JLEV(4*I-3),JLEV(4*I-2),JLEV(4*I-1) 664 FORMAT('0 INITIAL LEVEL =',I4,' J, TAU, PARITY =',3I4) DO 6101 IF=1,NLEV SIG(IF)=0.D0 S(IF)=BLANK 6101 CALL SIG6(NLEV,JLEV,ATAU,I,IF,SIG(IF),S(IF),IMSG,QL,IXQL,NIXQL, 1 NQL,LM,LMAX) 6100 WRITE(6,604) (IF,SIG(IF)*XJSTEP,S(IF),IF=1,NLEV) IF (IMSG.GT.0) WRITE(6,699) RETURN C END SUBROUTINE IOSPB(ENERGY,QL,QLOLD,NL,LINE,LTYPE,ITYPE, 1 NVC,LM,IXQL,LMAX,NIXQL,NQL) C *** C *** MODIFIED DEC 86 FOR COMPATBILITY WITH OFF-DIAGONAL PRBR CODE C *** C ** N.B. DIMENSIONS ON QL,QLOLD SHOULD HAVE NVC REMOVED. C ALSO, LM APPEARS NOT TO BE USED IN THIS ROUTINE C AUG 86 IXQLF ADD LM,LMAX ARGUMENTS C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * LOGICAL EXISTS C TO CONTROL PRINTING OF 'OPTIONAL' OUTPUT LOGICAL LPRT C FOR UPWARD COMPATIBILITY WITH OLD (DIAG ONLY) INPUT LOGICAL LDIAG C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DEC 86 LINE() CHANGED TO 1-DIMENSIONAL ARRAY CONTROLED BY NPL DIMENSION QL(NVC,NVC,NQL),QLOLD(NVC,NVC),LINE(2),LTYPE(NL) DIMENSION LM(3,LMAX),IXQL(NIXQL,NQL) C QLOLD IS QL(0) IN THE NOTATION OF IOS PAPER 1. C C COMMON TO COMMUNICATE WITH IOSBIN ROUTINE DIMENSION JLEV(4000) COMMON /CMBASE/DUM(1016),IDUM(4031) EQUIVALENCE (JLEV(1),IDUM(2)), (NLEV,IDUM(1)) C DATA IZERO/0/, IONE/1/, TOL/1.D-5/ DATA LPRT/.FALSE./ DATA LDIAG/.FALSE./ C C STATEMENT FUNCTION DEFINITIONS. . . XNORM(EPSA)=1.D0/(1.D0+ABS(EPSA)) FUNC(JA)=DBLE(2*JA+1) EXISTS(I)= I.GT.0 .AND. I.LE.NLEV C IF (NL.LE.0) RETURN C NPL IS NO. OF INDICES IN LINE PER CROSS SECTION NPL=4 IF (LDIAG) NPL=2 WRITE(6,600) NL,ENERGY 600 FORMAT('0'/'0 PRESSURE BROADENING CROSS SECTIONS REQUESTED FOR', & I4,' SPECTRAL LINES.'/'0 ENERGY =',F12.4,' (1/CM).') IF (ITYPE.EQ.1 .AND. NVC.EQ.1) GO TO 1111 IF (ITYPE.EQ.5 .AND. NVC.EQ.1) GO TO 5000 WRITE(6,695) ITYPE,NVC 695 FORMAT('0 * * * NOTE. IOSPB NOT SUPPORTED FOR ITYPE, NVC =',2I6) NL=0 RETURN 1111 QTOT=0D0 IF (LMAX.LT.2) GO TO 1001 DO 1000 IL=2,LMAX 1000 QTOT=QTOT+QL(1,1,IL) 1001 LM1=LMAX-1 WRITE(6,651) LM1,QTOT,QLOLD(1,1) 651 FORMAT('0 SUM OVER Q(L), L = 1,',I3,' =',F12.4,' QLOLD(0) =', & F12.4) C *** C *** SAVE QL(1,1,1) AND REPLACE WITH QLOLD(1,1) Q0SAVE=QL(1,1,1) QL(1,1,1)=QLOLD(1,1) C *** LOOP OVER LINES DO 2000 LN=1,NL LVA=LINE((LN-1)*NPL+1) LVB=LINE((LN-1)*NPL+2) IF (.NOT.LDIAG) GO TO 1091 LVA1=LVA LVB1=LVB GO TO 1092 1091 LVA1=LINE((LN-1)*NPL+3) LVB1=LINE((LN-1)*NPL+4) 1092 IF (EXISTS(LVA).AND.EXISTS(LVB).AND.EXISTS(LVA1).AND.EXISTS(LVB1)) 1 GO TO 2001 WRITE(6,691) LN,LVA,LVB,LVA1,LVB1 691 FORMAT('0 * * * ERROR. FOR LINE',I3,' LEVEL A OR B .GT. NLEV - & CANNOT PROCESS',4I6) GO TO 2000 2001 JA=JLEV(LVA) JB=JLEV(LVB) JA1=JLEV(LVA1) JB1=JLEV(LVB1) K=LTYPE(LN) IF (K.LE.0) K=IABS(JA-JB) WRITE(6,601) LN,JA,JB,JA1,JB1,K 601 FORMAT('0 LINE',I3,' FOR JA, JB; JA1, JB1 = ',2I4,4X,2I4, & ' PROCESSED FOR',I4,'-POLE RADIATION.') LTOP=MIN0(JA+JA1,JB+JB1) IF (LTOP.LE.LM1) GO TO 2002 WRITE(6,692) LTOP,LM1 692 FORMAT('0 * * * WARNING. POSSIBLE ERROR LTOP.GT.LMAX',2I6) LTOP=LM1 2002 LMIN=MAX0(IABS(JA-JA1),IABS(JB-JB1)) QTOT2=0. DO 2100 L=LMIN,LTOP C FC=FCOEF(JA,JB,JA,JB,K,L) FC=PARITY(K)*FUNC(JA1)*DSQRT(FUNC(JB1)*FUNC(JB))* 1 THREEJ(JA,JA1,L)*THREEJ(JB,JB1,L)*SIXJ(JA,JB,JA1,JB1,K,L) TERM=FC*QL(1,1,L+1) 2100 QTOT2=QTOT2-TERM WRITE(6,602) QTOT2 602 FORMAT(11X,'***** PRESSURE BROADENING CROSS SECTION =',F12.4, & ' ANG**2 *****') 2000 CONTINUE C RESTORE QL(1,1,1) QL(1,1,1)=Q0SAVE RETURN C ***** ITYPE = 5 ***** C Q(L,MA,MB) ACCESSED VIA IXQLF WHICH RETURNS INDEX IN QL. C -1 RETURNED IF MISSING BY SYMMETRY RESTRICTION / 0 IF NOT FOUND C FOLLOWING ASSUMED ABOUT TABLE. C MA.GE.MB IN TABLE / TO REVERSE ORDER TAKE COMPLEX CONJUGATE C IMAGINARY PART FOR L,MA,MB ASSUMED TO FOLLOW REAL PART IN TABLE. C IF KA (KB) .NE. 0 THEN TERMS 2 (3) AND 4 WILL NOT BE PROCESSED. C 5000 IF (LDIAG) GO TO 5901 WRITE(6,699) 699 FORMAT('0 *** NEW IOSPB NOT SUPPORTED FOR ITYPE=5 AND .NOT.LDIAG' 1 ,' --- REQUEST CANCELED.') RETURN 5901 DO 5001 LN=1,NL LVA=LINE((LN-1)*NPL+1) LVB=LINE((LN-1)*NPL+2) IF (EXISTS(LVA).AND.EXISTS(LVB)) GO TO 5002 WRITE(6,691) LN,LVA,LVB GO TO 5001 5002 JA=JLEV(3*LVA-2) KA=JLEV(3*LVA-1) EPSA=PARITY(JLEV(3*LVA)) IF (KA.EQ.0) EPSA=0.D0 XJA=JA XKA=KA KA2=2*KA JB=JLEV(3*LVB-2) KB=JLEV(3*LVB-1) EPSB=PARITY(JLEV(3*LVB)) IF (KB.EQ.0) EPSB=0.D0 XJB=JB XKB=KB KB2=2*KB K=LTYPE(LN) IF (K.LE.0) K=IABS(JA-JB) WRITE(6,652) LN,LVA,LVB,JA,KA,EPSA,JB,KB,EPSB,K 652 FORMAT('0 LINE',I3,' BETWEEN LEVEL',2I4,5X,'(J, K, EPS =',2I4,F5.1 & ,' TO',2I4,F5.1,') PROCESSED FOR', 2 I4,'-POLE RADIATION.') LTOP=2*MIN0(JA,JB) QTOT2=0.D0 QTOTI=0.D0 FACT=-XNORM(EPSA)*XNORM(EPSB)*PARITY(K+KA+KB)*FUNC(JA)*FUNC(JB) DO 5100 L=IZERO,LTOP,2 SFACT=SIXJ(JA,JB,JA,JB,K,L) IF (ABS(SFACT).LT.TOL) GO TO 5100 XL=L C TERM 1 . . . PF=(1.D0+EPSA*EPSA)*(1.D0+EPSB*EPSB) TF=THRJ(XJA,XL,XJA,XKA,0D0,-XKA)*THRJ(XJB,XL,XJB,XKB,0D0,-XKB) C HANDLE Q(0,0,0) -- I.E. QLOLD -- SEPARATELY. IF (L.EQ.0) GO TO 5101 CALL IXQLF(LM,LMAX,L,IZERO,IZERO,IZERO,IX,IXQL,NIXQL,NQL) IF (IX.EQ.0) WRITE(6,659) L,IZERO,IZERO,IZERO 659 FORMAT(' REQUESTED MISSING Q. L, MA, MB, CODE =',4I4) IF (IX.LE.0) GO TO 5200 XXX=FACT*SFACT*PF*TF ADDR=XXX*QL(1,1,IX) QTOT2=QTOT2+ADDR ADDI=0.D0 IF(LPRT)WRITE(6,657)L,IZERO,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI 657 FORMAT(' L, MA, MB =',3I3,' *', F12.5 ,' ADD(R/I) =',2F12.5, & ' = ',2F12.5) GO TO 5200 5101 ADDI=0.D0 XXX=FACT*SFACT*PF*TF ADDR=XXX*QLOLD(1,1) QTOT2=QTOT2+ADDR IF(LPRT)WRITE(6,657)L,IZERO,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI C TERM 2 . . . 5200 IF (EPSA.EQ.0.D0 .OR. KA2.GT.L) GO TO 5300 PF=2.D0*EPSA*(1.D0+EPSB*EPSB) TF=THRJ(XJA,XL,XJA,-XKA,2.D0*XKA,-XKA)* & THRJ(XJB,XL,XJB,XKB,0D0,-XKB) CALL IXQLF(LM,LMAX,L,KA2,IZERO,IONE,IX,IXQL,NIXQL,NQL) IF (IX.EQ.0) WRITE(6,659) L,KA2,IZERO,IONE IF (IX.LE.0) GO TO 5300 XXX=FACT*SFACT*PF*TF ADDR=XXX*QL(1,1,IX) ADDI=XXX*QL(1,1,IX+1) QTOT2=QTOT2+ADDR QTOTI=QTOTI+ADDI IF (LPRT)WRITE(6,657)L,KA2,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI C TERM 3 . . . 5300 IF (EPSB.EQ.0.D0 .OR. KB2.GT.L) GO TO 5400 PF=2.D0*EPSB*(1.D0+EPSA*EPSA) TF=THRJ(XJA,XL,XJA,XKA,0D0,-XKA)* & THRJ(XJB,XL,XJB,-XKB,2.D0*XKB,-XKB) CALL IXQLF(LM,LMAX,L,KB2,IZERO,IONE,IX,IXQL,NIXQL,NQL) IF (IX.EQ.0) WRITE(6,659) L,IZERO,KB2,IONE IF (IX.LE.0) GO TO 5400 XXX=FACT*SFACT*PF*TF ADDR=XXX*QL(1,1,IX) ADDI=-XXX*QL(1,1,IX+1) QTOT2=QTOT2+ADDR QTOTI=QTOTI+ADDI IF(LPRT) WRITE(6,657) L,IZERO,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI C TERM 4 . . . 5400 IF (EPSA*EPSB.EQ.0.D0 .OR. KA2.GT.L .OR. KB2.GT.L) GO TO 5100 PF=4.D0*EPSA*EPSB TF=THRJ(XJA,XL,XJA,-XKA,2.D0*XKA,-XKA)* & THRJ(XJB,XL,XJB,-XKB,2.D0*XKB,-XKB) IF (KA2-KB2) 5401,5402,5403 5401 CALL IXQLF(LM,LMAX,L,KA2,KB2,IONE,IX,IXQL,NIXQL,NQL) IF (IX.EQ.0) WRITE(6,659) L,KA2,KB2,IONE IF (IX.LE.0) GO TO 5100 XXX=FACT*SFACT*PF*TF ADDR=XXX*QL(1,1,IX) ADDI=XXX*QL(1,1,IX+1) QTOT2=QTOT2+ADDR QTOTI=QTOTI+ADDI IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI GO TO 5100 5402 CALL IXQLF(LM,LMAX,L,KA2,KB2,IZERO,IX,IXQL,NIXQL,NQL) IF (IX.EQ.0) WRITE(6,659) L,KA2,KB2,IZERO IF (IX.LE.0) GO TO 5100 XXX=FACT*SFACT*PF*TF ADDR=XXX*QL(1,1,IX) QTOT2=QTOT2+ADDR ADDI=0.D0 IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI GO TO 5100 5403 CALL IXQLF(LM,LMAX,L,KB2,KA2,IONE,IX,IXQL,NIXQL,NQL) IF (IX.EQ.0) WRITE(6,659) L,KB2,KA2,IONE IF (IX.LE.0) GO TO 5100 XXX=FACT*SFACT*PF*TF ADDR=XXX*QL(1,1,IX) ADDI=-XXX*QL(1,1,IX+1) QTOT2=QTOT2+ADDR QTOTI=QTOTI+ADDI IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI 5100 CONTINUE WRITE(6,658) QTOT2,QTOTI 658 FORMAT(11X,'***** CROSS SECTION (A**2), REAL PART =',F12.4,5X, & 'IMAG. PART =',F12.4) 5001 CONTINUE C RETURN END FUNCTION IPASYM(JI,NK,A) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ROUTINE TO SET PARITY CODE FOR ASYMMETRIC TOP FUNCTIONS. C C IPASYM K-PAR +/- PAR C 0 EVEN + C 1 EVEN - C 2 ODD + C 3 ODD - C DIMENSION A(NK) DATA EPS/1.D-4/ C IPAR=-1 KPAR=-1 IF (NK.EQ.2*JI+1) GO TO 1000 1999 WRITE(6,699) JI,NK,(A(I),I=1,NK) 699 FORMAT('0 * * * ERROR. FOLLOWING SET OF ASYMMETRIC TOP COEFFICIEN &TS ARE INVALID (PARITY).',2I6/(10X,6F12.8)) IPASYM=-1 RETURN C NORMALIZE IF NECESSARY . . . 1000 XN=0.D0 DO 1100 I=1,NK 1100 XN=XN+A(I)*A(I) IF (ABS(XN).GE.EPS) GO TO 1200 WRITE(6,602) 602 FORMAT('0 * * * ERROR. COEFFICIENTS CANNOT BE NORMALIZED.') GO TO 1999 1200 XN=1.D0/SQRT(XN) IF (ABS(XN-1.D0).LE.EPS) GO TO 2000 WRITE(6,601) XN 601 FORMAT(10X,'COEFFICIENTS NORMALIZED WITH FACTOR',D14.6) 2000 DO 2100 I=1,NK 2100 A(I)=A(I)*XN C NMID=JI+1 C DETERMINE EVEN/ODD K LP=0 IF (ABS(A(NMID)).LE.EPS) GO TO 3100 KPAR=0 3100 IF (JI.LE.0) GO TO 4000 DO 3200 I=1,JI LP=IABS(LP-1) IF (ABS(A(NMID+I)).LE.EPS .AND. ABS(A(NMID-I)).LE.EPS) & GO TO 3200 IF (KPAR.GE.0) GO TO 3300 KPAR=LP GO TO 3200 3300 IF (KPAR.EQ.LP) GO TO 3200 KPAR=-1 GO TO 1999 3200 CONTINUE C C NOW DO +/- KPARITY . . . 4000 IF (ABS(A(NMID)).LE.EPS) GO TO 4100 IPAR=0 4100 IF (JI.LE.0) GO TO 5000 DO 4200 I=1,JI IF (ABS(A(NMID-I)).GT.EPS) GO TO 4300 IF (ABS(A(NMID+I)).LE.EPS) GO TO 4200 IPAR=-1 GO TO 1999 4300 RATIO=A(NMID+I)/A(NMID-I) IF (ABS(RATIO-1.D0).LE.EPS) GO TO 4400 IF (ABS(RATIO+1.D0).LE.EPS) GO TO 4500 IPAR=-1 GO TO 1999 4500 IF (IPAR) 4501,4502,4200 4501 IPAR=1 GO TO 4200 4502 IPAR=-1 GO TO 1999 4400 IF (IPAR) 4401,4200,4402 4401 IPAR=0 GO TO 4200 4402 IPAR=-1 GO TO 1999 4200 CONTINUE C 5000 IF (KPAR.LT.0 .OR. IPAR.LT.0) GO TO 1999 IPASYM=2*KPAR+IPAR RETURN END SUBROUTINE ISUTP(ISU,EN,JTL,JST,JT,NVC,NQL,QLS,QLT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION QLS(NVC,NVC),QLT(NVC,NVC,NQL) IF (ISU.LE.0) RETURN WRITE(ISU,3232) EN,JTL,JST,JT 3232 FORMAT(' ENERGY',F10.3,' JTOT',3I6) WRITE(ISU,3233) ((QLS(IV,IVP),IV=1,NVC),IVP=1,NVC) 3233 FORMAT(1P,5D16.8) WRITE(ISU,3233) (((QLT(IV,IVP,L),IV=1,NVC),IVP=1,NVC),L=1,NQL) RETURN END SUBROUTINE IVCHK(IVLFL,IPRINT,ITYPE,NLABV,MXLAM,NPOTL,LAM) DIMENSION LAM(1),NLABV(9) C C THIS ROUTINE CHECKS LAMBDA (MOLSCAT POTENTIAL SYMMETRY INDICES) C TO ASCERTAIN WHETHER IV() INDEXING SCHEME ('NON-TRIVIAL' CASES) C WILL WORK. IMPLEMENTATION BEGINNING V9 WILL **NOT** WORK C PROPERLY IF TWO OF THE 'SYMMETRIES' ARE IDENTICAL. C C SINCE WE HAVE ACCESS TO ITYPE/NPOTL, WE COULD ALSO CHECK WHETHER C NPOTL IS BIG ENOUGH; NOT DONE IN CURRENT CODE. C LOGICAL OKEY,LTEST C C CALLED FROM DRIVER AFTER BASIN(IOSBIN)/POTENL(INITIZATION) C IF (IVLFL.LE.0) THEN IF (IPRINT.GE.3) 1 WRITE(6,*) ' IVCHK. IV() INDEXING IS NOT REQUESTED.' RETURN ENDIF IF (MXLAM.LE.1) THEN IF (IPRINT.GE.3) WRITE(6,*) ' IVCHK. NOT NEEDED, MXLAM.LE.1 ' RETURN ENDIF C ITP=ITYPE-10*(ITYPE/10) IF (ITP.EQ.0) THEN WRITE(6,*) ' *** IVCHK. ILLEGAL ITYPE',ITYPE STOP ENDIF NQ=NLABV(ITP) OKEY=.TRUE. DO 1000 I1=2,MXLAM ITOP=I1-1 DO 1000 I2=1,ITOP C LTEST IS TRUE IF LAM(,I1) IDENTICAL TO LAM(,I2) C FALSE IF ANY INDICES DIFFER LTEST=.TRUE. DO 1100 N=1,NQ 1100 LTEST=LTEST.AND.LAM((I2-1)*NQ+N).EQ.LAM((I1-1)*NQ+N) IF (.NOT.LTEST) GO TO 1000 C IF WE REACH CODE BELOW,TWO SETS OF INDICES ARE IDENTICAL IF (OKEY) WRITE(6,600) OKEY=.FALSE. WRITE(6,601) I1,(LAM((I1-1)*NQ+N),N=1,NQ) WRITE(6,601) I2,(LAM((I2-1)*NQ+N),N=1,NQ) 600 FORMAT('0 *** IVCHK. IV() INDEXING WILL NOT WORK. TERMINATING'/ 1 ' *** IDENTICAL INDICES FOR TWO SYMMETRIES IN LAMBDA()'/ 2 ' *** SYMMETRY/ INDICES') 601 FORMAT(9X,I5,10I6) 1000 CONTINUE IF (OKEY) THEN IF (IPRINT.GE.3) WRITE(6,*) ' IVCHK. COMPLETED SUCCESSFULLY.' RETURN ENDIF STOP END SUBROUTINE J3J000(J2,J3,IVAL,W3J,J1MIN) IMPLICIT DOUBLE PRECISION (A-H,J-M,O-Z) DIMENSION W3J(1) C A(J1)=SQRT((J1*J1-DJ23S)*(J23P1S-J1*J1)) C DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/,HALF/0.5D0/,ONPO/1.1D0/, $ MZERO/1.0D-34/,TENTH/0.1D0/ C C THIS SUBROUTINE CALCULATES A SEQUENCE OF 3-J SYMBOLS FOR FIXED J2, C J3, M2=M3=0 FOR J1MIN.LE.J1.LE.J1MAX USING THE RECURSIVE METHOD OF C K. SCHULTEN AND R. G. GORDON, J. MATH. PHYS., VOL. 10, P. 1971, C (1975). PROGRAMMED BY D. E. FITZ, 9/16/79. C C NOT TESTED FOR HALF-INTEGER QUANTUM NUMBERS. C JJ2P1=J2*(J2+ONE) JJ3P1=J3*(J3+ONE) DJ23S=(J2-J3)**2 J23P1S=(J2+J3+ONE)**2 J1MIN=ABS(J2-J3) J1MAX=J2+J3 SGNV=J2-J3 SGN=ONE IF(SGNV.LT.ZERO) SGN=-ONE ISGN=INT(SGNV+SGN*TENTH) SGN=ONE IF(MOD(ISGN,2).NE.0) SGN=-ONE IVAL=INT(J1MAX-J1MIN+TENTH)/2+1 C C RIGHT RECURSION. C 20 NMID=IVAL/2+1 W3J(1)=HALF IF(IVAL.EQ.1) GO TO 40 J1=J1MIN DO 21 IM2=2,NMID J1=J1+TWO 21 W3J(IM2)=-A(J1-ONE)*W3J(IM2-1)/A(J1) IF(IVAL.EQ.2) GO TO 40 SCALE=W3J(NMID) C C LEFT RECURSION. C 30 W3J(IVAL)=HALF J1=J1MAX IEND=IVAL-NMID DO 32 IM2=1,IEND W3J(IVAL-IM2)=-A(J1)*W3J(IVAL-IM2+1)/A(J1-ONE) 32 J1=J1-TWO C C MATCH LEFT AND RIGHT RECURSIVE RESULTS BY SCALING. C 31 SCALE=SCALE/W3J(NMID) DO 33 IM2=NMID,IVAL 33 W3J(IM2)=SCALE*W3J(IM2) C C NORMALIZE RESULTS AND SET PHASE. C 40 SUM=ZERO DO 41 IM2=1,IVAL J1=J1MIN+TWO*DBLE(IM2-1) 41 SUM=SUM+(TWO*J1+ONE)*W3J(IM2)**2 RNORM=ONE/SQRT(SUM) IF((SGN*W3J(IVAL)).LT.ZERO) RNORM=-RNORM DO 42 IM2=1,IVAL 42 W3J(IM2)=W3J(IM2)*RNORM RETURN END SUBROUTINE J6J(J2,J3,L1,L2,L3,IVAL,J1MIN,D6J) IMPLICIT DOUBLE PRECISION (A-H,J-Z) DIMENSION D6J(2) DATA ZERO/0.D0/,TENTH/0.1D0/,HALF/0.5D0/,ONE/1.D0/,TWO/2.D0/, $ CONST/1.0D-12/ E(J1S)=SQRT((J1S-MJ23S)*(J23P1S-J1S)*(J1S-ML23S)*(L23P1S-J1S)) F(J1,JJP1)=(TWO*J1+ONE)*(JJP1*(FACT-JJP1-TWO*LLP1)+FACT2) C C THIS ROUTINE CALCULATES THE 6-J COEFFICIENTS FOR ALL PERMISSIBLE C VALUES OF J1 FOR FIXED VALUES OF J2, J3, L1, L2, AND L3 USING THE C RECURSIVE ALGORITHM OF K. SCHULTEN AND R. G. GORDON, J. MATH. PHYS. C VOL. 16, P. 1961, (1975). C PROGRAMMED BY D. E. FITZ, 10/22/79 C MODIFIED BY S. GREEN 20 AUG 93 TO TEST DIMENSION ON D6J C MXDIM=IVAL JJP2=J2*(J2+ONE) JJP3=J3*(J3+ONE) LLP1=L1*(L1+ONE) LLP2=L2*(L2+ONE) LLP3=L3*(L3+ONE) MJ23S=(J2-J3)**2 ML23S=(L2-L3)**2 J23P1S=(J2+J3+ONE)**2 L23P1S=(L2+L3+ONE)**2 FACT2=(LLP2-LLP3)*(JJP2-JJP3) FACT=JJP2+JJP3+LLP2+LLP3 J1MIN=MAX(ABS(J2-J3),ABS(L2-L3)) J1MAX=MIN(J2+J3,L2+L3) IVAL=INT(J1MAX-J1MIN+ONE+TENTH) IF (IVAL.GT.MXDIM) THEN WRITE(6,*) 'J6J: ARRAY D6J TOO SMALL. NEEDS ',IVAL,' BUT ONLY ', 1 MXDIM,' SUPPLIED' STOP ENDIF C C TEST FOR OTHER TRIANGULAR INEQUALITES. C IL1=INT(TWO*L1+TENTH) IL2=INT(TWO*L2+TENTH) IL3=INT(TWO*L3+TENTH) IJ2=INT(TWO*J2+TENTH) IJ3=INT(TWO*J3+TENTH) IF((IJ2.LE.IL1+IL3.AND.IJ2.GE.IABS(IL1-IL3)).AND. $ (IJ3.LE.IL1+IL2.AND.IJ3.GE.IABS(IL1-IL2))) GO TO 11 DO 12 I=1,IVAL 12 D6J(I)=ZERO RETURN C 11 INMID=(IVAL+3)/2 SGNV=J2+J3+L2+L3 SGN=ONE ISIGN=INT(SGNV+TENTH) IF(MOD(ISIGN,2).NE.0) SGN=-ONE D6J(1)=HALF C C UPWARD RECURSION. C IF(IVAL.EQ.1) GO TO 40 JJP1=J1MIN*(J1MIN+ONE) F1=F(J1MIN,JJP1) J1=J1MIN+ONE J1S=J1*J1 E2=E(J1S) IF(J1MIN.LT.TENTH) GO TO 15 D6J(2)=-F1*D6J(1)/(E2*J1MIN) GO TO 16 15 D6J(2)=-HALF*(LLP2+JJP2-LLP1)*D6J(1)/SQRT(JJP2*LLP2) 16 SCALE=D6J(2) IF(IVAL.EQ.2) GO TO 40 DO 21 IJ2=3,INMID JJP1=J1*(J1+ONE) F1=F(J1,JJP1) J1=J1+ONE E1=E2 J1S=J1*J1 E2=E(J1S) 21 D6J(IJ2)=-(F1*D6J(IJ2-1)+J1*E1*D6J(IJ2-2))/(E2*(J1-ONE)) SCALE=D6J(INMID) IEXC=5 IF(ABS(SCALE).GT.CONST) GO TO 18 INMID=INMID-1 SCALE=D6J(INMID) IEXC=3 GO TO 30 18 IF(IVAL.EQ.3) GO TO 40 C C DOWNWARD RECURSION. C 30 D6J(IVAL)=HALF J1=J1MAX J1S=J1*J1 JJP1=J1*(J1+ONE) F1=F(J1,JJP1) E1=E(J1S) D6J(IVAL-1)=-F1*D6J(IVAL)/(E1*(J1+ONE)) IEND=IVAL-INMID IF(IVAL.LE.IEXC) GO TO 31 DO 32 IJ2=2,IEND J1=J1-ONE E2=E1 J1S=J1*J1 JJP1=J1*(J1+ONE) E1=E(J1S) F1=F(J1,JJP1) 32 D6J(IVAL-IJ2)=-(J1*E2*D6J(IVAL-IJ2+2)+F1*D6J(IVAL-IJ2+1))/ $ (E1*(J1+ONE)) C C MATCH UPWARD AND DOWNWARD RECURSIVE RESULTS BY SCALING. C 31 SCALE=SCALE/D6J(INMID) DO 33 IJ2=INMID,IVAL 33 D6J(IJ2)=SCALE*D6J(IJ2) C C NORMALIZE RESULTS AND SET PHASE. C 40 SUM=ZERO DO 41 IJ2=1,IVAL J1=J1MIN+DBLE(IJ2-1) 41 SUM=SUM+(TWO*J1+ONE)*D6J(IJ2)**2 RNORM=ONE/SQRT(SUM*(TWO*L1+ONE)) IF((SGN*D6J(IVAL)).LT.ZERO) RNORM=-RNORM DO 42 IJ2=1,IVAL 42 D6J(IJ2)=D6J(IJ2)*RNORM RETURN END SUBROUTINE J6TO4(NLEV,JLEV,ATAU,JLNW,NAVAIL,ELEVNW,JLEVNW) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION JLEV(1),ATAU(1),JLNW(NAVAIL),ELEVNW(MXEL),JLEVNW(MXJL) C CMBASE FOR VERSION 14 (AUG 94) DIMENSION BE(2),ALPHAE(2),DE(2) EQUIVALENCE (BE(1),AAE(1)), (ALPHAE(1),BBE(1)), (DE(1),CCE(1)) COMMON /CMBASE/ AAE(2),BBE(2),CCE(2),ROTI(6),ELEVEL(1000),EMAX, 1 WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10), 2 J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL C C WE MUST BE ABLE TO GET J2 FROM J2MIN,J2MAX,J2STEP C AND CALCULATE LINEAR ROTOR ENERGY FROM BE(2) WRITE(6,641) J2MIN,J2MAX,J2STEP 641 FORMAT(/' *** J6TO4. COMBINING ASYMMETRIC ROTOR AND LINEAR ROTOR' 1 /' LINEAR ROTOR LEVELS FROM J2MIN =',I3, 2 ', J2MAX =',I3,', J2STEP =',I2) J2MIN=MAX0(J2MIN,0) J2MAX=MAX0(J2MAX,J2MIN) J2STEP=MAX0(J2STEP,1) IF (BE(2).LE.0.D0) THEN IF (J2MAX.EQ.0) THEN C SET ARBITRARY BE(2) SINCE ENERGY WILL ALWAYS BE ZERO BE(2)=1.D0 ELSE WRITE(6,*) ' *** SET4/J6TO4. CANNOT OBTAIN LINEAR ROTOR', 1 ' ENERGY FROM BE(2)' STOP ENDIF ENDIF WRITE(6,644) BE(2) 644 FORMAT(/' LINEAR ROTOR ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) IF (ALPHAE(2).NE.0.D0) WRITE(6,645) ALPHAE(2) 645 FORMAT(27X,'CORRECTED FOR ALPHA(E) = ',F12.8) IF (DE(2).NE.0.D0) WRITE(6,646) DE(2) 646 FORMAT(27X,'CORRECTED FOR D(E) = ',F12.8) IF (EMAX.GT.0.D0) WRITE(6,648) EMAX 648 FORMAT(/' ENERGY CAP ON BASIS FUNCTIONS IS EMAX =',F14.4) C C NLNW COUNTS NEW 'NLEVEL'; INEW COUNTS NEW 'NLEV' MINA=9999999 MAXA=0 INEW=0 NLNW=0 ITOP=0 NKVAL=0 MXNEW=NAVAIL/8 C LOOP OVER ITYPE=6 FORMAT IN JLEV(NLEV,6) JMIN=9999999 JMAX=0 DO 1000 IOLD=1,NLEV J1=JLEV(IOLD) ITAU=JLEV(NLEV+IOLD) IPAR=JLEV(2*NLEV+IOLD) ISTA=JLEV(3*NLEV+IOLD) NK=JLEV(4*NLEV+IOLD) MINA=MIN(MINA,ISTA+1) MAXA=MAX(MAXA,ISTA+NK) NKVAL=NKVAL+NK INDX=JLEV(5*NLEV+IOLD) IF (INDX.NE.IOLD) WRITE(6,690) INDX,IOLD 690 FORMAT(' *** J6TO4. PROBABLY ERROR. INDX.NE.I',2I6) C EXPAND ON J2 DO 2000 J2=J2MIN,J2MAX,J2STEP FJ=DBLE(J2) FJ=FJ*(FJ+1.D0) E2=(BE(2)-ALPHAE(2)*0.5D0)*FJ - DE(2)*FJ*FJ EN=ELEVEL(INDX) + E2 IF (EMAX.GT.0.D0 .AND. EN.GT.EMAX) GO TO 2000 NLNW=NLNW+1 IF (NLNW.GT.MXEL) THEN WRITE(6,*) ' *** J6TO4. NUMBER LEVELS EXCEEDS MXEL',MXEL STOP ENDIF ELEVNW(NLNW)=EN JLEVNW(3*NLNW-2)=J1 JLEVNW(3*NLNW-1)=ITAU JLEVNW(3*NLNW)=J2 IF (JLEVEL(2*INDX-1).NE.J1 .OR. JLEVEL(2*INDX).NE.ITAU) THEN WRITE(6,*) ' *** J6TO4. INCOMPATIBLE JLEVEL(), JLEV() FOR' WRITE(6,*) ' LEVEL',INDX ENDIF C EXPAND J1+J2 TO J12; NEED TO SET JMIN,JMAX TO MIN/MAX OF J12 C FOR USE IN PICKING ORBITAL MOMENTA FOR A GIVEN JTOT DO 3000 J12=ABS(J1-J2),J1+J2 INEW=INEW+1 IF (INEW.GT.MXNEW) THEN WRITE(6,*) ' *** J6TO4. SCRATCH SPACE EXCEEDED FOR BASIS NO.' 1 ,INEW STOP ENDIF JLNW(ITOP+1)=J12 JLNW(ITOP+2)=J2 JLNW(ITOP+3)=J1 JLNW(ITOP+4)=ITAU JLNW(ITOP+5)=IPAR JLNW(ITOP+6)=ISTA JLNW(ITOP+7)=NK JLNW(ITOP+8)=NLNW JMIN=MIN(JMIN,J12) JMAX=MAX(JMAX,J12) 3000 ITOP=ITOP+8 2000 CONTINUE 1000 CONTINUE C C COPY JLEVNW,ELEVNW BACK TO JLEVEL,ELEVEL DO 4000 I=1,NLNW ELEVEL(I)=ELEVNW(I) JLEVEL(3*I-2)=JLEVNW(3*I-2) JLEVEL(3*I-1)=JLEVNW(3*I-1) 4000 JLEVEL(3*I)=JLEVNW(3*I) C SHIFT ATAU UP TO REFLECT START AT 6*NLEV+1 TO 8*INEW+1 IF (NKVAL.NE.MAXA-MINA+1) 1 WRITE(6,*) ' POSSIBLE ERROR. MINA,MAXA,NKVAL',MINA,MAXA,NKVAL MOVE=8*INEW-6*NLEV DO 4500 I=1,NKVAL 4500 ATAU(8*INEW+NKVAL+1-I)=ATAU(6*NLEV+NKVAL+1-I) C SHIFT ISTA (JLNW(6,I)) TO REFLECT MOVED ATAU IX=6 DO 4600 I=1,INEW JLNW(IX)=JLNW(IX)+MOVE 4600 IX=IX+8 C RESET NLEV; COPY JLNW TO JLEV, CORRECTING ORDER NLEV=INEW ITOP=0 DO 5000 I=1,NLEV IX=I DO 5100 II=1,8 ITOP=ITOP+1 JLEV(IX)=JLNW(ITOP) 5100 IX=IX+NLEV 5000 CONTINUE RETURN END SUBROUTINE J9J(J1,J2,J4,J5,J6,J7,J8,J9,IVAL,J3MIN,D9J) IMPLICIT DOUBLE PRECISION (A-H,J-Z) DIMENSION D9J(1),D6J3(200),D6J5(200),D6J7(200) DATA MXDIM6/200/ DATA ZERO/0.D0/,TENTH/0.1D0/,HALF/0.5D0/,ONE/1.D0/,TWO/2.D0/ C C THIS ROUTINE CALCULATES THE 9-J SYMBOLS BY SUMMATION OVER 6-J C SYMBOLS WHICH IN TURN ARE CALCULATED BY THE RECURSIVE METHOD C OF SCHULTEN AND GORDON. C PROGRAMMED BY D. E. FITZ, 22 OCT 79. C C MODIFIED BY M. L. DUBERNET, 15 SEP 93 AND J. M. HUTSON, 3 OCT 93 C TO ALLOW HALF-INTEGER ANGULAR MOMENTA C MODIFIED BY J. M. HUTSON, 3 OCT 93 TO CHECK D9J DIMENSION C MXDIM9=IVAL J3MIN=MAX(ABS(J1-J2),ABS(J6-J9)) J3MAX=MIN(J1+J2,J6+J9) IJ3N=INT(TWO*J3MIN+TENTH) IJ3X=INT(TWO*J3MAX+TENTH) IVAL=1+(IJ3X-IJ3N)/2 IF(IVAL.GT.MXDIM9) THEN WRITE(6,*) 'J9J: ARRAY D9J TOO SMALL. NEEDS ',IVAL,' BUT ONLY ', 1 MXDIM9,' SUPPLIED' STOP ENDIF C C TEST FOR TRIANGULAR INEQUALITIES. C D9J(1)=ZERO IF (IVAL.LE.0) RETURN IJ1=INT(TWO*J1+TENTH) IJ2=INT(TWO*J2+TENTH) IJ4=INT(TWO*J4+TENTH) IJ5=INT(TWO*J5+TENTH) IJ6=INT(TWO*J6+TENTH) IJ7=INT(TWO*J7+TENTH) IJ8=INT(TWO*J8+TENTH) IJ9=INT(TWO*J9+TENTH) DO 15 IJL=1,IVAL 15 D9J(IJL)=ZERO IF((IJ4-IABS(IJ7-IJ1))*(IJ7+IJ1-IJ4).LT.0) RETURN IF((IJ5-IABS(IJ8-IJ2))*(IJ8+IJ2-IJ5).LT.0) RETURN IF((IJ5-IABS(IJ6-IJ4))*(IJ6+IJ4-IJ5).LT.0) RETURN IF((IJ8-IABS(IJ9-IJ7))*(IJ9+IJ7-IJ8).LT.0) RETURN C IVAL7=MXDIM6 CALL J6J(J1,J9,J7,J8,J4,IVAL7,JMIN7,D6J7) C IVAL5=MXDIM6 CALL J6J(J6,J2,J5,J8,J4,IVAL5,JMIN5,D6J5) C JMIN=MAX(JMIN5,JMIN7) JMAX=MIN(J1+J9,J2+J6,J4+J8) IEND=INT(JMAX-JMIN+TENTH+ONE) I5=INT(JMIN-JMIN5+TENTH) I7=INT(JMIN-JMIN7+TENTH) C C LOOP RUNS OVER TWICE J3 TO ALLOW HALF-INTEGER VALUES C ITAB=0 DO 20 IJ3=IJ3N,IJ3X,2 ITAB=ITAB+1 J3=HALF*DBLE(IJ3) C IVAL3=MXDIM6 CALL J6J(J1,J9,J3,J6,J2,IVAL3,JMIN3,D6J3) I3=INT(JMIN-JMIN3+TENTH) SUM=ZERO C DO 10 I=1,IEND J=DBLE(I-1)+JMIN SGN=ONE ISIGN=INT(TWO*J+TENTH) IF(MOD(ISIGN,2).NE.0) SGN=-ONE SUM=SUM+(TWO*J+ONE)*SGN*D6J3(I+I3)*D6J5(I+I5)*D6J7(I+I7) 10 CONTINUE D9J(ITAB)=SUM 20 CONTINUE RETURN END SUBROUTINE KSYM(AK,N) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION AK(N,N) DO 10 I=1,N DO 10 J=1,I TMP=0.5D0*(AK(I,J)+AK(J,I)) AK(I,J)=TMP AK(J,I)=TMP 10 CONTINUE RETURN END SUBROUTINE KTOS(R,SR,SI,NOP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION R(1),SR(1),SI(1) C C ROUTINE TO OBTAIN THE S MATRIX FROM THE REACTANCE (K) MATRIX C ALTHOUGH THIS ROUTINE USES SYMMETRIC MATRIX MULTIPLICATION, C THE WHOLE OF R MUST BE SUPPLIED AND THE WHOLE OF SR AND C SI ARE RETURNED. C C I + R*R IS POSITIVE DEFINITE, SO SYMINV CANNOT FAIL C NOPP1=NOP+1 NOPSQ=NOP*NOP CALL DSYMM('L','L',NOP,NOP,0.5D0,R,NOP,R,NOP,0.D0,SR,NOP) DO 10 II=1,NOPSQ,NOPP1 10 SR(II)=SR(II)+0.5D0 CALL SYMINV(SR,NOP,NOP,IFAIL) CALL DSYFIL('U',NOP,SR,NOP) CALL DSYMM('L','L',NOP,NOP,1.D0,SR,NOP,R,NOP,0.D0,SI,NOP) DO 30 II=1,NOPSQ,NOPP1 30 SR(II)=SR(II)-1.D0 RETURN END SUBROUTINE LDPROP(U,Z,N,RBEGIN,REND,NSTEP, X ESHIFT,IREAD,IWRITE,ISCRU, X P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL,ISTART,NODES) IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL IREAD,IWRITE DIMENSION U(N,N),Z(N,N),P(MXLAM),VL(2),IV(2),EINT(N),CENT(N),DG(N) C H = (REND-RBEGIN)/DBLE(2*NSTEP) D1 = H*H/3.D0 D2 = 2.D0*D1 D4 = -D1/16.D0 R = RBEGIN NODES=0 IF( .NOT. IREAD) GO TO 100 READ(ISCRU) U DO 90 I = 1,N 90 U(I,I)=U(I,I)-ESHIFT GO TO 110 100 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL) IF(IWRITE) WRITE(ISCRU) U C 110 IF(ISTART.EQ.1) GO TO 135 SGN=1.D0 IF(REND.LT.RBEGIN) SGN=-1.D0 DO 130 J = 1,N DO 120 I = J,N 120 Z(I,J) = 0.D0 Z(J,J) = SGN*1.D30 130 IF(U(J,J).GT.0.D0) Z(J,J) = SGN*SQRT(U(J,J)) 135 CONTINUE C DO 150 J = 1,N DO 140 I = J,N 140 Z(I,J) = H*Z(I,J)+D1*U(I,J) 150 Z(J,J) = 1.D0+Z(J,J) C DO 260 ISTEP = 1,NSTEP R = R+H IF( .NOT. IREAD) GO TO 160 READ(ISCRU) U ESH=-D4*ESHIFT DO 155 I=1,N 155 U(I,I)=U(I,I)+ESH GO TO 190 160 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL) DO 180 J = 1,N DO 170 I = J,N 170 U(I,J) = D4*U(I,J) 180 U(J,J) = 0.125D0+U(J,J) IF(IWRITE) WRITE(ISCRU) U 190 CALL SYMINV(U,N,N,NCU) IF(NCU.GT.N) GO TO 900 CALL SYMINV(Z,N,N,NCZ) IF(NCZ.GT.N) GO TO 900 NODES=NODES+NCZ DO 210 J = 1,N DO 200 I = J,N 200 Z(I,J) = U(I,J)-Z(I,J) 210 Z(J,J) = Z(J,J)-6.D0 CALL SYMINV(Z,N,N,NCZ) IF(NCZ.GT.N) GO TO 900 NODES=NODES+NCZ-NCU R = R+H IF(ISTEP.EQ.NSTEP) D2=D1 IF( .NOT. IREAD) GO TO 220 READ(ISCRU) U ESH=-D2*ESHIFT DO 215 I=1,N 215 U(I,I)=U(I,I)+ESH GO TO 245 220 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL) DO 240 I=1,N DO 230 J=1,I 230 U(I,J)=D2*U(I,J) 240 U(I,I)=U(I,I)+2.D0 IF(IWRITE) WRITE(ISCRU) U 245 DO 250 J = 1,N DO 250 I = J,N 250 Z(I,J) = U(I,J)-Z(I,J) 260 CONTINUE C HI = 1.D0/H DO 280 J = 1,N DO 270 I = J,N Z(I,J) = HI*Z(I,J) 270 Z(J,I) = Z(I,J) 280 Z(J,J) = Z(J,J)-HI RETURN C 900 WRITE(6,901) 901 FORMAT('0 *** ERROR IN SYMINV CALLED FROM LDPROP - TERMINATING') STOP END SUBROUTINE LDVIVS(N,NSQ,MXLAM,NPOTL, 1 SR,SI,W,VL,IVL,EINT,CENT,WV,L,NB, 2 P,A1,A1P,B1,B1P, 3 WKS,G1,G1P,G2,G2P,COSX,SINX,SINE,DIAG,XK,XSQ, 4 TSTORE,W0,W1,W2,EYE11,EYE12,EYE22,VEC, 5 ICODE,IPRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C *** C *** INTERFACE TO VIVAS/LDPROP C *** ------------------------------------------------------------- C *** ADAPTED FROM PROGRAMS OF G.A. PARKER, J.V. LILL, & J.C. LIGHT C *** REF.: N.R.C.C. SOFTWARE CATALOG, VOL. 1, PROG. NO. KQ04, 1980. C *** ------------------------------------------------------------- C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGY. C *** DIMENSION SR(NSQ),SI(NSQ),W(NSQ),VL(2),IVL(2), 1 EINT(N),CENT(N),WV(N),L(N),NB(N), 2 P(MXLAM),A1(N),A1P(N),B1(N),B1P(N), 3 WKS(N),G1(N),G1P(N),G2(N),G2P(N), 4 COSX(N),SINX(N),SINE(N),DIAG(N),XK(N),XSQ(N), 5 TSTORE(NSQ),W0(NSQ),W1(NSQ),W2(NSQ), 6 EYE11(NSQ),EYE12(NSQ),EYE22(NSQ),VEC(NSQ) C COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR, 1 DRMAX,RVIVAS,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, 2 NOPEN,JKEEP,ISCRU,MAXSTP C LOGICAL IALFP,IV,IVP,IVPP,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE COMMON /LDVVCM/ XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP, 1 NUMDER,IVPP,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE C C LOGICAL VARIABLES LOGICAL LLD,LVIVS C C----------------------------------------------------------------- C SET UP TO USE UNIT (ISCRU) IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 C------------------------------------------------------------------- IF(IWRITE) WRITE(ISCRU) RMIN,RVIVAS,RMAX IF(IREAD) READ (ISCRU) RMIN,RVIVAS,RMAX C C DECIDE WHICH CALCULATIONS (LDPROP/VIVAS) ARE DESIRED C LLD= RMIN.LT.RVIVAS LVIVS= RMAX.GT.RVIVAS IF (LLD.OR.LVIVS) GO TO 130 WRITE(6,699) RMIN,RVIVAS,RMAX 699 FORMAT('0 * * * ERROR. NULL CALCULATION REQUESTED.'/ & ' RMIN, RVIVAS, RMAX =',3E14.4) STOP C 130 RMID=MIN(RMAX,RVIVAS) RMID=MAX(RMIN,RMID) C C CALCULATE WAVEVECTORS, AND STEP SIZE FOR LDPROP C BIG=0.D0 NOPEN=0 DO 190 I=1,N DIF=ERED-EINT(I) WV(I)=SIGN(SQRT(ABS(DIF)),DIF) BIG=MAX(BIG,WV(I)) NB(I)=I 190 IF(DIF.GT.0.D0) NOPEN=NOPEN+1 IF(NOPEN.LE.0) RETURN IF(IREAD) THEN READ(ISCRU) NSTEP ELSE NSTEP=BIG*STEPS*(RMID-RMIN)/ACOS(-1.D0) IF(IWRITE) WRITE(ISCRU) NSTEP ENDIF LLD = LLD .AND. NSTEP.GT.0 C------------------------------------------------------------------- C PROPAGATE THE LOG-DERIVATIVE MATRIX THROUGH THE SCATTERING REGION IF (.NOT.LLD) GO TO 200 CALL LDPROP(W,SR,N,RMIN,RMID,NSTEP, & ESHIFT,IREAD,IWRITE,ISCRU, & P,VL,IVL,ERED,EINT,CENT,RMLMDA,A1,MXLAM,NPOTL,0,NODES) IF(IPRINT.GE.3) WRITE(6,195) RMIN,RMID,NSTEP 195 FORMAT('0 LDPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ', & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') 200 IF (.NOT.LVIVS) GO TO 210 C GET R-MATRIX BY INVERTING LOGD OR BY DIRECT INITIALIZATION IF (LLD) THEN CALL SYMINV(SR,N,N,IFAIL) CALL DSYFIL('U',N,SR,N) ELSE N1=N+1 DO 170 I=1,NSQ 170 SR(I)=0.D0 DO 180 I=1,NSQ,N1 180 SR(I)=1.D30 ENDIF DRNOW=DR C SET TLDIAG/TOFF FROM TOLHI. C.F. NRCC DEFAULTS OF .064 TLDIAG=.064D0*SQRT(TOLHI/.001D0) TOFF=TLDIAG CALL VIVAS(N,NSQ,DRNOW,RMID,RMAX,DRMAX,TLDIAG,TOFF,ESHIFT, & SR,EYE11,EYE12,EYE22,W,W0,W1,W2,TSTORE,VEC,SI, & G1,G1P,G2,G2P,A1,A1P,B1,B1P,XSQ,XK,COSX, & SINX,SINE,DIAG,NOPEN,IPRINT,ISCRU, & P,VL,IVL,ERED,EINT,CENT,RMLMDA,MXLAM,WKS,NPOTL) C AND CONVERT R-MATRIX BACK TO LOGD MATRIX CALL SYMINV(SR,N,N,IFAIL) C------------------------------------------------------------------ C SORT CHANNELS BY ASYMPTOTIC ENERGY C 210 IF(N.LE.1) GOTO 230 NM1=N-1 DO 220 I=1,NM1 IP1=I+1 DO 220 J=IP1,N IF(EINT(NB(I)).LE.EINT(NB(J))) GOTO 220 IT=NB(I) NB(I)=NB(J) NB(J)=IT 220 CONTINUE C------------------------------------------------------------- C CALCULATE K AND S MATRICES 230 CALL YTOK(NB,WV,L,N,NOPEN,A1,A1P,B1,B1P,SR,SI,W,RMAX) CALL KTOS(W,SR,SI,NOPEN) RETURN END SUBROUTINE MASK RETURN END * ---------------------------------------------------------------------- SUBROUTINE MAXMGV (A, NA, C, NC, N) * SUBROUTINE TO SCAN A VECTOR FOR ITS MAXIMUM MAGNITUDE (ABSOLUTE VAL * ELEMENT * CURRENT REVISION DATE: 24-SEPT-87 * ------------------------------------------------------------------- * VARIABLES IN CALL LIST: * A: FLOATING POINT INPUT VECTOR * NA: INTEGER ELEMENT STEP FOR A * C: FLOATING POINT OUTPUT SCALAR: ON RETURN CONTAINS VALUE OF * MAXIMUM MAGNITUDE (ABSOLUTE VALUE) ELEMENT * NC: INTEGER INDEX OF MAXIMUM MAGNITUDE ELEMENT * N: INTEGER ELEMENT COUNT * SUBROUTINES CALLED: * IDAMAX: BLAS ROUTINE TO FIND INDEX OF MAXIMUM MAGNITUDE (ABSOLUTE V * ELEMENT * ------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER IDAMAX, N, NA, NC DIMENSION A(1) NC = ( IDAMAX (N, A, NA) - 1) * NA + 1 C = ABS( A(NC) ) RETURN END SUBROUTINE MCGCPL(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,MVALUE,ITYPE, 1 IEX,VL,IV,PRINT) C MODIFIED FOR ITYPE=4 BY SG 29 JUN 94 IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE LFIRST INTEGER PRINT INTEGER LAM(2),JLEV(NLEV,3),J(2),L(2),IV(1) DIMENSION VL(2) LOGICAL LFIRST C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA SQRTHF/.70710678118654753D0/, Z0/0.D0/ C STATEMENT FUNCTION DEFINITION . . . Z(I)=DBLE(I+I+1) C IF (ITYPE.EQ.21) GO TO 1000 IF (ITYPE.EQ.22) GO TO 2000 IF (ITYPE.EQ.23) GO TO 3000 IF (ITYPE.EQ.24) GO TO 4000 IF (ITYPE.EQ.25) GO TO 5000 IF (ITYPE.EQ.26) GO TO 6000 IF (ITYPE.EQ.27) GO TO 7000 STOP C 1000 IF (IVLFL.NE.0) GO TO 9999 CALL CPL21(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) RETURN C 2000 IF (IVLFL.LE.0) GO TO 9999 CALL CPL22(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,MVALUE, 1 IV,VL,PRINT,LFIRST) RETURN C 3000 IF (IVLFL.NE.0) GO TO 9999 CALL CPL23(N,MXLAM,LAM,NLEV,JLEV,J,L,MVALUE,IEX,VL,PRINT,LFIRST) RETURN C CTRP>> JUN94 (SG) 4000 CALL CPL24(N,MXLAM,LAM,NLEV,JLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) RETURN C< 0, THEN SUBROUTINE CALLED AT SUBSEQUENT ENERGY OF MU * ENERGY CALCULATION, SO TRANSFORMATION MATRIX AND RELEVANT * INFORMATION WILL BE READ * --------------------------------------------------------------------- C C ----- ADAPTED TO MOLSCAT BY TRP AT NASAGISS, MAY 1991 ----- C ----- ISCRU IS UNIT NUMBER ----- C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER I, ITWO, NMAX LOGICAL ISECND DIMENSION EIGOLD(1), HP(1), TMAT(1) ISECND = .FALSE. IF (ITWO .GT. 0) ISECND = .TRUE. * IF FIRST ENERGY CALCULATION, ISECND = .FALSE. * IN WHICH CASE LOGICAL UNIT ISCRU WILL BE WRITTEN * IF SUBSEQUENT ENERGY CALCULATION, ISECND = .TRUE. * IN WHICH CASE LOGICAL UNIT ISCRU WILL BE WRITTEN * READ/WRITE RNOW, DRNOW, DIAGONAL ELEMENTS OF TRANSFORMED DW/DR MATRIX * AND DIAGONAL ELEMENTS OF TRANSFORMED W MATRIX NSQ = NMAX * NMAX IF (ISECND) THEN READ (ISCRU) RNOW, DRNOW, (HP(I) , I = 1, N), : (EIGOLD(I) , I = 1, N), (TMAT(I), I=1, NSQ) ELSE WRITE (ISCRU) RNOW, DRNOW, (HP(I) , I = 1, N), : (EIGOLD(I) , I = 1, N), (TMAT(I), I=1, NSQ) ENDIF * NOW SHIFT ENERGIES (IF SUBSEQUENT ENERGY) IF (ISECND) THEN DO 30 I = 1, N EIGOLD(I) = EIGOLD(I) + ESHIFT 30 CONTINUE END IF RETURN END SUBROUTINE OUTPUT( JTOT, NBASIS, J, L, WVEC, SREAL, SIMAG, 1 AKMAT, CONV, NOPEN, M, MXPAR, WT, IEXCH, INRG, RM, PRNT, TTIME, 2 ENERGY, SIG, JLEV, ISST, IECONV, MINJT, MAXJT, 3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE INVERR,NSTOR,ITYPE,NLEVEL,LOUT,JSTEP C C FOR MOLSCAT VERSION 14, JUL 1994 C WITH RESTART (IRSTRT) CAPABILITIES C C ENTRY OUTPUT - PROCESSES S MATRICES TO X-SECTIONS OUTPUTS THEM. C ENTRY OUTSIG - (10/92) SEPARATE ENTRY TO UPDATE UNIT(ISIGU) C TO FIX BUG W/ NO BASIS FNS FOR PARITY M=MXPAR C ENTRY OUTINT - INITIALIZATION ENTRY FROM DRIVER. C ENTRY OUTPCH - PUNCHES FINAL CROSS SECTIONS. C ENTRY OUTERR - SETS ERROR FLAG, CALLED ONLY FROM DVSCAT. C C MODIFICATIONS AUG. 74 - - - C NLEVEL IS DIFFERENT FROM NLEV. FORMER FOR ELEVEL,JLEVEL, C AND LATTER FOR JLEV(NLEV,NQN). C TSIG IS NOW FIRST NLEVEL*NLEVEL=NSTOR ELEMENTS OF SIG. C DEGENERACY IS IN 2ND NSTOR ELEMENTS OF SIG. C MODIFIED NOV 91 - - - MULTIPLIES CROSS SECTIONS BY JSTEP C MODIFIED JUN 92 TO GIVE UNFORMATTED ISAVEU OUTPUT W/ ONLY C NONREDUNDANT S(I,J). OLDER (FORMATTED) CODE IS SAVED AS C COMMENTS TO PROVIDE COMPATIBILITY W/ VERSION 10 AND EARLIER. C N.B FORMATS 800,801,802 ALSO USED FOR IPARTU OUTPUT. C SREAL,SIMAG ARE WRITTEN USING A SUBROUTINE SWRITE. C 21 JAN 93 -- NEW DYNAMIC MEMORY HANDLING C APR 94 -- MODIFED CALLING SEQUENCES, OUTPUT FORMATS C ACCOMMODATE NEGATIVE SIG-INDEX, JLEV((NQN-1)*NLEV+I) C DIMENSION NBASIS(1),J(1),L(1),WVEC(1),SREAL(1),SIMAG(1) DIMENSION AKMAT(NOPEN,NOPEN) INTEGER ISST(2),MAXJT(2),MINJT(2),IECONV(2) INTEGER PRINT,PRNT INTEGER NLEV,JLEV(1) DIMENSION SIG(1),ENERGY(1) LOGICAL OKEY,LOUT,ACCUM,OPENED,LWARN C INTEGER CTIME(2),CDATE(4) CHARACTER CTIME*9,CDATE*11 CHARACTER*4 LABEL(20) CHARACTER*1 STAR,BLANK C COMMON /CMBASE/ ROTI(12),ELEVEL(1004),IDUM(4031) EQUIVALENCE (JHALF,IDUM(4028)) C C COMMON BLOCK TO DRIVER FOR RESONANCE SEARCHES C COMMON/EIGSUM/EPSM(5) C EQUIVALENCE (NLVL,IDUM(1)) C DATA STAR/'*'/, BLANK/' '/ DATA EPS/1.D-12/ DATA IPUNCH/7/ C PI=ACOS(-1.D0) PI2=2.D0*PI C PRINT=PRNT C>>SG IEXCH=1 IRET=0 C C SET LOGICAL VARIABLES OKEY=CONV.GE.0.D0 .AND. IECONV(INRG).GE.0 ACCUM=OKEY .AND. INVERR.LE.0 .AND. ITYPE.NE.8 C C BOOKEEPING FOR MINJT AND MAXJT IF (MINJT(INRG).LT.0) MINJT(INRG)=JTOT IF (OKEY .AND. JTOT.GT.MAXJT(INRG) .AND. MAXJT(INRG).GE.0) & MAXJT(INRG)=JTOT C C PRINT OUT OPEN-CHANNEL BASIS FUNCTIONS AND WAVEVECTORS IN 1/A. IF (PRINT.GE.11) WRITE(6,601) 601 FORMAT('0 CHANNEL NO. TARGET LEVEL ORBITAL L WVEC(1/ANG.)') C CONVERT WVEC TO INVERSE ANGSTROMS DO 1000 I=1,NOPEN NB=NBASIS(I) WVEC(NB)=WVEC(NB)/RM IF (PRINT.GE.11) WRITE(6,602) I,J(NB),L(NB),WVEC(NB) 602 FORMAT(3I12,E18.8) 1000 CONTINUE C C C PROCESS S-MATRIX. ACCUMULATE X-SECTIONS IN TSIG. PRINT. C J(NBASIS(I)) IS LEVEL NUMBER OF ITH BASIS FN. IN ASYMPTOTIC AREA. C CLEAR TSIG. DO 1400 I=1,NSTOR 1400 SIG(I)=0.D0 IF (PRINT.GT.10) WRITE(6,606) 606 FORMAT('0 ROW COL',10X,'S**2',15X,'PHASE/2PI',12X,'RE (S)',14X, 1 'IM (S)' ) C IJ=0 NTOP=(NQN-1)*NLEV C CALCULATE GLOBAL MULTIPLICATIVE FACTOR FOR X-SECTIONS. XJ=DBLE((2/JHALF)*JTOT+1)*PI C>>SG CALCULATE (OR GET FROM PARM LIST) IEXCH -- FOR USE W/ISAVEU C IF (IEXCH.NE.0) XJ=XJ*WT IF (WT.GT.0.D0) XJ=XJ*WT DO 2000 ICOL=1,NOPEN LEVC=J(NBASIS(ICOL)) LCOL=JLEV(NTOP+LEVC) IF (LCOL.GT.0) THEN CS1=1.D0 ELSE CS1=-1.D0 LCOL=-LCOL ENDIF DO 2000 IROW=1,NOPEN DD=WVEC(NBASIS(IROW)) DD=DD*DD LEVR=J(NBASIS(IROW)) C IJ IS INDEX OF SREAL,SIMAG(IROW,ICOL) IJ=IJ+1 SMAG=( SREAL(IJ)*SREAL(IJ)+SIMAG(IJ)*SIMAG(IJ) ) IF (PRINT.LE.10 .OR. SMAG.LE.EPS) GO TO 2300 PHASE=ATAN2(SIMAG(IJ),SREAL(IJ)) / PI2 IF(ITYPE.NE.8) GO TO 2100 C SPECIAL CASE FOR SURFACE SCATTERING: WRITE OUT ONE COLUMN ONLY, C LABELLED BY G VECTORS RATHER THAN CHANNEL NUMBERS XJ=1.D0 IF(JLEV(LEVC).NE.0 .OR. JLEV(NLEV+LEVC).NE.0) GOTO 2400 WRITE(6,607) JLEV(LEVR),JLEV(NLEV+LEVR), 1 SMAG,PHASE,SREAL(IJ),SIMAG(IJ) GOTO 2400 C ALL OTHER CASES 2100 WRITE(6,607) IROW,ICOL,SMAG,PHASE,SREAL(IJ),SIMAG(IJ) 607 FORMAT(2I5,4E20.6) 2300 IF (IROW.NE.ICOL) GO TO 2400 C FOR IROW = ICOL, CALCULATE T = 1 - S. SMAG=1.D0-SREAL(IJ) SMAG=SMAG*SMAG + SIMAG(IJ)*SIMAG(IJ) 2400 CONTINUE C N.B. LCOL (LROW) < 0 IMPLIES JI (JF) .GT. JZCSMX C IF BOTH NEGATIVE, INDICATE BY NEGATIVE SIGMA LROW=JLEV(NTOP+LEVR) CSF=1.D0 IF (LROW.LT.0) THEN LROW=-LROW IF (CS1.LT.0.D0) CSF=-1.D0 ENDIF IF (LROW.GT.NLEVEL .OR. LCOL.GT.NLEVEL) GO TO 2000 C II IS INDEX OF SIG(ICOL,IROW). N.B. JLEV(LEV,NQN) HAS POINTER C TO 'SERIAL' NUMBER OF 'LEVEL'. II=(LROW-1)*NLEVEL+LCOL C ACCOUNT FOR K(J,J), DEGEN. LATTER IN SIG(NSTOR+II). SIG(II) = SIG(II) + CSF * SMAG*XJ/(SIG(NSTOR+II)*DD) 2000 CONTINUE C C ACCUMULATE X-SECTIONS. SET IJ TO START OF INRG-TH ENERGY IN SIG 4100 IJ=(INRG+1)*NSTOR II=0 XII=0.D0 XIJ=0.D0 DO 3000 JI=1,NLEVEL DO 3000 I=1,NLEVEL II=II+1 IJ=IJ+1 IF ( ACCUM ) SIG(IJ)=SIG(IJ)+SIG(II) IF (JI.EQ.I) GO TO 3100 XIJ=MAX(XIJ,ABS( SIG(II))) GO TO 3000 3100 XII=MAX(XII,ABS( SIG(II))) 3000 CONTINUE C IF (ACCUM) GO TO 5101 C CODE BELOW IS REACHED IF SIGMA NOT ACCUMULATED. . . IF (ITYPE.EQ.8) GO TO 6500 IF (OKEY) GO TO 9100 WRITE(6,9600) 9600 FORMAT(' ****** SIGMA NOT ACCUMULATED DUE TO LACK OF CONVERGENCE', 1 ' IN THIS OR PREVIOUS CALCULATION.') IF(ISAVEU.GT.0) WRITE(6,9632) 9632 FORMAT(' ****** SCATTERING MATRIX NOT SAVED') MAXJT(INRG)=-IABS(MAXJT(INRG)) IECONV(INRG)=MIN0(IECONV(INRG)-1,-1) GO TO 6500 C 9100 WRITE(6,9611) INVERR 9611 FORMAT(' ****** SIGMA NOT ACCUMULATED BECAUSE OF MATRIX ', 1 'INVERSION ERROR',I4) IF(ISAVEU.GT.0) WRITE(6,9632) GO TO 6500 C C BELOW REACHED IF SIGMA ACCUMULATED. OUTPUT, SAVE ON TAPE, DISK. C 5101 IF(PRINT.EQ.1) THEN WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ ELSEIF(PRINT.GT.1) THEN WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ,TTIME 642 FORMAT(' JTOT=',I4,'.',I2,' E(',I3, 1 ')=',F10.3,', MAX D/O-D=',1P,2D9.1, 2 2X,'TIME=',0P,F8.2) ENDIF C IF(ISIGPR.LE.0) GO TO 5100 IF (PRINT.LE.4) GO TO 5100 WRITE(6,9601) 9601 FORMAT('0',8(' * '),'PARTIAL CROSS SECTIONS',8(' * ')) DO 5200 I=1,NLEVEL C5200 WRITE(6,631) (ABS(SIG((II-1)*NLEVEL+I)),I,II, II=1,NLEVEL) C BELOW INCORPORATES JMH V12 UPDATE AND SG V13X UPDATE IF (ENERGY(INRG).GT.ELEVEL(I)) 1WRITE(6,631) (ABS(SIG((II-1)*NLEVEL+I)),I,II, II=1,NLEVEL) 5200 CONTINUE 631 FORMAT('0',4(1P,D10.2,' FOR SIG(',2I3,')' )/ 1 ( ' ',4(1P,D10.2,' FOR SIG(',2I3,')' ))) IF (PRINT.LE.10) GO TO 5100 WRITE(6,9602) MINJT(INRG),JTOT 9602 FORMAT('0',6(' * '),'CROSS SECTIONS ACCUMULATED FROM JTOT=', 1 I4,' TO',I4,6(' * ')) ISTART=(INRG+1)*NSTOR XJS=DBLE(JSTEP)/DBLE(JHALF) IF (JSTEP.NE.1) WRITE(6,9630) XJS 9630 FORMAT(31X,'MULTIPLIED BY',F5.1,' TO ACCOUNT FOR JSTEP.') DO 5299 I=1,NLEVEL 5299 WRITE(6,631) 1 (ABS(SIG((II-1)*NLEVEL+I+ISTART))*XJS,I,II,II=1,NLEVEL) 5100 IF (XII.LE.DTOL .AND. XIJ.LE.OTOL) GO TO 5102 IECONV(INRG)=MIN0(IECONV(INRG),0) GO TO 5103 5102 IECONV(INRG)=IECONV(INRG)+1 5103 IF(KSAVE.GT.0) GO TO 6320 C C SAVE S MATRICES ON TAPE (ISAVEU) . . . IF (IRSTRT.GT.0) GO TO 6500 IF (ISAVEU.LE.0) GO TO 6500 C BEGINNING IN VERSION 14 NOPEN IS WITH THE 'HEADER' RECORD WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M,NOPEN C WRITE(ISAVEU,803) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M C 803 FORMAT(2I4,E16.8,I4,E16.8,I4) WRITE(ISAVEU) 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN) C WRITE(ISAVEU,804) NOPEN, C 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN) C 804 FORMAT(I4/(2I4,E16.8)) CALL SWRITE(ISAVEU,NOPEN,SREAL) CALL SWRITE(ISAVEU,NOPEN,SIMAG) C NSQ=NOPEN*NOPEN C WRITE(ISAVEU,805) (SREAL(I),I=1,NSQ) C WRITE(ISAVEU,805) (SIMAG(I),I=1,NSQ) C 805 FORMAT(5E16.8) GO TO 6500 C 6320 IF(ISAVEU.LE.0) GO TO 6322 C 'KSAVE' OUTPUT FORMAT *NOT* CHANGED WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M 6324 FORMAT(2I4,D22.15,I4,D22.15,I4) WRITE(ISAVEU) NOPEN, 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN) 6326 FORMAT(I4/(2I4,D22.15)) NPL1=NOPEN+1 NSQ=NOPEN*NOPEN WRITE(ISAVEU) (SREAL(I),SIMAG(I),I=1,NSQ,NPL1) WRITE(ISAVEU) ((AKMAT(I,JJ),I=1,JJ),JJ=1,NOPEN) 6328 FORMAT(4(D20.13)) 6322 ESUM=EPSUM(AKMAT,NOPEN,SREAL,SIMAG,SREAL(NOPEN+1)) IF(ISAVEU.GT.0) WRITE(ISAVEU) ESUM WRITE(6,6342) ESUM 6342 FORMAT('0 S-MATRIX EIGENPHASE SUM, EPSUM/PI =',F9.5) IS=INRG-5*((INRG-1)/5) EPSM(IS)=ESUM C WRITE(KSAVE,6330) JTOT,M,NOPEN,INRG,ENERGY(INRG),ESUM 6330 FORMAT(1X,I3,2I4,I5,F18.10,F21.15) C C ENTRY TO ALLOW UPDATING OF SIG() ON UNIT ISIGU C IN CASE THERE ARE NO BASIS FNS FOR SYMMETRY BLOCK M=MXPAR. GO TO 6500 ENTRY OUTSIG(ISIGU,M,MXPAR,INRG,ENERGY,MINJT,MAXJT,SIG) IRET=1 C C UPDATE DISK (ISIGU) RECORD IF THIS IS THE LAST PARITY CASE 6500 IF (.NOT.LOUT .OR. M.NE.MXPAR) GO TO 7200 XJS=JSTEP IJ=(INRG+1)*NSTOR I10=ISST(INRG) DO 7100 I=1,NLEVEL DO 7100 II=1,NLEVEL IJ=IJ+1 C I10 IS INCREMENTED BY ASSOCIATED VARIABLE HERE. IF (SIG(IJ).GE.0.D0) THEN WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG), 1 MINJT(INRG),JSTEP,MAXJT(INRG),II,I,SIG(IJ)*XJS,BLANK ELSE WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG), 1 MINJT(INRG),JSTEP,MAXJT(INRG),II,I,ABS(SIG(IJ))*XJS,STAR ENDIF I10=I10+1 101 FORMAT(A1,F19.6,I5,2I7,5X,2I5,1P,D20.6,1X,A1) 7100 CONTINUE IF (PRINT.GT.1) WRITE(6,690) ISIGU,INRG,ENERGY(INRG),JTOT,M 690 FORMAT(' OUTSIG: DA FILE (',I2,') UPDATED WITH SIGMA FOR ENERGY(' 1 ,I3,') =',F10.2,' JTOT =',I4,'.',I2) C C>>SG(10/92) C7200 CONTINUE 7200 IF (IRET.EQ.1) RETURN C<> IT WOULD MAKE GOOD SENSE TO USE IVMIN,IVMAX TO GENERATE HERE. C 3192 NQPL=3 C IF MXLAM=0, ASSUME V=V'=0; PROCESS SAME AS OTHER ITYPES IF(MXLAM.EQ.0) GOTO 3190 MXLAM=ABS(MXLAM) WRITE(6,621) MXLAM 621 FORMAT(/' POTENL, ITYPE=102. NEGATIVE MXLAM REQUESTS',I3, 1 ' SYMMETRIES'//' SYMMETRY LAMBDA VIB1 VIB2') DO 3104 I=1,MXLAM IF (LAMBDA(3*I-2).EQ.0) GO TO 3102 WRITE(6,622) 622 FORMAT(' *** WARNING. INPUT LEGENDRE SYMMETRY .GT. ZERO BELOW', 1 ' WILL BE IGNORED AND SET TO ZERO.') 3102 LAM(3*I-2)=0 LAM(3*I-1)=LAMBDA(3*I-1) LAM(3*I )=LAMBDA(3*I ) 3104 WRITE(6,623) I,LAMBDA(3*I-2),LAMBDA(3*I-1),LAMBDA(3*I) 623 FORMAT(1X,I8,I9,2I10) XLAM=.TRUE. NPOTL=1 GOTO 9050 C C STATEMENT BELOW BEGINS PROCESSING FOR LVRTP=.FALSE. 3998 IF (LMAX.GE.0) THEN WRITE(6,*) ' *** POTENL. &POTL REQUESTS MXLAM.GT.0 AND ', 1 'LVRTP=.FALSE.' WRITE(6,*) ' &POTL LMAX.GT.0 IS IGNORED;', 1 ' AND MXLAM, LAMBDA INPUT USED INSTEAD' LMAX=-1 ENDIF C C ATTEMPT TO PROCESS ITYPE AND POTENTIAL DESCRIPTION NUMBERS 3999 QOUT=.TRUE. NPOTL=MXLAM NQPL=1 WRITE(6,639) 639 FORMAT(/' ANGULAR DEPENDENCE OF POTENTIAL EXPANDED IN TERMS OF') ITYPE=ITYP-10*(ITYP/10) IF(ITYPE.EQ.1) GOTO 2001 IF(ITYPE.EQ.2) GOTO 2002 IF(ITYPE.EQ.3) GOTO 2003 IF(ITYPE.EQ.4) GOTO 2004 IF(ITYPE.EQ.5) GOTO 2005 IF(ITYPE.EQ.6) GOTO 2005 IF(ITYPE.EQ.7) GOTO 2002 IF(ITYPE.EQ.8) GOTO 2008 C WRITE(6,640) ITYPE 640 FORMAT(/' *** POTENL. ITYPE =',I4,' CANNOT BE PROCESSED TO', 1 ' DETERMINE THE POTENTIAL SYMMETRY LABLES') QOUT=.FALSE. GOTO 2100 C 2001 NQPL=1 QNAME(1)=QTYPE(1) WRITE(6,641) 641 FORMAT(' LEGENDRE POLYNOMIALS, P(LAMBDA).') IF(LMAX.GE.0) WRITE(6,615) LMAX,IHOMO 615 FORMAT(' POTENTIAL SYMMETRIES GENERATED FROM LMAX =',I3, 1 ' AND IHOMO =',I2) GOTO 2100 C 2002 NQPL=3 QNAME(1)=QTYPE(1) QNAME(2)=QTYPE(7) QNAME(3)=QTYPE(8) WRITE(6,641) WRITE(6,642) 642 FORMAT(' INTEGRATED OVER DIATOM VIBRATIONAL FUNCTIONS') IF(ITYPE.EQ.2) THEN IF(LMAX.GE.0) WRITE(6,616) LMAX,IHOMO,IVMIN,IVMAX 616 FORMAT(' POTENTIAL SYMMETRIES GENERATED FROM LMAX =',I3, 1 ' AND IHOMO =',I2/' WITH V FROM',I2,' TO',I2) ELSEIF (ITYPE.EQ.7) THEN WRITE(6,643) 643 FORMAT(' FOR EACH PAIR OF V,J LEVELS') NQPL=5 QNAME(3)=QTYPE(9) QNAME(4)=QTYPE(8) QNAME(5)=QTYPE(10) ENDIF C DETERMINE NPOTL FOR USE OF IV(); ITYPE=2 AND 7 IN THIS VERSION NPOTL=0 IF (XLAM) THEN DO 2010 I=1,MXLAM 2010 NPOTL=MAX0(NPOTL,LAM((I-1)*NQPL+1)) ELSE DO 2110 I=1,MXLAM 2110 NPOTL=MAX0(NPOTL,LAMBDA((I-1)*NQPL+1)) ENDIF NPOTL=NPOTL+1 GOTO 2100 C 2003 NQPL=3 QNAME(1)=QTYPE(4) QNAME(2)=QTYPE(5) QNAME(3)=QTYPE(6) WRITE(6,644) 644 FORMAT(' CONTRACTED NORMALISED SPHERICAL HARMONICS, SUM', 1 '(M1,M2,M) C(L1,M1,L2,M2,L,M) Y(L1,M1) Y(L2,M2) Y(L,M)'/ 2 ' SEE RABITZ, J. CHEM. PHYS. 57, 1718 (1972)') IF(LMAX.GE.0) THEN WRITE(6,*) ' FOR MOLECULE - 1' WRITE(6,615) L1MAX,IHOMO WRITE(6,*) ' FOR MOLECULE - 2' WRITE(6,615) L2MAX,ICNSYM ENDIF GOTO 2100 C 2004 NQPL = 4 QNAME(1) = QTYPE(4) QNAME(2) = QTYPE(3) QNAME(3) = QTYPE(5) QNAME(4) = QTYPE(6) WRITE(6,448) 448 FORMAT(' CONTRACTION OF SPHERICAL HARMONICS AND ROTATION', 1 'MATRICES'/ 2 ' SEE T.R. PHILLIPS, ET AL. JCP XXX, NNNN (1994)') GO TO 2100 C 2005 NQPL=2 QNAME(1)=QTYPE(1) QNAME(2)=QTYPE(2) WRITE(6,645) 645 FORMAT(' NORMALISED SPHERICAL HARMONICS: (Y(LAM,MU) + ', 1 '(-)**MU Y(LAM,-MU)) / (1+DELTA(MU,0))') IF(LMAX.GE.0) WRITE(6,617) LMAX,IHOMO,MMAX,ICNSYM 617 FORMAT(' POTENTIAL SYMMETRIES GENERATED FROM LMAX =',I3, 1 ', IHOMO =',I2,', MMAX =',I3,' AND ICNSYM =',I2) IF(CFLAG.EQ.1) THEN IF(LVRTP) THEN WRITE(6,662) ELSE WRITE(6,646) 646 FORMAT(/' COEFFICIENTS IN POTENTIAL WILL BE MULTIPLIED BY ', 1 'SQRT(4*PI/(2*LAM+1)) TO BRING POTENTIAL INTO CORRECT FORM') ENDIF ENDIF GOTO 2100 C C SEEMS THAT CODE BELOW TREATS NPOTL SAME AS VERSION 9 (SG JAN 94) 2008 NQPL=2 QNAME(1)=QTYPE(4) QNAME(2)=QTYPE(5) NPOTL=NPTL WRITE(6,647) NPOTL 647 FORMAT(' SURFACE FOURIER COMPONENTS'/' NPOTL =',I2, 1 ' FROM SURBAS') GOTO 2100 C C ******************************************************************* C CODE BELOW IS MAINLY FOR CASE 1 - EXPANDED POTENTIAL C USING NTERM,NPOWER,A,E *OR* VSTAR MECHANISM C ******************************************************************* C HOWEVER, CASE 2 - EXPANDED POT'L PROJECTED FROM VRTP C ALSO RUNS THROUGH THIS CODE, BUT DOES LITTLE C ******************************************************************* C 2100 IF (.NOT.XLAM.AND.NQPL*MXLAM.GT.MXL) WRITE(6,650) MXLAM,NQPL,MXL 650 FORMAT(/' *** POTENL. MXLAM =',I4,' AND NQPL =',I2, 1 ' APPEAR TO EXCEED INTERNAL STORAGE IN LAMBDA(',I5,')'/ 2 ' WILL ATTEMPT TO PROCEED.') IX=0 IEX=0 IQ=0 NPX=0 DO 9000 I=1,MXLAM C OUTPUT SYMMETRY DESCRIPTION ONLY IF MXLAM,LAMBDA WERE USED C IN THOSE CASES, LMAX.LT.0 IF(LMAX.LT.0) THEN WRITE(6,651) I 651 FORMAT(/' INTERACTION POTENTIAL FOR SYMMETRY TYPE NUMBER',I4) IF(QOUT) WRITE(6,652) (QNAME(J),LAMBDA(IQ+J),J=1,NQPL) 652 FORMAT(' WHICH HAS ',6(A8,I3,3X)) WRITE(6,654) 654 FORMAT(1X) ENDIF IQ=IQ+NQPL NT=NTERM(I) C FOR CASE 2, LVRTP=.TRUE. AND WE SKIP PROCESSING IF(LVRTP .OR. NT.EQ.0) GOTO 9000 IF(NT.LT.0) GOTO 8800 DO 8700 IT=1,NT IX=IX+1 IF(IX.GT.IXMX) THEN WRITE(6,9101) IXMX 9101 FORMAT(/' *** POTENL. DIMENSION IXMX EXCEEDED',I6) STOP ENDIF IF(NPOWER(IX).LT.0) GOTO 8200 IF(NPOWER(IX).EQ.0) GOTO 8000 WRITE(6,655) IX,NPOWER(IX) 655 FORMAT(/' * * * WARNING - POSITIVE EXPONENT OF R ILLEGAL',2I6/ 1 ' NEGATIVE OF SUPPLIED VALUE ASSUMED') IF(NPOWER(IX).GT.12 .OR. NPOWER(IX).LT.3) STOP NPOWER(IX)=-NPOWER(IX) GOTO 8200 C 8000 IEX=IEX+1 IF(IEX.GT.IEXMX) THEN WRITE(6,9201) IEXMX 9201 FORMAT(/' *** POTENL. DIMENSION IEXMX EXCEEDED',I6) STOP ENDIF IF(E(IEX).LT.0.D0) GOTO 8100 WRITE(6,656) E(IEX) 656 FORMAT(/' * * * WARNING - POTENTIAL CONTAINS INCREASING', 1 ' EXPONENTIAL =',D16.8) C 8100 WRITE(6,657) A(IX), E(IEX) 657 FORMAT(15X,D16.8,' * EXP(',F10.4,' * R )') IF(CFLAG.EQ.1) A(IX)=A(IX)*SQRT(4.D0*PI 1 /DBLE(2*LAMBDA(IQ-NQPL+1)+1)) GOTO 8700 C 8200 WRITE(6,658) A(IX), NPOWER(IX) 658 FORMAT(15X,D16.8,' * R **',I3) IF(CFLAG.EQ.1) A(IX)=A(IX)*SQRT(4.D0*PI 1 /DBLE(2*LAMBDA(IQ-NQPL+1)+1)) DO 8400 INPX=1,NPX IF(NPOWER(IX).EQ.NPUNI(INPX)) GOTO 8700 8400 CONTINUE 8500 NPX=NPX+1 IF(NPX.GT.NPXMX) THEN WRITE(6,9301) NPXMX 9301 FORMAT(/' *** POTENL. DIMENSION NPXMX EXCEEDED',I6) STOP ENDIF NPUNI(NPX)=NPOWER(IX) C 8700 CONTINUE GOTO 9000 8800 CALL VINIT(I,RM,EPSIL) IF(CFLAG.EQ.1) WRITE(6,662) 662 FORMAT(' *** WARNING. SETTING CFLAG=1 HAS NO EFFECT', 1 ' EXCEPT WHEN THE POTENTIAL IS SUPPLIED IN ARRAY A') 9000 CONTINUE WRITE(6,663) NPX 663 FORMAT(/' NUMBER OF UNIQUE POWERS =',I4) C IF(NPX.EQ.0) GOTO 9020 -- NOT REQUIRED IN FORTRAN 77 DO 9010 I=1,NPX 9010 WRITE(6,664) I, NPUNI(I) 664 FORMAT(' POWER',I3,' =',I4) 9020 CONTINUE C C IF LAM HAS NOT YET BEEN FILLED, GET FROM LAMBDA IF (XLAM) GO TO 9050 IF (MXLAM*NQPL.GT.MXLMB) GO TO 9500 DO 9030 I=1,MXLAM*NQPL 9030 LAM(I)=LAMBDA(I) XLAM=.TRUE. C C COMMON RETURN POINT FOR ALL INITIALIZATIONS. C SET VALUES BACK IN CALLING PARAMETERS. C 9050 WRITE(6,665) EPSIL,RM,MXLAM,NPOTL 665 FORMAT(/' POTENL PROCESSING FINISHED.'// 1 ' ENERGY IN UNITS OF EPSILON =',F15.5,' CM-1'/ 2 ' R IN UNITS OF RM =',F15.5,' ANGSTROMS'// 3 ' MXLAM =',I5/' NPOTL =',I5) C R=RM P(1)=EPSIL MPOTL=NPOTL MXLMB=MXLAM RETURN C C ********** ERROR CONDITIONS ********** C 9300 WRITE(6,9301) NDIM,MXDIM 9306 FORMAT(/' *** POTENL. PROJECTED POTENTIAL HAS',I3, 1 ' DIMENSIONS, BUT MXDIM=',I3) STOP 9400 WRITE(6,9401) NPT,NPS,MXPT 9401 FORMAT(/' *** POTENL. EITHER NPT OR NPS EXCEEDS MXPT' 2 /' NPT =',I6,' NPS =',I6/' MXPT=',I7) C WRITE(6,649) NPT,MXPT STOP 9500 WRITE(6,9501) MXLMB,MXLAM 9501 FORMAT(/' *** POTENL. DIMENSION OF EXTERNAL LAM ARRAY EXCEEDED'/ 1 ' SIZE PASSED FROM CALLING PROGRAM (MXLMB) =',I8/ 2 ' OFFENDING VALUE OF MXLAM =',I8) STOP C C BELOW IS REACHED IF THERE WAS NOT ENOUGH ROOM IN THE X ARRAY TO C STORE THE PROJECTION COEFFS. IF USING /MEMORY/...X, IT IS C POSSIBLE FOR THE CODE HERE TO OVERWRITE THE LAM ARRAY WITH C COEFFS. HOWEVER, THE PROGRAM SHOULD THEN TERMINATE WHEN CHKSTR C IS CALLED FROM DRIVER AFTER RETURN FROM POTENL INITIALIZATION. 9600 NREQ=MXLAM*(NPT+NPS) MXSTRT=MX+NREQ WRITE(6,9601) NPT,NPS,MXLAM,NREQ,MXSTRT,MXSTRT-IXNEXT+1 9601 FORMAT(' *** POTENL. NOT ENOUGH ROOM FOR PROJECTION COEFFICIENTS'/ 1 ' REQUIRES (',I4,' +',I4,') * ',I4,' =',I8/ 2 ' OF',I8,' ORIGINALLY SUPPLIED IN X(), ONLY',I8, 3 ' WERE AVAILABLE.') STOP END SUBROUTINE POTENT (W, VECNOW, SCMAT, EIGNOW, HP, SCR, 1 RNOW, DRNOW, EN, XLARGE, NCH, 2 P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL) * ---------------------------------------------------------------------- * THIS SUBROUTINE FIRST SETS UP THE WAVE-VECTOR MATRICES: * W = W[RNOW + 0.5 DRNOW/SQRT(3)] AND W = W[RNOW - 0.5 DRNOW/SQRT(3)] * B A * THEN DIAGONALIZES THE AVERAGE; I.E. 0.5 (W + W ) * B A * THE RADIAL DERIVATIVE OF THE WAVEVECTOR MATRIX IS CALCULATED BY FINIT * DIFFERENCE, USING THE NODES OF A TWO-POINT GAUSS-LEGENDRE QUADRATURE * 1/2 * D(W)/DR = 3 (W - W ) / DRNOW * B A * THIS IS THEN TRANSFORMED INTO THE LOCAL BASIS * AUTHOR: MILLARD ALEXANDER * CURRENT REVISION DATE: 25-SEPT-87 * --------------------------------------------------------------------- * VARIABLES IN CALL LIST: * W: ON RETURN: CONTAINS TRANSFORM OF DH/DR * THIS IS THE SAME AS THE NEGATIVE OF THE * WN-TILDE-PRIME MATRIX * VECNOW: ON RETURN: CONTAINS MATRIX OF EIGENVECTORS * SCMAT: SCRATCH MATRIX * EIGNOW: ON RETURN: CONTAINS EIGENVALUES OF WAVEVECTOR MATRIX * HP: ON RETURN: CONTAINS DIAGONAL ELEMENTS OF TRANSFORMED DH/D * THIS IS THE SAME AS THE NEGATIVE OF THE DIAGON * ELEMENTS OF THE WN-TILDE-PRIME MATRIX * SCR: SCRATCH VECTOR * RNOW: MIDPOINT OF THE CURRENT INTERVAL * DRNOW: WIDTH OF THE CURRENT INTERVAL * EN: TOTAL ENERGY IN ATOMIC UNITS * XLARGE: ON RETURN CONTAINS LARGEST OFF-DIAGONAL ELEMENT IN * WN-TILDE-PRIME MATRIX * NCH: NUMBER OF CHANNELS. SAME AS * MAXIMUM ROW DIMENSION OF MATRICES AND MAXIMUM DIMENSION O * VECTORS * ---------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) * REAL EIGNOW, HP, SCMAT, SCR, VECNOW, W * REAL DRNOW, EN, FACT, HALF, ONE, RA, RB, RNOW, SQ3, XLARGE, XMIN1 INTEGER ICOL, IERR, IONE, IPT, NCH, NCHM1, NCHP1, NROW * SQUARE MATRICES (OF ROW DIMENSION NCH) DIMENSION W(1), VECNOW(1), SCMAT(1) * VECTORS DIMENSIONED AT LEAST NCH DIMENSION EIGNOW(1), HP(1), SCR(1) C DIMENSION P(1),VL(1),IV(1),EINT(1),CENT(1) C DATA IONE / 1 / DATA ONE, XMIN1, HALF, SQ3 /1.D0, -1.D0, 0.5D0, 1.732050807D0/ NCHP1 = NCH + 1 NCHM1 = NCH - 1 RA = RNOW - 0.5 * DRNOW / SQ3 RB = RNOW + 0.5 * DRNOW / SQ3 * SCMAT IS USED TO STORE THE WAVEVECTOR MATRIX AT RB CALL WAVMAT (W, NCH, RA, P, VL, IV, ERED, EINT, CENT, 1 RMLMDA, SCR, MXLAM, NPOTL) CALL WAVMAT (SCMAT, NCH, RB, P, VL, IV, ERED, EINT, CENT, 1 RMLMDA, SCR, MXLAM, NPOTL) * SINCE WAVMAT RETURNS NEGATIVE OF LOWER TRIANGLE OF W(R) MATRIX (EQ.(3 * M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."), * NEXT STATEMENTS CHANGE ITS SIGN CALL DSCAL(NCH*NCH, XMIN1, W, 1) CALL DSCAL(NCH*NCH, XMIN1, SCMAT, 1) * NEXT LOOP STORES AVERAGE WAVEVECTOR MATRIX IN SCMAT AND DERIVATIVE OF * HAMILTONIAN MATRIX, IN FREE BASIS, IN W FACT = - SQ3 / DRNOW * THE ADDITIONAL MINUS SIGN IN THE PRECEDING EXPRESSION IS INTRODUCED B * DH/DR =-DW/DR; SEE EQ.(9) OF * M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." IPT = 1 DO 105 ICOL = 1, NCH * NROW IS THE NUMBER OF (DIAGONAL PLUS SUBDIAGONAL) ELEMENTS IN COLUMN * IPT POINTS TO THE DIAGONAL ELEMENT IN COLUMN ICOL FOR A MATRIX STORED * PACKED COLUMN FORM * HP AND SCR ARE USED AS SCRATCH VECTORS HERE NROW = NCH - ICOL + 1 CALL DCOPY (NROW, SCMAT(IPT), 1, SCR, 1) CALL DAXPY (NROW, ONE, W(IPT), 1, SCMAT(IPT), 1) CALL DAXPY (NROW, XMIN1, W(IPT), 1, SCR, 1) CALL DSCAL (NROW, HALF, SCMAT(IPT), 1) CALL DSCAL (NROW, FACT, SCR, 1) CALL DCOPY (NROW, SCR, 1, W(IPT), 1) IPT = IPT + NCHP1 105 CONTINUE * NEXT LOOP FILLS IN UPPER TRIANGLES OF W AND SCMAT IF (NCH .GT. 1) THEN IPT = 2 DO 110 ICOL = 1, NCH -1 * IPT POINTS TO THE FIRST SUBDIAGONAL ELEMENT IN COLUMN ICOL * NROW IS THE NUMBER OF SUBDIAGONAL ELEMENTS IN COLUMN ICOL NROW = NCH - ICOL CALL DCOPY (NROW, W(IPT), 1, W(IPT + NCHM1), NCH) CALL DCOPY (NROW, SCMAT(IPT), 1, SCMAT(IPT + NCHM1), NCH) IPT = IPT + NCHP1 110 CONTINUE END IF * ---------------------------------------------------------------------- * DIAGONALIZE SCMAT AT RNOW AND TRANSPOSE MATRIX OF EIGENVECTORS * AFTER TRANSPOSITION, THE VECNOW MATRIX IS IDENTICAL TO THE TN MATRIX * OF EQ.(6) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS .. CALL F02ABF(SCMAT,NCH,NCH,EIGNOW,VECNOW,NCH,SCR,IERR) IF (IERR .NE. 0) THEN WRITE (6, 115) IERR 115 FORMAT (' *** IERR =',I3,' IN AIRPRP/POTENT/RS; ABORT ***') WRITE (6, 120) (EIGNOW (I), I=1, NCH) 120 FORMAT (' EIGENVALUES ARE:',/,8(1PE16.8) ) STOP END IF * TRANSFORM THE DERIVATIVE INTO THE LOCAL BASIS * SUBROUTINE DTRANS RETURNS THE NEGATIVE OF THE WN-TILDE-PRIME MATRIX; * EQ.(9) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." CALL TRNSFM(VECNOW, W, SCMAT, NCH, .FALSE., .TRUE.) CALL TRNSP(VECNOW, NCH) CALL DCOPY(NCH, W, NCH+1, HP, 1) C C FIND LARGEST OFF-DIAGONAL ELEMENT IN TRANSFORMED W C XLARGE=0.D0 IPT=2 DO 130 ICOL=1,NCH-1 NCOL=NCH-ICOL CALL MAXMGV (W(IPT), 1, ZABS, IC, NCOL) IF(ZABS .GT. XLARGE) XLARGE=ZABS IPT=IPT+NCH+1 130 CONTINUE C RETURN END SUBROUTINE POTIN9(ITYPE,LAM,MXLAM,NPTS,NDIM,XPT,XWT,MXPT,X,MX, 1 IXFAC) DIMENSION XPT(MXPT,NDIM),XWT(MXPT,NDIM),NPTS(NDIM), 1 LAM(MXLAM),X(MX) WRITE(6,*) ' *** POTIN9 CALLED WITHOUT A SUITABLE USER-SUPPLIED', 1 ' ROUTINE' STOP END SUBROUTINE PRBR(JTOT,M,N,INRG,RM, 1 NBASIS,LEV,L,WVEC,SREAL,SIMAG,IC,IL,IC1,IL1, 2 JLEV,MXPAR,WGHT,PRINT,ILSU) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C C *** AUG 76 NEW COUPLED STATES TREATMENT (KOURI ET AL.) C *** JUL 86 (CCP6 VERSION 9) MOD 26 AUG 86 TO GET MXREC PROPERLY. C *** AND MOD 21 OCT 86 : EDIFMX C *** OCT 86 VERSION FOR 'OFF-DIAGONAL' CROSS SECTIONS C *** JAN 87 CHANGES TO GET MPLMIN HANDLING CORRECT FOR ITYPE=25,26 C *** AND ADD JSTEP TO ENTRY PRBOUT (REQUIRES CHANGE IN DRIVER) C *** MAR 87 CORRECTIONS FOR ITYPE=26 C *** DEC 88 INCLUDE ITYPE=7 AND Q=0 C *** MAR 89 HAS 'IN-CORE' D.A. SIMULATION C *** (NEED SUBROUTINE DASIZE/ENTRIES DARD1,DARD2,DAWR1,DAWR2) C *** JUL 92 REMOVES ALL REFERENCES TO LCSOLD (OLD, INCORRECT, C *** FORMULATION FOR COUPLED STATES: SEE, E.G., C *** GREEN, ET AL. JCP, 66, 1409 (1977)) C *** CALLS TO ENTRIES (IN PRBR3) ALSO HAVE BEEN TRAPPED THERE. C *** JUN 93 FIXES BUG IN PRBR3 AND USES /MEMORY/ TO ELIMINATE LIMITS. C *** AUG 94 V14: ENTRY PRBCNT ADDED AND COMMON CMBASE CHANGED C C CALCULATES SIGMA(JA1,JB1;JA,JB;K) C WHERE A/B INDICATE INITIAL/FINAL SPECTRAL LINES, C A1/B1 ARE AFTER COLLISION, AND K IS TENSOR ORDER C SEE, E.G., SHAFER AND GORDON, JCP 58, 5422 (1973). C C SUPPOSED TO BE UPWARD COMPATIBLE IF LDIAG=.TRUE.: C LDIAG=.TRUE. TAKES *OLD* INPUT LINE=LEVA,LEVB, LEVA,LEVB, ... , C AND SETS LEVA1=LEVA, LEVB1=LEVB FOR ALL LINES. C LDIAG=.FALSE. INPUT IS LINE=LEVA,LEVB,LEVA1,LEVB1, C LEVA,LEVB,LEVA1,LEVB1, ... C N.B. LDIAG FORCED TO TRUE FOR ITYPE=3 CALCULATIONS. C C ENTRY PRBRIN ACCEPTS &INPUT DATA AND SETS UP PRES. BROAD. CALC. C ENTRY PRBOUT PRINTS OUT ACCUMULATED SIGR, SIGI. C ENTRY PRBCNT FINDS WHETHER AN S-MATRIX WILL BE USED FOR PB CALC C C PRBR SPECIFICATIONS -------------------------------------- C DIMENSION NBASIS(1),LEV(1),L(1),IC(1),IL(1),IC1(1),IL1(1), 1 JLEV(NLEV,NQN) DIMENSION WVEC(1),SREAL(1),SIMAG(1) C C JTOT IS TOTAL ANGULAR MOMENTUM C M = 0 FOR LAST PARITY STEP AT THIS JTOT. C N IS NUMBER OF OPEN CHANNELS, DETERMINES DIMENSION OF VECTORS. C INRG IS INDEX FOR ENERGY VALUES C RM IS SCALING FACTOR FOR RADIAL WAVEFUNCTION. C NBASIS (I) POINTS TO LEV,L VALUES FOR ITH OPEN CHANNEL. C LEV IS VECTOR OF BASIS SET LEVELS C L IS VECTOR OF BASIS ORBITAL ANGULAR MOMENTA. C WVEC IS VECTOR OF WAVEVECTORS C SREAL(N,N) IS REAL PART OF S MATRIX. C SIMAG(N,N) IS IMAGINARY PART OF S MATRIX. C LOGICAL ITYPE3,EPM,LCSNEW,MPLMIN,LCSSYM INTEGER JT(2) C C PRBRIN SPECIFICATIONS ------------------------------------ C INTEGER NLPRBR,MXLN,LINE(MXLN),ILSU,NNRG,PRINT,MXNRG,IFEGEN INTEGER T(MXLN) DIMENSION ENERGY(NNRG) C C NLPRBR =0 FOR NO LINE SHAPE CALC. C =N (GT.0) GIVES NO. OF LINES FOR WHICH TO COMPUTE L.S. C LINE(4*I-3),... ,I=1,NLPRBR IS LEVEL DATA FOR LINES. C ILSU (NOW REDUNDANT) WAS DIRECT ACCESS FILE FOR WORKING STORAGE C ENERGY(NNRG) ARE ENERGIES AT WHICH S MATRIX IS CALCULATED. C MXNRG IS MAXIMUM DIMENSION OF ENERGY ARRAY C IFEGEN .GT. 0 REQUESTS GENERATION OF ADDITIONAL ENERGY VALUES. C PRINT IS INTEGER PRINT CONTROL. C LOGICAL NOCALC,PF,NDEBUG LOGICAL LDIAG,EXISTS,LDIAGX CHARACTER*8 PTP(3) C STORAGE DIMENSIONED FOR NO. OF LINES = MAXLN. DIMENSION LN(400,9) DIMENSION EREL(400),SIGR(400),SIGI(400) DIMENSION P(2),PRTY(4) C C INFORMATION ORIGINALLY PASSED AS ENTRY PRBRBS, NOW IN COMMON C COMMON /CMBASE/ ROTI(12),ELEVEL(1000),EMAX,WT(2),SPNUC, 1 NLEVEL,JLEVEL(4000),MISC(26),JHALF,IDENT,MXJL,MXEL COMMON /PRBASE/ ITYPE,NQN,NLEV,MVALUE,IEXCH,MPLMIN COMMON /ASSVAR/ IDA C C NLEV AND NLEVEL ARE NO. OF LEVELS IN BASIS SET. C JLEV AND JLEVEL ARE QUANTUM NUMBERS FOR THESE LEVELS. C ELEVEL ARE ENERGIES OF THESE LEVELS. C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C --- DATA INITIALIZATIONS --- C DATA PTP/' Q = 0 ',' DIPOLE ',' RAMAN '/ DATA P/1.D0,-1.D0/, PRTY/1.D0,-1.D0,-1.D0,1.D0/ C *** BELOW REPLACES JMH'S CRITERION OF 1.D-10 FOR ENERGY DIFFERENCE C *** SMALLER VALUE MAY BE NEEDED FOR RESONANCE CALCULATIONS. DATA EDIFMX/5.D-6/ C FOR COMPATBILITY WITH OLD INPUT, SET LDIAG=.TRUE. DATA LDIAGX/.FALSE./ C IF NDEBUG .EQ. .FALSE. CHECK FOR 'IMPOSSIBLE' NUMBERS OF MATCHES. DATA NDEBUG/.FALSE./ C DIMENSION LIMITATION ... DATA MAXLN/400/ C FOR CHECKING OVER-WRITE OF "DA FILE" DATA JCHKSV/-1/ C C STATEMENT FUNCTION (LOGICAL) EXISTS(I) = I.GT.0 .AND. I.LE.NLEVEL C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C IF (NOCALC) RETURN IF (JCHKSV.EQ.-1) JCHKSV=JTOT DO 3000 IA=1,2 C IA=1 CHECKS FOR USE OF THIS JTOT,INRG WITH J(ALPHA). C IA=2 FOR J(BETA). IB=3-IA C FIND LINES, I, WHICH USE THIS INRG, JTOT S MATRIX. IKEEP=0 DO 3100 I=1,NLINE IF (LN(I,IA+3).NE.INRG) GO TO 3100 K=LN(I,3) JDIFMX=K IF (LCSNEW) JDIFMX=0 JDM=MAX(JDM,JDIFMX) IF (ITYPE3) GO TO 3211 C FOR ITYPE=1,2,5 GET J-VALUE FROM 1ST COL OF JLEV. JA=JLEV(LN(I,1),1) JB=JLEV(LN(I,2),1) JA1=JLEV(LN(I,8),1) JB1=JLEV(LN(I,9),1) C PARITY FACTOR FOR CS WITH MPLMIN; THIS IS NORMALLY +1. F3PJ=PARITY(JA+JA1+JB+JB1) C FIND BASIS FNS. CORRESPONDING TO JA/JA1 (JB/JB1) AND GET L VALUES. C ROWS=>JA1,IC1,IL1 COLS=>JA,IC,IL C FOR DIAG CASE (JA=JA1), IC/IC1 AND IL/IL1 HAVE SAME VALUES. NLVAL=0 NLVAL1=0 DO 3200 II=1,N JJ=NBASIS(II) IF (LEV(JJ).NE.LN(I,IA)) GO TO 3201 NLVAL=NLVAL+1 IC(NLVAL)=II IL(NLVAL)=L(JJ) 3201 IF (LEV(JJ).NE.LN(I,IA+7)) GO TO 3200 NLVAL1=NLVAL1+1 IC1(NLVAL1)=II IL1(NLVAL1)=L(JJ) 3200 CONTINUE GO TO 3212 C C FOR ITYPE=3 GET J-VALUE FROM JLEVEL. RECALL J1,J2 PACKED IN ORDER C 3211 JA=JLEVEL(2*LN(I,1)-1) JB=JLEVEL(2*LN(I,2)-1) C BELOW MAY BE NEEDED FOR COMPATIBILITY IN OFF-DIAG CODE JA1=JA JB1=JB C ALLOCATE TEMPORARY STORAGE FOR SR,SI,TR,JBAR,ISTB,NBLK,LVAL NSQ=N*N NINT=(N+NIPR-1)/NIPR IT1=IXNEXT IT2=IT1+NSQ IT3=IT2+NSQ IT4=IT3+NSQ IT5=IT4+NINT IT6=IT5+NINT IT7=IT6+NINT IXNEXT=IT7+NINT C WRITE(6,*) ' IT1-IT7,IXNEXT',IT1,IT2,IT3,IT4,IT5,IT6,IT7,IXNEXT NUSED=0 CALL CHKSTR(NUSED) CALL PRBR3(N,SREAL,SIMAG,JTOT,NLEV,NQN,JLEV,NBASIS,LEV,L,NPACK, 1 LN(I,IA),NLVAL,IC,IL, 2 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7)) C N.B. ONLY SR,SI NEED TO BE KEPT, IXNEXT COULD BE REDUCED HERE ... C IXNEXT=IT3 C>>SG 1 JUN 93: NLVAL1,IL1,IC1 MUST BE ALSO BE SET (CF. DIAGONAL CASE). NLVAL1=NLVAL DO 3311 II=1,NLVAL IL1(II)=IL(II) 3311 IC1(II)=IC(II) C< RMID. THE CONSTANT-STEP METHOD IS RECOMMENDED BY C ANDERSON, J.CHEM.PHYS. 77,4431(1982). C VTOL IS A TOLERANCE PARAMETER FOR THE LARGEST OFF-DIAGONAL C ELEMENT OF THE TRANSFORMATION MATRIX, USED TO DECIDE WHEN TO C STOP INTEGRATING. C FACT AND DRMAX ARE NOT USED IN THIS VERSION. C C ISTART IS 0 IF THE R-MATRIX IS TO BE INITIALISED C 1 IF THE R-MATRIX (FROM L2 CALC) IS ALREADY IN R C C ---------------------------------------------------------------- C SET UP TO USE UNIT (ISCRU) IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 C --------------------------------------------------------------- C N=NBAS NSQ=NSQBAS GOTTP=.FALSE. IF(XEPS.LE.0.D0 .OR. ISCRU.LE.0) GOTO 100 IF (IVLFL.NE.0) THEN IF(IWRITE) WRITE(ISCRU) JJ,L,EINT,CENT,VL,IV IF(IREAD) READ (ISCRU) JJ,L,EINT,CENT,VL,IV ELSE IF(IWRITE) WRITE(ISCRU) JJ,L,EINT,CENT,VL IF(IREAD) READ (ISCRU) JJ,L,EINT,CENT,VL ENDIF C C COUNT NUMBER OF OPEN CHANNELS AND SET UP WVEC ARRAY. C 100 NOPEN=0 DO 110 I=1,N DIF=ERED-EINT(I) WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) IF(DIF.LE.0.D0) GOTO 110 NOPEN=NOPEN+1 110 CONTINUE C C IF THERE ARE NO OPEN CHANNELS RETURN C IF(NOPEN.EQ.0) RETURN NOPSQ=NOPEN*NOPEN C C SORT CHANNELS BY ASYMPTOTIC ENERGY C DO 120 I=1,N CLOSE(I)=0.D0 120 NB(I)=I IF(N.LE.1) GOTO 140 NM1=N-1 DO 130 I=1,NM1 IP1=I+1 DO 130 J=IP1,N IF(EINT(NB(I)).LE.EINT(NB(J))) GOTO 130 IT=NB(I) NB(I)=NB(J) NB(J)=IT 130 CONTINUE 140 CONTINUE C C ICODE=1/2 MEANS PROPAGATION ISN'T/IS TO BE DONE WITH STORED DATA C IF(ICODE.EQ.1 .AND. PRINT.GE.2) WRITE(6,150) RMIN 150 FORMAT('0 START R-MATRIX PROPAGATOR AT RMIN =',F8.5) IF(PRINT.GE.15 .AND. ICODE.EQ.1) WRITE(6,160) 160 FORMAT('0 KSTEP RNOW EIGVAL(1) EIGVAL(N)'/) C C CALCULATE R-MATRIX AT FIRST STEP. C IF(IREAD) GOTO 170 RNOW=RMIN IF(ISTART.EQ.0) RNOW=RNOW+0.5D0*DR DRNOW=DR DRNEW=DRNOW KSTP=1 CALL WAVMAT(W,NBAS,RNOW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IFAIL=0 CALL F02ABF(W,NBAS,NBAS,EIGOLD,SI,NBAS,R1,IFAIL) IF(ISCRU.LE.0) GOTO 190 WRITE(ISCRU) RNOW,DRNOW WRITE(ISCRU) KSTP,EIGOLD WRITE(ISCRU) DRNEW GOTO 190 C 170 READ(ISCRU) RNOW,DRNOW READ(ISCRU) KSTP,EIGOLD READ(ISCRU) DRNEW DO 180 I=1,N EIGOLD(I)=EIGOLD(I)-ESHIFT 180 CONTINUE C 190 IF(ISTART.NE.0) GOTO 220 C C NO INITIAL R-MATRIX SUPPLIED. INITIALISE IT. C DO 200 I=1,NSQ 200 R(I)=0.D0 IND=-N DO 210 I=1,N IND=IND+N+1 R(IND)=1.D0/SQRT(ABS(EIGOLD(I))) 210 CONTINUE GOTO 230 C C TRANSFORM SUPPLIED R-MATRIX TO LOCAL BASIS C 220 CALL TRNSFM(SI,R,Q,N,.FALSE.,.TRUE.) C 230 ITRY=-1 DLAST=1.D36 C C PROPAGATE R-MATRIX C DO 430 KSTEP=2,MAXSTP NOLD=N ROLD=RNOW RNOW=RNOW+0.5D0*(DRNOW+DRNEW) DRNOW=DRNEW IF(.NOT.IREAD) GOTO 250 C C IF ICODE = 2 READ EIGNOW AND Q MATRIX FROM DISK C READ(ISCRU) KSTP,EIGNOW,Q DO 240 I=1,N EIGNOW(I)=EIGNOW(I)-ESHIFT 240 CONTINUE GOTO 290 C C IF ICODE = 1 CALCULATE EIGNOW AND Q MATRIX C 250 CALL WAVMAT(W,N,RNOW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IF(XEPS.LE.0.D0 .OR. GOTTP) GOTO 270 C C LOOK FOR TURNING POINT OR POTENTIAL MINIMUM IN LOWEST-LYING C CHANNEL (WHICHEVER OCCURS AT SMALLEST R). C SAVE INFORMATION FOR USE IN NEXT CALL TO RMSET. C IF(DIAG(IK).GT.0.D0.AND.DIAG(IK).LT.DLAST) GOTO 260 GOTTP=.TRUE. RTURN=RNOW 260 DLAST=DIAG(IK) C 270 IFAIL=0 CALL F02ABF(W,N,N,EIGNOW,SR,N,R1,IFAIL) CALL SGNCHK(SI,SR,N) CALL DGEMUL(SI,N,'T',SR,N,'N',Q,N,N,N,N) IF(ISCRU.GT.0) WRITE(ISCRU) KSTEP,EIGNOW,Q DO 280 I=1,NSQ 280 SI(I)=SR(I) 290 CONTINUE C C IF(KSTEP.GT.2) GOTO 213 C C CALCULATE PROPAGATOR FOR R-MATRIX. C NOPLOC=0 DO 320 I=1,N EIG=EIGNOW(I) FLAM=SQRT(ABS(EIG)) IF(EIG.GE.0.D0) GOTO 300 R1(I) = -1.D0/(FLAM*TAN(DRNEW*FLAM)) R2(I) = -1.D0/(FLAM*SIN(DRNEW*FLAM)) NOPLOC=NOPLOC+1 GOTO 310 300 R1(I) = 1.D0/(FLAM*TANH(DRNEW*FLAM)) R2(I) = 1.D0/(FLAM*SINH(DRNEW*FLAM)) IF(RNOW.GT.1.5D0*RTURN) CLOSE(I)=CLOSE(I)+DRNEW*FLAM 310 R3(I) = R2(I) R4(I) = R1(I) 320 CONTINUE C CALL TRNSFM(Q,R,SR,N,.FALSE.,.TRUE.) C IND=-N DO 330 I=1,N IND=IND+N+1 R(IND)=R(IND)+R1(I) 330 CONTINUE CALL SYMINV(R,N,N,IFAIL) IF(IFAIL.GT.N) GOTO 480 CALL DSYFIL('U',N,R,N) IND=0 DO 340 IC=1,N DO 340 IR=1,N IND=IND+1 R(IND)=-R3(IR)*R(IND)*R2(IC) 340 CONTINUE IND=-N DO 350 I=1,N IND=IND+N+1 R(IND)=R(IND)+R4(I) 350 CONTINUE IF(IREAD) GOTO 400 C C IF ICODE=1 COMPUTE NEW STEP SIZE AND TEST FOR END OF PROPAGATION. C DRNEW=DR*RNOW/RMID IF(DRNEW.LT.DR) DRNEW=DR C DO 360 I=1,N EIGOLD(I)=EIGNOW(I) 360 CONTINUE C C SEE IF OFF-DIAG ELEMENTS OF SI ARE SMALL ENOUGH. C CALL COLIM(SI,R1,R2,VTOL,N) CALL STRY(R1,R2,N,ITRY,EIGOLD) IF(ITRY.NE.1) GOTO 380 RUP=RNOW+DRNOW/2.D0 IF(RUP.GE.RMAX .AND. NOPLOC.GE.NOPEN) GOTO 370 ITRY=0 GOTO 380 370 IF(ISCRU.LE.0) GOTO 450 DRNEW=-9999.D0 WRITE(ISCRU) DRNEW WRITE(ISCRU) SI GOTO 450 380 IF(ISCRU.GT.0) WRITE(ISCRU) DRNEW EIG1=(ERED+EIGOLD(1))/RMLMDA EIGN=(ERED+EIGOLD(N))/RMLMDA IF(PRINT.GE.15) WRITE(6,390) KSTEP,RNOW,EIG1,EIGN 390 FORMAT(1X,I7,F11.5,2(1PD16.6)) GOTO 410 C C IF ICODE=2 READ NEW STEP SIZE FROM DISK C 400 READ(ISCRU) DRNEW IF(DRNEW.NE.-9999.D0) GOTO 410 READ(ISCRU) SI GOTO 450 C 410 CNTRCT=XEPS.GT.0.D0 .AND. N.GT.NOPMAX .AND. CLOSE(N).GT.DEEP IF(IWRITE) WRITE(ISCRU) CLOSE,CNTRCT IF(IREAD) READ (ISCRU) CLOSE,CNTRCT IF (CNTRCT) 1 CALL SHRINK(ICODE,RNOW,W,N,VL,IV,NB,JJ,L,EINT,CENT,WVEC, 2 CLOSE,SI,EIGOLD,R,SR,DEEP,NSQ,NPOTL,ISCRU,NOPMAX,PRINT) 430 CONTINUE C C END OF R-MATRIX PROPAGATION LOOP C WRITE(6,440) 440 FORMAT('0***** ERROR IN RMTPRP - LIMIT OF',I7,'STEPS REACHED.', 1 ' RUN HALTED.') STOP C C REACH HERE WHEN ASYMPTOTIC REGION IS REACHED C 450 CALL TRNSP(SI,N) CALL TRNSFM(SI,R,SR,N,.FALSE.,.TRUE.) C RUP=RNOW+DRNOW/2.D0 IF(ICODE.EQ.1 .AND. PRINT.GE.2) 1 WRITE(6,460) RUP,KSTEP 460 FORMAT(' FINISHED AT RUP =',F10.5,' AFTER',I7,' STEPS') IF(ICODE.NE.1 .AND. PRINT.GE.5) WRITE(6,470) 470 FORMAT('0 R-MATRIX PROPAGATION COMPLETED USING STORED DATA') C CALL SYMINV(R,N,N,IFAIL) IF(IFAIL.GT.N) GOTO 480 CALL YTOK(NB,WVEC,L,N,NOPEN,R1,R2,R3,R4,R,SR,Q,RUP) CALL KTOS(Q,SR,SI,NOPEN) RETURN C 480 WRITE(6,490) 490 FORMAT('0***** ERROR IN SYMINV CALLED FROM RMTPRP.', 1 ' RUN HALTED.') STOP END SUBROUTINE RSYM(NN,R,STEST,PRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER PRINT DIMENSION R(NN,NN) IF (NN.LE.1) RETURN NERR=0 XX=0.D0 TEST=MAX(STEST,5.D-7) DO 1200 I=2,NN IM1=I-1 DO 1200 J=1,IM1 SUM=R(I,J)+R(J,I) ASUM=ABS(SUM) ADIF=ABS(R(I,J)-R(J,I)) IF (ASUM.LE.TEST) GO TO 1100 RAT=ADIF IF (ASUM.GE.2.D0) RAT=RAT/ASUM IF (RAT.LE.TEST) GO TO 1100 XX=MAX(XX,RAT) NERR=NERR+1 1100 SUM=.5D0*SUM R(I,J)=SUM 1200 R(J,I)=SUM IF (NERR.LE.0) RETURN NO=NN*(NN-1)/2 IF(PRINT.GE.4) WRITE(6,601) NERR,NO,TEST,XX 601 FORMAT(I6,' OF',I4,' OFF-DIAGONAL ELEMENTS OF ', & 'K-MATRIX NOT SYMMETRIC WITH RESPECT TO TEST =',2D12.4) RETURN END FUNCTION RSYMTP(J1,K1,J2,J1P,K1P,J2P,JJ,JJP,MU,P1,Q1,P2,PP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER P1,Q1,P2,PP DATA Z0/0.D0/, PI/3.14159265358979289D0/ C STATEMENT FUNCTION . . . Z(X)=2.D0*X+1.D0 C XJ1 = J1 XK1 = K1 XJ2 = J2 XJ1P = J1P XK1P = K1P XJ2P = J2P XJJ = JJ XJJP = JJP XMU = MU XQ1 = Q1 XP1 = P1 XP2 = P2 XPP = PP RSYMTP=0.D0 F=THRJ(XJ1,XP1,XJ1P,-XK1,XQ1,XK1P) IF (ABS(F) .LE. 1.D-8) RETURN F=F*THRJ(XJJ,XPP,XJJP,XMU,Z0,-XMU) IF (ABS(F) .LE. 1.D-8) RETURN F = F*THREEJ(J2,P2,J2P) IF(ABS(F) .LE. 1.D-8) RETURN F = F*XNINEJ(JJ,PP,JJP,J1,P1,J1P,J2,P2,J2P) IF(ABS(F) .LE. 1.D-8) RETURN RSYMTP=F*SQRT(Z(XJ1)*Z(XJ1P)*Z(XJ2)*Z(XJ2P)*Z(XPP)*Z(XP2) 1 *Z(XJJ)*Z(XJJP))*PARITY(J1P+J2P+JJ+MU-K1)/(4.0D0*PI) RETURN END * ---------------------------------------------------------------------- SUBROUTINE SCAIRY (Z, SCAI, SCBI, SCAIP, SCBIP, ZETA) * SCALED AIRY FUNCTIONS AND DERIVATIVES * THIS PROGRAM WRITTEN BY D.E. MANOLOPOULOS (SEPT. 1986) * CURRENT REVISION DATE: SEPT-1986 * ---------------------------------------------------------------- * FOR Z .LT. (-5.0D0) * AI(Z) = SCAI*COS(ZETA) + SCBI*SIN(ZETA) * BI(Z) = SCBI*COS(ZETA) - SCAI*SIN(ZETA) * AI'(Z) = SCAIP*COS(ZETA) + SCBIP*SIN(ZETA) * BI'(Z) = SCBIP*COS(ZETA) - SCAIP*SIN(ZETA) * WHERE ZETA = (2/3)*(-Z)**(3/2) + PI/4 * FOR (-5.0D0) .LE. Z .LE. (+0.0D0) * AI(Z) = SCAI * BI(Z) = SCBI * AI'(Z) = SCAIP * BI'(Z) = SCBIP * AND ZETA = 0 * FOR (+0.0D0) .LT. Z * AI(Z) = SCAI*EXP(-ZETA) * BI(Z) = SCBI*EXP(+ZETA) * AI'(Z) = SCAIP*EXP(-ZETA) * BI'(Z) = SCBIP*EXP(+ZETA) * WHERE ZETA = (2/3)*(+Z)**(3/2) * ---------------------------------------------------------------- * EVALUATION OF THE FUNCTIONS IS BASED ON A NUMBER OF * CHEBYSHEV EXPANSIONS * * THIS VERSION IS SUITABLE FOR MACHINES WITH FULL WORD PRECISION * ---------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION A, B, C, C1, C2, DF, DG, EX, EXP1Z, EXP2Z, F, : G, PIB4, ROOT4Z, ROOTZ, RT3, SCAI, SCAIP, SCBI, : SCBIP, T, T2, XEPS, Y, Z, ZCUBE, ZETA, ZSQ DATA C1 / 3.55028053887817239D-01 / DATA C2 / 2.58819403792806798D-01 / DATA RT3 / 1.73205080756887729D+00 / DATA PIB4 / 7.85398163397448310D-01 / ZETA = 0.0D0 XEPS = 0.0D0 * ---------------------------------------------------------------------- * HERE IF NEAR ENOUGH ORIGIN TO USE 3 TERM POWER SERIES IF ( ABS(Z) .LE. 0.025D0) THEN ZSQ = Z * Z ZCUBE = ZSQ * Z * EVALUATE POWER SERIES ( THREE TERMS IS SUFFICIENT FOR ABS(X) < 0.025) DF = 1.D0 + ZCUBE / 6.D0 + ZCUBE * ZCUBE / 180.D0 DG = Z * (1.D0 + ZCUBE / 12.D0 + ZCUBE * ZCUBE / 504.D0) SCAI = C1 * DF - C2 * DG SCBI = RT3 * (C1 * DF + C2 * DG) * NOW FOR DERIVATIVES DF = ZSQ / 2.D0 + ZSQ * ZCUBE / 30.D0 DG = 1.D0 + ZCUBE / 3.D0 + ZCUBE * ZCUBE / 72.D0 SCAIP = C1 * DF - C2 * DG SCBIP = RT3 * (C1 * DF + C2 * DG) * SCALE THE FUNCTIONS BY EXP(ZETA) IF Z .GT. 0 IF (Z .GT. 0.D0) THEN ROOTZ = SQRT(Z) ZETA = 2.0D0 * Z * ROOTZ / 3.0D0 EX = EXP(ZETA) SCAI = SCAI * EX SCAIP = SCAIP * EX SCBI = SCBI / EX SCBIP = SCBIP / EX END IF RETURN END IF IF (Z.LT.(+9.0D0)) GO TO 10 ROOTZ = SQRT(Z) ROOT4Z = SQRT(ROOTZ) ZETA = 2.0D0*Z*ROOTZ/3.0D0 T = 36.0D0/ZETA - 1.0D0 Y = ((((((((( +1.16537795324979200D-15*T * -1.16414171455572480D-14)*T +1.25420655508401920D-13)*T * -1.55860414100340659D-12)*T +2.21045776110011276D-11)*T * -3.67472827517194031D-10)*T +7.44830865396606612D-09)*T * -1.95743559326380581D-07)*T +7.44672431969805149D-06)*T * -5.28651881409929932D-04)*T +2.81558489585006298D-01 SCAI = Y/ROOT4Z Y = ((((((((((( +4.50165999254528000D-15*T * +1.56232018374502400D-14)*T +5.26240712559918080D-14)*T * +2.97814898856618752D-13)*T +1.97577620975625677D-12)*T * +1.53678944110742706D-11)*T +1.45409933537455235D-10)*T * +1.71547326972380087D-09)*T +2.61898617129147064D-08)*T * +5.49497993491833009D-07)*T +1.76719804365109334D-05)*T * +1.12212109935874117D-03)*T +5.65294557558522063D-01 SCBI = Y/ROOT4Z Y = ((((((((( +1.20954638924697600D-15*T * -1.21281218539020800D-14)*T +1.31303723724964224D-13)*T * -1.64152781754533677D-12)*T +2.34672185025709461D-11)*T * -3.94507329122119338D-10)*T +8.13125005420910243D-09)*T * -2.19736365932356533D-07)*T +8.83993515227257822D-06)*T * -7.43456339972080231D-04)*T -2.82847316336379200D-01 SCAIP = Y*ROOT4Z Y = ((((((((((( -4.59170437029478400D-15*T * -1.59840960512122880D-14)*T -5.41258863340784640D-14)*T * -3.07414589507261184D-13)*T -2.04866616770522650D-12)*T * -1.60321415915690897D-11)*T -1.52922073861488292D-10)*T * -1.82445639488695332D-09)*T -2.83250890588806503D-08)*T * -6.11130377639012647D-07)*T -2.07842147963678572D-05)*T * -1.56350017663858255D-03)*T +5.62646283094843014D-01 SCBIP = Y*ROOT4Z RETURN 10 IF (Z.LT.(+4.5D0)) GO TO 20 ROOTZ = SQRT(Z) ZETA = 2.0D0*Z*ROOTZ/3.0D0 EXP1Z = EXP(ZETA-2.5D0*Z) EXP2Z = EXP(ZETA-2.625D0*Z) T = 4.0D0*Z/9.0D0 - 3.0D0 Y = ((((((((((((((((((((( +9.69081960415394529D-11*T * +3.24436136050920784D-10)*T -3.57419513430644674D-09)*T * -3.84461320827974687D-09)*T +8.88116699085949212D-08)*T * -6.26105174374717557D-08)*T -1.69051051004298110D-06)*T * +3.80731416363041759D-06)*T +2.43840529113057777D-05)*T * -9.74379632673654766D-05)*T -2.45324254437931970D-04)*T * +1.69517926953312785D-03)*T +1.19638433540225211D-03)*T * -2.15255594590357451D-02)*T +9.33777073522844198D-03)*T * +1.98716159257796883D-01)*T -2.54001858882057718D-01)*T * -1.27148775197878180D+00)*T +2.52046376168394778D+00)*T * +5.04987271423387057D+00)*T -1.33120978544419281D+01)*T * -9.34903846550381088D+00)*T +3.10330812950257837D+01 SCAI = Y*EXP1Z Y = (((((((((((((((((((((((( +3.79210935744593920D-14*T * -4.16346635040194560D-14)*T -3.63110681886588928D-13)*T * +1.38932592029414195D-12)*T -4.00489068810888806D-12)*T * +1.39019501834951721D-11)*T -4.50877182237241508D-11)*T * +1.38942309844733264D-10)*T -3.92503498108710093D-10)*T * +1.20125005161756928D-09)*T -3.14234550677825531D-09)*T * +1.03100587323694771D-08)*T -2.35240060783126760D-08)*T * +8.98525670958611253D-08)*T -1.57273011181242048D-07)*T * +7.77696763289738864D-07)*T -8.40211181188135235D-07)*T * +6.34887361301864569D-06)*T -2.73464023289055762D-06)*T * +4.54606729925166230D-05)*T +2.20459155042947089D-06)*T * +2.58823388957588056D-04)*T +7.31023768389466446D-05)*T * +1.01013806904596356D-03)*T +2.64794416332118755D-04)*T * +1.97499785553709145D-03 SCBI = Y/EXP1Z Y = ((((((((((((((((((((( -4.40679918437492851D-10*T * +1.30954945449348301D-10)*T +1.30052079376596751D-08)*T * -2.21315827945437064D-08)*T -2.56850909380644963D-07)*T * +8.66960855365698346D-07)*T +3.75622307499741911D-06)*T * -2.15396233361107222D-05)*T -3.55804094667597110D-05)*T * +3.95317852914037711D-04)*T +5.03369361986934094D-05)*T * -5.54634417403436820D-03)*T +5.29658186908372832D-03)*T * +5.91311623537658225D-02)*T -1.09446664596286554D-01)*T * -4.63589435529194219D-01)*T +1.25323269822030972D+00)*T * +2.50138108959469254D+00)*T -9.12668774193995449D+00)*T * -8.14385732036876466D+00)*T +4.00134082550833019D+01)*T * +1.15396202931444799D+01)*T -8.17378314444550419D+01 SCAIP = Y*EXP1Z Y = (((((((((((((((((((((((( -1.12976379481423872D-13*T * +2.84163275199873024D-13)*T +9.21367859618119680D-14)*T * -6.47465116933029888D-13)*T +5.66210442158931968D-13)*T * -3.03158042458901709D-12)*T +1.32640217809876419D-11)*T * -3.03558223041639219D-11)*T +5.32290407073565901D-11)*T * +1.67561690905544950D-11)*T -3.35234276365918044D-10)*T * +2.92807773020050397D-09)*T -8.76900994127464369D-09)*T * +4.69138029321003869D-08)*T -1.00929917942876779D-07)*T * +5.40401934648687824D-07)*T -8.19977129258456927D-07)*T * +5.13367651438974580D-06)*T -4.77800617725922708D-06)*T * +4.02415391117897098D-05)*T -1.74571192912274417D-05)*T * +2.45332091645215217D-04)*T -2.22916383050374016D-05)*T * +1.02535993549737948D-03)*T +5.94033287658300975D-05)*T * +2.17420627539345627D-03 SCBIP = Y/EXP2Z RETURN 20 IF (Z.LE.(+0.0D0)) GO TO 40 ROOTZ = SQRT(Z) ZETA = 2.0D0*Z*ROOTZ/3.0D0 EXP1Z = EXP(ZETA-1.5D0*Z) EXP2Z = EXP(ZETA-1.375D0*Z) T = 4.0D0*Z/9.0D0 - 1.0D0 IF (Z.LT.(+XEPS)) GO TO 30 Y = ((((((((((((((((((((((( +4.97635854909020570D-12*T * -3.25024150273916928D-11)*T -5.15773946723072737D-11)*T * +8.66802872160017711D-10)*T -9.51292671519803048D-10)*T * -1.33268133924677102D-08)*T +4.37061406144179625D-08)*T * +1.18943714086308365D-07)*T -8.66980482244589319D-07)*T * -2.46768077494905499D-08)*T +1.10610939830483627D-05)*T * -1.80475663535516462D-05)*T -9.22213518989192294D-05)*T * +3.15767712665407001D-04)*T +4.08626419412850994D-04)*T * -3.12704269924340764D-03)*T +6.27899244118607949D-04)*T * +1.99062142478229001D-02)*T -2.27427058211322122D-02)*T * -7.94869698136278246D-02)*T +1.54261999158247445D-01)*T * +1.75618463128730757D-01)*T -5.05223670654169859D-01)*T * -1.49695902416050331D-01)*T +6.91290454439828966D-01 SCAI = Y*EXP1Z Y = (((((((((((((((((((((((((((-8.01144609907912212D-11*T * +2.67566208080291037D-10)*T +1.74416971406971503D-10)*T * -3.12642164666800066D-09)*T +1.22114569059570056D-08)*T * -2.93647730218878800D-08)*T +1.76951994785830839D-08)*T * +2.13143266932123830D-07)*T -1.15569603602267288D-06)*T * +3.34394065752949896D-06)*T -5.20143492253259528D-06)*T * -3.21937890029830155D-06)*T +5.00360593064643409D-05)*T * -1.77449408434194908D-04)*T +3.86357389967150628D-04)*T * -4.53337922165622921D-04)*T -2.60866378774883161D-04)*T * +3.01355585350049504D-03)*T -8.39047077309199055D-03)*T * +1.63240267627966090D-02)*T -1.90830727084112485D-02)*T * +1.65592661387959142D-02)*T +1.76101803014184860D-02)*T * -3.36652019472526494D-02)*T +1.23831258886916327D-01)*T * -6.48342330363017516D-02)*T +2.20310550882807725D-01)*T * -1.03883014957365224D-02)*T +2.06857611342460346D-01 SCBI = Y/EXP2Z 30 Y = ((((((((((((((((((((((( -2.31635825886515692D-11*T * +8.43840142802870600D-11)*T +3.68028065271203758D-10)*T * -2.61043232825754937D-09)*T -4.65110871930215858D-10)*T * +4.46164842334855713D-08)*T -9.24599436690579710D-08)*T * -4.55809882095931368D-07)*T +2.21024501804834447D-06)*T * +1.50251398952558802D-06)*T -2.91830008657289876D-05)*T * +3.51391100964982453D-05)*T +2.37966767002002741D-04)*T * -7.00969870295148024D-04)*T -9.84923358717942729D-04)*T * +6.68935321740601810D-03)*T -1.66398286740112083D-03)*T * -3.83618654865390504D-02)*T +4.80463615092658847D-02)*T * +1.28359791076466449D-01)*T -2.80267155846714091D-01)*T * -2.06049815358004057D-01)*T +7.63522843530878467D-01)*T * +6.47699892977822355D-02)*T -8.32940737409625965D-01 SCAIP = Y*EXP2Z Y = (((((((((((((((((((((((((((+2.69330665471830131D-10*T * -1.25313111217921013D-09)*T +1.45057587508619405D-09)*T * +5.82827351134571594D-09)*T -3.96093412314305685D-08)*T * +1.37346521367521144D-07)*T -2.78927594518121271D-07)*T * +2.96531845420687661D-08)*T +2.27734981888044076D-06)*T * -1.02295902888535994D-05)*T +2.65515218319523965D-05)*T * -3.86457370206378782D-05)*T -1.52212232476268640D-05)*T * +2.84765225803690646D-04)*T -9.65798046252914453D-04)*T * +2.04618065580453522D-03)*T -2.68702422147972510D-03)*T * +8.36839039610090712D-04)*T +6.87131161447866570D-03)*T * -2.10563741100004648D-02)*T +4.13290131622517073D-02)*T * -5.03310394511775398D-02)*T +5.95467795825179773D-02)*T * -1.64213101223235839D-02)*T +5.02536006477020710D-02)*T * +5.75601787687195966D-02)*T +1.33220031651076020D-01)*T * +7.76356357899154668D-02)*T +2.11213324176049168D-01 SCBIP = Y/EXP1Z RETURN 40 IF (Z.LT.(-5.0D0)) GO TO 60 T = Z/5.0D0 T = -T*T*T T = 2.0D0*T - 1.0D0 T2 = 2.0D0*T IF (Z.GT.(-XEPS)) GO TO 50 A = +1.63586492025000000D-18 B = T2*A -1.14937368283025000D-16 C = T2*B-A +7.06090635856696000D-15 A = T2*C-B -3.75504581033290114D-13 B = T2*A-C +1.70874975807662448D-11 C = T2*B-A -6.56273599013291800D-10 A = T2*C-B +2.09250023300659871D-08 B = T2*A-C -5.42780372893997236D-07 C = T2*B-A +1.11655763472468469D-05 A = T2*C-B -1.76193215080912647D-04 B = T2*A-C +2.03792657403144947D-03 C = T2*B-A -1.61616260941907957D-02 A = T2*C-B +7.87369695059018748D-02 B = T2*A-C -1.88090320218915726D-01 C = T2*B-A +8.83593328666433903D-02 A = T2*C-B +9.46330439565858235D-02 F = T*A-C +7.60869994141726643D-02 A = +1.23340698467000000D-19 B = T2*A -9.05440546731800000D-18 C = T2*B-A +5.83052348377146000D-16 A = T2*C-B -3.26253073273305810D-14 B = T2*A-C +1.56911825099665634D-12 C = T2*B-A -6.40386375393414830D-11 A = T2*C-B +2.18414557202733054D-09 B = T2*A-C -6.11127835033401880D-08 C = T2*B-A +1.37095478225289560D-06 A = T2*C-B -2.39464595313812449D-05 B = T2*A-C +3.13306256975299299D-04 C = T2*B-A -2.90953380590207648D-03 A = T2*C-B +1.76972907074092250D-02 B = T2*A-C -6.17055677164122241D-02 C = T2*B-A +9.52472833367213949D-02 A = T2*C-B -4.32381694223484894D-02 G = T*A-C +3.76828717701544063D-02 SCAI = F - G*Z SCBI = RT3*(F + G*Z) 50 A = -2.51308436743000000D-18 B = T2*A +1.65543326242034000D-16 C = T2*B-A -9.49237123028142500D-15 A = T2*C-B +4.68795260455788096D-13 B = T2*A-C -1.96942895842729954D-11 C = T2*B-A +6.93493715818491929D-10 A = T2*C-B -2.01076965264476206D-08 B = T2*A-C +4.69655735896232104D-07 C = T2*B-A -8.59527033121202608D-06 A = T2*C-B +1.18871496270269531D-04 B = T2*A-C -1.18244097697332692D-03 C = T2*B-A +7.87645202148185146D-03 A = T2*C-B -3.14174372672396468D-02 B = T2*A-C +6.20464642445295805D-02 C = T2*B-A -4.83824291776351778D-02 F = T*C-B +2.64808460123486707D-02 A = +5.89382778069400000D-18 B = T2*A -4.04811810887971000D-16 C = T2*B-A +2.42680453287673090D-14 A = T2*C-B -1.25683910148099294D-12 B = T2*A-C +5.55607745069567295D-11 C = T2*B-A -2.06683376304577072D-09 A = T2*C-B +6.35924425685425485D-08 B = T2*A-C -1.58422527393619013D-06 C = T2*B-A +3.11007119112993551D-05 A = T2*C-B -4.64189437787271433D-04 B = T2*A-C +5.00970025411579034D-03 C = T2*B-A -3.62166342717373453D-02 A = T2*C-B +1.53114671641953510D-01 B = T2*A-C -2.69270807740667256D-01 C = T2*B-A -9.61843661149152853D-02 A = T2*C-B +2.07099372879297732D-01 G = T*A-C +9.79943887874547828D-02 SCAIP = Z*Z*F - G SCBIP = RT3*(Z*Z*F + G) RETURN 60 ROOTZ = SQRT(-Z) ROOT4Z = -SQRT(ROOTZ) ZETA = 2.0D0*(-Z)*ROOTZ/3.0D0 T = -250.0D0/(Z*Z*Z) - 1.0D0 A = ((((((((((((( -4.50071772808806400D-15*T * +1.11777933477806080D-14)*T -1.39959545848483840D-14)*T * +4.93110187870320640D-14)*T -2.02193307034590720D-13)*T * +7.53585452663569920D-13)*T -3.14632365928501299D-12)*T * +1.52351450024952975D-11)*T -8.75801572233507014D-11)*T * +6.27349413509555121D-10)*T -6.02183526555303242D-09)*T * +8.70043536788235270D-08)*T -2.32935044050984079D-06)*T * +1.83605337367638430D-04)*T -5.64003555099413391D-01 SCBI = A/ROOT4Z B = (((((((((((((((( -4.12972759036723200D-15*T * +8.36512465551360000D-15)*T -2.05945081774080000D-16)*T * +6.23733840790323200D-15)*T -5.81333983959859200D-14)*T * +1.52893566095288320D-13)*T -4.11064788026333184D-13)*T * +1.33820884559538637D-12)*T -4.74293914921785574D-12)*T * +1.84868021228605050D-11)*T -8.15686769476673166D-11)*T * +4.19373390376196942D-10)*T -2.61584084406303574D-09)*T * +2.10021454539364698D-08)*T -2.37847770210509358D-07)*T * +4.43114636962516363D-06)*T -1.83241371436579068D-04)*T * +3.89918976811026487D-02 SCAI = (B/ZETA)/ROOT4Z A = ((((((((((((( -4.58484390222233600D-15*T * +1.13969221615738880D-14)*T -1.43160328250060800D-14)*T * +5.04734978526300160D-14)*T -2.07055957015081472D-13)*T * +7.73043520694004480D-13)*T -3.23454581960357018D-12)*T * +1.57043540332660220D-11)*T -9.06023827679991573D-11)*T * +6.52303613917050367D-10)*T -6.30993998756281944D-09)*T * +9.23711460831703303D-08)*T -2.54030284953639173D-06)*T * +2.17448385781448409D-04)*T +5.64409671680379110D-01 SCAIP = A*ROOT4Z B = (((((((((((((((( +4.19612197958451200D-15*T * -8.50454708509081600D-15)*T +2.31421341122560000D-16)*T * -6.39683104557465600D-15)*T +5.92509321833062400D-14)*T * -1.56008660983891968D-13)*T +4.20106807813331968D-13)*T * -1.36926896339755520D-12)*T +4.86000800286762854D-12)*T * -1.89780061819570625D-11)*T +8.39314701970122041D-11)*T * -4.32843814802265754D-10)*T +2.71124934991469715D-09)*T * -2.19026888712002973D-08)*T +2.50504395196083566D-07)*T * -4.75245434337472120D-06)*T +2.05252791097940732D-04)*T * -5.46414841607309762D-02 SCBIP = (B/ZETA)*ROOT4Z ZETA = ZETA + PIB4 RETURN END SUBROUTINE SET4(NLEV,JLEV,ATAU,EFACT,IUNIT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C THIS ROUTINE SETS UP BASIS FOR ITYPE=4. C LINEAR RIGID ROTOR + ASYMMETRIC RIGID ROTOR SCATTERING. C INITIAL ROUTINE WRITTEN BY T.R. PHILLIPS, GISS, AUGUST 1990 C DERIVED FROM ROUTINES SET6 AND SET3. C EXTENSIVELY REVISED FOR MOLSCAT VERSION 12 BY TRP (JUL 93) C CURRENT CODE ENTIRELY REWRITTEN (VERSION 14) BY S GREEN (5 AUG 94) C C IMPLEMENTS THREE METHODS TO INPUT BASIS: C 1) A,B,C .GT. 0 SPECIFIED; GENERATE ASYM TOP FNS VIA SET6C ROUTINE C 2) NLEVEL.GT.0 SPECIFIED; READ ASYM TOP FNS FROM IUNIT=IASYMU C -- FOR BOTH 1 & 2, EXPAND WITH J2=J2MIN,J2MAX,J2STEP; LINEAR C ROTOR ENERGIES MUST BE CALCULABLE FROM BE(2); SCREEN ON EMAX C 3) NLEVEL.LT.0 SPECIFIED; READ ASYM TOP FNS FROM IUNIT=IASYMU C FILTERING ON JLEVEL(3*I-1),JLEVEL(3*I)=J1,ITAU; J2=JLEVEL(3*I); C LEVEL ENERGIES MAY BE SPECIFIED IN ELEVEL, OTHERWISE CALC'D C DIMENSION JLEV(2),ATAU(2) C N.B. JLEV AND ATAU OCCUPY SAME STORAGE PASSED FROM DRIVER/BASIN C ON ENTRY X(IXNEXT) SHOULD BE SAME AS ATAU(1)==JLEV(1) C NOTE: NIPR NOT USED FOR JLEV STORAGE; THIS IS CONSERVATIVE C IXNEXT MUST BE INCREMENTED TO REFLECT *ATAU* STORAGE USED. C LOGICAL EIN C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C C CMBASE MADE COMPATIBLE WITH VERSION 14 (SG 2 AUG 94) DIMENSION BE(2),ALPHAE(2),DE(2) EQUIVALENCE (BE(1),AAE(1)), (ALPHAE(1),BBE(1)), (DE(1),CCE(1)) COMMON /CMBASE/ AAE(2),BBE(2),CCE(2),ROTI(6),ELEVEL(1000),EMAX, 1 WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10), 2 J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL C C DEFAULT UNIT IS STANDARD INPUT DATA IDU/5/ C C CHECK FOR CORRECT IV() FLAG IN INITIALIZATION ENTRY IF (IVLFL.NE.0) THEN WRITE(6,690) IVLFL 690 FORMAT(/' SET4 (JUL 93). ILLEGAL IVLFL =',I6) STOP ENDIF C IF (AAE(1).GT.0.D0.AND.BBE(1).GT.0.D0.AND.CCE(1).GT.0.D0) 1 GO TO 3000 C C ASYMMETRIC TOP FUNCTIONS WILL BE INPUT FROM IUNIT; CHECK IT WRITE(6,602) IUNIT 602 FORMAT(/' ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', 1 I4) IF (NLEVEL.GT.0) THEN NREAD=NLEVEL WRITE(6,603) NLEVEL 603 FORMAT(' NUMBER OF INPUT LEVELS SPECIFIED BY NLEVEL IS',I6) ELSE IF (IUNIT.EQ.IDU) THEN WRITE(6,*) ' *** SET4. CANNOT READ FROM STD INPUT FOR', 1 ' NLEVEL.LE.0' STOP ENDIF NREAD=1000000 WRITE(6,*) ' WILL INPUT LEVELS UNTIL END-OF-FILE' ENDIF C IF (NLEVEL.LT.0) GO TO 7000 C C BELOW IS 'CASE 2' -- RESULT SHOULD BE SAME AS FOR 'CASE 1' C C --- READ IN ASYMMETRIC RIGID ROTOR WAVEFUNCTIONS AND ENERGIES --- C CODE BELOW FOLLOWS SET6 CODE NLEV=0 IOFF=0 NKVAL=0 DO 2000 III=1,NREAD READ(IUNIT,500,END=9000) JI,ITAU,EINP 500 FORMAT(2I5,F15.10) NLEV=NLEV+1 JI=IABS(JI) NK=2*JI+1 ELEVEL(NLEV)=EINP*EFACT C SEE IF WE SHOULD SKIP ON JMIN,JMAX,JSTEP OR EMAX IF (JMAX.LE.0) GO TO 2080 JDIF=JI-JMIN JDIF=JDIF-JSTEP*(JDIF/JSTEP) IF (JDIF.EQ.0 .AND. JI.GE.JMIN .AND. JI.LE.JMAX) GO TO 2080 WRITE(6,611) JI,ITAU,ELEVEL(NLEV),JMIN,JSTEP,JMAX 611 FORMAT(/' INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED. ', 1 'J NOT IN RANGE',I4,' (',I4,')',I4) GO TO 2070 2080 IF (EMAX.LE.0.D0) GO TO 2090 IF (ELEVEL(NLEV).LE.EMAX) GO TO 2090 WRITE(6,612) JI,ITAU,ELEVEL(NLEV),EMAX 612 FORMAT(/' INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED ', 1 'DUE TO EMAX =',F11.3) C REACH BELOW IF WE ARE SKIPPING THIS SET 2070 NLEV=NLEV-1 READ(IUNIT,501,END=9100) (ATAUX,I=1,NK) GO TO 2000 C REACH BELOW IF WE ARE INCLUDING THIS SET 2090 CONTINUE C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR NEW JLEV; NB. NIPR NOT USED IOFF=IOFF+6 DO 2020 I=1,NKVAL 2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I) INST=IOFF+NKVAL READ(IUNIT,501,END=9100) (ATAU(INST+I),I=1,NK) 501 FORMAT(6F12.8) C OUTPUT INFORMATION READ. WRITE(6,614) NLEV,JI,ITAU,EINP,ELEVEL(NLEV) 614 FORMAT(/' INPUT LEVEL',I4,' J, TAU =',2I4,' ENERGY =',F15.5, & ' = ',F15.5,' (1/CM)') MJI=-JI WRITE(6,615) (ATAU(INST+1+JI+I),I, I=MJI,JI) 615 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) C GET PARITY CODE FROM ATAU SYMMETRIES. . . IPAR=IPASYM(JI,NK,ATAU(INST+1)) C IPAR=-1 IS ERROR RETURN FROM IPASYM. IF (IPAR.NE.-1) GO TO 2001 WRITE(6,*) ' *** SET4. TERMINAL ERROR.' STOP C REORDER JLEV TO RECEIVE NEW ROW. 2001 NRM1=NLEV-1 IF (NRM1.LE.0) GO TO 2100 IOLD=6*NRM1 IX=6*NLEV DO 2110 II=1,6 IX=IX-1 DO 2120 I=1,NRM1 JLEV(IX)=JLEV(IOLD) IX=IX-1 2120 IOLD=IOLD-1 2110 CONTINUE 2100 JLEV(NLEV)=JI JLEV(2*NLEV)=ITAU JLEV(3*NLEV)=IPAR JLEV(4*NLEV)=NKVAL JLEV(5*NLEV)=NK JLEV(6*NLEV)=NLEV NKVAL=NKVAL+NK GO TO 2000 C C * * * END OF FILE CONDITIONS * * * 9000 IF (NLEVEL.GT.0) GO TO 2200 WRITE(6,606) IUNIT,NLEV 606 FORMAT('0 END OF FILE ENCOUNTERED ON UNIT',I4,' AFTER',I5, & ' FUNCTIONS.') GO TO 2400 2200 WRITE(6,607) IUNIT,NLEV 607 FORMAT('0 PREMATURE E.O.F. ON UNIT',I4,'. NLEVEL REDUCED TO',I6) GO TO 2400 9100 WRITE(6,608) IUNIT,NLEV 608 FORMAT('0 * * * ERROR. E.O.F. ON UNIT',I4,' BEFORE ATAU CARDS F &OR NLEV =',I5) WRITE(6,699) 699 FORMAT('0 * * * TERMINAL ERROR.') STOP 2000 CONTINUE C THIS COMPLETES READ(IASYMU) LOOP C C SET JLEVEL() (ITYPE=6 FORMAT); N.B. ELEVEL() ALREADY SET 2400 DO 2401 I=1,NLEV JLEVEL(2*I-1)=JLEV(I) 2401 JLEVEL(2*I)=JLEV(I+NLEV) C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . . IF (IOFF.NE.6*NLEV) THEN WRITE(6,698) IOFF, NLEV 698 FORMAT(' *** SET4. INDEXING ERROR. IOFF,NLEV =',2I6) STOP ENDIF IX=3*NLEV+1 IXTOP=4*NLEV DO 2410 I=IX,IXTOP 2410 JLEV(I)=JLEV(I)+IOFF C INCREMENT IXNEXT FOR STORAGE TAKEN BY ATAU IXNEXT=IXNEXT+NKVAL C CHECK THAT FUNCTIONS ARE ORTHOGONAL CALL CHECK6(NLEV,JLEV,ATAU) GO TO 4000 C C BELOW IS 'CASE 1', I.E. GENERATE BASIS VIA SET6C 3000 CALL SET6C(JLEV,ATAU,NLEV,.FALSE.) C N.B. SET6C INCREMENTS IXNEXT FOR ATAU STORAGE C IF VALID IASYMU IS GIVEN, OUTPUT ROTOR WFNS IF (IUNIT.LE.0.OR.IUNIT.GE.100.OR.IUNIT.EQ.IDU) GO TO 4000 WRITE(6,*) ' *** SET4 WILL OUTPUT ROTOR WAVEFUNCTIONS TO UNIT', 1 IUNIT WRITE(6,*) ' IN FORMAT FOR FUTURE INPUT' DO 1011 I=1,NLEV JI=JLEV(I) ITAU=JLEV(NLEV+I) ISTA=JLEV(3*NLEV+I) NK=JLEV(4*NLEV+I) INDX=JLEV(5*NLEV+I) WRITE(IUNIT,500,ERR=1099) JI,ITAU,ELEVEL(INDX) 1011 WRITE(IUNIT,501,ERR=1099) (ATAU(ISTA+II),II=1,NK) RETURN 1099 WRITE(6,*) ' *** SET4. ERROR WRITING TO IASYMU; WFNS NOT SAVED' RETURN C C CALL J6TO4 TO EXPAND 'ITYPE=6' TO 'ITYPE=4' FORMAT C SET UP WORKING STORAGE. IXNEXT ALREADY REFLECTS ATAU STORAGE C N.B. JLEV STORAGE DOES *NOT* REFLECT NIPR; SHOULD BE CONSERVATIVE 4000 IOFF=6*NLEV IXEL=IXNEXT+IOFF IXJL=IXEL+MXEL IXJNW=IXJL+MXJL NAVAIL=MX-IXJNW IF (NAVAIL.LT.8*NLEV) THEN WRITE(6,*) ' *** SET4. INSUFFICIENT WORKING SPACE FOR J6TO4' WRITE(6,*) ' IXNEXT,MX,NAVAIL =',IXNEXT,MX,NAVAIL STOP ENDIF C J6TO4 EXPANDS ITYPE=6 DATA FORMAT WITH POSSIBLE J2 VALUES C TO PRODUCE ITYPE=4 DATA FORMAT CALL J6TO4(NLEV,JLEV,ATAU,X(IXJNW),NAVAIL,X(IXEL),X(IXJL)) RETURN C C CODE BELOW IS 'CASE 3' NLEVEL.LT.0; FILTER IASYMU INPUT ON JLEVEL 7000 NLEVEL=ABS(NLEVEL) IF (NLEVEL.GT.MXEL) THEN WRITE(6,*) ' *** SET4. REQUESTED NLEVEL.GT.MXEL' STOP ENDIF WRITE(6,*) ' BASIS FUNCTIONS DETERMINED BY &BASIS JLEVEL()' WRITE(6,*) ' NUMBER OF LEVELS (NLEVEL) =',NLEVEL EIN=.FALSE. DO 7001 I=1,NLEVEL 7001 EIN=EIN.AND.ELEVEL(I).GT.0.D0 IF (EIN) THEN WRITE(6,*) 1 ' ENERGIES FOR BASIS FNS TAKEN FROM &BASIN ELEVEL VALUES' ELSE IF (BE(2).LE.0.D0) THEN WRITE(6,*) ' *** SET4. CANNOT OBTAIN LINEAR ROTOR', 1 ' ENERGY FROM BE(2)' STOP ENDIF WRITE(6,*) ' ASYMMETRIC TOP ENERGIES TAKEN FROM IASYMU' WRITE(6,644) BE(2) 644 FORMAT(/' LINEAR ROTOR ENERGY LEVELS COMPUTED FROM B(E) =', 1 F12.8) IF (ALPHAE(2).NE.0.D0) WRITE(6,645) ALPHAE(2) 645 FORMAT(27X,'CORRECTED FOR ALPHA(E) = ',F12.8) IF (DE(2).NE.0.D0) WRITE(6,646) DE(2) 646 FORMAT(27X,'CORRECTED FOR D(E) = ',F12.8) ENDIF C BEGIN READ(IASYMU) LOOP NLEV=0 IOFF=0 NKVAL=0 DO 7100 III=1,NREAD READ(IUNIT,500,END=9200) JI,ITAU,EINP NK=2*JI+1 EINX=EINP*EFACT NMATCH=0 DO 7200 IND=1,NLEVEL IF (JLEVEL(3*IND-2).NE.JI.OR.JLEVEL(3*IND-1).NE.ITAU) GO TO 7200 C WE'VE FOUND A MATCH ON JI, ITAU, NMATCH=NMATCH+1 J2=JLEVEL(3*IND) FJ=DBLE(J2) FJ=FJ*(FJ+1.D0) E2=(BE(2)-ALPHAE(2)*0.5D0)*FJ - DE(2)*FJ*FJ IF (.NOT.EIN) ELEVEL(IND)=EINX+E2 C EXPAND JI WITH J2 TO J12 IN GENERATING NLEV,JLEV FROM THIS SET J12MIN=ABS(JI-J2) J12MAX=JI+J2 DO 7400 J12=J12MIN,J12MAX NLEV=NLEV+1 C SHIFT ATAU BY 8 WORDS TO MAKE ROOM FOR INCOMING JLEV IOFF=IOFF+8 DO 7220 I=1,NKVAL 7220 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-7-I) C READ ATAU, BUT ONLY THE FIRST TIME WE USE THIS WAVEFUNCTION IF (NMATCH.EQ.1) THEN INST=IOFF+NKVAL READ(IUNIT,501,END=9300) (ATAU(INST+I),I=1,NK) C OUTPUT INFORMATION READ. WRITE(6,651) JI,ITAU,EINP,EINX 651 FORMAT(/' INPUT LEVEL, J, TAU =',2I4,' ENERGY =',F12.4, 1 ' = ',F12.4,' (1/CM)') MJI=-JI WRITE(6,652) (ATAU(INST+1+JI+I),I,I=MJI,JI) 652 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) C GET PARITY CODE FROM ATAU SYMMETRIES. . . IPAR=IPASYM(JI,NK,ATAU(INST+1)) C IPAR=-1 IS ERROR RETURN FROM IPASYM. IF (IPAR.EQ.-1) THEN WRITE(6,*) ' *** SET4. ILEGAL SYMMETRY FOR INPUT WFN.' STOP ENDIF ISTA=NKVAL NKVAL=NKVAL+NK ENDIF C REORDER JLEV TO RECEIVE NEW ROW; ADAPTED FROM SET6 CODE. NRM1=NLEV-1 IF (NRM1.LE.0) GO TO 7300 IOLD=8*NRM1 IX=8*NLEV DO 7310 II=1,8 IX=IX-1 DO 7320 I=1,NRM1 JLEV(IX)=JLEV(IOLD) IX=IX-1 7320 IOLD=IOLD-1 7310 CONTINUE 7300 JLEV(NLEV)=J12 JLEV(2*NLEV)=J2 JLEV(3*NLEV)=JI JLEV(4*NLEV)=ITAU JLEV(5*NLEV)=IPAR JLEV(6*NLEV)=ISTA JLEV(7*NLEV)=NK JLEV(8*NLEV)=IND 7400 CONTINUE C THIS ENDS J12 LOOP 7200 CONTINUE C THIS ENDS LOOP OVER NLEVEL, JLEVEL() SETS. C IF WE DID NOT USE THIS FUNCTION (NMATCH.EQ.0) SKIP ATAU CARDS IF (NMATCH.LE.0) READ(IUNIT,501,END=9300) (ATAUX,I=1,NK) GO TO 7100 C C END OF FILE CONDITIONS 9300 WRITE(6,*) ' *** SET4. EOF ON IASYMU WHILE READING ATAU DATA' STOP 9200 WRITE(6,*) ' *** SET4. NORMAL EOF ENCOUNTERED ON IASYMU' GO TO 7500 C 7100 CONTINUE C THIS ENDS LOOP OVER READ IASYMU C C CORRECT ISTA=JLEV(LEV,6) FOR SPACE TAKEN BY JLEV. . . 7500 IF (IOFF.NE.8*NLEV) THEN WRITE(6,698) IOFF, NLEV STOP ENDIF IX=5*NLEV+1 IXTOP=6*NLEV DO 7505 I=IX,IXTOP 7505 JLEV(I)=JLEV(I)+IOFF C C NEED TO SET JMIN,JMAX FOR USE IN SELECTING ORBITAL L IN BASE JMIN=JLEV(1) JMAX=JMIN DO 7510 I=1,NLEV JMIN=MIN(JMIN,JLEV(I)) 7510 JMAX=MAX(JMAX,JLEV(I)) C C MAKE SURE THAT WE HAVE FOUND AN ASYMMETRIC ROTOR WFN FOR C ALL NLEVEL JLEVEL() SETS. UNLIKE ITYPE=6, WE DO NOT REORDER DO 7600 I=1,NLEVEL DO 7601 IX=1,NLEV IF (JLEV(7*NLEV+IX).EQ.IX) GO TO 7600 7601 CONTINUE WRITE(6,660) I,JLEVEL(3*I-2),JLEVEL(3*I-1) 660 FORMAT(/' *** SET4. DID NOT FIND BASIS FUNCTIONS FOR LEVEL',I4/ 1 ' JI,ITAU =',2I6) STOP 7600 CONTINUE C INCREMENT IXNEXT TO REFLECT ATAU STORAGE IXNEXT=IXNEXT+NKVAL RETURN C END SUBROUTINE SET6(LEVIN,EIN,NLEV,JLEV,ATAU,EFACT,IUNIT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C REVISED FOR VERSION 14: C THREE POSSIBLE METHODS OF SPECIFYING ASYMMETRIC TOP LEVELS C 1. A,B,C .GT.0 IMPLIES GENERATE VIA SET6C C 2. NLEVEL.GE.0 IMPLIES READ FROM IASYMU (FILTER ON JMIN,JMAX, C JSTEP,EMAX); IF (NLEVEL.EQ.0) READ TO END-OF-FILE C 3. NLEVEL.LT.0 IMPLIES READ FROM IASYMU BUT ACCEPT ONLY THOSE C J,ITAU CORRESPONDING TO JLEVEL(2*I-1),JLEVEL(2*I), C I=1,ABS(NLEVEL) C C BELOW REPLACES GENERIC SAVE IN V11, WHICH APPEARED UNNECESSARY. SAVE IFIRST,NOMEM,NL12,IXMX,ISTART C C THIS ROUTINE HANDLES INPUT, ALSO MATRIX ELEMENTS FOR ITYPE=6. C LATTER ARE OBTAINED VIA ENTRIES ASYME, CPL6, CPL26. C FIRST VERSION WRITTEN AT MPI, MUNCHEN, JULY 1976. C CURRENT VERSION 11 MAR 93 SAVES COUPLING ELEMENTS IN X ARRAY C ASYME (EFF. POTL) COULD BE CHANGED, BUT PROBABLY NO LONGER USED C C N.B. NKVAL HERE COULD BE OBTAINED AS NEEDED - NK=2*J+1. C THIS CODE IS MORE FLEXIBLE AS NOT ALL NEED BE STORED BUT C K-VALUE COULD BE OBTAINED VIA ADDITIONAL VECTOR KVAL(IST+1). C LOGICAL LEVIN,EIN LOGICAL LIN LOGICAL NOMEM,ODD INTEGER JLEV(2) DIMENSION ATAU(2) C N.B. JLEV AND ATAU OCCUPY SAME STORAGE PASSED FROM DRIVER/BASIS. C IXNEXT MUST BE INCREMENTED TO REFLECT *ATAU* STORAGE USED C (BUT NOT JLEV, BECAUSE BASIN INCREMENTS IXNEXT BY NQN*NLEV) C C SPECIFICATIONS FOR ASYME, CPL6, CPL26 ENTRIES. INTEGER J(N),L(N),LAM(2) DIMENSION VL(2) INTEGER PRINT LOGICAL LFIRST C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) COMMON /VLSAVE/ IVLU C COMMON /CMBASE/ AE(2),BE(2),CE(2),ROTI(6),ELEVEL(1000),EMAX, & WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10), & J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL C C DEFAULT INPUT UNIT IS STANDARD INPUT ... DATA IDU/5/ DATA PI/3.14159 26535 89793 D0/ DATA EPS/1.D-9/, Z0/0.D0/ C C STATEMENT FUNCTIONS F(NN)=DBLE(NN+NN+1) ODD(I)=I-2*(I/2).NE.0 C C CHECK FOR CORRECT IV() FLAG IN INITIALIZATION ENTRY IF (IVLFL.NE.0) THEN WRITE(6,690) IVLFL 690 FORMAT(/' SET6 (JAN 93). ILLEGAL IVLFL =',I6) STOP ENDIF C C IF ROTATION CONSTANTS ARE INPUT, GENERATE BASIS VIA SET6C IF (AE(1).GT.0.D0 .AND. BE(1).GT.0.D0 .AND. CE(1).GT.0.D0) THEN CALL SET6C(JLEV,ATAU,NLEV,EIN) C OPTION ADDED (AUG 94) TO OUTPUT ROTOR WFNS TO IASYMU IF (IUNIT.LE.0.OR.IUNIT.GE.100.OR.IUNIT.EQ.IDU) RETURN WRITE(6,*) ' *** SET6 WILL OUTPUT ROTOR WAVEFUNCTIONS TO UNIT', 1 IUNIT WRITE(6,*) ' IN FORMAT FOR FUTURE INPUT' DO 1011 I=1,NLEV JI=JLEV(I) ITAU=JLEV(NLEV+I) ISTA=JLEV(3*NLEV+I) NK=JLEV(4*NLEV+I) INDX=JLEV(5*NLEV+I) WRITE(IUNIT,500,ERR=1099) JI,ITAU,ELEVEL(INDX) 1011 WRITE(IUNIT,501,ERR=1099) (ATAU(ISTA+II),II=1,NK) RETURN 1099 WRITE(6,*) ' *** SET6. ERROR WRITING TO IASYMU; WFNS NOT SAVED' RETURN ENDIF C C OTHERWISE, INPUT FROM UNIT IASYMU IF (IUNIT.GT.0 .AND. IUNIT.LT.100) GO TO 1000 WRITE(6,601) IUNIT,IDU 601 FORMAT(/' ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, ', 1 'DEFAULTED TO ',I4) IUNIT=IDU C 1000 WRITE(6,602) IUNIT 602 FORMAT(/' ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', 1 I4) LIN=.FALSE. IF (LEVIN) THEN NREAD=NLEVEL WRITE(6,603) NLEVEL 603 FORMAT(' ',10X,I6,' INPUT LEVELS SPECIFIED BY NLEVEL.') ELSE IF (IUNIT.EQ.IDU) THEN WRITE(6,*) ' *** SET6. CANNOT READ FROM STD INPUT FOR', 1 ' NLEVEL.LE.0' STOP ENDIF NREAD=1000000 IF (NLEVEL.LT.0) THEN LIN=.TRUE. WRITE(6,613) NLEVEL 613 FORMAT(5X,'NEGATIVE NLEVEL =',I5, 1 ' WILL SCREEN INPUT ON &BASIS JLEVEL()') NLEVEL=-NLEVEL IF (EIN) THEN WRITE(6,*) ' ENERGIES TAKEN FROM &BASIS ELEVEL' ELSE WRITE(6,*) ' ENERGIES TAKEN FROM IASYMU' ENDIF ENDIF ENDIF C NLEV=0 IOFF=0 NKVAL=0 DO 2000 III=1,NREAD READ(IUNIT,500,END=9000) JI,ITAU,EINP 500 FORMAT(2I5,F15.10) NLEV=NLEV+1 IF (NLEV.GT.MXEL) THEN WRITE(6,*) ' *** SET6. DIMENSION OF ELEVEL EXCEEDED',NLEV STOP ENDIF JI=IABS(JI) NK=2*JI+1 IF (LIN) THEN C CODE BELOW FILTERS IASYMU INPUT ON JLEVEL DO 2099 IND=1,NLEVEL IF (JLEVEL(2*IND-1).NE.JI.OR.JLEVEL(2*IND).NE.ITAU) GO TO 2099 INDX=IND IF (.NOT.EIN) ELEVEL(INDX)=EINP*EFACT GO TO 2090 2099 CONTINUE WRITE(6,683) JI,ITAU,EINP 683 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED.', 1 ' NOT IN JLEVEL LIST') GO TO 2070 ELSE ELEVEL(NLEV)=EINP*EFACT C SEE IF WE SHOULD SKIP ON JMIN,JMAX,JSTEP OR EMAX IF (JMAX.LE.0) GO TO 2080 JDIF=JI-JMIN JDIF=JDIF-JSTEP*(JDIF/JSTEP) IF (JDIF.EQ.0 .AND. JI.GE.JMIN .AND. JI.LE.JMAX) GO TO 2080 WRITE(6,681) JI,ITAU,ELEVEL(NLEV),JMIN,JSTEP,JMAX 681 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED. ', 1 'J NOT IN RANGE',I4,' (',I4,')',I4) GO TO 2070 2080 IF (EMAX.LE.0.D0) GO TO 2090 IF (ELEVEL(NLEV).LE.EMAX) GO TO 2090 WRITE(6,680) JI,ITAU,ELEVEL(NLEV),EMAX 680 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED ', 1 'DUE TO EMAX =',F11.3) ENDIF C C REACH BELOW IF WE ARE SKIPPING THIS SET 2070 NLEV=NLEV-1 READ( IUNIT,501,END=9100) (ATAUX,I=1,NK) GO TO 2000 C C READ BELOW IF WE ARE INCLUDING THIS SET 2090 CONTINUE C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR INCOMING JLEV. IOFF=IOFF+6 DO 2020 I=1,NKVAL 2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I) INST=IOFF+NKVAL READ(IUNIT,501,END=9100) (ATAU(INST+I),I=1,NK) 501 FORMAT(6F12.8) C OUTPUT INFORMATION READ. WRITE(6,604) NLEV,JI,ITAU,EINP,ELEVEL(NLEV) 604 FORMAT('0 INPUT LEVEL',I4,' J, TAU =',2I4,' ENERGY =',F15.5, & ' = ',F15.5,' (1/CM)') MJI=-JI WRITE(6,605) (ATAU(INST+1+JI+I),I, I=MJI,JI) 605 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) C C GET PARITY CODE FROM ATAU SYMMETRIES. . . IPAR=IPASYM(JI,NK,ATAU(INST+1)) C IPAR=-1 IS ERROR RETURN FROM IPASYM. IF (IPAR.NE.-1) GO TO 2001 WRITE(6,699) STOP C REORDER JLEV TO RECEIVE NEW ROW. 2001 NRM1=NLEV-1 IF (NRM1.LE.0) GO TO 2100 IOLD=6*NRM1 IX=6*NLEV DO 2110 II=1,6 IX=IX-1 DO 2120 I=1,NRM1 JLEV(IX)=JLEV(IOLD) IX=IX-1 2120 IOLD=IOLD-1 2110 CONTINUE C 2100 JLEV(NLEV)=JI JLEV(2*NLEV)=ITAU JLEV(3*NLEV)=IPAR JLEV(4*NLEV)=NKVAL JLEV(5*NLEV)=NK IF (LIN) THEN JLEV(6*NLEV)=INDX ELSE JLEV(6*NLEV)=NLEV ENDIF NKVAL=NKVAL+NK GO TO 2000 C C * * * END OF FILE CONDITIONS * * * 9000 IF (LEVIN) GO TO 2200 WRITE(6,606) IUNIT,NLEV 606 FORMAT('0 END OF FILE ENCOUNTERED ON UNIT',I4,' AFTER',I5, & ' FUNCTIONS.') GO TO 2400 2200 WRITE(6,607) IUNIT,NLEV 607 FORMAT('0 PREMATURE E.O.F. ON UNIT',I4,'. NLEVEL REDUCED TO',I6) GO TO 2400 9100 WRITE(6,608) IUNIT,NLEV 608 FORMAT('0 * * * ERROR. E.O.F. ON UNIT',I4,' BEFORE ATAU CARDS F &OR NLEV =',I5) WRITE(6,699) 699 FORMAT('0 * * * TERMINAL ERROR.') STOP 2000 CONTINUE C THIS COMPLETES READ(IASYMU) LOOP C 2400 IF (LIN) THEN C WE FILTERED ON JLEVEL(), MAKE SURE WE HAVE THEM ALL IF (NLEV.NE.NLEVEL) THEN WRITE(6,*) ' ALL LEVELS SPECIFIED BY JLEVEL() WERE NOT FOUND' WRITE(6,*) ' *** TERMINAL ERROR.' STOP ENDIF C MAKE SURE EACH VALUE IS THERE AND REORDER IF NECESSARY C SO THAT JLEV(I,6)=I (EXPECTED BY PRBR, EG) DO 2409 I=1,NLEVEL DO 2408 IX=1,NLEV IF (I.NE.JLEV(5*NLEV+IX)) GO TO 2408 IF (I.EQ.IX) GO TO 2409 DO 2407 IC=1,6 ITMP=JLEV((IC-1)*NLEV+I) JLEV((IC-1)*NLEV+I)=JLEV((IC-1)*NLEV+IX) 2407 JLEV((IC-1)*NLEV+IX)=ITMP GO TO 2409 2408 CONTINUE WRITE(6,684) I,JLEVEL(2*I-1),JLEVEL(2*I) 684 FORMAT(' INPUT SET',I4,' J, TAU =',2I5,' NOT FOUND ON IASYMU' 1 /' *** TERMINAL ERROR') STOP 2409 CONTINUE ELSE C SET J,TAU INTO JLEVEL; GET JMIN,JMAX (ARE THOSE NEEDED?) NLEVEL=NLEV C SET JLEVEL(), JMIN, AND JMAX. JMIN=JLEV(1) JMAX=JMIN DO 2401 I=1,NLEV JI=JLEV(I) JLEVEL(2*I-1)=JI JLEVEL(2*I)=JLEV(I+NLEV) JMIN=MIN0(JMIN,JI) 2401 JMAX=MAX0(JMAX,JI) ENDIF C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . . IF (IOFF.NE.6*NLEV) THEN WRITE(6,698) IOFF, NLEV 698 FORMAT(' SET6. INDEXING ERROR. IOFF,NLEV =',2I6) STOP ENDIF IX=3*NLEV+1 IXTOP=4*NLEV DO 2410 I=IX,IXTOP 2410 JLEV(I)=JLEV(I)+IOFF C CHECK THAT FUNCTIONS ARE ORTHOGONAL CALL CHECK6(NLEV,JLEV,ATAU) C CHECK THAT ENERGIES ARE NOT ALL IDENTICALLY ZERO. DO 2500 I=1,NLEV IF (ELEVEL(I).NE.0.D0) GO TO 2510 2500 CONTINUE IF (NLEVEL.GT.1) THEN WRITE(6,609) 609 FORMAT(' *** WARNING. SET6. ENERGIES ARE ALL ZERO') ENDIF 2510 IXNEXT=IXNEXT+NKVAL RETURN C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THESE ENTRY POINTS COMPUTE COUPLING MATRIX ELEMENTS . . . C ENTRY ASYME(N,J,L,MXLAM,LAM,VL,IV,JLEV,ATAU,NLEV) ASSIGN 3003 TO IGO1 ASSIGN 3033 TO IGO2 GO TO 3000 C ENTRY CPL6(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,ATAU,NLEV,PRINT,LFIRST) IF (LFIRST) THEN IFIRST=-1 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF IF (IFIRST.GT.-1) GO TO 5500 IF (NOMEM) GO TO 5900 NL12=NLEV*(NLEV+1)/2 IXMX=NL12*MXLAM ISTART=MX+1 NAVAIL=ISTART-IXNEXT IF (IXMX.LE.NAVAIL) GO TO 5100 IF (PRINT.GE.3) WRITE(6,694) IXMX,NAVAIL 694 FORMAT(/' CPL6 (MAR 93). UNABLE TO STORE JTOT-INDEPENDENT PART' 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) NOMEM=.TRUE. GO TO 5900 5100 IX=0 DO 5200 LL=1,MXLAM LM=LAM(2*LL-1) XLM=LM MU=LAM(2*LL) XMU=MU DO 5201 IC=1,NLEV JC=JLEV(IC) XJC=JC ISTC=JLEV(IC+3*NLEV) NKC=JLEV(IC+4*NLEV) DO 5201 IR=1,IC IX=IX+1 JR=JLEV(IR) XJR=JR ISTR=JLEV(IR+3*NLEV) NKR=JLEV(IR+4*NLEV) XCPL=Z0 KKC=-JC DO 5300 KC=1,NKC C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 5300 XKC=KKC KKR=-JR DO 5400 KR=1,NKR C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 5400 XKR=KKR C AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)*PARITY(KKR) AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) IF (ODD(KKR)) AF=-AF IF (KKR-KKC.NE.MU) GO TO 5401 XCPL=XCPL+AF*THRJ(XJC,XJR,XLM,XKC,-XKR,XMU) IF (MU.EQ.0) GO TO 5400 5401 IF (KKC-KKR.NE.MU) GO TO 5400 C ADJUST FOR (-1)**MU IN POTENTIAL. . . C AF=AF*PARITY(MU) IF (ODD(MU)) AF=-AF XCPL=XCPL+AF*THRJ(XJC,XJR,XLM,XKC,-XKR,-XMU) 5400 KKR=KKR+1 5300 KKC=KKC+1 C NOW GET 'CONSTANT FACTORS' XFCT=PARITY(JC+JR)*SQRT((F(JC)*F(JR)*F(LM))/(4.D0*PI)) 5201 X(ISTART-IX)=XCPL*XFCT 5200 CONTINUE IF (PRINT.GT.3) WRITE(6,695) IXMX 695 FORMAT(/' CPL6 (MAR 93). JTOT-INDEPENDENT PARTS OF COUPLING', 1 ' MATRIX STORED.'/ 2 ' REQUIRED STORAGE =',I8) C RESET MX, IFIRST TO REFLECT STORED VALUES MX=MX-IXMX IFIRST=0 C C NOW GET COUPLING MATRIX ELEMENTS FROM STORED PARTS 5500 PJT=PARITY(JTOT) IF (IVLU.GT.0) REWIND IVLU DO 5600 LL=1,MXLAM LM=LAM(2*LL-1) MU=LAM(2*LL) C C STORAGE FOR 3J AND 6J SYMBOLS C ITL=IXNEXT IT6=ITL+2*LM+1 IXNEXT=IT6+2*LM+1 NUSED=0 CALL CHKSTR(NUSED) C IX1=(LL-1)*NL12 NNZ=0 IF (IVLU.EQ.0) THEN IX=LL ELSE IX=1 ENDIF C LSAV=-1 DO 5700 IC=1,N LEVC=J(IC) JC=JLEV(LEVC) LC=L(IC) IF (LC.NE.LSAV) THEN CALL J3J000(DBLE(LC),DBLE(LM),IVALL,X(ITL),XLMIN) LMIN=IABS(LC-LM) LMAX=LC+LM LSAV=LC ENDIF C LSAV6=-1 DO 5700 IR=1,IC LEVR=J(IR) JR=JLEV(LEVR) LR=L(IR) C IF (LEVR.GE.LEVC) THEN IX2=LEVR*(LEVR-1)/2+LEVC ELSE IX2=LEVC*(LEVC-1)/2+LEVR ENDIF INDX=IX1+IX2 C IF (X(ISTART-INDX).EQ.0.D0 1 .OR. LR.LT.LMIN .OR. LR.GT.LMAX 2 .OR. ODD(LR+LMAX)) THEN VL(IX)=0.D0 ELSE IF (LR.NE.LSAV6) THEN IVAL6=MX-IT6+1 CALL J6J(DBLE(LR),DBLE(JTOT),DBLE(LC),DBLE(JC),DBLE(LM), 1 IVAL6,XJMIN6,X(IT6)) JMIN6=INT(XJMIN6) LSAV6=LR ENDIF IF (JR.LT.JMIN6 .OR. JR.GE.JMIN6+IVAL6) THEN VL(IX)=0.D0 ELSE INDL=ITL+(LR-LMIN)/2 IND6=IT6+JR-JMIN6 VL(IX)=PJT*SQRT(F(LC)*F(LR))*X(ISTART-INDX)*X(INDL)*X(IND6) ENDIF ENDIF IF (VL(IX).NE.0.D0) NNZ=NNZ+1 IF (IVLU.EQ.0) THEN IX=IX+MXLAM ELSE IX=IX+1 ENDIF 5700 CONTINUE IF (NNZ.EQ.0) WRITE(6,697) LM,MU IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) IXNEXT=ITL 5600 CONTINUE RETURN C C IF WE CANNOT STORE PARTIAL COUPLING MATRIX, RECALCULATE. 5900 ASSIGN 3001 TO IGO1 ASSIGN 3011 TO IGO2 GO TO 3000 C ENTRY CPL26(N,MXLAM,LAM,NLEV,JLEV,ATAU,J,MVAL,VL,PRINT,LFIRST) C C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION IF (LFIRST) THEN IFIRST=-1 LFIRST=.FALSE. NOMEM=.FALSE. ENDIF C IF (IFIRST.GT.-1) GO TO 4500 C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS NL12=NLEV*(NLEV+1)/2 IXMX=NL12*MXLAM ISTART=MX+1 C 4500 MVABS=IABS(MVAL) C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE C IF NOT, TRY TO STORE THEM IN XCPL(). IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 4900 MV=IFIRST+1 C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. 4600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 4610 IF (PRINT.GE.1) WRITE(6,642) MV,ISTART-1,MX,IXMX*(IFIRST+1) 642 FORMAT(/' CPL26 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT', 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X, 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) NOMEM=.TRUE. GO TO 4900 C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL 4610 NAVAIL=MX-IXNEXT+1 IF (IXMX.LE.NAVAIL) GO TO 4601 IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL 692 FORMAT(/' CPL26 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES NOMEM=.TRUE. GO TO 4900 C C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL 4601 MX=MX-IXMX C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0) IX=MV*IXMX DO 4200 LL=1,MXLAM LM=LAM(2*LL-1) MU=LAM(2*LL) DO 4201 IC=1,NLEV JC=JLEV(IC) ISTC=JLEV(IC+3*NLEV) NKC=JLEV(IC+4*NLEV) DO 4201 IR=1,IC JR=JLEV(IR) ISTR=JLEV(IR+3*NLEV) NKR=JLEV(IR+4*NLEV) IX=IX+1 XCPL=Z0 KKC=-JC DO 4300 KC=1,NKC C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 4300 KKR=-JR DO 4400 KR=1,NKR C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 4400 AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) IF (KKR-KKC.NE.MU) GO TO 4401 XCPL=XCPL+AF*GSYMTP(JC,KKC,JR,KKR,MV ,LM,MU) IF (MU.EQ.0) GO TO 4400 4401 IF (KKC-KKR.NE.MU) GO TO 4400 C ADJUST FOR (-1)**MU IN POTENTIAL. . . C AF=AF*PARITY(MU) IF (ODD(MU)) AF=-AF XCPL=XCPL+AF*GSYMTP(JC,KKC,JR,KKR,MV,LM,-MU) 4400 KKR=KKR+1 4300 KKC=KKC+1 4201 X(ISTART-IX)=XCPL 4200 CONTINUE IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL 693 FORMAT(/' CPL26 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. IFIRST=MV C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. MV=MV+1 IF (MV.LE.MVABS) GO TO 4600 C 4900 IF (MVABS.GT.IFIRST) GO TO 4800 C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL IXM=MVABS*IXMX IF (IVLU.GT.0) REWIND IVLU DO 4513 LL=1,MXLAM LM=LAM(2*LL-1) NNZ=0 IF (IVLU.EQ.0) THEN IX=LL ELSE IX=1 ENDIF DO 4503 ICOL=1,N I1=J(ICOL) J1=JLEV(I1) DO 4503 IROW=1,ICOL I2=J(IROW) J2=JLEV(I2) IF (I1.GT.I2) THEN IX12=I1*(I1-1)/2+I2 ELSE IX12=I2*(I2-1)/2+I1 ENDIF IXX=IXM+(LL-1)*NL12+IX12 VL(IX)=X(ISTART-IXX) C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY C FOR PARITY OF THRJ(J1,LM,J2,-MVAL,0,MVAL) IF (MVAL.LT.0.AND.ODD(J1+J2+LM)) VL(IX)=-VL(IX) IF (VL(IX).NE.Z0) NNZ=NNZ+1 IF (IVLU.EQ.0) THEN IX=IX+MXLAM ELSE IX=IX+1 ENDIF 4503 CONTINUE IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVAL,LL 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', & 'COEFFICIENTS ARE 0.') IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) 4513 CONTINUE RETURN C C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM VIA OLD CODE 4800 ASSIGN 3002 TO IGO1 ASSIGN 3022 TO IGO2 GO TO 3000 C C -------------------- OLD CODE REJOINS HERE --------------------- C 3000 IF (IVLU.GT.0) REWIND IVLU DO 3100 LL=1,MXLAM LM=LAM(2*LL-1) MU=LAM(2*LL) NNZ=0 IF (IVLU.EQ.0) THEN IX=LL ELSE IX=1 ENDIF C DO 3200 IC=1,N JC=JLEV(J(IC)) ISTC=JLEV(J(IC)+3*NLEV) NKC=JLEV(J(IC)+4*NLEV) DO 3200 IR=1,IC JR=JLEV(J(IR)) ISTR=JLEV(J(IR)+3*NLEV) NKR=JLEV(J(IR)+4*NLEV) C VL(IX)=0.D0 KKC=-JC DO 3300 KC=1,NKC C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 3300 KKR=-JR DO 3400 KR=1,NKR C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 3400 AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) IF (KKR-KKC.NE.MU) GO TO 3500 GO TO IGO1,(3001,3002,3003) 3001 VL(IX)=VL(IX)+AF*FSYMTP(JC,KKC,L(IC),JR,KKR,L(IR),JTOT,LM,MU) GO TO 3009 3002 VL(IX)=VL(IX)+AF*GSYMTP(JC,KKC,JR,KKR,MVAL,LM,MU) GO TO 3009 3003 VL(IX)=VL(IX)+AF*ESYMTP(JC,KKC,JR,KKR,LM,MU) C 3009 IF (MU.EQ.0) GO TO 3400 3500 IF (KKC-KKR.NE.MU) GO TO 3400 C ADJUST FOR (-1)**MU IN POTENTIAL. . . AF=AF*PARITY(MU) GO TO IGO2,(3011,3022,3033) 3011 VL(IX)=VL(IX)+AF*FSYMTP(JC,KKC,L(IC),JR,KKR,L(IR),JTOT,LM,-MU) GO TO 3400 3022 VL(IX)=VL(IX)+AF*GSYMTP(JC,KKC,JR,KKR,MVAL,LM,-MU) GO TO 3400 3033 VL(IX)=VL(IX)+AF*ESYMTP(JC,KKC,JR,KKR,LM,-MU) C 3400 KKR=KKR+1 3300 KKC=KKC+1 IF (VL(IX).NE.0.D0) NNZ=NNZ+1 IF (IVLU.EQ.0) THEN IX=IX+MXLAM ELSE IX=IX+1 ENDIF 3200 CONTINUE IF (NNZ.EQ.0) WRITE(6,697) LM,MU 697 FORMAT(' * * * NOTE. ALL COUPLING COEFFICIENTS ARE ZERO FOR ', & 'LAMBDA, MU =', 2I4) IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) 3100 CONTINUE RETURN END SUBROUTINE SET6C(JLEV,ATAU,NLEV,EIN) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C save statement should be unnec; only called once (sg aug 94) SAVE LOGICAL EIN DIMENSION JLEV(1),ATAU(1) DIMENSION ROTI(12),WT(2),ELEVEL(1000),JLEVEL(4000) COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C MODS 11 JUL 94 FOR V14 CMBASE C n.b IPAR was equivalenced to J2MAX, now to ISYM(1) EQUIVALENCE (IPAR,ISYM(1)) COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC, 1 NLEVEL,JLEVEL,JMIN,JMAX,JSTEP,ISYM(10),J2MIN,J2MAX, 2 J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL DATA TOL/1.D-8/ C C CALCULATE ASYMMETRIC ROTOR ENERGY LEVELS AND WAVEFUNCTIONS C FROM ROTATIONAL CONSTANTS. WRITTEN BY JMH, MARCH 1989. C MODIFIED TO HANDLE SPHERICAL TOP SYMMETRY, APRIL 1991. C MODIFIED TO USE WORKSPACE PROPERLY FOR VERSION 12, NOV 1993. C IF(EIN) WRITE(6,601) 601 FORMAT('0 TARGET ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL)'/ 1 ' WILL OVERRIDE THOSE CALCULATED FROM ROTATIONAL CONSTANTS') IF(ROTI(1).EQ.ROTI(3) .AND. ROTI(3).EQ.ROTI(5)) THEN WRITE(6,602) ROTI(1),ROTI(7),ROTI(10) 602 FORMAT('0 SPHERICAL ROTOR LEVELS CALCULATED FROM'/ 1 ' A = B = C =',F11.5/' DJ',8X,'=',E11.3/' DT',8X,'=',E11.3) IF(ABS(ROTI(10)).LT.1.D-8) WRITE(6,603) 603 FORMAT(' *** WARNING: IF ABS(DT) IS LESS THAN ABOUT 1.D-8,', 1 ' THE PROGRAM MAY FAIL TO DISTINGUISH LEVELS OF DIFFERENT', 2 ' SYMMETRY') ELSE WRITE(6,604) ROTI(1),ROTI(3),ROTI(5), 1 ROTI(7),ROTI(8),ROTI(9) 604 FORMAT('0 ASYMMETRIC ROTOR LEVELS CALCULATED FROM'/ 1 ' A =',F10.5,8X,'B =',F10.5,8X,'C =',F10.5/ 2 ' DJ =',E10.3,8X,'DJK =',E10.3,8X,'DK =',E10.3/ 3 '0 A, B AND C MUST CORRESPOND TO THE X, Y AND Z', 4 ' COORDINATES USED TO DEFINE THE INTERACTION POTENTIAL') ENDIF WRITE(6,605) IPAR 605 FORMAT('0 INPUT ENERGY LEVELS WILL BE INCLUDED ONLY IF THEY', 1 ' MEET SELECTION CRITERIA SPECIFIED BITWISE BY ISYM =',I4) C C NTAU IS SAFELY ABOVE ANYTHING WE MAY NEED FOR JLEV C NLVL=0 ESAVE=-999.D0 NLEV=0 NTAU=6*(JMAX+1)**2 NORIG=NTAU IXSAVE=IXNEXT DO 450 J=JMIN,JMAX,JSTEP NVEC=NTAU NK=J+J+1 C C ASROT NEEDS SOMEWHERE TO PUT THE EIGENVALUES AND EIGENVECTORS C AND SOME WORKSPACE. USE THE TOP OF THE ATAU ARRAY. C IC2=NVEC+1+NK*NK IC3=IC2+NK*NK IC4=IC3+NK IXNEXT=IC4+NK NUSED=1 CALL CHKSTR(NUSED) CALL ASROT(J,ATAU(NVEC+1),ATAU(IC2),ATAU(IC3),ATAU(IC4),NK) DO 440 IK=1,NK C C CHECK LEVEL ENERGY AND PARITY TO SEE WHETHER WE REALLY WANT IT C ELEV=ATAU(IC3+IK-1) IF(EMAX.GT.0.D0 .AND. ELEV.GT.EMAX) GOTO 430 IPLEV=IPASYM(J,NK,ATAU(NVEC+1)) C C IPAR IS INTERPRETED BITWISE: THE BITS ARE FLAGS AS FOLLOWS C 1 - ODD K EXCLUDED C 2 - EVEN K EXCLUDED C 3 - ODD +/-K * (-1)**J EXCLUDED C 4 - EVEN +/-K * (-1)**J EXCLUDED C 5 - DEGENERACY = 1 EXCLUDED C 6 - DEGENERACY = 2 EXCLUDED C 7 - DEGENERACY = 3 EXCLUDED C 8 - DEGENERACY > 3 EXCLUDED C C NOTE THAT THIS LOGIC WAS CHANGED IN AUGUST 1992, C IN A WAY THAT ALTERS THE INPUT VALUE OF ISYM REQUIRED, C FOLLOWING BETA TESTING OF VERSION 11 C IF(IPAR.LE.0) GOTO 410 C C FIND DEGENERACY C IDEG=0 DO 400 KK=1,NK IF(ABS(ATAU(IC3+KK-1)-ELEV).LT.TOL) IDEG=IDEG+1 400 CONTINUE C JPAR=IPAR C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. IPLEV.GE.2) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. IPLEV.LE.1) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. MOD(IPLEV+J,2).EQ.1) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. MOD(IPLEV+J,2).EQ.0) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. IDEG.EQ.1) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. IDEG.EQ.2) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. IDEG.EQ.3) GOTO 430 C IP=MOD(JPAR,2) JPAR=JPAR/2 IF(IP.EQ.1 .AND. IDEG.GT.3) GOTO 430 C 410 NLEV=NLEV+1 IF(NLEVEL.GT.0 .AND. NLEV.GT.NLEVEL) GOTO 430 C C ARRIVE HERE IF WE DO: STORE JLEV AND TAU IN TEMPORARY LOCATIONS C PREV=ESAVE ESAVE=ELEV IF(ABS(ESAVE-PREV).GT.TOL) THEN NLVL=NLVL+1 JLEVEL(2*NLVL-1)=J JLEVEL(2*NLVL)=IK IF(.NOT.EIN) ELEVEL(NLVL)=ELEV ENDIF C JLEV(6*NLEV-5)=J JLEV(6*NLEV-4)=IK JLEV(6*NLEV-3)=IPLEV JLEV(6*NLEV-2)=NTAU JLEV(6*NLEV-1)=NK JLEV(6*NLEV )=NLVL C C NTAU KEEPS TRACK OF WHERE WE ARE PUTTING THE COEFFICIENTS, C AND NVEC KEEPS TRACK OF WHERE THEY ARE COMING FROM. C NTAU IS NEVER LESS THAN NVEC. C DO 420 I=1,NK ATAU(NTAU+I)=ATAU(NVEC+I) 420 CONTINUE NTAU=NTAU+NK 430 NVEC=NVEC+NK 440 CONTINUE 450 CONTINUE C C COPY ATAU INTO THE RIGHT PLACE C IF(NLEVEL.GT.0) NLEV=MIN(NLEV,NLEVEL) IF(NLEVEL.EQ.0) NLEVEL=NLVL NBASE=6*NLEV NSHIFT=NORIG-NBASE DO 460 I=NORIG+1,NTAU 460 ATAU(I-NSHIFT)=ATAU(I) NTAU=NTAU-NSHIFT C C COPY JLEV INTO WORKSPACE ABOVE ATAU AND REARRANGE IT, C REMEMBERING TO MODIFY THE POINTER TO ATAU. C NBASE=2*NTAU I=0 DO 470 NL=1,NLEV DO 470 IQ=1,6 I=I+1 IF(IQ.EQ.4) JLEV(I)=JLEV(I)-NSHIFT JLEV(NBASE+NL+NLEV*(IQ-1))=JLEV(I) 470 CONTINUE C C THEN COPY IT BACK TO WHERE IT BELONGS C DO 480 I=1,6*NLEV 480 JLEV(I)=JLEV(NBASE+I) IXNEXT=IXSAVE+NTAU RETURN END SUBROUTINE SET6I(JLEV,MXLV,NLEV,A,MXA,IUNIT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION JLEV(MXLV) DIMENSION A(MXA) DATA IDU/5/ C NTOP=MXLV/4 ISTA=0 C ALLOW FOR EMPTY SET OF BASIS FUNCTIONS, I.E., NLEV.LE.0 IF (NLEV.LE.0) GO TO 3000 IF (NLEV.LE.NTOP) GO TO 1000 WRITE(6,603) NLEV,NTOP 603 FORMAT('0 INPUT NLEVEL =',I7, 1 ' REPLACED BY MAX ALLOWED BY DIMENSIONS =',I5) NLEV=NTOP C 1000 IF (IUNIT.GT.0) GO TO 1001 WRITE(6,601) IUNIT,IDU 601 FORMAT('0 ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, CHANGED TO' & ,I4) IUNIT=IDU 1001 WRITE(6,602) IUNIT,NLEV 602 FORMAT('0 ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', & I4/'0 NUMBER OF REQUESTED LEVELS, NLEVEL =',I4 ) C NL=0 DO 2000 III=1,NLEV READ(IUNIT,500,END=9000) JI,ITAU,EIN 500 FORMAT(2I5,F15.10) C N.B. ENERGY (EIN) NOT USED FOR IOS, KEPT FOR MOLSCAT COMPATIBILITY NL=NL+1 JI=IABS(JI) NK=2*JI+1 IF (ISTA+NK.GT.MXA) GO TO 9001 READ(IUNIT,501,END=9100) (A(ISTA+I),I=1,NK) 501 FORMAT(6F12.8) WRITE(6,604) NL,JI,ITAU 604 FORMAT('0 INPUT LEVEL',I4,' J, TAU =',2I4) MJI=-JI WRITE(6,605) (A(ISTA+1+JI+I),I,I=MJI,JI) 605 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) IPAR=IPASYM(JI,NK,A(ISTA+1)) IF (IPAR.NE.-1) GO TO 2001 WRITE(6,619) 619 FORMAT('0 *** ILLEGAL PARITY. BASIS FUNCTION REMOVED.') NL=NL-1 GO TO 2000 C ADD INDICES TO JLEV. . . 2001 JLEV(4*NL-3)=JI JLEV(4*NL-2)=ITAU JLEV(4*NL-1)=IPAR JLEV(4*NL )=ISTA ISTA=ISTA+NK GO TO 2000 C END OF FILE AND OTHER ERROR CONDITIONS 9000 WRITE(6,606) IUNIT,NL 606 FORMAT('0 END OF FILE ON UNIT',I4,' AFTER',I4,' FUNCTIONS.') GO TO 2400 9001 WRITE(6,607) MXA,NL 607 FORMAT('0 OUT OF ROOM IN ATAU MATRIX. MXA, NLEV =',2I6) NL=NL-1 GO TO 2400 9100 WRITE(6,608) NL 608 FORMAT('0 * * * ERROR. END OF FILE BEFORE ATAU CARDS FOR LEVEL', & I4,'. * * * TERMINATING.') STOP 2000 CONTINUE C 2400 NLEV=NL 3000 MXA=ISTA CALL CHCK6I(NLEV,JLEV,A) RETURN END SUBROUTINE SETBAS IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C LOGICAL LEVIN,EIN INTEGER NLEV,JLEV(1) C C VERSION 14 CMBASE C COMMON BLOCK FOR BASIS DATA DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),WE(2),WEXE(2),A(2),B(2), 1 C(2),WT(2),ELEVEL(1000) DIMENSION JLEVEL(4000),ISYM(10),ISYM2(10) EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)), 1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),(JSTEP,J1STEP), 2 (ROTI(7),WE(1)), (ROTI(9),WEXE(1)),(KMAX,J2MAX) COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL, 1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT C C ENTRY SET1(LEVIN,EIN,NLEV,JLEV) IF (LEVIN) GO TO 1902 WRITE(6,601) JMIN,JMAX,JSTEP 601 FORMAT(/' TARGET ROTATIONAL LEVELS COMPUTED FROM JMIN =',I3, 1 ', JMAX =',I3,', AND JSTEP =',I2) JMIN=MAX0(0,JMIN) JMAX=MAX0(JMIN,JMAX) NLEVEL=0 DO 1012 I=JMIN,JMAX,JSTEP NLEVEL=NLEVEL+1 1012 JLEVEL(NLEVEL)=I GO TO 1802 1902 WRITE(6,632) NLEVEL 632 FORMAT(/' TARGET ROTATIONAL LEVELS TAKEN FROM &BASIS (JLEVEL) ', 1 'INPUT. NLEVEL =',I3) 1802 JMIN=JLEVEL(1) JMAX=JMIN NLEV=NLEVEL DO 1912 I=1,NLEVEL JI=JLEVEL(I) IF (JI.LT.JMIN) JMIN=JI IF (JI.GT.JMAX) JMAX=JI JLEV(NLEV+I)=I 1912 JLEV(I)=JI IF (EIN) GO TO 7002 WRITE(6,633) BE(1) 633 FORMAT(/' ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) 634 FORMAT(' WITH B(V) COMPUTED FROM B(E) AND ALPHA(E) =',F10.6) IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) 635 FORMAT(' ROTATIONAL ENERGIES CORRECTED FOR D(E) =',F12.8) DO 1702 I=1,NLEV JI=JLEV(I) FJ=JI*(JI+1) 1702 ELEVEL(I)=(BE(1)-ALPHAE(1)/2.D0)*FJ - DE(1)*FJ*FJ RETURN 7002 WRITE(6,631) 631 FORMAT(/' TARGET ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL) INPUT') RETURN C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY SET2(LEVIN,EIN,NLEV,JLEV) IF (LEVIN) GO TO 2902 WRITE(6,201) 201 FORMAT(/' * * * ERROR. FOR ITYPE=2 &BASIS MUST SPECIFY NLEVEL ', 1 'AND J, V PAIRS') STOP 2902 WRITE(6,632) NLEVEL JMIN=JLEVEL(1) JMAX=JMIN NLEV=NLEVEL DO 2912 I=1,NLEVEL JI=JLEVEL(2*I-1) JVI=JLEVEL(2*I) JMIN=MIN0(JMIN,JI) JMAX=MAX0(JMAX,JI) JLEV(2*NLEV+I)=I JLEV(NLEV+I)=JVI 2912 JLEV(I)=JI IF(EIN) GO TO 2002 WRITE(6,202) WE(1),BE(1) 202 FORMAT(/' ENERGY LEVELS COMPUTED FROM W(E) =',F10.4, 1 ', B(E) =',F10.4/9X,'WITH ZERO ENERGY AT V=0, J=0') IF (WEXE(1).NE.0.D0) WRITE(6,636) WEXE(1) 636 FORMAT(' CORRECTED FOR W(E)X(E) =',F10.4) IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) DO 2702 I=1,NLEV JI=JLEV(I) JVI=JLEV(NLEV+I) FJ=JI*(JI+1) FV=JVI 2702 ELEVEL(I)=WE(1)*FV-WEXE(1)*FV*(FV+1.D0)+(BE(1)-ALPHAE(1) 1 *(FV+0.5D0))*FJ - DE(1)*FJ*FJ RETURN 2002 WRITE(6,631) RETURN C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY SET3(LEVIN,EIN,NLEV,JLEV) IF (IDENT.EQ.0) GO TO 1993 J2MIN=J1MIN J2MAX=J1MAX J2STEP=J1STEP IF (BE(2).EQ.0.D0) BE(2)=BE(1) IF (ALPHAE(2).EQ.0.D0) ALPHAE(2)=ALPHAE(1) IF (DE(2).EQ.0.D0) DE(2)=DE(1) 1993 IF (LEVIN) GO TO 5303 WRITE(6,310) J1MIN,J1MAX,J1STEP,J2MIN,J2MAX,J2STEP 310 FORMAT(/' TARGET ROTOR LEVELS COMPUTED FROM J1MIN =',I3, 1 ', J1MAX =',I3,', J1STEP =',I2// 2 ' PROJECTILE ROTOR LEVELS COMPUTED FROM J2MIN =',I3, 3 ', J2MAX =',I3,', J2STEP =',I2) J1MIN=MAX0(J1MIN,0) J1MAX=MAX0(J1MIN,J1MAX) J1STEP=MAX0(J1STEP,1) J2MIN=MAX0(J2MIN,0) J2MAX=MAX0(J2MAX,J2MIN) J2STEP=MAX0(J2STEP,1) NLEVEL=0 I=1 DO 1013 JJ1=J1MIN,J1MAX,J1STEP DO 1013 JJ2=J2MIN,J2MAX,J2STEP IF (IDENT.NE.0 .AND. JJ1.GT.JJ2) GO TO 1013 JLEVEL(I)=JJ1 JLEVEL(I+1)=JJ2 I=I+2 NLEVEL=NLEVEL+1 1013 CONTINUE GO TO 1023 5303 WRITE(6,333) NLEVEL 333 FORMAT(/' TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS ', 1 '(JLEVEL) INPUT. NLEVEL =',I3) C PROCESS JLEVEL TO JLEV FORMAT. JMIN(JMAX) ARE LOW(HIGH) OF J12. 1023 JMIN=IABS(JLEVEL(1)-JLEVEL(2)) JMAX=JMIN C EXPAND J1, J2 TO J1, J2, J12 NLEV=0 DO 1033 I=1,NLEVEL JJ1=JLEVEL(2*I-1) JJ2=JLEVEL(2*I) JK=IABS(JJ1-JJ2) JTOP=JJ1+JJ2 DO 1033 J12=JK,JTOP JLEV(4*NLEV+1)=JJ1 JLEV(4*NLEV+2)=JJ2 JLEV(4*NLEV+3)=J12 JLEV(4*NLEV+4)=I NLEV=NLEV+1 JMIN=MIN0(JMIN,J12) JMAX=MAX0(JMAX,J12) 1033 CONTINUE C REARRANGE TO PROPER ORDER IN HIGHER JLEV STORAGE JK=4*NLEV DO 1043 I=1,NLEV JLEV(JK+I)=JLEV(4*I-3) JLEV(JK+NLEV+I)=JLEV(4*I-2) JLEV(JK+2*NLEV+I)=JLEV(4*I-1) 1043 JLEV(JK+3*NLEV+I)=JLEV(4*I) C COPY BACK . . . DO 1053 I=1,JK 1053 JLEV(I)=JLEV(JK+I) C SET ELEVEL VALUES IF (EIN) GO TO 1073 WRITE(6,633) BE(1) IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) WRITE(6,313) BE(2) 313 FORMAT(/' PROJECTILE ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) IF (ALPHAE(2).NE.0.D0) WRITE(6,634) ALPHAE(2) IF (DE(2).NE.0.D0) WRITE(6,635) DE(2) DO 1063 I=1,NLEVEL FJ=DBLE(JLEVEL(2*I-1)) GJ=DBLE(JLEVEL(2*I)) FJ=FJ*(FJ+1.D0) GJ=GJ*(GJ+1.D0) 1063 ELEVEL(I)=(BE(1)-ALPHAE(1)*0.5D0)*FJ - DE(1)*FJ*FJ 1 + (BE(2)-ALPHAE(2)*0.5D0)*GJ - DE(2)*GJ*GJ RETURN 1073 WRITE(6,312) 312 FORMAT(/' TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS ', 1 '(ELEVEL) INPUT') RETURN C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY SET5(LEVIN,EIN,NLEV,JLEV) C C N.B. WE USE D(L,K,M) WITH EDMONDS CONVENTIONS OF PHASE FOR THE C BASIS FUNCTIONS. THIS IS SAME AS THADDEUS IN H2CO PAPER. C IF (LEVIN) GO TO 5305 NLEVEL=0 I=0 WRITE(6,601) JMIN,JMAX,JSTEP IF(KMAX.LT.0) WRITE(6,602) -KMAX 602 FORMAT(10X,' ABS(K) FOR ALL LEVELS SET TO',I4) IF(KMAX.GE.0 .AND. KMAX.LT.JMAX) WRITE(6,603) KMAX 603 FORMAT(10X,' ONLY LEVELS WITH K <=',I3,' INCLUDED IN BASIS') JMIN=MAX0(JMIN,0) JMAX=MAX0(JMIN,JMAX) DO 5315 JJ=JMIN,JMAX DO 5315 KK=0,JJ IF (KMAX.LT.0 .AND. KK+KMAX.NE.0) GO TO 5315 IF (KMAX.GE.0 .AND. KK.GT.KMAX) GO TO 5315 IF (MOD(JJ+KK,JSTEP).NE.JMIN) GO TO 5314 JLEVEL(I+1)=JJ JLEVEL(I+2)=KK JLEVEL(I+3)=2 I=I+3 NLEVEL=NLEVEL+1 5314 IF(KK.EQ.0) GOTO 5315 IF (MOD(JJ+KK+1,JSTEP).NE.JMIN) GO TO 5315 JLEVEL(I+1)=JJ JLEVEL(I+2)=KK JLEVEL(I+3)=1 I=I+3 NLEVEL=NLEVEL+1 5315 CONTINUE GO TO 5355 5305 WRITE(6,632) NLEVEL 5355 JMIN=JLEVEL(1) JMAX=JMIN NLEV=NLEVEL DO 5325 I=1,NLEVEL JLEV(I)=JLEVEL(3*I-2) JLEV(NLEV+I)=JLEVEL(3*I-1) JLEV(2*NLEV+I)=JLEVEL(3*I) JLEV(3*NLEV+I)=I JJ=JLEV(I) IF (JJ.LT.JMIN) JMIN=JJ IF (JJ.GT.JMAX) JMAX=JJ 5325 CONTINUE IF (EIN) GO TO 5335 WRITE(6,604) A(1),B(1),C(1) 604 FORMAT(/' ENERGY LEVELS COMPUTED FROM ZEROTH ORDER ', 1 'NEAR-SYMMETRIC TOP FORMULA'/ 2 10X,'ROTATIONAL CONSTANTS ARE A, B, C (1/CM) =',3F12.4/ 3 10X,'N.B. THESE MOMENTS MUST CORRESPOND RESPECTIVELY TO ', 4 'X, Y, Z COORDINATES USED TO DEFINE INTERACTION POTENTIAL') DO 5345 I=1,NLEV JJ=JLEV(I) KK=IABS(JLEV(I+NLEV)) SS=(-1.D0)**JLEV(I+2*NLEV) HKK=(A(1)+B(1))*DBLE(JJ*(JJ+1)-KK*KK)/2.D0+ C(1)*DBLE(KK*KK) C OFF-DIAGONAL CONTRIBUTION ONLY FROM K=1/K=-1 CASE. . . IF (KK.EQ.1) HKK=HKK+ SS * (A(1)-B(1)) * 1 SQRT(DBLE((JJ*(JJ+1)-KK*(KK-1))*(JJ*(JJ+1)-(KK-1)*(KK-2))))/4.D0 5345 ELEVEL(I)=HKK RETURN 5335 WRITE(6,631) RETURN C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * END SUBROUTINE SGNCHK(A,B,N) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(1),B(1) IND=-N DO 1 I=1,N IND=IND+N VMAX=0.D0 JMAX=0 DO 2 J=1,N IF(ABS(B(IND+J)).LT.VMAX) GO TO 2 JMAX=J VMAX=B(IND+JMAX) 2 CONTINUE IF(JMAX.EQ.0) GO TO 999 TEST=SIGN(B(IND+JMAX),A(IND+JMAX)) IF(TEST.EQ.B(IND+JMAX)) GO TO 1 DO 3 J=1,N B(IND+J)=-B(IND+J) 3 CONTINUE 1 CONTINUE RETURN 999 WRITE(6,100) 100 FORMAT(/10X,'JMAX EQ. 0 IN SGNCHK') RETURN END SUBROUTINE SHRINK(ICODE,RNOW,W,N,VL,IV,NB,J,L,EINT,CENT,WVEC, 1 CLOSE,VECOLD,EIGOLD,R,T,DEEP,NSQ,NPOTL,ISCRU,NOPMAX,PRINT) C C SUBROUTINE TO PERFORM A CHANNELECTOMY. C SHRINK REMOVES THE HIGHEST-ENERGY CHANNEL(S) FROM THE PRIMITIVE C BASIS SET, AND MODIFIES NUMEROUS ARRAYS TO REFLECT THIS. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER PRINT DIMENSION W(1),VL(1),IV(1),NB(N),J(N),L(N),EINT(N),CENT(N), 1 WVEC(N),CLOSE(N),VECOLD(NSQ),EIGOLD(N),R(1),T(1) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C IF(ISCRU.LE.0) GOTO 100 IF(ICODE.EQ.1) WRITE(ISCRU) VECOLD IF(ICODE.EQ.2) READ(ISCRU) VECOLD 100 CALL TRNSP(VECOLD,N) CALL TRNSFM(VECOLD,R,T,N,.FALSE.,.TRUE.) C DEEP2=DEEP DO 1000 NNEW=N,1,-1 IF(NNEW.LE.NOPMAX .OR. CLOSE(NNEW).LT.DEEP2) GOTO 1100 ISKIP=NB(NNEW) C I=0 INEW=0 DO 200 II=1,NNEW DO 200 JJ=1,NNEW I=I+1 IF(II.EQ.ISKIP .OR. JJ.EQ.ISKIP) GOTO 200 INEW=INEW+1 W(INEW)=W(I) R(INEW)=R(I) 200 CONTINUE C INEW=0 DO 300 I=1,NNEW IF(I.EQ.ISKIP) GOTO 300 INEW=INEW+1 J(INEW)=J(I) L(INEW)=L(I) EINT(INEW)=EINT(I) CENT(INEW)=CENT(I) WVEC(INEW)=WVEC(I) 300 CONTINUE C I=0 INEW=0 DO 400 II=1,NNEW DO 400 JJ=1,II DO 400 K=1,NPOTL I=I+1 IF(II.EQ.ISKIP .OR. JJ.EQ.ISKIP) GOTO 400 INEW=INEW+1 VL(INEW)=VL(I) IF (IVLFL.NE.0) IV(INEW)=IV(I) 400 CONTINUE C DO 500 I=1,NNEW 500 IF(NB(I).GE.ISKIP) NB(I)=NB(I)-1 C 1000 CONTINUE C 1100 N=NNEW IF (ICODE.EQ.2) GOTO 1300 IF(PRINT.GE.8) WRITE(6,601) N,RNOW 601 FORMAT(' BASIS SET CONTRACTED TO N =',I3,' AT R =',F6.2,' A') IFAIL=0 CALL F02ABF(W,N,N,EIGOLD,VECOLD,N,T,IFAIL) IF(ISCRU.GT.0) WRITE(ISCRU) VECOLD GOTO 1400 C 1300 IF(ISCRU.GT.0) READ(ISCRU) VECOLD 1400 CALL TRNSFM(VECOLD,R,T,N,.FALSE.,.TRUE.) NSQ=N*N C RETURN END SUBROUTINE SIG6(NLEV,JLEV,A,LI,LF,SIG,S,IMSG,QL,IXQL,NIXQL,NQL, 1 LM,LMAX) C ROUTINE TO EVALUATE SIG(J,TAU->J',TAU') FROM IOS Q(L,M1,M2) C VALUE FOR LEVEL LI TO LF RETURNED IN SIG C SG(2/1/93) VERSION TAKES STORAGE FOR REAL/IMAGINARY COEFFS C FROM /MEMORY/ ..,X IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION JLEV(4,NLEV),A(2),IXQL(NIXQL,NQL),LM(3,LMAX) DIMENSION QL(2) CHARACTER*1 S,STAR C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA STAR/'*'/ DATA EPS/1.D-8/ C C STATEMENT FUNCTION FOR INDEX M1.GE.M2, M STARTING AT ZERO. IX(M1,M2)=M1*(M1+1)/2+M2+1 C SIG=0.D0 JI=JLEV(1,LI) XJI=JI NKI=2*JI+1 ISTAI=JLEV(4,LI) JF=JLEV(1,LF) XJF=JF NKF=2*JF+1 ISTAF=JLEV(4,LF) LMN=IABS(JI-JF) LMX=JI+JF DO 1100 L=LMN,LMX XL=L C DETERMINE AMOUNT OF AVAILABLE SCRATCH STORAGE IN X(). MAXC=MX-IXNEXT+1 C M-VALUES CAN RANGE UP TO L. CHECK ABILITY TO STORE IN CR,CI MMAX=L 1101 IXMX=IX(MMAX,MMAX) IF (2*IXMX.LE.MAXC) GO TO 1102 WRITE(6,699) L,IXMX,MAXC 699 FORMAT(' *** CANNOT STORE ALL CR,CI FOR L=',I3, 1 '. REQUIRED, AVAILABLE =',2I7) MMAX=MMAX-1 S=STAR IMSG=1 IF (MMAX.LT.0) THEN WRITE(6,698) LI,LF,NAVAIL 698 FORMAT(/' SIG6 (2/1/93). FOR INITIAL FINAL LEVELS',2I3, 1 ' AVAILABLE STORAGE IS INADEQUATE',I8) STOP ENDIF GO TO 1101 C SET STORAGE POINTERS AND ZERO TEMP STORAGE. 1102 IXSAVE=IXNEXT IXR=IXNEXT-1 IXI=IXR+IXMX IXNEXT=IXI+IXMX DO 1109 II=1,IXMX X(IXR+II)=0.D0 1109 X(IXI+II)=0.D0 C -------------LOOP OVER IPI,IPF IQI,IQF ----------- IPI=-JI-1 DO 1201 IIPI=1,NKI IPI=IPI+1 API=A(ISTAI+IIPI) IF (ABS(API).LE.EPS) GO TO 1201 PI=IPI IPF=-JF-1 DO 1200 IIPF=1,NKF IPF=IPF+1 APF=A(ISTAF+IIPF) IF (ABS(APF).LE.EPS) GO TO 1200 PF=IPF IF (IABS(IPI-IPF).GT.MMAX) GO TO 1200 IQI=-JI-1 DO 1301 IIQI=1,NKI IQI=IQI+1 AQI=A(ISTAI+IIQI) IF (ABS(AQI).LE.EPS) GO TO 1301 QI=IQI IQF=-JF-1 DO 1300 IIQF=1,NKF IQF=IQF+1 AQF=A(ISTAF+IIQF) IF (ABS(AQF).LE.EPS) GO TO 1300 QF=IQF IF (IABS(IQI-IQF).GT.MMAX) GO TO 1300 C CALCULATE FACTOR TJ1 = THRJ(XJI,XL,XJF,-PI,PI-PF,PF) IF (ABS(TJ1).LE.EPS) GO TO 1300 TJ2 = THRJ(XJI,XL,XJF,-QI,QI-QF,QF) IF (ABS(TJ2).LE.EPS) GO TO 1300 FACT=API*AQI*APF*AQF *TJ1*TJ2 C RECALCULATE MP,MQ AS THEY MIGHT HAVE BEEN SWAPPED IN LAST LOOP. MP=IPI-IPF MQ=IQI-IQF SIGNR=1.D0 SIGNI=1.D0 IF (MP.GE.0) GO TO 1401 P=PARITY(MP) SIGNR=P*SIGNR SIGNI=P*SIGNI MP=IABS(MP) 1401 IF (MQ.GE.0) GO TO 1402 P=PARITY(MQ) SIGNR=P*SIGNR SIGNI=P*SIGNI MQ=IABS(MQ) 1402 IF (MP.GE.MQ) GO TO 1403 SIGNI=-SIGNI MT=MP MP=MQ MQ=MT 1403 INDX=IX(MP,MQ) IF (MP.EQ.MQ) SIGNI=0.D0 X(IXR+INDX)=X(IXR+INDX)+SIGNR*FACT X(IXI+INDX)=X(IXI+INDX)+SIGNI*FACT C**** WRITE(6,686) INDX,X(IXR+INDX),X(IXI+INDX) **** DEBUGGING **** 686 FORMAT(' INDX, REAL/IMAG =',I5,2F10.5) 1300 CONTINUE 1301 CONTINUE C ---------- THIS ENDS LOOP OVER IQI,IQF 1200 CONTINUE 1201 CONTINUE C ---------- THIS ENDS LOOP OVER IPI,IPF C MATCH CONTRIBUTING (I.E., NON-ZERO) CR WITH QL VALUES IZERO=0 INDX=0 DO 1500 MP=IZERO,MMAX DO 1500 MQ=IZERO,MP INDX=INDX+1 C N.B. IMAGINARY PART SHOULD VANISH; ERROR MESSAGE IF ANY SURVIVE. IF (ABS(X(IXI+INDX)).LE.EPS) GO TO 1501 WRITE(6,694) L,MP,MQ,X(IXI+INDX),LI,LF 694 FORMAT('0 *** ERROR. NON-ZERO IMAGINARY COEFF QL(', & 3I4,' ) =',F12.6,' FOR LI,LF =',2I4) 1501 IF (ABS(X(IXR+INDX)).LE.EPS) GO TO 1500 C CALL IXQLF TO GET INDEX OF L,MP,MQ IN QL C AND ACCUMULATE IN CROSS SECTION CALL IXQLF(LM,LMAX,L,MP,MQ,1,INDEX,IXQL,NIXQL,NQL) C N.B. 6TH ARG (1) ASKS FOR REAL PART; SHOULD WORK OK FOR MP.EQ.MQ IF (INDEX.GT.0) GO TO 1502 IF (INDEX.EQ.-1) GO TO 1500 S=STAR IMSG=1 GO TO 1500 1502 SIG=SIG + X(IXR+INDX)*QL(INDEX) C WRITE(6,602) LI,LF,L,MP,MQ,X(IXR+INDX),QL(INDEX) *** DEBUGGING** 602 FORMAT(2X,'I/F=',2I3,' QL(',3I3,' ) COEFF/QL =',2F10.5) 1500 CONTINUE C RECOVER TEMPORARY STORAGE ... 1100 IXNEXT=IXSAVE C ---------- THIS ENDS LOOP OVER L - VALUES C MULTIPLY FINALLY BY 2*JF+1 SIG = SIG * (2*JF+1) RETURN END FUNCTION SIXJ(J1,J2,J5,J4,J3,J6) C C CALCULATES 6-J SYMBOL: _(J1 J2 J3 )_ C (J4 J5 J6 ) C INTERFACE TO J6J ROUTINE. C MODIFIED BY S. GREEN 20 AUG 93; PASS DIMENSION OF XJ6J FOR CHECKING C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER(MXDIM=200) DIMENSION XJ6J(MXDIM) IVAL=MXDIM CALL J6J( DBLE(J2),DBLE(J3), 1 DBLE(J4),DBLE(J5),DBLE(J6), 3 IVAL,XJ1MIN,XJ6J) IND=1+J1-INT(XJ1MIN+0.1D0) SIXJ=0.D0 IF(IND.GE.1 .AND. IND.LE.IVAL) SIXJ=XJ6J(IND) RETURN END * ---------------------------------------------------------------------- SUBROUTINE SPROPN (WIDTH, EIGNOW, HP, Y1, Y4, Y2, NCH) * CURRENT REVISION DATE: 23-9-87 *----------------------------------------------------------------------- * THIS SUBROUTINE CALCULATES THE DIAGONAL MATRICES TO PROPAGATE THE * LOG-DERIVATIVE MATRIX THROUGH THE CURRENT INTERVAL * THE KEY EQUATIONS, REPRODUCED BELOW, ARE TAKEN FROM * M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR REFERENCE POTENTIA * ALGORITHM FOR SOLUTION ..." * EACH UNCOUPLED EQUATION CAN BE WRITTEN AS: * 2 2 * [ D / DR + EIGNOW - HP * R ] F(R) = 0 * WHERE R IS THE DISTANCE FROM THE MIDPOINT OF THE CURRENT INTERVAL * THE LINEARLY INDEPEDENT SOLUTIONS ARE THE AIRY FUNCTIONS AI(X) AND BI * WHERE X = ALPHA (R + BETA) * 1/3 * WITH ALPHA = HP , AND BETA = (-EIGNOW) / HP * THE THREE DIAGONAL ELEMENTS OF THE CAUCHY PROPAGATOR NECESSARY TO PRO * THE LOG-DERIVATIVE MATRIX ARE: * B = PI [ AI(X ) BI(X ) - AI(X )BI(X ) ] / ALPHA * 1 2 2 1 * A = PI [ - AI'(X ) BI(X ) + AI(X ) BI'(X ) ] * 1 2 2 1 * D = PI [ AI(X ) BI'(X ) - AI'(X ) BI(X ) ] * 1 2 2 1 * WHERE X = ALPHA ( BETA + WIDTH / 2) AND * 2 * X = ALPHA ( BETA - WIDTH / 2) * 1 * HERE "WIDTH" DENOTES THE WIDTH OF THE INTERVAL * THE DIAGONAL ELEMENTS OF THE "IMBEDDING TYPE" PROPAGATOR ARE GIVEN IN * OF THE DIAGONAL ELEMENTS OF THE CAUCHY PROPAGATOR BY: * Y = A/B Y = Y = 1/B AND Y = D/B * 1 2 3 4 *----------------------------------------------------------------------- * VARIABLES IN CALL LIST: * WIDTH: WIDTH OF THE CURRENT INTERVAL * EIGNOW: ARRAY CONTAINING THE WAVEVECTORS * THESE ARE DEFINED BY EQ. (6) OF M.ALEXANDER, * J. CHEM. PHYS. 81,4510 (1984) * HP: ARRAY CONTAINING THE NEGATIVE OF DIAGONAL ELEMENTS OF T * DERIVATIVE OF THE WAVEVECTOR MATRIX AT THE CENTER OF TH * CURRENT INTERVAL [SEE EQ. (9) OF M.ALEXANDER, * J. CHEM. PHYS. 81,4510 (1984) * THIS ARRAY THUS CONTAINS THE DERIVATIVE OF THE DIAGONAL * ELEMENTS OF THE TRANSFORMED HAMILTONIAN MATRIX * Y1, Y2, Y4: ON RETURN, CONTAIN THE DESIRED DIAGONAL ELEMENTS OF THE * IMBEDDING PROPAGATOR * NCH: THE NUMBER OF CHANNELS, THIS EQUALS THE DIMENSIONS OF T * EIGNOW, HP, Y1, Y4, AND B ARRAYS *----------------------------------------------------------------------- * THE AIRY FUNCTIONS ARE DEFINED IN TERMS OF THEIR MODULI AND PHASES * FOR NEGATIVE X THESE DEFINITIONS ARE: * AI(-X) = M(X) COS[THETA(X)] * BI(-X) = M(X) SIN[THETA(X)] * AI'(-X) = N(X) COS[PHI(X)] * BI'(-X) = N(X) SIN[PHI(X)] * IN OTHER WORDS * 2 2 2 * M(X) = SQRT[ AI(X) + BI(X) ] * 2 2 2 * N(X) = SQRT[ AI'(X) + BI'(X) ] * THETA(X) = ATAN [ BI(X) / AI(X) ] * PHI(X) = ATAN [ BI'(X) / AI'(X) ] * FOR POSITIVE X THE MODULI AND PHASES ARE DEFINED BY: * AI(X) = M(X) SINH[THETA(X)] * BI(X) = M(X) COSH[THETA(X)] * AI'(X) = N(X) SINH[PHI(X)] * BI'(X) = N(X) COSH[PHI(X)] * IN OTHER WORDS * 2 2 2 * M(X) = SQRT[ BI(X) - AI(X) ] * 2 2 2 * N(X) = SQRT[ BI'(X) - AI'(X) ] * THETA(X) = ATANH [ AI(X) / BI(X) ] * PHI(X) = ATANH [ AI'(X) / BI'(X) ] * HERE THE THE EXPONENTIALLY SCALED AIRY FUNCTIONS * AI(X), AI'(X), BI(X), BI'(X) ARE: * AI(X) = AI(X) * EXP[ZETA] * AI'(X) = AI'(X) * EXP[ZETA] * BI(X) = BI(X) * EXP[-ZETA] * BI'(X) = BI'(X) * EXP[-ZETA] * 3/2 * WHERE ZETA = (2/3) X * NOTE THAT FOR POSITIVE X THE PHASES ARE LABELED CHI AND ETA IN * M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR REFERENCE POTENTIA * ALGORITHM FOR SOLUTION ..." *----------------------------------------------------------------------- * FOR BOTH X AND X NEGATIVE * 1 2 * (THIS CORRESPONDS TO A CHANNEL WHICH IS CLASSICALLY OPEN AT BOTH ENDS * INTERVAL) * WE FIND: * Y = 1 / { M M SIN[THETA -THETA ] } * 2 1 2 2 1 * N SIN[PHI -THETA ] * 1 1 2 * Y = ---------------------- * 1 M SIN[THETA - THETA ] * 1 2 1 * N SIN[PHI -THETA ] * 2 2 1 * Y = ---------------------- * 4 M SIN[THETA - THETA ] * 2 2 1 * HERE THE SUBSCRIPTS 1 AND 2 IMPLY THE MODULI AND PHASES EVALUATED AT * * AND X = X , RESPECTIVELY * 2 *----------------------------------------------------------------------- * FOR BOTH X AND X POSITIVE * 1 2 * (THIS CORRESPONDS TO A CHANNEL WHICH IS CLASSICALLY CLOSED AT BOTH EN * THE INTERVAL) * WE FIND: * 1 / Y = M M COSH[Z -Z ] { SINH[THETA -THETA ] * 2 1 2 2 1 1 2 * + TANH[Z -Z ] SINH[THETA +THETA ] } * 2 1 1 2 * 3/2 * WHERE Z = (2/3) X AND SIMILARLY FOR Z * 1 1 2 * N { SINH [THETA -PHI ] - TANH[Z -Z ] SINH[THETA +PHI ] } * 1 2 1 2 1 2 1 * Y = -------------------------------------------------------- * 1 M { SINH [THETA -THETA ] + TANH[Z -Z ] SINH[THETA +THETA ] } * 1 2 1 2 1 2 1 * N { SINH [THETA -PHI ] - TANH[Z -Z ] SINH[THETA +PHI ] } * 2 1 2 2 1 1 2 * Y = -------------------------------------------------------- * 4 M { SINH [THETA -THETA ] + TANH[Z -Z ] SINH[THETA +THETA ] } * 2 2 1 2 1 2 1 *----------------------------------------------------------------------- * FOR X POSITIVE AND X NEGATIVE WE FIND: * 1 2 * 1 / Y = M M COSH[Z ] COSH[THETA ] { - COS[THETA ] (1 + TANH[Z ]) * 2 1 2 1 1 2 1 * + TANH[THETA ] SIN[THETA ] (1 - TANH * 1 2 * N { COS[THETA ](1 + TANH[Z ]) - TANH[PHI ] SIN[THETA ] (1 - TANH[ * 1 2 1 1 2 * Y = ------------------------------------------------------------------ * 1 M {-COS[THETA ](1 + TANH[Z ]) + TANH[THETA ] SIN[THETA ] (1 - TAN * 1 2 1 1 2 * N {-COS[PHI ](1 + TANH[Z ]) + TANH[THETA ] SIN[PHI ] (1 - TANH[Z * 2 2 1 1 2 1 * Y = ----------------------------------------------------------------- * 4 M {-COS[THETA ](1 + TANH[Z ]) + TANH[THETA ] SIN[THETA ] (1 - TAN * 2 2 1 1 2 *----------------------------------------------------------------------- * FOR X NEGATIVE AND X POSITIVE WE FIND: * 1 2 * 1 / Y = M M COSH[Z ] COSH[THETA ] { COS[THETA ] (1 + TANH[Z ]) * 2 1 2 2 2 1 2 * - TANH[THETA ] SIN[THETA ] (1 - TANH[ * 2 1 * N {-COS[PHI ](1 + TANH[Z ]) + TANH[THETA ] SIN[PHI ] (1 - TANH[Z * 1 1 2 2 1 2 * Y = ----------------------------------------------------------------- * 1 M {COS[THETA ](1 + TANH[Z ]) - TANH[THETA ] SIN[THETA ] (1 - TANH * 1 1 2 2 1 * N { COS[THETA ](1 + TANH[Z ]) - TANH[PHI ] SIN[THETA ] (1 - TANH[ * 2 1 2 2 1 * Y = ----------------------------------------------------------------- * 4 M {COS[THETA ](1 + TANH[Z ]) - TANH[THETA ] SIN[THETA ] (1 - TANH * 2 1 2 2 1 *----------------------------------------------------------------------- * FOR THE SPECIAL CASE OF A CONSTANT REFERENCE POTENTIAL (HP=0) * THEN THE PROPAGATORS ARE: * FOR EIGNOW .GT. 0 (THE CLASSICALLY ALLOWED REGION) * Y1 = Y4 = K COT (K WIDTH) * Y2 = K / SIN (K WIDTH) * WHERE K = SQRT (EIGNOW) * FOR EIGNOW .LT. 0 (THE CLASSICALLY FORBIDDEN REGION) * Y1 = Y4 = KAP COTH (KAP WIDTH) * Y2 = KAP / SINH (KAP WIDTH) * * WHERE KAP = SQRT (-EIGNOW) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DALPHA, DBETA, DHALF, DONETH, DROOT, DSLOPE, : DTWOTH, DLZETA, DMMOD1, DMMOD2, DNMOD1, DNMOD2, : DPI, DX1, DX2, DZETA1, DZETA2, DPHI1, DPHI2, : DTHET1, DTHET2, DTNHFM, DTNHFP, DARG, DCAY, DKAP, : OFLOW,X1,X2 * REAL B, BFACT, TNHFAC, WIDTH * REAL EIGNOW(1), HP(1), Y1(1), Y2(1), Y4(1) DIMENSION EIGNOW(1), HP(1), Y1(1), Y2(1), Y4(1) INTEGER I, NCH DATA DONETH, DTWOTH, DHALF : / 0.333333333333333D0, 0.666666666666667D0, 0.5D0 / DATA DPI / 3.1415926535897932D0 / * THE PARAMETER OFLOW IS THE LARGEST VALUE OF X FOR WHICH EXP(X) * DOES NOT CAUSE A SINGLE PRECISION OVERFLOW * N * A REASONABLE VALUE IS X = [ LN(2) 2 ] - 5, WHERE N IS THE NUMBER OF B * THE CHARACTERISTIC OF A FLOATING POINT NUMBER DATA OFLOW / 83.D0 / * NOW DETERMINE B_MIN1, Y1, AND Y4 PARAMETERS FOR ALL NCH CHANNELS DO 10 I = 1, NCH DSLOPE = HP(I) DARG = 1.E+10 IF (DSLOPE .NE. 0.D0) : DARG = LOG (ABS(EIGNOW(I))) - LOG (ABS(DSLOPE)) IF (DARG .GT. 20.D0 ) THEN * HERE IF THE RELATIVE SLOPE IN THE WAVEVECTOR MATRIX IS LESS THAN 1.** * IN MAGNITUDE, IN WHICH CASE THE POTENTIAL IS ASSUMED TO BE CONSTANT IF (EIGNOW(I) .GT. 0) THEN * HERE FOR CLASSICALLY ALLOWED REGION (SINES AND COSINES AS REFERENCE * SOLUTIONS) DCAY = SQRT (EIGNOW(I)) DARG = DCAY * WIDTH Y1(I) = DCAY / TAN (DARG) Y4(I) = Y1(I) Y2(I) = DCAY / SIN (DARG) ELSE * HERE FOR CLASSICALLY FORBIDDEN REGION (HYPERBOLIC SINES AND COSINES A * REFERENCE SOLUTIONS) DKAP = SQRT ( - EIGNOW(I)) DARG = DKAP * WIDTH Y1(I) = DKAP / TANH (DARG) Y4(I) = Y1(I) Y2(I) = DKAP / SINH (DARG) END IF ELSE * HERE IF THE RELATIVE SLOPE IN THE WAVEVECTOR MATRIX IS GREATER THAN * 1.**(-20) IN MAGNITUDE, IN WHICH CASE A LINEAR REFERENCE POTENTIAL IS * WITH AIRY FUNCTIONS AS REFERENCE SOLUTIONS DROOT = ( ABS (DSLOPE) ) ** DONETH DALPHA = SIGN (DROOT, DSLOPE) DBETA = - EIGNOW(I) / DSLOPE DX1 = DALPHA * ( DBETA - WIDTH * DHALF) DX2 = DALPHA * ( DBETA + WIDTH * DHALF) IF (DX1 .GT. 0.) DZETA1 = DTWOTH * DX1 * SQRT(DX1) IF (DX2 .GT. 0.) DZETA2 = DTWOTH * DX2 * SQRT(DX2) CALL AIRYMP (DX1, DTHET1, DPHI1, DMMOD1, DNMOD1) CALL AIRYMP (DX2, DTHET2, DPHI2, DMMOD2, DNMOD2) X1 = DX1 X2 = DX2 *----------------------------------------------------------------------- IF (X1 .GT. 0. .AND. X2 .GT. 0.) THEN * HERE FOR BOTH X AND X POSITIVE * 1 2 TNHFAC = TANH(DZETA2 - DZETA1) BFACT = SINH(DTHET1 - DTHET2) + : TNHFAC * SINH(DTHET1 + DTHET2) DLZETA = ABS(DZETA2 - DZETA1) Y2(I) = 0. IF (DLZETA .LE. OFLOW) THEN B = DMMOD1 * DMMOD2 * COSH(DZETA2 - DZETA1) * BFACT Y2(I) = 1. / B END IF Y1(I) = DNMOD1 * (SINH(DTHET2 - DPHI1) : - TNHFAC * SINH(DTHET2 + DPHI1) ) / (DMMOD1 * BFACT) Y4(I) = DNMOD2 * (SINH(DTHET1 - DPHI2) : + TNHFAC * SINH(DTHET1 + DPHI2) ) / (DMMOD2 * BFACT) *----------------------------------------------------------------------- ELSE IF (X1 .LE. 0. .AND. X2 .LE. 0.) THEN * HERE FOR BOTH X AND X NEGATIVE * 1 2 B = DMMOD1 * DMMOD2 * SIN(DTHET2 - DTHET1) Y2(I) = 1. / B Y1(I) = DNMOD1 * SIN(DPHI1 - DTHET2) : / (DMMOD1 * SIN(DTHET2 - DTHET1) ) Y4(I) = DNMOD2 * SIN(DPHI2 - DTHET1) : / (DMMOD2 * SIN(DTHET2 - DTHET1) ) *----------------------------------------------------------------------- ELSE IF (X1 .GT. 0. .AND. X2 .LE. 0.) THEN * HERE FOR X POSITIVE AND X NEGATIVE * 1 2 DTNHFP = 1 + TANH(DZETA1) DTNHFM = 1 - TANH(DZETA1) BFACT = COSH(DTHET1) * ( - COS(DTHET2) * DTNHFP : + TANH(DTHET1) * SIN(DTHET2) * DTNHFM) Y2(I) = 0. IF (ABS(DZETA1) .LE. OFLOW) THEN Y2(I) = COSH(DZETA1) * (DMMOD1 * DMMOD2 * BFACT) Y2(I) = 1. / Y2(I) END IF Y1(I) = (DNMOD1 * COSH(DPHI1) * ( COS(DTHET2) * DTNHFP : - TANH(DPHI1) * SIN(DTHET2) * DTNHFM) ) : / (DMMOD1 * BFACT) Y4(I) = (DNMOD2 * COSH(DTHET1) * ( - COS(DPHI2) * DTNHFP : + TANH(DTHET1) * SIN(DPHI2) * DTNHFM) ) : / (DMMOD2 * BFACT) *----------------------------------------------------------------------- ELSE IF (X2 .GT. 0. .AND. X1 .LE. 0.) THEN * HERE FOR X POSITIVE AND X NEGATIVE * 2 1 DTNHFP = 1 + TANH(DZETA2) DTNHFM = 1 - TANH(DZETA2) BFACT = COSH(DTHET2) * ( COS(DTHET1) * DTNHFP : - TANH(DTHET2) * SIN(DTHET1) * DTNHFM) Y2(I) = 0. IF (ABS(DZETA2) .LE. OFLOW) THEN Y2(I) = COSH(DZETA2) * (DMMOD1 * DMMOD2 * BFACT) Y2(I) = 1. / Y2(I) END IF Y4(I) = (DNMOD2 * COSH(DPHI2) * ( COS(DTHET1) * DTNHFP : - TANH(DPHI2) * SIN(DTHET1) * DTNHFM) ) : / (DMMOD2 * BFACT) Y1(I) = (DNMOD1 * COSH(DTHET2) * ( - COS(DPHI1) * DTNHFP : + TANH(DTHET2) * SIN(DPHI1) * DTNHFM) ) : / (DMMOD1 * BFACT) *----------------------------------------------------------------------- END IF Y1(I) = DALPHA * Y1(I) Y4(I) = DALPHA * Y4(I) Y2(I) = DALPHA * Y2(I) / DPI * AT THIS POINT THE Y1, Y2, AND Y4 PROPAGATORS CORRESPOND IDENTICALLY T * EQS. (38)-(44) OF M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR * REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..." END IF 10 CONTINUE RETURN END SUBROUTINE STABIL(N,NB,Y,YP,F1,F2,SCR,YN,YPN,F1N,F2N) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C FIND SCR SUCH THAT Y*SCR IS (PERMUTED) UNIT MATRIX, C THEN TRANSFORM Y, YP, F1, AND F2 BY RIGHT MULTIPLICATION WITH SCR. C DIMENSION NB(N),Y(1),YP(1),F1(1),F2(1), & YN(1),YPN(1),F1N(1),F2N(1),SCR(1) C C SAVE OLD INPUT MATRICES AND INITIALIZE SCR C NSQ=N*N CALL DCOPY(NSQ,Y,1,YN,1) CALL DCOPY(NSQ,YP,1,YPN,1) CALL DCOPY(NSQ,F1,1,F1N,1) CALL DCOPY(NSQ,F2,1,F2N,1) DO 1100 IJ=1,NSQ Y(IJ)=0.D0 1100 SCR(IJ)=0.D0 DO 1200 I=1,N IJ=N*(I-1)+NB(I) Y(IJ)=1.D0 1200 SCR(IJ)=1.D0 C CALL DGESV(N,N,YN,N,YP,SCR,N,IER) IF (IER.EQ.0) GO TO 2000 WRITE(6,600) 600 FORMAT(' * * * WARNING - STABILIZATION WITH BAD MATRIX.') C 2000 CALL DGEMUL(YPN,N,'N',SCR,N,'N',YP,N,N,N,N) CALL DGEMUL(F1N,N,'N',SCR,N,'N',F1,N,N,N,N) CALL DGEMUL(F2N,N,'N',SCR,N,'N',F2,N,N,N,N) C RETURN END FUNCTION STEFF(X1,X2,IFLAG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE D C C STEFFENSON ITERATION C CONVERGENCE ACCELERATION FOR LINEAR CONVERGENCE C STEFF=X2 IF(IFLAG.EQ.1) D=0.D0 DEL=X2-X1 IF(DEL.EQ.0.D0) RETURN RINV=D/DEL D=DEL IF(ABS(RINV).LE.0.4D0) RETURN STEFF=STEFF+DEL/(RINV-1.D0) D=0.D0 RETURN END SUBROUTINE STORAG(INTFLG,N,MXLAM,NV,NPOTL, 1 ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9, 2 ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT, NUMDER) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER PRINT LOGICAL NUMDER C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C N.B. NIPR WAS NOT USED IN V11 STORAGE ROUTINE! SHOULD IT BE? C NSQ=N*N C C IC2 IS NEXT AVAILABLE LOCATION ... IC2=IXNEXT NUSED=0 C C SOLVE COUPLED EQUATIONS BY METHOD OF DEVOGELAERE C IF(INTFLG.EQ.2) THEN IT1=IC2 IT2=IT1+MXLAM IT3=IT2+4*NSQ IT4=IT3+2*NSQ IT5=IT4+4*NSQ IT6=IT5+NSQ IT7=IT6+NSQ IXNEXT=IT7+N CALL CHKSTR(NUSED) C CALL DVSCAT(N,NSQ,MXLAM,NPOTL, 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), 2 X(IS8),X(IS9), 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7), 4 ESHIFT,ICODE,PRINT) C C SOLVE COUPLED EQUATIONS BY WALKER-LIGHT R-MATRIX PROPAGATOR METHOD C ELSE IF(INTFLG.EQ.3) THEN IT1=IC2 IT2=IT1+MXLAM IT3=IT2+NSQ IT4=IT3+NSQ IT5=IT4+N IT6=IT5+N IT7=IT6+N IT8=IT7+N IT9=IT8+N IT10=IT9+N IT11=IT10+N IXNEXT=IT11+N CALL CHKSTR(NUSED) C CALL RMTPRP(N,NSQ,MXLAM,NPOTL, 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), 2 X(ISJ),X(IS8),X(IS9), 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8), 4 X(IT9),X(IT10),X(IT11), 5 NOPMAX,DEEP,IK,ICODE,PRINT,NV,0) C C SOLVE COUPLED EQUATIONS BY LOG DERIVATIVE/VIVAS C ELSE IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN IT1=IC2 IT2=IT1+MXLAM IF(NUMDER) IT2=IT2+2*MXLAM IT3=IT2+N IT4=IT3+N IT5=IT4+N IT6=IT5+N IVIV=1 IF(INTFLG.EQ.5) IVIV=0 IT7=IT6+N*IVIV IT8=IT7+N*IVIV IT9=IT8+N*IVIV IT10=IT9+N*IVIV IT11=IT10+N*IVIV IT12=IT11+N*IVIV IT13=IT12+N*IVIV IT14=IT13+N*IVIV IT15=IT14+N*IVIV IT16=IT15+N*IVIV IT17=IT16+N*IVIV IT18=IT17+NSQ*IVIV IT19=IT18+NSQ*IVIV IT20=IT19+NSQ*IVIV IT21=IT20+NSQ*IVIV IT22=IT21+NSQ*IVIV IT23=IT22+NSQ*IVIV IT24=IT23+NSQ*IVIV IXNEXT=IT24+NSQ*IVIV CALL CHKSTR(NUSED) C CALL LDVIVS(N,NSQ,MXLAM,NPOTL, 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), 2 X(IS8),X(IS9), 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8), 4 X(IT9),X(IT10),X(IT11),X(IT12),X(IT13),X(IT14), 5 X(IT15),X(IT16),X(IT17),X(IT18),X(IT19),X(IT20),X(IT21), 6 X(IT22),X(IT23),X(IT24), 7 ICODE,PRINT) C C DIABATIC MODIFIED LOG DERIVATIVE ALGORITHM. C ELSE IF(INTFLG.EQ.6) THEN IT1=IC2 IT2=IT1+MXLAM IT3=IT2+N IT4=IT3+N IT5=IT4+N IXNEXT=IT5+N CALL CHKSTR(NUSED) C C N.B. IT5 IS PASSED SO SPECIAL N=1 CODE CAN OVERLAY STORAGE CALL DASCAT(N,NSQ,MXLAM,NPOTL, 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), 2 X(IS8),X(IS9), 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5), 4 ICODE,PRINT, IT5 ) C C QUASIADIABATIC MODIFIED LOG DERIVATIVE ALGORITHM. C ELSE IF(INTFLG.EQ.7) THEN IT1=IC2 IT2=IT1+MXLAM IT3=IT2+NSQ IT4=IT3+NSQ IT5=IT4+N IT6=IT5+N IT7=IT6+N IT8=IT7+N IT9=IT8+N IXNEXT=IT9+N CALL CHKSTR(NUSED) C CALL QASCAT(N,NSQ,MXLAM,NPOTL, 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), 2 X(IS8),X(IS9), 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8), 4 X(IT9), 5 ICODE,PRINT) C C HYBRID DMLD/AIRY ALGORITHM OF ALEXANDER AND MANOLOPOULOS C ELSE IF(INTFLG.EQ.8) THEN IT1=IC2 IT2=IT1+MXLAM IT3=IT2+N IT4=IT3+N IT5=IT4+N IT6=IT5+N IT7=IT6+NSQ IT8=IT7+NSQ IT9=IT8+N IU1=IT9+N IXNEXT=IU1+N CALL CHKSTR(NUSED) C CALL AXSCAT(N,NSQ,MXLAM,NPOTL, 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), 2 X(IS8),X(IS9), 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5), $ X(IT6),X(IT7),X(IT8),X(IT9),X(IU1), 4 ICODE,PRINT) C ELSE IF (INTFLG.EQ.-1) THEN C C SOLVE EQUATIONS BY WKB USING GAUSS-MEHLER INTEGRATION. C ONLY GOOD FOR ONE-CHANNEL CASES C IF (N.EQ.1) GO TO 810 WRITE(6,601) N 601 FORMAT('0 ***** ERROR. WKB (INTFLG=-1) ONLY IMPLEMENTED FOR', 1 ' ONE-CHANNEL CASE. TERMINATED WITH N =',I4) STOP 810 IT1=IC2 IT2=IT1+1 IT3=IT2+1 IXNEXT=IT3+MXLAM IF (NUMDER) IC=IC+2*MXLAM CALL CHKSTR(NUSED) CALL WKB(N,MXLAM,NPOTL,X(IT1),X(IS0),X(IS1),X(IT3),X(IS8), 1 X(IS5),X(IS6),X(IT2),X(IS9),X(IS7),X(IS3),X(IS4), 2 NUMDER,PRINT) C ELSE WRITE(6,699) INTFLG 699 FORMAT('0 STORAG CALLED WITH AN ILLEGAL INTFLG=',I4) STOP ENDIF C C WE ARE FINISHED WITH THIS TEMPORARY STORAGE; RESTORE IXNEXT. C THIS IS CONSISTENT W/ V11 WHICH DID NOT MODIFY STORAG IC2 ARGUMENT C HOWEVER, THIS MEANS THAT ONE CANNOT EXPECT ALLOCATED STORAGE C TO BE RETAINED BEYOND A SCATTERING CALL IXNEXT=IC2 RETURN END SUBROUTINE STRY(NLB,NUB,N,ITRY,EIGNEW) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE ITOLD C C THIS TESTS TO SEE IF ALL THE OFF-DIAGONAL ELEMENTS OF THE C EIGENVECTORS HAVE BECOME NEGLIGIBLE COMPARED TO VTOL C DIMENSION NLB(1),NUB(1) DIMENSION EIGNEW(1) C TOLERANCE TO DETERMINE DEGENERACY. DATA EPSIL / 1.D-2/ C STORE OLD VALUE OF ITRY ITOLD = ITRY IF(N.LE.1) GO TO 15 DO 10 I=1,N C TEST FOR DEGENERACY IF(I.EQ.1) GO TO 8 DIFF = ABS(EIGNEW(I)-EIGNEW(I-1)) C IF NEARLY DEGENERATE, DON'T BOTHER TO CHECK OFF-DIAGONAL C EIGENVECTOR COMPONENTS IF(DIFF.LT.EPSIL ) GO TO 10 IF(I.EQ.N) GO TO 9 8 DIFF = ABS(EIGNEW(I)-EIGNEW(I+1)) IF(DIFF.LT.EPSIL ) GO TO 10 9 IF(NLB(I).NE.NUB(I)) GO TO 20 10 CONTINUE C IF THE FOLLOWING STATEMENT IS REACHED, ALL COMPONENTS ARE C INDEED NEGLIGIBLE OR DEGENERATE 15 ITRY = 0 GO TO 30 C THIS IS REACHED WHEN AN ELEMENT IS TOO LARGE. 20 ITRY = -1 RETURN 30 IF(ITOLD.EQ.0 .AND. ITRY.EQ.0) ITRY = 1 C THIS MAKES SURE THAT THE ELEMENTS WERE ALSO NEGLIGIBLE AT THE C LAST STEP. C ITRY = 1 ON RETURN MEANS READY TO TRY FOR S-MATRIX CONVERGENCE RETURN END LOGICAL FUNCTION STSRCH(LOG,LSTR,N,I4) CHARACTER*1 LOG,LSTR(N) IF (N.LE.0) GO TO 9000 DO 1000 I=1,N IF (LSTR(I).NE.LOG) GO TO 1000 I4=I STSRCH=.TRUE. RETURN 1000 CONTINUE 9000 STSRCH=.FALSE. I4=0 RETURN END SUBROUTINE SURBAS(JLEV, N, J, L, EINT, CENT, VL, IV, 1 MXLAM, NPOTL, LAM, ERED, WVEC, LCNT, THETA, PHI, EMAXK) C C SUBROUTINE TO SET UP ATOM-SURFACE SCATTERING. C THIS VERSION USES 2 ELEMENTS OF THE VL ARRAY FOR EACH PAIR OF C BASIS FUNCTIONS, SO REQUIRES NPOTL=2 RETURNED FROM POTENL. C COMMON BLOCK NPOT COMMUNICATES THIS TO POTENL C VERSION 14 CMBASE C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE INTEGER FIND LOGICAL LCNT,LEVIN,EIN,HEX,ORTHOG,EQUIV DIMENSION JLEV(1), J(1), L(1), EINT(1), CENT(1), 1 WVEC(1), VL(1), IV(1), LAM(1) COMMON/NPOT/NPTL COMMON/CMBASE/ROTI(12),ELEVEL(1000),EMAX,WT(2),SPNUC,NLEVEL, 1 JLEVEL(4000),J1MIN, 2 J1MAX,J1STEP,IS1(10),J2MIN,J2MAX,J2STEP,IS2(10),JHALF,IDENT 3 ,MXJL,MXEL COMMON/LATSYM/HEX,ORTHOG,EQUIV DATA BFCT/16.857630D0/ C SQUARE(A,B) = A*A + B*B + 2.D0*A*B*COSLAT C C ISYM IS A LABEL FOR THE TYPE OF SYMMETRIZATION: C < 0 NO SYMMETRIZATION C = 0 0 DEGREE SYMMETRIZATION FOR RECTANGULAR OR HEX LATTICE C = 1 30 DEGREE SYMMETRIZATION FOR HEX LATTICE C = 2 45 DEGREE SYMMETRIZATION FOR SQUARE LATTICE C ISYM = -1 IF((HEX.OR.ORTHOG) .AND. ABS(PHI).LT.1.D-10) ISYM = 0 IF(HEX .AND. ABS(MOD(PHI,60.D0)-30.D0).LT.1.D-10) ISYM = 1 IF(ORTHOG .AND. EQUIV .AND. ABS(MOD(PHI,90.D0)-45.D0).LT.1.D-10) 1 ISYM = 2 C PARA=SQRT(ERED)*SIN(THETA*PI/180.D0) SINPHI=SIN(PHI*PI/180.D0) COSPHI=COS(PHI*PI/180.D0) XK2=PARA*SINPHI/SINLAT XK1=PARA*COSPHI-XK2*COSLAT IF(LCNT) GOTO 50 WRITE(6,598)N,THETA,PHI,XK1,XK2 598 FORMAT(/I4,' CHANNEL BASIS FOR THETA =',F8.3,' PHI =',F8.3, 1 ' DEGREES'/' CORRESPONDING TO K = (',2F10.6,' ) A-1') IF(ISYM.GE.0) WRITE(6,599) 599 FORMAT(' SYMMETRIZED BASIS USED FOR THESE ANGLES'/ 1 ' NOTE THAT CALCULATED INTENSITIES FOR OUT-OF-PLANE BEAMS', 2 ' ARE IMPLICITLY SUMMED OVER EQUIVALENT PAIRS') IF(EMAXK.NE.EMAX) WRITE(6,600) EMAXK 600 FORMAT(' BASIS FUNCTIONS LIMITED BY EMAXK =',F10.3) C 50 I=0 N=0 DO 200 N1=1,NLEVEL J1=JLEV(N1+NLEVEL) IF(ISYM.GE.0 .AND. 2*J1.LT.ISYM*JLEV(N1)) GOTO 200 A=XK1+XH*DBLE(JLEV(N1)) B=XK2+XK*DBLE(J1) ECHAN=SQUARE(A,B) IF(ECHAN*ESCALE.GT.EMAXK) GOTO 200 N=N+1 IF(LCNT) GOTO 200 EINT(N)=ECHAN DIF=ERED-ECHAN WVEC(N)=SIGN(SQRT(ABS(DIF)),DIF) J(N)=JLEV(N1+NLEV2) L(N)=0 CENT(N)=0.D0 DO 100 M=1,N N2=J(M) J2=JLEV(N2+NLEVEL) IF(ISYM.GE.0 .AND. 2*J2.LT.ISYM*JLEV(N2)) GOTO 100 I=I+1 I1=JLEV(N2)-JLEV(N1) I2=J2-J1 IV(I)=FIND(I1,I2,LAM,MXLAM) VL(I)=1.D0 IF(IV(I).EQ.0) VL(I)=0.D0 I=I+1 IV(I)=0 VL(I)=0.D0 IF(ISYM.LT.0) GOTO 100 IF(2*J1.EQ.ISYM*JLEV(N1) .NEQV. 2*J2.EQ.ISYM*JLEV(N2)) 1 VL(I-1)=VL(I-1)*ROOT2 IF(2*J1.EQ.ISYM*JLEV(N1) .OR. 2*J2.EQ.ISYM*JLEV(N2)) GOTO 100 C C IDENTIFY FOURIER COMPONENT CONNECTING SIGMA(N1) TO N2 C GOTO(70,80),ISYM I1=JLEV(N1) IF(HEX) I1=I1-J1 I2=-J1 GOTO 90 70 I1=JLEV(N1) I2=I1-J1 GOTO 90 80 I1=J1 I2=JLEV(N1) 90 I1=JLEV(N2)-I1 I2=J2-I2 IV(I)=FIND(I1,I2,LAM,MXLAM) VL(I)=1.D0 IF(IV(I).EQ.0) VL(I)=0.D0 100 CONTINUE 200 CONTINUE RETURN C C ENTRY SET8(LEVIN,EIN,NLEV,JLEV,URED) C NPTL=2 ROOT2=SQRT(2.D0) ESCALE=BFCT/URED C EMIN=0.D0 PI=ACOS(-1.D0) COSLAT=COS(ROTI(3)*PI/180.D0) SINLAT=SIN(ROTI(3)*PI/180.D0) ORTHOG = ABS(COSLAT).LT.1.D-8 EQUIV = ABS(ROTI(1)-ROTI(2)).LT.1.D-8 HEX = EQUIV .AND. ABS(COSLAT+0.5D0).LT.1.D-8 XH=2.D0*PI/SINLAT/ROTI(1) XK=2.D0*PI/SINLAT/ROTI(2) WRITE(6,601)(ROTI(I),I=1,3),COSLAT 601 FORMAT(' LATTICE LENGTHS ARE',F10.6,' AND',F10.6,' A'/ 1 ' RECIPROCAL LATTICE ANGLE IS ',F10.3,' DEGREES,', 2 ' COSINE =',F10.6/) C IF(LEVIN) GOTO 500 WRITE(6,602)EMIN,EMAX,J1MAX,J2MAX 602 FORMAT(' BASIS FUNCTIONS GENERATED WITH'/5X,'EMIN =',F10.3/ 1 5X,'EMAX =',F10.3/5X,'G1MAX =',I10/5X,'G2MAX =',I10/) N1MAX=SQRT(EMAX)/(SINLAT*XH) N1MAX=MIN0(N1MAX,J1MAX) NLEVEL=0 DO 300 N1=-N1MAX,N1MAX A=DBLE(N1)*XH B=A*COSLAT N2MAX=(ABS(B)+SQRT(EMAX+B*B-A*A))/XK N2MAX=MIN0(N2MAX,J2MAX) DO 300 N2=-N2MAX,N2MAX B=DBLE(N2)*XK E=SQUARE(A,B)*ESCALE IF(E.LT.EMIN .OR. E.GT.EMAX) GOTO 300 NLEVEL=NLEVEL+1 JLEVEL(2*NLEVEL-1)=N1 JLEVEL(2*NLEVEL) =N2 ELEVEL(NLEVEL)=E 300 CONTINUE C C SORT CHANNELS ON ENERGY FOR K=0 C DO 400 N1=1,NLEVEL DO 400 N2=N1+1,NLEVEL IF(ELEVEL(N2).GE.ELEVEL(N1)) GOTO 400 E=ELEVEL(N1) ELEVEL(N1)=ELEVEL(N2) ELEVEL(N2)=E I1=2*N1 I2=2*N2 I=JLEVEL(I1-1) JLEVEL(I1-1)=JLEVEL(I2-1) JLEVEL(I2-1)=I I=JLEVEL(I1) JLEVEL(I1)=JLEVEL(I2) JLEVEL(I2)=I 400 CONTINUE GOTO 700 C 500 DO 520 N1=1,NLEVEL DO 520 N2=N1+1,NLEVEL 520 IF (JLEVEL(2*N1-1).EQ.JLEVEL(2*N2-1) 1 .AND. JLEVEL(2*N1) .EQ.JLEVEL(2*N2)) GOTO 530 GOTO 540 530 WRITE(6,603)N1,N2 603 FORMAT(' **** BASIS FUNCTIONS',I3,' AND',I3,' ARE THE SAME.', 1 ' TERMINATING.') STOP 540 WRITE(6,604)NLEVEL 604 FORMAT(' BASIS FUNCTIONS TAKEN FROM JLEVEL INPUT WITH NLEVEL =', 1 I3) 700 NLEV=NLEVEL NLEV2=NLEV+NLEV DO 800 I=1,NLEV N1=JLEVEL(2*I-1) N2=JLEVEL(2*I) JLEV(I)=N1 JLEV(I+NLEV)=N2 JLEV(I+NLEV2)=I IF(.NOT.LEVIN) GOTO 800 A=DBLE(N1)*XH B=DBLE(N2)*XK ELEVEL(I)=SQUARE(A,B)*BFCT/URED 800 CONTINUE C IF(EIN) WRITE(6,605) 605 FORMAT(' *** NOTE. INPUT CHANNEL ENERGIES OVERWRITTEN BY VALUES', 1 ' CALCULATED FROM LATTICE PARAMETERS'/) RETURN END SUBROUTINE SWRITE(IU,N,S) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION S(N,N) C WRITE(IU) ((S(I,J),J=1,I),I=1,N) RETURN C ENTRY SREAD(IU,N,S,IEND) IEND=0 READ(IU,END=9999) ((S(I,J),J=1,I),I=1,N) DO 1000 I=1,N DO 1000 J=1,I-1 1000 S(J,I)=S(I,J) RETURN 9999 IEND=1 RETURN END SUBROUTINE SYMINV(A, IA, N, INERT) C C SIMULATES SYMINV SYMMETRIC MATRIX INVERTER WITH LAPACK CALLS C THIS VERSION USES ONLY THE UPPER TRIANGLE OF A: C NOT COMPATIBLE WITH MOLSCAT VERSION 11. C JMH MAY 93 C IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DIMENSION A(IA,N) C IT1=IXNEXT IT2=IT1+(N+1)/NIPR LWORK=MX-IT2+1 C NB=ILAENV(1,'DSYTRF','L',N,-1,-1,-1) LWREQ=N*NB IF(LWORK.LT.LWREQ) THEN WRITE(6,100) LWORK,N,NB 100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE', 1 ' IN SYMINV.'/' LAPACK ROUTINE DSYTRF NEEDS AT LEAST N*NB:', 2 ' N =',I5,' AND NB =',I5,' ON THIS CALL.') STOP ENDIF C IXNEXT=IT2+LWREQ NUSED=0 CALL CHKSTR(NUSED) C CALL DSYTRF('L',N,A,IA,X(IT1),X(IT2),LWORK,INFO) C IF (INFO .NE. 0) THEN WRITE (6,120) INFO 120 FORMAT(' *** ERROR IN DSYTRF: INFO =',I3) STOP END IF C INERT=0 C CALL DSYNEG(A,X(IT1),N,INERT) C CALL DSYTRI('L',N,A,IA,X(IT1),X(IT2),INFO) C IF (INFO .NE. 0) THEN WRITE (6,130) INFO 130 FORMAT(' *** ERROR IN DSYTRI: INFO =',I3) STOP END IF C IXNEXT=IT1 C RETURN END FUNCTION THREEJ (J1,J2,J3) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C COMPUTATION OF SPECIAL WIGNER 3J COEFFICIENT WITH C VANISHING PROJECTIONS. SEE EDMONDS, P. 50. C C THIS VERSION EVALUATES BINOM AND PARITY IN-LINE C SHOULD IMPROVE EFFICIENCY, ESPECIALLY ON CRAY; C ALSO GIVES IMPROVEMENT ON AMDAHL (SG: 20 DEC 92) C C STATEMENT FUNCTION FOR DELTA ASSOCIATED W/ RACAH AND SIXJ SYMBOLS C DELTA(I,J,K)= SQRT(1.D0/ ( BINOM(I+J+K+1,I+J-K) * C 1 BINOM(K+K+1,I-J+K) * DBLE(K+J-I+1) ) ) C I1=J1+J2+J3 IF (I1-2*(I1/2).NE.0) GO TO 8 1 I2=J1-J2+J3 IF (I2) 8,2,2 2 I3=J1+J2-J3 IF (I3) 8,3,3 3 I4=-J1+J2+J3 IF (I4) 8,4,4 4 I5=I1/2 I6=I2/2 SIGN=1.D0 IF (I5-2*(I5/2).NE.0) SIGN=-SIGN C 7 THREEJ=SIGN*DELTA(J1,J2,J3)*BINOM(I5,J1)*BINOM(J1,I6) C B1,B2 ARE BINOM ASSOCIATED W/ DELTA N=J1+J2+J3+1 M=J1+J2-J3 NM = N-M MNM = MIN(NM,M) IF(MNM.LE.0) THEN B1=1.D0 ELSE FN = N+1 F = 0.D0 B = 1.D0 DO 101 I = 1,MNM F = F+1.D0 C = (FN-F)*B 101 B = C/F B1 = B ENDIF N=J3+J3+1 M=J1-J2+J3 NM = N-M MNM = MIN(NM,M) IF(MNM.LE.0) THEN B2=1.D0 ELSE FN = N+1 F = 0.D0 B = 1.D0 DO 102 I = 1,MNM F = F+1.D0 C = (FN-F)*B 102 B = C/F B2 = B ENDIF DELTA=SQRT(1.D0/(B1*B2*(J3+J2-J1+1))) C B3=BINOM(I5,J1), B4=BINOM(J1,I6) N=I5 M=J1 NM = N-M MNM = MIN(NM,M) IF(MNM.LE.0) THEN B3=1.D0 ELSE FN = N+1 F = 0.D0 B = 1.D0 DO 103 I = 1,MNM F = F+1.D0 C = (FN-F)*B 103 B = C/F B3 = B ENDIF N=J1 M=I6 NM = N-M MNM = MIN(NM,M) IF(MNM.LE.0) THEN B4=1.D0 ELSE FN = N+1 F = 0.D0 B = 1.D0 DO 104 I = 1,MNM F = F+1.D0 C = (FN-F)*B 104 B = C/F B4 = B ENDIF THREEJ=SIGN*DELTA*B3*B4 RETURN 8 THREEJ=0.D0 RETURN END FUNCTION THRJ(F1,F2,F3,G1,G2,G3) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE MUNG,X,Y DIMENSION X(302),Y(302) DATA MUNG/0/,MXIX/302/ IF (MUNG.EQ.21) GO TO 69 MUNG = 21 X(1) = 0.D0 DO 100 I = 1, 201 A = I X(I+1) = LOG(A) +X(I) Y(I+1) = LOG(A) 100 CONTINUE 69 IF(F1-ABS(G1)) 1,13,13 13 IF(F2-ABS(G2))1,14,14 14 IF(F3-ABS(G3))1,15,15 15 SUM=F1+F2+F3 NSUM=SUM+.001D0 IF(SUM-NSUM)2,2,1 1 THRJ=0.D0 RETURN 2 IF(ABS(G1+G2+G3)-1.D-08)3,3,1 3 IF(F1+F2-F3)1,4,4 4 IF(F1+F3-F2)1,5,5 5 IF(F2+F3-F1)1,6,6 6 J1=2.D0*F3+2.001D0 J2=F1+F2-F3+1.001D0 J3=F1-F2+F3+1.001D0 J4=-F1+F2+F3+1.001D0 J5=F1+F2+F3+2.001D0 J6=F1+G1+1.001D0 J7=F1-G1+1.001D0 J8=F2+G2+1.001D0 J9=F2-G2+1.001D0 J10=F3+G3+1.001D0 J11=F3-G3+1.001D0 IF(J5.GT.MXIX) THEN WRITE(6,601) J5,MXIX 601 FORMAT(' *** DIMENSION ERROR IN THRJ - INDEX.GT.MXIX',2I5) STOP ENDIF R=0.5D0*(Y(J1)+X(J2)+X(J3)+X(J4)-X(J5) 1+X(J6)+X(J7)+X(J8)+X(J9)+X(J10)+X(J11)) SUM=0.D0 F=-1 KZ=-1 7 KZ=KZ+1 F=-F J1=KZ+1 J2=F1+F2-F3-KZ+1.001D0 IF(J2)20,20,8 8 J3=F1-G1-KZ+1.001D0 IF(J3)20,20,9 9 J4=F2+G2-KZ+1.001D0 IF(J4)20,20,10 10 J5=F3-F2+G1+KZ+1.001D0 IF(J5)7,7,11 11 J6=F3-F1-G2+KZ+1.001D0 IF(J6)7,7,12 12 JMAX=MAX(J1,J2,J3,J4,J5,J6) IF(JMAX.GT.MXIX) THEN WRITE(6,601) JMAX,MXIX STOP ENDIF S=-(X(J1)+X(J2)+X(J3)+X(J4)+X(J5)+X(J6)) SUM=SUM+F*EXP(R+S) GO TO 7 20 INT=ABS(F1-F2-G3)+0.0001D0 VAL=((-1.D0)**INT)*SUM/SQRT(2.D0*F3+1.D0) IF(ABS(VAL).LE.1.D-6) VAL=0.D0 THRJ=VAL RETURN END SUBROUTINE TRNSFM(T,W,A,N,ISTOP,ISYM) C------------------------------------------------------------------- C WRITTEN BY G. A. PARKER. C MODIFIED TO USE BLAS BY J. M. HUTSON C THIS ROUTINE TRANSFORMS THE MATRIX W INTO A NEW BASIS SET C ISTOP=.TRUE. ==> RETURN AFTER A = TRANSPOSE(W) * T C ISTOP=.FALSE. ==> CONTINUE TO FORM W = TRANSPOSE(T) * W * T C ISYM =.TRUE. ==> FORCE THE RESULTING MATRIX TO BE SYMMETRIC. C N IS THE DIMENSION OF THE MATRICES. C------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL ISTOP,ISYM DIMENSION T(1),W(1),A(1) DATA ZERO/0.D0/,HALF/0.5D0/,ONE/1.D0/ C------------------------------------------------------------------- C MULTIPLY THE TRANSPOSE OF THE MATRIX W TIMES T AND C STORE THE RESULT INTO MATRIX A. C------------------------------------------------------------------- IF (N.EQ.1) GOTO 300 IF (ISYM) GOTO 140 CALL DGEMUL(W,N,'T',T,N,'N',A,N,N,N,N) IF (ISTOP) RETURN C------------------------------------------------------------------- C MULTIPLY THE TRANSPOSE OF MATRIX A TIMES MATRIX C T AND STORE THE RESULT INTO MATRIX W C------------------------------------------------------------------- CALL DGEMUL(A,N,'T',T,N,'N',W,N,N,N,N) RETURN C------------------------------------------------------------------- C THIS IS REACHED ONLY WHEN W AND THE RESULT MATRIX ARE SYMMETRIC, C SO THAT ONLY HALF THE MATRIX NEED BE COMPUTED C AND THE OTHER HALF STORED BY SYMMETRY. C------------------------------------------------------------------- 140 CALL DSYMM('L','L',N,N,ONE,W,N,T,N,ZERO,A,N) IF (ISTOP) RETURN CALL DSYR2K('L','T',N,N,HALF,A,N,T,N,ZERO,W,N) CALL DSYFIL('U',N,W,N) RETURN C 300 A(1)=W(1)*T(1) IF (ISTOP) RETURN W(1)=A(1)*T(1) RETURN END SUBROUTINE TRNSP(A,N) C C SUBROUTINE FOR IN-PLACE TRANSPOSITION OF N X N MATRIX A C BASED ON MILLARD ALEXANDER'S TRANSP C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(1) ICOLPT = 2 IROWPT = N + 1 DO 100 ICOL = 1, N - 1 C ICOLPT POINTS TO FIRST SUB-DIAGONAL ELEMENT IN COLUMN ICOL C IROWPT POINTS TO FIRST SUPER-DIAGONAL ELEMENT IN ROW ICOL C NROW IS NUMBER OF SUBDIAGONAL ELEMENTS IN THIS COLUMN NROW = N - ICOL CALL DSWAP (NROW, A(ICOLPT), 1, A(IROWPT), N) ICOLPT = ICOLPT + N + 1 IROWPT = IROWPT + N + 1 100 CONTINUE RETURN END SUBROUTINE VINIT(I,RM,EPSIL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) ENTRY VSTAR (I,RR,SUM) ENTRY VSTAR1(I,RR,SUM) ENTRY VSTAR2(I,RR,SUM) WRITE(6,601) I 601 FORMAT('0 *** ERROR. DUMMY VERSION OF VINIT CALLED WITH I =', 1 I4/14X,'VINIT MUST BE PROVIDED IF NTERM(I) IS ZERO.') STOP END SUBROUTINE VIVAS(N,NSQ,DRNOW,RMIN,RMAX,DRMAX,TLDIAG,TOFF, X ESHIFT,RMAT,EYE11,EYE12,EYE22,W,W0,W1,W2,TSTORE, X VECOLD,VECNEW,G1,G1P,G2,G2P,A1,A1P,B1,B1P, X XSQ,XK,COSX,SINX,SINE,DIAG,NOPEN,PRNTLV,ISC, X P,VL,IVL,ERED,EINT,CENT,RMLMDA,MXLAM,WKS,NPOTL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C------------------------------------------------------------------ C MODIFIED FROM NRCC CODE FOR COMPATIBILITY WITH MOLSCAT C BY S. GREEN (FEB. 1981) AND J.M. HUTSON (OCT. 1984) C APR 87 MODIFY WARNING OUTPUT ASSOC. W/ 1800 FORMAT C------------------------------------------------------------------ C ROUTINES USED C WAVMAT -CALCULATES THE POTENTIAL ENERGY INTERACTION MATRIX C DERMAT -CALCULATES THE FIRST AND SECOND DERIVATIVES OF THE POTENTIAL C TRNSFM -TRANSFORMS MATRICES INTO THE NEW BASIS VIA A C SIMILARITY TRANSFORMATION C PERT1 -CALCULATES THE PERTURBATION CORRECTIONS TO THE C PERT2 WAVEFUNCTONS. C DGESV -SOLVES A LINEAR SYSTEMS OF EQUATIONS. C DELRD -PREDICTS THE NEW STEP SIZE. C F02ABF -DIAGONALIZES A REAL SYMMETRIC MATRIX AND RETURN THE C EIGENVALUES AND EIGENVECTORS. C------------------------------------------------------------------ C ON ENTERING C N - NUMBER OF CHANNELS C NSQ - N*N C DRNOW - INITIAL STEP SIZE C RMIN - MINIMUM RADIAL DISTANCE C RMAX - MAXIMUM RADIAL DISTANCE C DRMAX - MAXIMUM ALLOWED STEP SIZE C TLDIAG- STEP TOLERANCE PARAMETER C TOFF - INTERVAL TOLERANCE PARAMETER C ISC - SCRATCH UNIT USED IF IREAD/IWRITE IS TRUE C-------------------------------------------------------------------- C PRINT LEVEL FOR MOLSCAT INTEGER PRNTLV C------------------------------------------------------------------ C CHARACTER VARIABLES C------------------------------------------------------------------ CHARACTER*4 LRMAT,LUDP,LUD,LDG2P,LDG2,LDG1P,LDG1,LG2P, 1 LG2,LG1P,LG1,LW0,LW2,LVECNW,LDIAG,LW1,LEYE11,LEYE12,LEYE22 C------------------------------------------------------------------- C LOGICAL VARIABLES C------------------------------------------------------------------- LOGICAL IVD,IVPD,IVPPD,IALFP,NUMDER LOGICAL IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,ITHS LOGICAL ITRUE,IFALSE,NEWINT LOGICAL IV,IVP,IVPP,ISHIFT,IREAD,IDIAG,IWRITE,ICRMAT LOGICAL IPERT,LAST,ISYM C------------------------------------------------------------------- C LABELLED COMMONS C CONTROL VARIABLES PASSED FROM DRIVER C------------------------------------------------------------------- COMMON/LDVVCM/ XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP, 1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE C------------------------------------------------------------------- C IF THE LOGICAL VARIABLE IS TRUE THEN C IV - CALCULATES PERTURBATION CORRECTIONS FROM THE CONSTANT C TERMS IN THE INTERACTION POTENTIAL. C IVP - CALCULATES PERTURBATION CORRECTIONS FROM THE FIRST C DERIVATIVE OF THE INTERACTION POTENTIAL. C IVPP - CALCULATES PERTURBATION CORRECTIONS FROM THE SECOND C DERIVATIVE OF THE INTERACTION POTENTIAL. C ISHIFT- SHIFTS THE REFERENCE POTENTIAL TO BEST FIT THE TRUE C POTENTIAL. C NUMDER- CALCULATES POTENTIAL DERIVATIVES NUMERICALLY C IDIAG - INCLUDES ALL OF THE DIAGONAL PERTUBATION CORRECTIONS. C ISYM - SYMMETRIZES THE R-MATRIX AT EACH INTERVAL. C IPERT - USES THE PERTURBATIONS CORRECTIONS. C IALFP - THE GEOMETRIC PROGRESSION PARAMETER ALPHA IS PREDICTED. C ALPHA1- MINIMUM GEOMETRIC PROGRESSION PARAMETER. C ALPHA2- MAXIMUM GEOMETRIC PROGRESSION PARAMETER. C IALPHA- IF IALPHA.GT.0 THEN THE STEP SIZE IS DETERMINED USING C A GEOMETRIC PROGRESSION AND THE INTERVAL IS DIVIDED C INTO IALPHA STEPS. C------------------------------------------------------------------ COMMON/POPT/IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,IOC LOGICAL LPOPT(7) EQUIVALENCE (LPOPT(1),IVECT) C LPOPT CONTAINS PRINTING OPTIONS FROM NRCC VERSION. C THESE ARE ALL SET FALSE HERE. CHANGE TO DEBUG. C WHEN THE LOGICAL VARIABLE IS TRUE, C IVECT - EIGENVALUES AND EIGENVECTORS. C IPOTL - POTENTIAL ENERGY MATRICES AND ITS DERIVATIVES. C IEYE - ACCUMULATED PERTURBATION INTEGRALS. C IGZRO - ZERO-TH ORDER WAVEFUNCTIONS. C IGPERT- PERTURBED WAVEFUNCTIONS. C IWAVE - PERTURBED WAVEFUNCTIONS. C IRMAT - R-MATRIX C IOC - INFORMATION PRINTED EVERY IOC-TH STEP C-------------------------------------------------------------------- C ARRAYS DIMENSIONED AS VECTORS C------------------------------------------------------------------- DIMENSION G1(N),G1P(N),G2(N),G2P(N) DIMENSION A1(N),A1P(N),B1(N),B1P(N) DIMENSION XSQ(N),XK(N),COSX(N),SINX(N),SINE(N),DIAG(N) C------------------------------------------------------------------- C ARRAYS DIMENSIONED AS MATRICES C------------------------------------------------------------------- DIMENSION EYE11(NSQ),EYE12(NSQ),EYE22(NSQ) DIMENSION W0(NSQ),W1(NSQ),W2(NSQ),W(NSQ) DIMENSION RMAT(NSQ) DIMENSION TSTORE(NSQ),VECOLD(NSQ),VECNEW(NSQ) DIMENSION P(MXLAM),VL(2),IVL(2),EINT(N),CENT(N),WKS(N) C------------------------------------------------------------------- C DATA STATEMENTS FOR PRINTING C------------------------------------------------------------------- DATA LRMAT/'RMAT'/,LUDP/' UP'/,LUD/' U'/,LDG2P/'DG2P'/ DATA LDG2/' DG2'/,LDG1P/'DG1P'/,LDG1/' DG1'/,LG2P/' G2P'/ DATA LG2/' G2'/,LG1P/' G1P'/,LG1/' G1'/,LW0/' W0'/ DATA LW2/' W2'/,LVECNW/'VCNW'/,LDIAG/'DIAG'/ DATA LW1/' W1'/,LEYE11/' I11'/,LEYE12/' I12'/,LEYE22/' I22'/ C------------------------------------------------------------------- C LOGICAL DATA STATEMENTS C------------------------------------------------------------------- DATA IFALSE/.FALSE./,ITRUE/.TRUE./ C------------------------------------------------------------------- C C SET DEFAULT VALUES FOR PRINTING NSGERR=0 IOC=5 DO 100 I=1,7 100 LPOPT(I)=.FALSE. IF(.NOT.(IREAD.AND.IWRITE)) GO TO 101 WRITE(6,699) 699 FORMAT('0 * * * ERROR. IREAD AND IWRITE CANNOT BOTH BE TRUE.') IREAD=.FALSE. IWRITE=.FALSE. 101 CONTINUE IVD = IV .OR. IDIAG IVPD = IVP .OR. IDIAG IVPPD = IVPP .OR. IDIAG C------------------------------------------------------------------- C PRINT CONTROL DATA IF(PRNTLV.LE.15) GO TO 110 WRITE(6,1200) WRITE(6,1300) IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT, X IWRITE,IREAD,IOC WRITE(6,1400) WRITE(6,1500) IV,IVP,IVPP,ISHIFT,IDIAG,ISYM,IPERT,IALFP WRITE(6,1600) ALPHA1,ALPHA2,IALPHA WRITE(6,2500) WRITE(6,2600) RMIN,RMAX,DRNOW,DRMAX,TOFF,TLDIAG 110 COFFL = 0.D0 IF(N .EQ. 0) RETURN NEWINT = .FALSE. NP1 = N+1 ICRMAT = .TRUE. TOL = 1.D-11 LAST = .FALSE. ITRANS = 0 IK = 0 DO 130 I = 1,N G1(I) = 0.D0 G1P(I) = 1.D0 G2(I) = 1.D0 G2P(I) = 0.D0 DO 130 K = 1,N IK = IK+1 VECNEW(IK) = 0.D0 IF(I .EQ. K) VECNEW(IK) = 1.D0 EYE11(IK) = 0.D0 EYE12(IK) = 0.D0 130 EYE22(IK) = 0.D0 IF(PRNTLV.GE.15) WRITE(6,3100) ISTEP = 1 NTRVL = 0 DINT = DRNOW DIAGI = RMIN+0.5D0*DINT RMID = RMIN RLAST = RMIN XBAR = 0.D0 XSBAR = 0.D0 EBAR = 0.D0 EXBAR = 0.D0 IF(IALPHA .LE. 0) GO TO 150 BALPHA = (ALPHA2-ALPHA1)/(RMAX-RMIN) ALPHA = ALPHA1+BALPHA*(DIAGI-RMIN) IF(IALFP) ALPHA = ALPHA1 IF(ALPHA .NE. 1.D0) GO TO 140 DRNOW = DINT/IALPHA GO TO 150 140 DRNOW = DINT*(ALPHA-1.D0)/(ALPHA**IALPHA-1.D0) 150 RNOW = RMIN+DRNOW IF(IWRITE) WRITE(ISC) RMIN,RMAX,DINT,DIAGI,RMID,IALPHA,BALPHA, X ALPHA1,ALPHA2,IALPHA IF(.NOT. IREAD) GO TO 160 READ(ISC) RMIN,RMAX,DINT,DIAGI,RMID,IALPHA,BALPHA, X ALPHA1,ALPHA2,IALPHA C------------------------------------------------------------------- C START OF THE PROPAGATION LOOP C------------------------------------------------------------------- 155 READ(ISC) ISTEP,RNOW,DRNOW,LAST,N,DIAG,TSTORE, X W0,W1,W2,VECNEW,NTRVL,RMIDI,RLAST,RCENT,ITRANS READ(ISC) NEWINT DO 158 I=1,N 158 DIAG(I)=DIAG(I)+ESHIFT 160 RCENT = RNOW-0.5D0*DRNOW ITHS = .FALSE. IF(((NTRVL+1)/IOC)*IOC .EQ. NTRVL+1) ITHS = .TRUE. IF(IREAD) GO TO 300 C------------------------------------------------------------------- C EVALUATE THE POTENTIAL AND ITS DERIVATIVES. C------------------------------------------------------------------- CALL WAVMAT(W,N,RCENT, 1 P,VL,IVL,ERED,EINT,CENT,RMLMDA,WKS,MXLAM,NPOTL) DO 165 I = 1, NSQ 165 W0(I) = W(I) IF(IVPD .AND. IVPPD) GO TO 200 DO 170 I = 1, NSQ W1(I) = 0.D0 170 W2(I) = 0.D0 200 IF(IVPPD .OR. ISHIFT) CALL DERMAT(2,W2,N,RCENT, 1 P,VL,IVL,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) IF (IVPD) CALL DERMAT(1,W1,N,RCENT, 1 P,VL,IVL,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) FACTOR = DRNOW*DRNOW/24.D0 IF( .NOT. ISHIFT) FACTOR = 0.D0 IF( .NOT. ICRMAT) GO TO 270 RMIDI = DIAGI C------------------------------------------------------------------- C EVALUATE THE POTENTIAL AT THE RMIDI WHERE THE INTERACTION IS TO C BE DIAGONALIZED AND SAVE THE OLD EIGENVECTORS. C------------------------------------------------------------------- IF(RMIDI .NE. RCENT) CALL WAVMAT(W,N,RMIDI, 1 P,VL,IVL,ERED,EINT,CENT,RMLMDA,WKS,MXLAM,NPOTL) DO 240 I = 1,NSQ 240 VECOLD(I) = VECNEW(I) ITRANS = ITRANS+1 C------------------------------------------------------------------- C DIAGONALIZE THE INTERACTION POTENTIAL. C------------------------------------------------------------------- IFAIL=0 CALL F02ABF(W,N,N,DIAG,VECNEW,N,WKS,IFAIL) IF( .NOT. ITHS) GO TO 270 IF( .NOT. IVECT) GO TO 270 WRITE(6,2900) LDIAG WRITE(6,2800) (DIAG(I),I = 1,N) WRITE(6,2900) LVECNW WRITE(6,2800) (VECNEW(I),I = 1,NSQ) C-------------------------------------------------------------------- C TRANSFORM THE POTENTIAL AND ITS DERIVATIVES INTO THE LOCAL BASIS. C-------------------------------------------------------------------- 270 CALL TRNSFM(VECNEW,W0,TSTORE,N,IFALSE,ITRUE) IF(IVPD) CALL TRNSFM(VECNEW,W1,TSTORE,N,IFALSE,ITRUE) IF(IVPPD .OR. ISHIFT) CALL TRNSFM(VECNEW,W2,TSTORE,N,IFALSE, X ITRUE) C------------------------------------------------------------------- C DETERMINE THE NEW TRANSFORMATION MATRIX C------------------------------------------------------------------- IF(ICRMAT) CALL DGEMUL(VECOLD,N,'T',VECNEW,N,'N',TSTORE,N,N,N,N) C------------------------------------------------------------------- C TRANSFORM THE R-MATRIX INTO THE NEW BASIS. C------------------------------------------------------------------- 300 IF(ICRMAT) CALL TRNSFM(TSTORE,RMAT,W,N,IFALSE,ISYM) ICRMAT = .FALSE. IF(IREAD) GO TO 350 C------------------------------------------------------------------- C SHIFT THE EIGENVALUES AND INITIALIZE FOR CONTRIBUTIONS NOT DESIRED. C------------------------------------------------------------------- INDEX = -N DO 330 J = 1,N INDEX = INDEX+NP1 DIAG(J) = -W0(INDEX)-FACTOR*W2(INDEX) 330 W0(INDEX) = -FACTOR*W2(INDEX) IF(IVD .AND. IVPD .AND. IVPPD) GO TO 350 CTERM0 = 1.D0 CTERM1 = 1.D0 CTERM2 = 1.D0 IF( .NOT. IVD) CTERM0 = 0.D0 IF( .NOT. IVPD) CTERM1 = 0.D0 IF( .NOT. IVPPD) CTERM2 = 0.D0 DO 340 I = 1,NSQ W0(I) = W0(I)*CTERM0 W1(I) = W1(I)*CTERM1 340 W2(I) = W2(I)*CTERM2 C------------------------------------------------------------------- C WRITE ON UNIT ISC THE INFORMATION NECESSARY FOR SUBSEQUENT ENERGY C CALCULATIONS. C------------------------------------------------------------------- 350 IF(IWRITE) WRITE(ISC) ISTEP,RNOW,DRNOW,LAST,N,DIAG,TSTORE, X W0,W1,W2,VECNEW,NTRVL,RMIDI,RLAST,RCENT,ITRANS IF( .NOT. ITHS) GO TO 360 IF( .NOT. IPOTL) GO TO 360 WRITE(6,2900) LDIAG WRITE(6,2800) (DIAG(I),I = 1,N) WRITE(6,2900) LW0 WRITE(6,2800) (W0(I),I = 1,NSQ) WRITE(6,2900) LW1 WRITE(6,2800) (W1(I),I = 1,NSQ) WRITE(6,2900) LW2 WRITE(6,2800) (W2(I),I = 1,NSQ) WRITE(6,2900) IALPHA C------------------------------------------------------------------- C CALCULATE THE ZERO-TH ORDER WAVEFUNCTIONS AND DERIVATIVES. C------------------------------------------------------------------- 360 NOPLOC = 0 DO 390 I = 1,N DIF = DIAG(I) XSQ(I) = DIF*DRNOW*DRNOW XLMBDA = SQRT(ABS(DIF)) X = XLMBDA*DRNOW IF(DIF .LT. 0.D0) GO TO 370 NOPLOC = NOPLOC+1 SX = SIN(X)/XLMBDA CX = COS(X) GO TO 380 370 IF(X.GT.173.D0) WRITE(6,1700) I,DIF,DRNOW,X SX = SINH(X)/XLMBDA CX = COSH(X) 380 A = G1P(I) SINX(I) = SX SINE(I) = SX*XLMBDA IF(DIF .LT. 0.D0) SINE(I) = -SINE(I) COSX(I) = CX XK(I) = X B = G1(I) G1(I) = A*SX+B*CX G1P(I) = A*CX-DIF*B*SX C = G2P(I) D = G2(I) A1(I) = B A1P(I) = A B1(I) = D B1P(I) = C G2(I) = C*SX+D*CX 390 G2P(I) = C*CX-DIF*D*SX C------------------------------------------------------------------- C ESTIMATE G2P(N) AT END OF NEXT STEP. IF IT IS TOO LARGE, C A NEW INTERVAL WILL BE STARTED. C------------------------------------------------------------------- IF(ABS(G2P(N)).LE.1.D04) GO TO 1801 IF (PRNTLV.GT.3) WRITE(6,1800) RNOW,DRNOW,G2P(N) NSGERR=NSGERR+1 1801 G2PMAX=G2P(N)*CX IF(IREAD .AND. .NOT. IPERT) GO TO 410 C------------------------------------------------------------------- C CALCULATE THE INTEGRALS NECESSARY FOR THE PERTURBATION CORRECTIONS. C THE STEP INTEGRALS ARE STORED IN W0, W1 AND W2, AND THE ACCUMULATED C INTEGRALS OVER THE INTERVAL ARE SAVED IN EYE11, EYE12 AND EYE22. C------------------------------------------------------------------- IF(IVPP) CALL PERT2(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11, X EYE12,EYE22,A1,B1,A1P,B1P) IF(IVPP) GO TO 400 IF(IVP) CALL PERT1(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11, X EYE12,EYE22,A1,B1,A1P,B1P) IF(IVP) GO TO 400 IF(IV) CALL PERT2(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11, X EYE12,EYE22,A1,B1,A1P,B1P) 400 CONTINUE 410 IF(IREAD .AND. .NOT. NEWINT) GO TO 590 SOFF = 0.D0 COFF = 0.D0 CDIAG = 0.D0 SDIAG = 0.D0 C------------------------------------------------------------------- C THE FOLLOWING IS USED TO DETERMINE THE MAXIMUM PERTURBATION C CORRECTIONS TO THE UNPERTURBED WAVEFUNCTIONS. SINCE THE STEP C SIZE FOR SUBSEQUENT ENERGIES HAS ALREADY BEEN STORED ON DISK C THIS INFORMATION IS NOT NECESSARY FOR SUBSEQUENT ENERGIES. C------------------------------------------------------------------- IF( .NOT. IPERT .AND. IREAD) GO TO 460 IF(IREAD) GO TO 430 DO 420 I = 1,N A1(I) = 1.D0/SQRT(A1P(I)*A1P(I)/ABS(DIAG(I))+A1(I)*A1(I)) B1(I) = 1.D0/SQRT(B1P(I)*B1P(I)/ABS(DIAG(I))+B1(I)*B1(I)) A1P(I) = DRNOW*A1(I)/XK(I) B1P(I) = DRNOW*B1(I)/XK(I) SINE(I) = 1.D0 IF(DIAG(I) .GT. 0.D0) GO TO 420 EXPX = EXP(-XK(I)*DINT/DRNOW) IF(DIAG(I).LT.-XSQMAX)EXPX=0.D0 SINE(I) = EXPX A1(I) = A1(I)*EXPX B1(I) = B1(I)*EXPX A1P(I) = A1P(I)*EXPX B1P(I) = B1P(I)*EXPX 420 CONTINUE 430 IJ = 0 C------------------------------------------------------------------- C CALCULATE THE PERTURBATION CORRECTIONS TO THE WAVEFUNCTION AND C ITS DERIVATIVE. C------------------------------------------------------------------- DO 450 J = 1,N A1J = A1(J) A1PJ = A1P(J) DO 450 I = 1,N JI = J+(I-1)*N IJ = IJ+1 PRT1 = G1(J)*EYE12(IJ)-G2(J)*EYE11(IJ) PRT2 = G1(I)*EYE22(IJ)-G2(I)*EYE12(IJ) PRT1P = G1P(J)*EYE12(IJ)-G2P(J)*EYE11(IJ) PRT2P = G1P(I)*EYE22(IJ)-G2P(I)*EYE12(IJ) C------------------------------------------------------------------- C DON'T DETERMINE THE MAXIMUM PERTURBATION CORRECTION FOR C SUBSEQUENT ENERGIES. C------------------------------------------------------------------- IF(IREAD) GO TO 440 B1I = B1(I) B1PI = B1P(I) E1 = ABS(PRT1)*A1J E2 = ABS(PRT2)*B1I E3 = ABS(PRT1P)*A1PJ E4 = ABS(PRT2P)*B1PI IF(I .NE. J) COFF = MAX(COFF,E1,E2,E3,E4) IF(I .EQ. J) CDIAG = MAX(CDIAG,E1,E2,E3,E4) IF(J .GT. I) GO TO 440 CCIJ = W0(IJ) CCJI = W0(JI) CSIJ = W1(IJ) CSJI = W1(JI) SSIJ = W2(IJ) SSJI = W2(JI) E1 = ABS(SINX(J)*CSJI-COSX(J)*SSIJ)*SINE(J)*XK(J)/DRNOW E2 = ABS(SINX(I)*CCIJ-COSX(I)*CSJI)*SINE(I) E3 = ABS(COSX(J)*CSJI+DIAG(J)*SINX(J)*SSIJ)*SINE(J) E4 = ABS(COSX(I)*CCIJ+DIAG(I)*SINX(I)*CSJI)*SINE(I)*DRNOW/XK(I) E5 = ABS(SINX(I)*CSIJ-COSX(I)*SSJI)*SINE(I)*XK(I)/DRNOW E6 = ABS(SINX(J)*CCJI-COSX(J)*CSIJ)*SINE(J) E7 = ABS(COSX(I)*CSIJ+DIAG(I)*SINX(I)*SSJI)*SINE(I) E8 = ABS(COSX(J)*CCJI+DIAG(J)*SINX(J)*CSIJ)*SINE(J)*DRNOW/XK(J) IF(I .NE. J) SOFF = MAX(SOFF,E1,E2,E3,E4,E5,E6,E7,E8) IF(I .EQ. J) SDIAG = MAX(SDIAG,E1,E2,E3,E4,E5,E6,E7,E8) 440 W2(IJ) = PRT1 W(JI) = PRT2 W0(IJ) = PRT1P 450 W1(JI) = PRT2P IF(SOFF.EQ.0.D0) SOFF=1.D-30 IF(IPERT) GO TO 480 460 DO 470 I = 1,NSQ W2(I) = 0.D0 W0(I) = 0.D0 W(I) = 0.D0 470 W1(I) = 0.D0 480 IF(LAST) GO TO 500 IF(IALPHA.LE.0) GO TO 485 IF((ISTEP/IALPHA)*IALPHA.EQ.ISTEP) GO TO 500 GO TO 590 C------------------------------------------------------------------- C ARRIVE HERE ONLY FOR IALPHA.EQ.0 OPTION. C START NEW INTERVAL IF PREDICTED G2P FOR NEXT STEP IS TOO LARGE C------------------------------------------------------------------- 485 IF(.NOT.IREAD .AND. ABS(G2PMAX).GT.1.D04) GO TO 500 IF(COFFL .EQ. 0.D0) GO TO 490 FACC = COFF/COFFL FACS = SOFF/SOFF1 IF(FACC .GT. 2.D0) FACC = 2.D0 IF(FACS .GT. 2.D0) FACS = 2.D0 IF(FACC*COFF .GT. 0.8D0*TOFF) GO TO 500 IF(FACS*SOFF .GT. 0.8D0*TLDIAG) GO TO 500 490 COFFL = COFF SOFF1 = SOFF SDIAG1 = SDIAG COFFL = COFF IF(IREAD .AND. NEWINT) GO TO 500 C------------------------------------------------------------------- C CHECK TO SEE IF THE PERTURBATION CORRECTIONS ARE LARGE ENOUGH C TO WARRANT A NEW INTERVAL AND BASIS SET TRANSFORMATION. C------------------------------------------------------------------- IF(COFF .LT. 0.8D0*TOFF .AND. CDIAG .LT. 0.8D0*TOFF) GO TO 590 500 COFFL = 0.D0 SOFF1 = SOFF SDIAG1 = SDIAG ICRMAT = .TRUE. IF( .NOT. ITHS) GO TO 510 IF( .NOT. IEYE) GO TO 510 WRITE(6,2900) LEYE11 WRITE(6,2800) (EYE11(I),I = 1,NSQ) WRITE(6,2900) LEYE12 WRITE(6,2800) (EYE12(I),I = 1,NSQ) WRITE(6,2900) LEYE22 WRITE(6,2800) (EYE22(I),I = 1,NSQ) C------------------------------------------------------------------- C MULTIPLY THE OLD R-MATRIX TIMES IRREGULAR WAVEFUNCTION AND ITS C PERTURBATION CORRECTION. C------------------------------------------------------------------- 510 NP1 = N+1 II = 1 DO 520 I = 1,N W0(II) = W0(II)+G1P(I) W1(II) = W1(II)+G2P(I) W2(II) = W2(II)+G1(I) W(II) = W(II)+G2(I) 520 II = II+NP1 CALL DCOPY(NSQ,W0,1,TSTORE,1) CALL DSYMM('L','L',N,N,1.D0,RMAT,N,W1,N,1.D0,TSTORE,N) CALL DCOPY(NSQ,W2,1,VECOLD,1) CALL DSYMM('L','L',N,N,1.D0,RMAT,N,W ,N,1.D0,VECOLD,N) IF( .NOT. ITHS) GO TO 550 IF( .NOT. IGZRO) GO TO 540 WRITE(6,2900) LG1 WRITE(6,2800) (G1(I),I = 1,N) WRITE(6,2900) LG1P WRITE(6,2800) (G1P(I),I = 1,N) WRITE(6,2900) LG2 WRITE(6,2800) (G2(I),I = 1,N) WRITE(6,2900) LG2P WRITE(6,2800) (G2P(I),I = 1,N) 540 IF( .NOT. IGPERT) GO TO 550 WRITE(6,2900) LDG1 WRITE(6,2800) (W2(I),I = 1,NSQ) WRITE(6,2900) LDG1P WRITE(6,2800) (W0(I),I = 1,NSQ) WRITE(6,2900) LDG2 WRITE(6,2800) (W(I),I = 1,NSQ) WRITE(6,2900) LDG2P WRITE(6,2800) (W1(I),I = 1,NSQ) 550 IF( .NOT. ITHS) GO TO 560 IF( .NOT. IWAVE) GO TO 560 WRITE(6,2900) LUD WRITE(6,2800) (EYE12(I),I = 1,NSQ) WRITE(6,2900) LUDP WRITE(6,2800) (EYE11(I),I = 1,NSQ) 560 IER = 0 C------------------------------------------------------------------- C SOLVE A LINEAR SYSTEM OF EQUATIONS TO DETERMINE THE NEW R-MATRIX C------------------------------------------------------------------- CALL DGESV(N,N,TSTORE,N,WKS,VECOLD,N,IER) C------------------------------------------------------------------- C REINITIALIZE FOR THE NEXT INTERVAL. STORE THE NEW R-MATRIX IN RMAT. C------------------------------------------------------------------- DO 570 I = 1,N G1(I) = 0.D0 G2(I) = 1.D0 G1P(I) = 1.D0 G2P(I) = 0.D0 DO 570 J = 1,N IJ = I+(J-1)*N JI = J+(I-1)*N RMAT(JI) = VECOLD(IJ) IF(ISYM) RMAT(JI) = 0.5D0*(VECOLD(IJ)+VECOLD(JI)) EYE11(IJ) = 0.D0 EYE12(IJ) = 0.D0 570 EYE22(IJ) = 0.D0 NTRVL = NTRVL+1 IF( .NOT. ITHS) GO TO 580 IF( .NOT. IRMAT) GO TO 580 WRITE(6,2900) LRMAT WRITE(6,2800) (RMAT(I),I = 1,NSQ) GO TO 590 580 CONTINUE 590 CONTINUE IF( .NOT. IWRITE) GO TO 600 NEWINT=ICRMAT WRITE(ISC) NEWINT C------------------------------------------------------------------- C WRITE THE MINIMAL STEP INFORMATION AND DETERMINE THE NEW STEP SIZE C AND PREDICT THE NEW INTERVAL SIZE. C------------------------------------------------------------------- 600 IF(PRNTLV.GE.15) WRITE(6,2700) ITRANS,RMIDI,DRNOW,RLAST,RNOW, X DIAG(1),DIAG(N),CDIAG,COFF,SDIAG,SOFF,ALPHA,NOPLOC,ISTEP IF( .NOT. LAST) ISTEP = ISTEP+1 IF(LAST) GO TO 670 IF(IREAD) GO TO 155 XBAR = XBAR+RNOW XSBAR = XSBAR+RNOW*RNOW EBAR = EBAR+SDIAG EXBAR = EXBAR+RNOW*SDIAG TMXX = 0.5D0*TOFF IF(TLDIAG .GT. TMXX) TMXX = TLDIAG IF(DINT.NE.DRNOW) SOFF = 0.8D0*TLDIAG*(SOFF/(0.8D0*TMXX))**1.5D0 IF(IALPHA .GT. 0) DRNOW = DRNOW*ALPHA IF(IALPHA. LE. 0) CALL DELRD(DRNOW,SDIAG,SOFF,TLDIAG,DRMAX, 1 DIAG(1),DIAG(N),RNOW,RMAX) IF( .NOT. ICRMAT) GO TO 650 DINT = RNOW-RMID DINT1 = DINT IF(IALPHA.LE.0) GO TO 630 XBAR = XBAR/IALPHA XSBAR = XSBAR/IALPHA EBAR = EBAR/IALPHA EXBAR = EXBAR/IALPHA IF(IALPHA.EQ.1) SLOPE=0.D0 IF(IALPHA.NE.1) SLOPE = (EXBAR-XBAR*EBAR)/(XSBAR-XBAR*XBAR) BINT = EBAR-XBAR*SLOPE EMAX = BINT+SLOPE*RNOW EMIN = BINT+SLOPE*(RNOW-DINT) ALFNEW = ALPHA IF(IALPHA .LE. 1) GO TO 630 IF(EMAX.EQ.0.D0) EMAX=1.D-30 FAC = EMIN/EMAX IF(FAC .LE. 0.D0) GO TO 620 FAC = (FAC)**(1.D0/DBLE(3*IALPHA-3)) IF(FAC .GT. 1.1D0) FAC = 1.1D0 IF(FAC .LT. 0.9D0) FAC = 0.9D0 ALFNEW = ALPHA*FAC GO TO 630 620 FAC = 1.1D0 IF(EMIN .LE. 0.D0) FAC = 0.9D0 ALFNEW = ALPHA*FAC 630 XBAR = 0.D0 XSBAR = 0.D0 EBAR = 0.D0 EXBAR = 0.D0 TMXX = TOFF IF(TLDIAG .GT. TOFF) TMXX = TLDIAG IF(DINT.NE.DRNOW) COFF = 0.8D0*TMXX*(COFF/(0.8D0*TMXX))**1.5D0 CALL DELRD(DINT,CDIAG,COFF,TMXX,DRMAX,DIAG(1),DIAG(N),RNOW,RMAX) IF(DINT1.NE.DRNOW) SOFF1 = TLDIAG*(2.D0*SOFF1/TLDIAG)**1.5D0 CALL DELRD(DINT1,SDIAG1,SOFF1,TLDIAG,DRMAX,DIAG(1),DIAG(N),RNOW, 1 RMAX) IF(ABS(DINT1) .LT. ABS(DINT)) DINT = DINT1 IF(DINT .LT. DRNOW) DINT = DRNOW IF(ABS(RMAX-RNOW-DINT) .LT. ABS(0.01D0*DINT)) DINT = RMAX-RNOW IF((RMAX-RNOW-DINT)*DINT .LT. 0.D0) DINT = RMAX-RNOW RMID = RNOW DIAGI = RNOW+0.5D0*DINT IF(IALPHA .LE. 0) GO TO 650 ALPHA = ALPHA1+BALPHA*(DIAGI-RMIN) IF(IALFP) ALPHA = ALFNEW IF(ALPHA .NE. 1.D0) GO TO 640 DRNOW = DINT/IALPHA GO TO 650 640 DRNOW = DINT*(ALPHA-1.D0)/(ALPHA**IALPHA-1.D0) 650 IF(ABS(RMAX-RNOW-DRNOW) .LT. ABS(0.01D0*DRNOW)) 1 DRNOW = RMAX-RNOW IF((RMAX-RNOW-DRNOW)*DRNOW .LT. 0.D0) DRNOW = RMAX-RNOW RLAST = RNOW RNOW = RNOW+DRNOW DEL = (RNOW-RMAX)/DRNOW IF(ABS(DEL) .LT. 0.005D0) LAST = .TRUE. GO TO 160 C------------------------------------------------------------------- C THE INTEGRATION IS NOW COMPLETE. TRANSFORM THE R-MATRIX INTO THE C ORIGINAL BASIS. C------------------------------------------------------------------- 670 NCOL = 1 NLAST = N DO 690 IR = 1,N NORIG = IR DO 680 NTRANS = NCOL,NLAST VECOLD(NTRANS) = VECNEW(NORIG) 680 NORIG = NORIG+N NLAST = NLAST+N 690 NCOL = NCOL+N CALL TRNSFM(VECOLD,RMAT,TSTORE,N,IFALSE,ISYM) IF(PRNTLV.GE.3) WRITE(6,3000) RMIN,RMAX,ISTEP IF (PRNTLV.LE.3 .AND. NSGERR.GT.0) WRITE(6,1802) NSGERR RETURN C------------------------------------------------------------------- C FORMAT STATEMENTS C------------------------------------------------------------------- 1200 FORMAT(1H0, 98H IVECT IPOTL IEYE IGZRO IGPERT IWAVE IRMAT IWRITE XIREAD IOC ) 1300 FORMAT(1H , 9L6,I4) 1400 FORMAT(1H0, 43H IV IVP IVPP ISHIFT IDIAG ISYM IPERT IALFP ) 1500 FORMAT(1H ,L3,L4,L5,L7,L6,L5,4L6) 1600 FORMAT(1H0,21H ALPHA1 ALPHA2 IALPHA/1X,2F7.2,I7) 1700 FORMAT('0 *** ERROR IN VIVAS. FOR CHANNEL',I3,', REDUCED V-E =', 1 E13.5/6X,'FOR STEP SIZE',E13.5,', COSH ARGUMENT OF',E13.5, 2 ' WILL CAUSE OVERFLOW.'/6X,'USE A SMALLER STEP SIZE TO AVOID', 3 ' THIS ERROR.') 1800 FORMAT('0 *** WARNING IN VIVAS. INTERVAL SIZE TOO LARGE, SO', 1 ' CLOSED CHANNEL GROWTH MAY CAUSE NUMERICAL INSTABILITY.'/ 2 24X,'RNOW =',F8.3,', DRNOW =',F8.3,', G2P(N) =',E13.5) 1802 FORMAT('0 *** WARNING IN VIVAS. INTERVAL SIZE POSSIBLY TOO', 1 ' LARGE FOR',I5,' STEPS. INCREASE PRNTLV FOR DETAILS') 2500 FORMAT(79H0 RMIN RMAX DRNOW DRMAX TOFF TLD XIAG ) 2600 FORMAT(F9.5,10F10.5,I10) 2700 FORMAT(1H ,I5,10E11.4,F6.3,2I5) 2800 FORMAT(1H ,9D14.7) 2900 FORMAT(1H0,A10) 3000 FORMAT('0 VIVAS. R-MATRIX INTEGRATED FROM',F12.4,' TO', & F12.4,' IN',I6,' STEPS.') 3100 FORMAT(132H0NTRVL RCENT DRNOW RLAST RNOW DI XAG(1) DIAG(N) CDIAG COFF SDIAG SOFF ALF XP NOPN ISTP ) C----------------***END-VIVAS***------------------------------------- END SUBROUTINE VRTP(IDERIV,R,P) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P(1) C C ***************************************************************** C * IF POTENTIAL IS --NOT-- EXPANDED IN ANGULAR FUNCTIONS, I.E., * C * MXSYM.LE.0, THIS ROUTINE MUST SUPPLY THE POTENTIAL AND * C * ITS 1ST AND 2ND DERIVATIVE (IDERIV=0,1,2, RESPECTIVELY). * C * EVALUATE POTENTIAL AT ANGLES SPECIFIED IN COMMON /ANGLES/ * C * ITYPE=1: COSANG(1) IS THETA * C * ITYPE=2: COSANG(1) IS THETA, COSANG(2) IS VIB COORD * C * ITYPE=3: COSANG(1),COSANG(2) ARE THETA'S, COSANG(3) IS PHI * C * SINCE IHOMO/ICNSYM CANNOT BE DETERMINED BY IOSBGP WITHOUT * C * ANGULAR TERMS, THEY MAY BE READ IN &POTL OR SET HERE IN * C * /ANGLES/. VALUES SET HERE OVERRIDE &POTL INPUT. * C * IF NOT SET, DEFAULT VALUES WILL BE IHOMO=ICNSYM=1 * C * POTENTIAL, RETURNED IN P(1), MUST BE MULTIPLIED BY 'FACTOR' * C * (SET IN IOSBIN AND PASSED IN /ANGLES/) TO COUNTER LOWEST * C * ANGULAR FUNCTION (ITYPE DEPENDENT) WHICH MULTIPLIES IT. * C * INITIALIZATION CALL (IDERIV.LT.0) MAY SET AND/OR USE * C * RM=R AND EPSIL=P(1) * C ***************************************************************** C COMMON /ANGLES/COSANG(7),FACTOR,IHOMO,ICNSYM,IHOMO2,ICNSY2 C C C *** ROUTINE BELOW IS FROM A TEST CASE (MOLTEST6) TO GIVE AN EXAMPLE. C IT CORRESPONDS TO THE FOLLOWING NAMELIST DATA SET C &POTL MXSYM=9, NTERM=2,8*1, NPOWER=0,-6, 8*0, E=9*-12., C LAMBDA=0,0, 1,0, 2,0, 2,2, 3,0, 3,2, 4,0, 4,2, 4,4, C A=162754.8, -2., -29296., 1367., 26041., 19531., -26041., C -9756., 8138., 6510., C RM=2.9, EPSIL=130., C &END C DIMENSION A(9),PL(9),L(9),M(9) DATA A/162754.8D0,-29296.D0,1367.D0,26041.D0,19531.D0,-26041.D0, & -9756.D0,8138.D0,6510.D0/ DATA L/0,1,2*2,2*3,3*4/,M/3*0,2,0,2,0,2,4/ C IF (IDERIV.LT.0) THEN ICNSYM=2 C IHOMO=1 WRITE(6,*) ' THIS IS A MOCK H2O-HE POTENTIAL FOR TESTING PURPOSE' WRITE(6,*) ' YOU MUST SUPPLY AN APPROPRIATE VRTP ROUTINE ' WRITE(6,600) (L(I),M(I),A(I),I=1,9) 600 FORMAT(' *** INITIALIZATION OF VRTP ***'/' L M A'/ 1 (2I5,F12.3)) R=2.9 P(1)=130. RETURN ENDIF IF (IDERIV.GT.2) STOP C DO 1000 J=1,9 PL(J)=PLM(L(J),M(J),COSANG(1)) * 0.398942280D0 C P(L,M) / SQRT(2*PI) IF (M(J).EQ.0) GO TO 1000 PL(J)=2.D0*PL(J)*COS(M(J)*COSANG(2)) 1000 CONTINUE IF(IDERIV-1) 2001,2002,2003 2001 B=1.D0 C=-2.D0 GO TO 3000 2002 B=-12.D0 C=12.D0/R GO TO 3000 2003 B=144.D0 C=-84.D0/(R*R) 3000 EX=EXP(-12.D0*R) R6=1.D0/(R*R*R) R6=R6*R6 P(1)=0.D0 DO 4000 J=1,9 4000 P(1)=P(1)+B*EX*PL(J)*A(J) P(1)=(P(1)+C*R6*PL(1))*FACTOR RETURN END SUBROUTINE WAVEIG (W, EIGNOW, SCR1, SCR2, RNOW, NCH, 1 P,MXLAM,VL,IV,RMLMDA,ERED,EINT,CENT,NPOTL) * THIS SUBROUTINE FIRST SETS UP THE WAVEVECTOR MATRIX AT RNOW * THEN OBTAINS ITS EIGENVALUES * WRITTEN BY: MILLARD ALEXANDER * CURRENT REVISION DATE: 25-SEPT-87 * ---------------------------------------------------------------- * VARIABLES IN CALL LIST: * W: MATRIX OF MAXIMUM ROW DIMENSION NCH USED TO STORE * WAVEVECTOR MATRIX * EIGNOW: ON RETURN: ARRAY CONTAINING EIGENVALUES OF WAVEVECTOR M * SCR1, SCR2: SCRATCH VECTORS OF DIMENSION AT LEAST NCH * RNOW: VALUE OF INTERPARTICLE SEPARATION AT WHICH WAVEVECTOR MA * IS TO BE EVALUATED * NCH: NUMBER OF CHANNELS * SUBROUTINES CALLED: * WAVMAT: DETERMINES WAVEVECTOR MATRIX * F02AAF: NAG ROUTINE TO OBTAIN EIGENVALUES OF REAL, * SYMMETRIC MATRIX * DSCAL, DCOPY: LINPACK BLAS ROUTINES * ---------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER IERR, NCH, NCHM1, NCHP1 EXTERNAL DSCAL, DCOPY, WAVMAT, F02AAF * SQUARE MATRIX (OF ROW DIMENSION NCH) DIMENSION W(1) * VECTORS DIMENSIONED AT LEAST NCH DIMENSION EIGNOW(1), SCR1(1), SCR2(1),P(1),VL(1),IV(1),EINT(1) DIMENSION CENT(1) * ------------------------------------------------------------------ DATA XMIN1 / -1.D0/ NCHP1 = NCH + 1 NCHM1 = NCH - 1 CALL WAVMAT (W, NCH, RNOW, P, VL, IV, ERED, EINT, CENT, RMLMDA, 1 SCR1, MXLAM, NPOTL) C * SINCE WAVMAT RETURNS NEGATIVE OF LOWER TRIANGLE OF W(R) MATRIX (EQ.(3 * M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."), * NEXT LINE CHANGES ITS SIGN CALL DSCAL(NCH*NCH, XMIN1, W, 1) C IERR=0 CALL F02AAF(W, NCH, NCH, EIGNOW, SCR1, IERR) IF (IERR .NE. 0) THEN WRITE (6, 120) IERR 120 FORMAT(' *** F02AAF IERR =', I3, ' .NE. 0 IN WAVEIG; ABORT ***') STOP ENDIF C RETURN END SUBROUTINE WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C EVALUATES THE MATRIX W OF WAVE-VECTORS AT RADIUS R C W = VCOUPL + EINT + VCENT - ETOT C ORDER OF THE REAL SYMMETRIC MATRIX W IS N C THE FULL MATRIX IS COMPUTED C VL IS THE PREVIOUSLY COMPUTED MATRIX OF THE COUPLING POTENTIAL C IV IS AN INDEX ARRAY MAPPING P ONTO VL, SUCH THAT VL(I) IS C A COEFFICIENT TO MULTIPLY P(IV(I)) C ERED IS THE TOTAL ENERGY ETOT IN REDUCED UNITS C (ETOT/EPSILON)*(2.*URED*EPSIL*RM**2/HBAR**2) C EINT(I) IS THE REDUCED INTERNAL ENERGY OF THE I-TH CHANNEL C CENT(I) IS L*(L+1) FOR THE I-TH CHANNEL C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO THE DEBROGLIE C WAVELENGTH AT RELATIVE ENERGY EPSILON C RMLMDA = 2.*URED*RM**2*EPSIL/HBAR**2 C RMLMDA MULTIPLIES THE POTENTIAL IN UNITS OF EPSIL C DIMENSION W(N,N),VL(1),IV(1),EINT(N),CENT(N),P(MXLAM),DIAG(N) COMMON/MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C RSQ=1.D0/(R*R) IF(IVLFL.LT.0) THEN NPOT=NPOTL-2 P(NPOT+1)=RSQ P(NPOT+2)=1.D0 ELSE NPOT=NPOTL ENDIF C C COMPUTE THE RADIAL PARTS OF THE POTENTIAL C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE. CALL POTENL(0,MXLAM,NPOT,IDUM1,R,P,IDUM2) C CALL PERTRB(R,P,MXLAM,0) C DO 15 I=1,MXLAM 15 P(I)=RMLMDA*P(I) C CALL WAVVEC(VL,P,IV,W,N,NPOTL) C C NOW COMPUTE THE DIAGONAL CONTRIBUTIONS W(I,I). C DO 18 I=1,N W(I,I) = W(I,I) - ERED DIAG(I) = W(I,I) 18 CONTINUE C IF(IVLFL.LT.0) RETURN C DO 20 I=1,N W(I,I) = W(I,I) + EINT(I) + RSQ*CENT(I) DIAG(I) = W(I,I) 20 CONTINUE RETURN END SUBROUTINE WAVVEC(VL,P,IV,W,N,NPOTL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION VL(1),P(1),IV(1),W(N,N) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C COMMON/VLSAVE/IVLU C IF(IVLFL.GT.0) GOTO 10 C C REACH HERE ONLY FOR IVLFL=0: NO IV ARRAY FOR INDEXING C IF(IVLU.EQ.0) THEN I=1 DO 1 J=1,N CALL DGEMV('T',NPOTL,J,1.D0,VL(I),NPOTL,P,1,0.D0,W(1,J),1) 1 I=I+J*NPOTL ELSE REWIND IVLU ISV=IXNEXT IXNEXT=ISV+N*(N+1)/2 NUSED=1 CALL CHKSTR(NUSED) DO 2 J=1,N DO 2 K=1,J 2 W(K,J)=0.D0 DO 5 LL=1,NPOTL READ(IVLU) (X(ISV+I),I=0,N*(N+1)/2-1) I=1 DO 4 J=1,N CALL DAXPY(J,P(LL),X(ISV+I-1),1,W(1,J),1) 4 I=I+J 5 CONTINUE IXNEXT=ISV ENDIF C C FILL IN LOWER TRIANGLE C CALL DSYFIL('L',N,W,N) RETURN C C ARRIVE HERE FOR NON-TRIVIAL USE OF THE IV ARRAY C 10 IF(IVLU.NE.0) THEN WRITE(6,601) 601 FORMAT(' *** ERROR IN WAVVEC. IVLU =',I2,' AND IVLFL =',I2/ 1 ' USE OF THE IV ARRAY IS NOT SUPPORTED FOR IVLU > 0.') STOP ENDIF C I2=0 DO 12 J=1,N DO 12 K=1,J I1=I2+1 I2=I2+NPOTL WW=0.D0 DO 11 I=I1,I2 IF(VL(I).NE.0.D0) WW=WW+VL(I)*P(IV(I)) 11 CONTINUE W(J,K)=WW W(K,J)=WW 12 CONTINUE C RETURN END SUBROUTINE WKB(N,MXLAM,NPOTL,W,SREAL,SIMAG,P,L,EINT,CENT, 1 DIAG,NBASIS,WVEC,VL,IV,NUMDER,IPRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C THIS ROUTINE GETS PHASE SHIFT (S-MATRIX) FOR 1-DIMENSIONAL C SCATTERING EQUATION VIA THE WKB APPROXIMATION USING GAUSS-MEHLER C NUMERICAL INTEGRATION AS SUGGESTED BY R.T PACK, J. CHEM. PHYS. C 60, 633 (1974). C C THIS ROUTINE IS COMPATIBLE WITH MOLSCAT/IOS CODE C WRITTEN OCT 1977 BY S. GREEN (GISS), MODIFIED APR 1986 FOR CCP6. C MODIFIED JUL 86 WITH MORE SOPHISTICATED START (FIND TURNING PT.) C>>SG MODIFIED SOME OUTPUT FORMATS 5/13/92 C C VARIABLES FOR MOLSCAT COMPATIBILITY . . . LOGICAL NUMDER DIMENSION W(2),SIMAG(2),SREAL(2),P(2),L(2),EINT(2),CENT(2), 1 DIAG(2),NBASIS(2),WVEC(2),VL(2),IV(2) C C C THE NUMBER OF GAUSS POINTS IS INCREASED CHECKING FOR CONVERGENCE C PARAMETERS TO CONTROL GAUSS-MEHLER CONVERGENCE ITERATION. . . COMMON /WKBCOM/ NGMP(3) C C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS C COMMON/DRIVE/DTOL,STEPS,STABIL,CONV,RMIN,RSTOP,XEPS, 1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, 2 NOPEN,JKEEP,ISCRU,MAXSTP C C TOLERANCES FOR NEWTON-RAPHSON SEARCH FOR R0 . . . DATA EPS/5.D-5/ , ITMX/24/ DATA IDER/1/ C C MODIFY CENTRIFUGAL POTENTIAL (CENT) VIA 'LANGER' CORRECTION PI=ACOS(-1.D0) DCENT=DBLE(L(1))+.5D0 DCENT=DCENT*DCENT CSAVE=CENT(1) CENT(1)=DCENT C INITIALIZE OTHER VARIABLES PI2=2.D0*PI C C FIND TURNING POINT VIA NEWTON-RAPHSON METHOD. START WITH RMIN C IT=0 ECNV=EPS*ERED RCNV=EPS*RMIN R=RMIN C IF POTENTIAL IS NOT DECREASING, TRY BACKING UP . . . 1198 CALL DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) IF (W(1).LE.0.D0) GO TO 1000 IF (IPRINT.GT.3) WRITE(6,699) IT,R,W(1) 699 FORMAT('0* * * WKB BAD START. TRY 7/86 FIX. ITER, R, DV/DR =', 1 I4,2F15.5) R=0.9D0*R IT=IT+1 IF (IT.LE.ITMX) GO TO 1198 WRITE(6,697) ITMX 697 FORMAT('0 * * * ERROR (7/86). WKB CANNOT START. ITMX =',I4) STOP 1000 CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) V=W(1) CALL DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) DVDR=W(1) DR=-V/DVDR C TO PREVENT OCCASIONAL ERRATIC BEHAVIOR ALLOW ONLY 25% CHANGE IN R DRMAX=2.5D-1*ABS(R) IF (ABS(DR).LE.DRMAX) GO TO 1199 IF (DR.LT.0.D0) DRMAX=-DRMAX IF (IPRINT.GT.3) WRITE(6,698) IT,R,DR,DRMAX 698 FORMAT(' * * WKB. 7/86 FIX. ITER, R, DR, DRMAX =',I4,3F15.5) DR=DRMAX 1199 IF (ABS(DR).LE.RCNV.OR.ABS(V).LE.ECNV) GO TO 1009 IT=IT+1 R=R+DR IF (IT.LE.ITMX) GO TO 1000 IF (IPRINT.GT.3) WRITE(6,694) IT,R,DR,V,DVDR 694 FORMAT(' WKB: NEWTON-RAPHSON START FAILED TO CONVERGE. IT =',I4 & /16X,'R,DR,V,DVDR=',4D12.4) C C TRY A REGULA-FALSI METHOD. 1ST, UNDO LAST R CHANGE, RESET IT. R=R-DR IT=0 XL=R YL=V C STEP IN DIRECTION OF OPPOSITE SIGN FOR POTENTIAL. IF (V*DVDR*DR.LT.0) GO TO 1201 DR=-DR 1201 RSV=R DO 1202 ITX=1,5 R=R+DR CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) V=W(1) IF (V*YL.LT.0.D0) GO TO 1205 1202 CONTINUE DR=-DR R=RSV DO 1203 ITX=1,5 R=R+DR CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) V=W(1) IF (V*YL.LT.0.D0) GO TO 1205 1203 CONTINUE WRITE(6,620) 620 FORMAT('0 WKB. * * * CRASH IN REGULA-FALSI. GIVING UP.') STOP 1205 XR=R YR=V 1210 SLOPE=(YR-YL)/(XR-XL) XINT=YL-SLOPE*XL XNEW=-XINT/SLOPE CALL WAVMAT(W,N,XNEW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM, 1 NPOTL) YNEW=W(1) IT=IT+1 IF (ABS(YNEW).GT.ECNV) GO TO 1211 1215 DR=XR-XL IF (IPRINT.GT.3) WRITE(6,621) IT,XNEW,DR,YNEW 621 FORMAT(' WKB: REGULA-FALSI CONVERGED. IT,R,DR,V =',I4,3F10.4) R=XNEW GO TO 1009 1211 IF (YNEW*YR.GT.0.D0) GO TO 1212 IF (YNEW*YL.GT.0.D0) GO TO 1213 WRITE(6,622) XL,XNEW,XR,YL,YNEW,YR 622 FORMAT('0 WKB. IMPOSSIBLE X(L,NEW,R) AND Y(L,NEW,R)=',6D12.4) STOP 1212 YR=YNEW XR=XNEW GO TO 1220 1213 YL=YNEW XL=XNEW 1220 IF (ABS(XR-XL).LE.RCNV) GO TO 1215 C ALLOW FOR TWICE AS MANY ITERATIONS AS NEWTON-RAPHSON. IF (IT.LT.2*ITMX) GO TO 1210 WRITE(6,623) IT,XL,XNEW,XR,YL,YNEW,YR 623 FORMAT(' WKB: REGULA-FALSI START FAILED TO CONVERGE. IT=',I4/ 1 16X, 'X(L,NEW,R) AND Y(L,NEW,R)=',6D12.4) C STOP C C GET WKB PHASE SHIFT BY PACK'S GAUSS-MEHLER QUADRATURE C C FORCE NGMP TO REASONABLE VALUES IF NECESSARY. 1009 NSTART=MAX0(NGMP(1),3) NADD=MAX0(NGMP(2),1) NHI=MAX0(NGMP(3),NSTART+3*NADD) RMIN=R DR0=R DWVEC=WVEC(1) XKR=DWVEC*DR0 DO 2000 NPOINT=NSTART,NHI,NADD NPSV=NPOINT X2NP1=DBLE(2*NPOINT+1) SUM=0.D0 XJ=0.D0 DO 2100 J=1,NPOINT XJ=XJ+1.D0 X=COS(XJ*PI/X2NP1) X2=X*X WT=(1.D0-X2)*PI/X2NP1 XCOMP=SQRT(1.D0-X2) R=DR0/X CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) C WAVMAT GIVES NEGATIVE OF WHAT WE WANT W(1)=-W(1) C GUARD AGAINST SQAURE ROOTS OF NEGATIVE DW IF (W(1).GE.0.D0) GO TO 2109 C JUDGE AS ROUND-OFF ERROR IF ABS(W) LE. 0.001*ERED IF (ABS(W(1)).LE.1.D-3*ERED) GO TO 2108 WRITE(6,696) R,W(1) 696 FORMAT(' * * * ERROR. WKB IN CLASSICALLY FORBIDDEN REGION. R, W & =',2E16.6) 2108 W(1)=0.D0 2109 DW=W(1) F=(SQRT(DW)/(DWVEC*XCOMP)-1.D0)/X2 2100 SUM=SUM+WT*F ETA=XKR*SUM+(SQRT(DCENT)-XKR)*PI*.5D0 IF (NPOINT.GT.NSTART) GO TO 2200 C ON FIRST ITERATION, GET SET FOR CONVERGENCE TEST. C SUBTRACT OUT AN INTEGRAL NUMBER OF 2*PI TO NORMALIZE NPI=ETA/PI2 IF (ETA.LT.0.D0) NPI=NPI-1 PIMIN=DBLE(NPI)*PI2 ETA=ETA-PIMIN ETAOLD=ETA GO TO 2000 C TEST FOR CONVERGENCE 2200 ETA=ETA-PIMIN X2=ABS(ETA-ETAOLD) IF (X2.LE.DTOL) GO TO 2900 X=ETAOLD ETAOLD=ETA 2000 CONTINUE C NOT CONVERGED IF THIS POINT IS REACHED. . . NPOINT=NPSV NM1=NPOINT-NADD WRITE(6,695) NPI,DTOL, NM1,X, NPOINT,ETA 695 FORMAT('0 * * * WARNING. NO CONVERGENCE OF GAUSS-MEHLER INTEGRATI &ON. NPI =',I4,' STEST =',D12.4/ A (15X,'FOR',I4,' GAUSS POINTS, ETA-NPI*(2*PI) =',F12.7) ) C SET CONVERGENCE FLAG, IF CONVERGENCE IS REALLY POOR IF (X2.GT.5.D0*DTOL) CONV=-1.D0 2900 IF (IPRINT.GE.3) WRITE(6,612) NPSV,X2,DR0,NPI,ETA 612 FORMAT('0 * * * NOTE. WKB PHASE SHIFT BY',I4,'-POINT QUAD, TOL =' & ,D12.4,', R0 =',F8.4,', ETA IS',I5,'*(2*PI) +',F9.5) C C CONVERT PHASE SHIFT TO SREAL, SIMAAG / RESTORE FOR RETURN SREAL(1)=COS(2.D0*ETA) SIMAG(1)=SIN(2.D0*ETA) CENT(1)=CSAVE RETURN C END FUNCTION XNINEJ(IX1,IY1,IZ1,IX2,IY2,IZ2,IX3,IY3,IZ3) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION XJ9J(200) DATA MXDIM/200/ C IVAL=MXDIM CALL J9J(DBLE(IX1),DBLE(IY1), 1 DBLE(IX2),DBLE(IY2),DBLE(IZ2), 2 DBLE(IX3),DBLE(IY3),DBLE(IZ3), 3 IVAL,Z1MIN,XJ9J) IND=1+IZ1-INT(Z1MIN+0.1D0) XNINEJ=0.D0 IF(IND.GE.1 .AND. IND.LE.IVAL) XNINEJ=XJ9J(IND) RETURN END FUNCTION YRR(L1,L2,L,CT1,CT2,DP) C C BISPHERICAL HARMONIC ANGULAR FUNCTIONS FOR TWO DIATOMS C CT1, CT2 ARE COS(THETA-1) AND COS(THETA-2), AND C DP IS DELTA(PHI), I.E., PHI2-PHI1, IN RADIANS C CF. GREEN, JCP 62, 2271 (1975) APPENDIX. C N.B. P(L,M;X) THERE IS (2*PI)**-1/2 NORMALIZED P(L,M;X) C MOLSCAT PLM(L,M,CT) ROUTINE IS NORMALIZED ON CT, AND C PLM(L,0,1.D0)=SQRT((2L+1)/2) . C THUS, MUST MULT EACH PLM BY (2*PI)**-1/2 C C ODD L1+L2+L *NOT* ALLOWED; TRAPPED W/MESSAGE AND STOP C C NEEDS ROUTINES THRJ(XJ1,XJ2,XJ3,XM1,XM2,XM3) C PLM(L,M,COSTH) C PARITY(J) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL ODD DATA PI/3.14159 26535 89793 D0/ ODD(I)=2*(I/2)-I.NE.0 C IF (ODD(L1+L2+L)) GO TO 9999 C XL1=L1 XL2=L2 XL=L C SQRT(4*PI) FROM Y(L,M,THETA=0), 2*PI FOR TWO PLM'S DEN=SQRT(4.D0*PI)*2.D0*PI FACT=((2.D0*XL+1.D0)/DEN)*PARITY(L1+L2) MTOP=MIN(L1,L2) M=0 XM=0.D0 SUM=THRJ(XL1,XL2,XL,0.D0,0.D0,0.D0)*PLM(L1,0,CT1)*PLM(L2,0,CT2) 2000 M=M+1 IF (M.GT.MTOP) GO TO 3000 XM=XM+1.D0 SUM=SUM+2.D0*PARITY(M)*THRJ(XL1,XL2,XL,XM,-XM,0.D0)* 1 PLM(L1,M,CT1)*PLM(L2,M,CT2)*COS(XM*DP) GO TO 2000 3000 YRR=FACT*SUM RETURN 9999 WRITE(6,699) L1,L2,L 699 FORMAT('0 YRR *** ERROR. ODD ARGUMENTS NOT ALLOWED',3I5) STOP END SUBROUTINE YTOK(NB,WVEC,L,N,NOPEN,SJ,SJP,SN,SNP,Y,T,Q,RUP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ROUTINE TO OBTAIN THE K MATRIX FROM THE LOG DERIVATIVE MATRIX C ON ENTRY, Y HOLDS THE LOG DERIVATIVE MATRIX C ON EXIT, Q HOLDS THE K MATRIX C SEE: B.R.JOHNSON, JOURNAL OF COMPUTATIONAL PHYSICS 13, 445 (1973) C DIMENSION NB(N), WVEC(N), L(N), SJ(N), SJP(N), SN(N), SNP(N), 1 Y(1), T(1), Q(1) C IF(NOPEN.EQ.0) RETURN DO 10 I = 1,NOPEN NX = NB(I) DW = WVEC(NX) DARG = DW*RUP CALL RBES(L(NX), DARG, UJ, UJP, UN, UNP) ROOTDW = SQRT(DW) SJ(NX) = UJ/ROOTDW SJP(NX) = UJP*ROOTDW SN(NX) = UN/ROOTDW SNP(NX) = UNP*ROOTDW 10 CONTINUE IF (NOPEN.EQ.N) GO TO 30 NCLOSE = N - NOPEN DO 20 I = 1,NCLOSE J = NOPEN + I NX = NB(J) DW = ABS(WVEC(NX)) DARG = DW*RUP CALL RMSBF(L(NX), DARG, RATIO) SN(NX) = 1.D0 SNP(NX) = RATIO*DW 20 CONTINUE 30 CONTINUE C CALL DSYFIL('U',N,Y,N) C IND = 0 DO 40 J = 1,NOPEN NXJ = NB(J) NXJJ = (NXJ - 1)*N DO 40 I = 1,N IND = IND + 1 INDY = NXJJ + NB(I) T(IND) = Y(INDY)*SJ(NXJ) 40 CONTINUE C IND = - N DO 50 I = 1,NOPEN IND = IND + N + 1 T(IND) = T(IND) - SJP(NB(I)) 50 CONTINUE C IND = 0 DO 60 J = 1,N NXJ = NB(J) NXJJ = (NXJ - 1)*N DO 60 I = 1,N IND = IND + 1 INDY = NXJJ + NB(I) Q(IND) = Y(INDY)*SN(NXJ) 60 CONTINUE C IND = - N DO 70 I = 1,N IND = IND + N + 1 Q(IND) = Q(IND) - SNP(NB(I)) 70 CONTINUE C CALL DGESV(N,NOPEN,Q,N,SJ,T,N,IER) IF (IER.NE.0) GO TO 900 C IND = 0 DO 80 J = 1,NOPEN INDA = (J - 1)*N DO 80 I = 1,NOPEN IND = IND + 1 INDA = INDA + 1 Q(IND) = T(INDA) 80 CONTINUE C C Q NOW HOLDS THE K MATRIX. FORCE SYMMETRY ON IT. C CALL KSYM(Q, NOPEN) RETURN C 900 WRITE (6,901) IER 901 FORMAT('0***** ERROR IN LINEAR EQUATION SOLVER IN YTOK.', 1 ' IER =',I4,'. RUN HALTED.') STOP END FUNCTION ZBES(K) C *** ROUTINE REQUIRED BY GASLEG (GAUSS LEGENDRE PT/WT GENERATOR) C *** TAKEN FROM AD VAN DER AVOIRD'S N2-N2 CODE (SG 11/7/91) DOUBLE PRECISION PI,ZBES,B,BB,B3,B5,B7 DATA PI/3.14159 26535 89793 D0/ B=(DBLE(K)-0.25D0)*PI BB=1.0D0/(8.0D0*B) B3=BB*BB*BB B5=B3*BB*BB B7=B5*BB*BB ZBES=B+BB-(124.0D0/3.0D0)*B3+(120928.0D0/15.0D0)*B5-(401743168.0D0 1/105.0D0)*B7 RETURN END