C THIS ROUTINE IS THE MAIN PROGRAM FOR MOLSCAT VERSION 12, 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 12 - JUN 93 ----- 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 11 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 WAVEFUNCTIONS 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 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,RTURNM,LINE DIMENSIONS LIMITED BY VALUES ... PARAMETER(MXNRG=100,MXLN=200,MXTEMP=5,MXRTM=100) 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 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 ARRAY TO SAVE TURNING POINTS FROM DIFFERENT PARITY CASES C FOR IRMSET > 0 OPTION. DIMENSION RTURNM(MXRTM) 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 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(87),LOCN(87),INDX(87) 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'/ C DATA INDX/87*0/ C C DATA LABEL/10*' '/ DATA CWD/' ','(8-BYTE)'/ DATA CTIME/' '/,CDATE/' '/ DATA IPROGM/12/, PDATE/'(NOV 93)'/ 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 DATA NLABV/1,3,3,-1,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 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,' (1993)'/ 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 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 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 C CALL NAMLIS('&INPUT',INAMES,LOCN,INDX,87,IEOF) C IF(IEOF.EQ.1) GOTO 1040 C-------------------------------------------------------------- READ(5,INPUT,END=1040) C WRITE(6,120) 120 FORMAT(/'0 /INPUT/ DATA ARE --') WRITE(LABL,'(A80)') LABEL WRITE(6,130) LABL 130 FORMAT('0 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('0 SCRATCH CORE STORAGE ALLOCATION IS',I10,A8, 1 ' WORDS (',F8.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('0 INTEGRATOR REQUESTED BY INPUT VALUE INTFLG =',I3) 220 FORMAT('0***** ERROR - NO IMPLEMENTATION FOR THIS INTFLG' 1 ,' - RUN HALTED.') 240 FORMAT('0 COUPLED EQUATIONS SOLVED BY METHOD OF DEVOGELAERE.') 250 FORMAT('0 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('0 COUPLED EQUATIONS SOLVED BY WALKER-LIGHT R-MATRIX', 1 ' PROPAGATOR ALGORITHM'/'0 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('0',' RVFAC =',F7.2,' OVERRIDES INPUT RMID') 300 FORMAT('0 COUPLED EQUATIONS SOLVED BY LOG DERIVATIVE METHOD ', 1 'OF JOHNSON') 310 FORMAT('0 INTEGRATION PARAMETERS ARE RMIN =',F7.2,8X, 1 'STEPS = ',F7.1/33X,'RMAX =',F7.2) 320 FORMAT('0 CHANGING TO VARIABLE INTERVAL / VARIABLE STEP METHOD', 1 ' AT LONG RANGE'/'0 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('0 COUPLED EQUATIONS SOLVED BY DIABATIC ', 1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS') 350 FORMAT('0 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('0 AIRY PARAMETERS ','RMID =',F10.4/ 2 33X,'DRAIRY=',F10.4/33X,'TOLHI=',F13.6/ 3 33X,'POWRX =',F8.2) 355 FORMAT('0 DRAIRY.LT.0 TAKES INITIAL AIRY STEP SIZE FROM' 1 ,' MODIFIED LOG-DERIVATIVE VALUE.') 356 FORMAT('0 TOLHI.GE.1 -- AIRY STEP SIZE INCREASED BY' 1 ,' FACTOR OF TOLHI AT EACH STEP') 357 FORMAT('0 TOLHI.LT.1 -- AIRY STEPS ADJUSTED TO MAINTAIN' 1 ,' APPROX. ACCURACY VIA PERTURBATION THEORY AND POWRX.') 370 FORMAT('0 EQUATIONS SOLVED BY WKB APPROXIMATION WITH GAUSS-' 1 ,'MEHLER INTEGRATION. SEE R. T PACK, JCP 60, 633 (1974).'/ 2 '0 NOTE THAT THIS IS IMPLEMENTED ONLY FOR ONE CHANNEL', 3 ' CASES, E.G., IOS CALCULATIONS.'/ 4 '0 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('0 IRXSET =',I3,' OPTION. RMAX ADJUSTED AUTOMATICALLY ', 1 'FOR EACH NEW JTOT,MVAL') IF(IRMSET.LE.0) GOTO 420 WRITE(6,390) IRMSET 390 FORMAT('0 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('0***** 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('0 ENERGY-INDEPENDENT MATRICES SAVED FROM A ', 1 'PREVIOUS RUN WILL BE READ FROM UNIT',I3) C*V12* OPEN(ISCRU,FILE='ISCRU',FORM='UNFORMATTED',STATUS='OLD') C***** GISS VERSION FOLLOWS OPEN(ISCRU, FORM='UNFORMATTED',STATUS='OLD') C OPEN(ISCRU,FORM='UNFORMATTED',STATUS='OLD',SHARED,READONLY) ELSE WRITE(6,450) ISCRU 450 FORMAT('0 ENERGY-INDEPENDENT MATRICES WILL BE SAVED ', 1 'TEMPORARILY ON UNIT',I3) C*V12* OPEN(ISCRU,FILE='ISCRU',FORM='UNFORMATTED',STATUS='UNKNOWN') C***** GISS VERSION FOLLOWS OPEN(ISCRU, FORM='UNFORMATTED',STATUS='UNKNOWN') ENDIF ENDIF C WRITE(6,470) URED 470 FORMAT('0 REDUCED MASS FOR COLLISION =',F14.9,' A.M.U.') IF(JTOTL.LT.0) JTOTL=0 IF(JTOTU.LT.JTOTL) JTOTU=999 WRITE(6,480) JTOTL,JTOTU,JSTEP 480 FORMAT('0 CONTROL DATA FOR TOTAL ANGULAR MOMENTUM IS'/ 1 7X,'JTOT FROM',I4,' TO',I6,' IN STEPS OF',I4) IF(JTOTU.GE.999) WRITE(6,490) NCAC,DTOL,OTOL 490 FORMAT('0 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.999.AND.NNRGPG.GT.1) WRITE(6,491) NNRGPG 491 FORMAT('0 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('0 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('0 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('0***** 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('0 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('0 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('0 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('0 NUMDER=.TRUE. POTENTIAL DERIVATIVE WILL BE COMPUTED', & ' NUMERICALLY FROM POTENTIAL.') WRITE(6,650) PRINT,ISIGPR,ITHROW 650 FORMAT('0 PRINT LEVEL (PRNTLV) =',I3,' OTHER PRINT CONTROLS', 1 ' ISIGPR =',I2,' ITHROW =',I2) WRITE(6,660) 660 FORMAT('0',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 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 *** 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('0****** 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 N.B 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) CALL CHKSTR(NUSED) IC1=IXNEXT WRITE(6,660) C EFIRST=ENERGY(1)*CINT MXP=0 CALL GCLOCK(TITIME) TTIME=TITIME-TFIRST WRITE(6,700) TTIME,NUSED 700 FORMAT('0 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('0 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 IF(M.LE.MXRTM) GO TO 735 WRITE(6,732) MXRTM 732 FORMAT(/' *** ERROR. EXCEEDED LIMIT ON RTURNM. MXRTM =',I5) STOP 735 PHI=PHILW+PHIST*DBLE(M-1) IF(MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) GO TO 980 IF(PRINT.LT.4) GOTO 760 IF(ITHROW.NE.0) WRITE(6,710) TIT IF(ITHROW.EQ.0) WRITE(6,740) TIT 740 FORMAT('0',120A1) WRITE(6,750) JTOT,M 750 FORMAT('0 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,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 INITIALISE RTURN FOR IRMSET > 0 OPTION C IF(JTOT.EQ.JTOTL) RTURNM(M)=RMIN IK=1 RTURN=RTURNM(M) 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 769 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 N.B. 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.LE.0) GOTO 770 IS10=IXNEXT IS11=IS10+NSQ IXNEXT=IS11+NSQ 770 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,THETA,PHI, 2 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 769 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)) 771,774,773 771 IF(IECONV(J).LT.-2*MXP) GOTO 775 WRITE(6,772) JTOT,J 772 FORMAT('0 * * * WARNING. JTOT =',2I5,'-TH ENERGY PREVIOUSLY ', 1 'FAILED TO CONVERGE.') LCALC=.TRUE. GOTO 775 773 IF(JTOTU.LT.999) GOTO 774 IF(IECONV(J).LT.NCAC*MXP) GOTO 774 GOTO 775 774 LCALC=.TRUE. 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 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 778 IF(PRINT.LT.4) GOTO 790 IF(ITHROW.NE.0) WRITE(6,710) TIT2 IF(ITHROW.EQ.0) WRITE(6,740) TIT2 WRITE(6,780) JTOT,M,J,ETOT 780 FORMAT('0 JTOT =',I5,' SYMMETRY BLOCK =',I4,' ENERGY(', 1 I3,') =',F18.9,' (1/CM)') C C FOR SURFACE SCATTERING AT SUBSEQUENT ENERGY, C GET CORRESPONDING THETA FOR PRINTING C 790 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('0 NOTE: K VECTORS PARALLEL TO SURFACE WERE CALCULATED ', 1 'FOR ENERGY(1)'/' SUBSEQUENT ENERGY(',I3,') =',F10.4, 2 ' CORRESPONDS TO THETA =',F10.4,' DEGREES') ENDIF C C TEMPORARY STORAGE FOR HEADER, FINDRX ... IT1=IXNEXT IT2=IT1+MXLAM IXNEXT=IT2+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) IF(ICODE.NE.1 .OR. IRMSET.LE.0) GOTO 810 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),MXLAM,NPOTL,XEPS,ITYPE,PRINT) IF(RVFAC.EQ.0.D0) GOTO 810 RMID=RVFAC*RTURN IF(PRINT.GE.3.AND.RSTOP.GT.RMAX) WRITE(6,799) RSTOP,RMAX 799 FORMAT(' DRIVER(11/01/89) RMID IGNORES RSTOP.GT.RMAX',2F8.2) IF(PRINT.GE.3) WRITE(6,800) RMID,RVFAC 800 FORMAT('0 RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3) C C RESET IXNEXT TO DELETE TEMPORARY STORAGE 810 IXNEXT=IT1 C C AND SOLVE COUPLED EQUATIONS. C PROPAGATORS ARE CALLED FROM SUBROUTINE STORAG 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) GOTO 910 IF(PRINT.GE.2) WRITE(6,900) JTOT,M,J,ETOT,TTIME 900 FORMAT('0 ****** NO OPEN CHANNELS FOR JTOT =',I5, 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 910 CONTINUE C CALL OUTPUT(JTOT,X(IS9),X(ISJ),X(IS8),X(IS7),X(IS0),X(IS1), 1 X(IS2),CONV,NOPEN,M,MXPAR,WGHT,J,RM,PRINT,TTIME, 2 ENERGY,X(IOUT),X(IXJLEV),ISST,IECONV,MINJT,MAXJT, 3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR) 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('0 FINISHED JTOT =',I5,' M =',I4,' ENERGY(',I3, 1 ') =',F18.9,10X,'STEP TIME =',F8.2,' SECS') C 960 ICODE=2 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('0'/'0 CALCULATION TERMINATED BY CONVERGENCE OF TOTAL ', 1 'CROSS SECTIONS.'/'0 DIAGONAL AND OFF-DIAGONAL TOLERANCES WERE', 2 2F9.5,' NCAC =',I3) GOTO 1000 ENDIF C IF(PRINT.GE.2 .AND. PRINT.LT.5) WRITE(6,970) 970 FORMAT('0') C SAVE RTURN FOR USE IN SUBSEQUENT JTOT FOR SAME M RTURNM(M)=RTURN 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, 1 ISIGU,JSTEP) 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(1X/' 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 N.B. MX MAY HAVE BEEN REDUCED, SO USE MXSAVE FOR ALLOCATED STORAGE 1020 CALL CHKSTR(NUSED) WRITE(6,1030) IPROGM,PDATE,TOTIME,NUSED,MXSAVE 1030 FORMAT('0'/'0 ',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,'|'/' |',15X,'THIS RUN USED',F9.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 CHCK6I(N,JL,A) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION JL(4,N),A(1) DATA EPS/7.D-6/ WRITE(6,600) 600 FORMAT('0 CHCK6I. INPUT FUNCTIONS WILL BE CHECKED FOR ', & 'ORTHOGONALITY.') NERR=0 DO 1000 I1=2,N DO 1000 I2=1,I1-1 C SEE IF SAME J-VALUE IF (JL(1,I2).NE.JL(1,I1)) GO TO 1000 C CHECK THAT NK AGREE NK1=2*JL(1,I1)+1 NK2=2*JL(1,I2)+1 3000 IF (NK1.EQ.NK2) GO TO 1001 WRITE(6,699) I1,I2,NK1,NK2 699 FORMAT('0 ***** CHCK6I ERROR. FOR LEVELS',2I4,', NK NOT EQUAL.', & 2I5) NERR=NERR+1 GO TO 1000 1001 SUM=0.D0 DO 1100 II=1,NK1 1100 SUM=SUM+A(JL(4,I1)+II)*A(JL(4,I2)+II) IF (ABS(SUM).LE.EPS) GO TO 1000 WRITE(6,698) I1,I2,SUM 698 FORMAT('0 ***** CHCK6I ERROR. LEVEL',2I4,' ARE NOT ORTHOGONAL.', & ' OVERLAP =',D12.4) NERR=NERR+1 1000 CONTINUE IF (NERR.LE.0) RETURN WRITE(6,697) NERR 697 FORMAT('0 *****'/' ***** CHCK6I. NUMBER OF ERRORS =',I4/ 1 ' ***** EXECUTION TERMINATING UNLESS CHCK6I MODIFIED'/ 2 ' *****') STOP END SUBROUTINE COLIM(A,NLA,NUA,TOL,N) C COMPUTES LIMITS FOR BAND OF SIGNIFICANT ELEMENTS IN COLUMNS OF A IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(1),NLA(1),NUA(1) C FIND THE TOLERANCE LIMITS FOR THE TOPS(BEGINNINGS) OF THE C COLUMNS OF A NP1 = N + 1 NM1 = N - 1 LIMLO = 1 C THIS LOOP IS OVER THE COLUMNS OF A DO 40 K=1,N LIMHI = LIMLO + NM1 C THIS LOOP STARTS AT THE TOP OF THE K-TH COLUMN DO 10 J=LIMLO,LIMHI IF(ABS(A(J)).LE.TOL) GO TO 10 NLA(K) = J-LIMLO+1 GO TO 20 10 CONTINUE C THIS IS REACHED ONLY IF ALL ELEMENTS IN THE K-TH COLUMN ARE TINY NLA(K) = N NUA(K) = 1 GO TO 40 20 CONTINUE C FIND LIMITS FOR BOTTOMS OF COLUMNS C THIS LOOP STARTS AT THE BOTTOM END OF THE K-TH COLUMN DO 30 J=1,N IF(ABS(A(LIMHI)).LE.TOL) GO TO 30 NUA(K) = NP1 - J GO TO 40 30 LIMHI = LIMHI - 1 40 LIMLO = LIMLO + N RETURN END SUBROUTINE CONVRG(J,SR,SI,SROLD,SIOLD) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C C SUBROUTINE TO ASSIST IN THE ESTIMATION OF CONVERGENCE ERRORS C DIMENSION SR(1),SI(1),SROLD(1),SIOLD(1) COMMON/DRIVE/STEST,STEPS,STABIL,XCONV,RMIN,RMAX,XEPS, 1 DRNOW,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, 2 NOPEN,JKEEP,ISCRU,MAXSTP C C CHARACTER*6 CNAMES C DIMENSION CNAMES(3),LOCN(3),INDX(3) C DATA CNAMES/'ICONVU','IVAR','DR'/ C DATA INDX/3*0/ NAMELIST/CONV/ICONVU,IVAR,DR C NOPSQ=NOPEN*NOPEN IF(J.GT.1) GOTO 200 ISCRU=0 IVAR=0 DR=0.1D0 C------------------------------------------------------------------ C LOCN(1)=LOC(ICONVU) C LOCN(2)=LOC(IVAR) C LOCN(3)=LOC(DR) C CALL NAMLIS('&CONV ',CNAMES,LOCN,INDX,3,IEOF) C------------------------------------------------------------------ READ(5,CONV) IF(ICONVU.LT.0) GOTO 200 NSQOLD=NOPSQ DO 100 I=1,NOPSQ SROLD(I)=SR(I) 100 SIOLD(I)=SI(I) IF(ICONVU.EQ.0) GOTO 300 REWIND ICONVU WRITE(ICONVU) NOPSQ WRITE(ICONVU) (SROLD(I),I=1,NOPSQ) WRITE(ICONVU) (SIOLD(I),I=1,NOPSQ) GOTO 300 200 ICONVU=IABS(ICONVU) IF(ICONVU.EQ.0) GOTO 300 REWIND(ICONVU) READ(ICONVU) NSQOLD READ(ICONVU) (SROLD(I),I=1,NSQOLD) READ(ICONVU) (SIOLD(I),I=1,NSQOLD) WRITE(6,601) ICONVU 601 FORMAT('0 CONVERGENCE TESTS: REFERENCE S-MATRIX READ IN FROM ', 1 'CHANNEL',I3) 300 IF(NOPSQ.NE.NSQOLD) GOTO 600 ERRSM=0.D0 ERRTP=0.D0 DO 400 I=1,NOPSQ DIF = (SR(I)-SROLD(I))**2 + (SI(I)-SIOLD(I))**2 ERRSM=ERRSM+DIF DIF = (SR(I)**2 - SROLD(I)**2 + SI(I)**2 - SIOLD(I)**2)**2 ERRTP=ERRTP+DIF 400 CONTINUE C ERRSM=SQRT(ERRSM/DBLE(NOPSQ)) ERRTP=SQRT(ERRTP/DBLE(NOPSQ)) XSM=LOG10(MAX(ERRSM,1.D-30)) XTP=LOG10(MAX(ERRTP,1.D-30)) WRITE(6,602) RMIN,RMAX,RMID,STEPS,DRNOW,ERRSM,XSM,ERRTP,XTP 602 FORMAT('0 FOR RMIN =',F7.2,' RMAX =',F7.2,' RMID =',F7.2, 1 ' STEPS =',F8.1,' DR =',F7.4/ 2 ' RMS CHANGE IN S-MATRIX ELEMENTS IS ',7X, 3 E12.5,5X,'LOG IS',F8.3/ 4 ' RMS CHANGE IN TRANSITION PROBABILITIES IS ', 5 E12.5,5X,'LOG IS',F8.3) C IF(IVAR.EQ.0) DRNOW=DRNOW+DRNOW IF(IVAR.EQ.0) STEPS=STEPS/2.D0 IF(IVAR.EQ.1) RMIN=RMIN+DR IF(IVAR.EQ.2) RMID=RMID-DR IF(IVAR.EQ.3) RMAX=RMAX-DR RETURN C 600 WRITE(6,605) NOPSQ,NSQOLD 605 FORMAT('0*** ERROR IN CONVRG - NUMBER OF OPEN CHANNELS HAS ', 1 ' CHANGED'/5X,'NOPSQ =',I5,6X,'NSQOLD =',I5) RETURN END SUBROUTINE CONVRT(PTPOT,NP,V,NLEG,ABSC,WT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C CONVRT TAKES A SET OF FUNCTION VALUES EVALUATED AT GAUSS-LEGENDRE C QUADRATURE POINTS, AND CONVERTS THEM INTO A LEGENDRE SERIES, C USING THE RECURSION RELATIONSHIP FOR LEGENDRE POLYNOMIALS. C C PTPOT IS THE INPUT ARRAY, EVALUATED AT NP POINTS C V IS THE OUTPUT ARRAY: V(N) CONTAINS THE COEFFICIENTS OF C THE (N-1)TH ORDER LEGENDRE POLYNOMIAL C C IF ABSC(1) NE 0.0 ON INPUT, THE SUBROUTINE ASSUMES THAT THE C ARRAYS ABSC AND WT ALREADY CONTAIN THE APPROPRIATE C GAUSS-LEGENDRE ABSCISSAE AND WEIGHTS; OTHERWISE, GAUSSP C (OR THE NAG ROUTINE D01BBF) IS CALLED TO OBTAIN THEM. C C EXTERNAL D01BAZ DIMENSION PTPOT(NP),V(NLEG),ABSC(NP),WT(NP) IF(NLEG.LE.NP) GOTO 5 WRITE(6,601)NLEG,NP 601 FORMAT(' *** ERROR IN CONVRT, NLEG =',I4,' > NP =',I4) STOP 5 IF(ABSC(1).EQ.0.0D0) THEN CALL GAUSSP(-1.D0,1.D0,NP,ABSC,WT) C IFAIL=0 C CALL D01BBF(D01BAZ,-1.0D0,1.0D0,0,NP,WT,ABSC,IFAIL) ENDIF DO 10 N=1,NLEG 10 V(N)=0.0D0 C DO 100 M=1,NP PTWT=PTPOT(M)*WT(M) X=ABSC(M) P0=1.0D0 P1=X DO 100 K=1,NLEG GOTO(30,40),K TEMP=(DBLE(2*K-3)*X*P1 - DBLE(K-2)*P0) / DBLE(K-1) P0=P1 P1=TEMP V(K) = V(K) + (DBLE(K)-0.5D0) * P1 * PTWT GOTO 100 30 V(1) = V(1) + 0.5D0 * PTWT GOTO 100 40 V(2) = V(2) + 1.5D0 * PTWT * X 100 CONTINUE 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 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 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 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 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 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 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 SUBROUTINE IOSBIN(NVC,ITYPX,ATAU,MX,IASYMU,IPHIFX,IOSNG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C 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(3),FACTOR,IH0,IC0 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(10),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2), 1 WEXE(2),WT(2),ELEVEL(200) INTEGER JMIN,JMAX,NLEVEL,JLEVEL(400),J1MIN,J1MAX,J2MIN,J2MAX, 1 IDENT,JSTEP,J1STEP,J2STEP 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,JMIN,JMAX, 1 J2MIN,J2MAX,JSTEP,J2STEP,NLEVEL,JLEVEL,IDENT C C INTERNAL VERSION OF JLEVEL,ELEVEL IS ALSO USED . . . DIMENSION LEVV(200),EV(200) 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 ****************************************************************** DIMENSION COSA(400),GWT(400) C FOR ITYPE=3 TO HOLD PLM(LI,M,) AND COS(M*PHI) -- LNEW=.TRUE. CODE DIMENSION PL1(400),PL2(400),COSM(400) DATA MXGPT/400/ C C LIMIT FROM /CMBASE/ ELEVEL(MXLVL),JLEVEL(2*MXLVL) -- DATA MXLVL/200/ C AND EQUIVALENT INTERNAL ARRAYS DATA NVCMX/200/ 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/MAY 92).', 1 ' MODIFIED/NEW ITYPE 102/103.') 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 WHICH MAY BE CHANGED IN VRTP IH0=0 IC0=0 C WRITE(6,620) ITYPX 620 FORMAT('0 INPUT ITYPE =',I4) C ITYP=ITYPX-10*(ITYPX/10) ITYPX=100+ITYP 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.MXLVL) 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=MXLVL 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.MXLVL) 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 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(MXLVL,NLEVEL,JLEVEL,ELEVEL)'/) C N.B. NLEVEL,JLEVEL,ELEVEL ARE AVAILABLE IN /CMBASE/ BUT MXLVL C IS A LOCAL DATUM GEARED TO DIMENSIONS IN COMMON CALL GET102(MXLVL,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.LE.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 GO TO 4999 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)) GO TO 4999 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) GO TO 4999 C 4999 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 6200 IF (NPOTL.EQ.MXLAM .AND.(.NOT.LVRTP)) GO TO 6250 IF (NPOTL.EQ.1.AND.LVRTP) GO TO 6201 WRITE(6,670) NPOTL,MXLAM 670 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LVRTP INCONSISTENT WITH', 1 ' NPOTL, MXLAM',2I6) STOP C C CHECK FOR CONSISTENT IVLFL 6201 IF (IVLFL.LE.0) GO TO 9999 ITOP=NVC*(NVC+1)*NPOTL/2 DO 6202 IX=1,ITOP IVIX(IX)=0 6202 VL(IX)=0.D0 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 IS NPOTL=MXLAM (POTENTIAL EXPANDED IN LEGENDRE POLY'S) C THIS IS ESSENTIALLY CODE FROM MOLSCAT VERSION 9. C C CHECK FOR CONSISTENT IVLFL 6250 IF (IVLFL.NE.0) GO TO 9999 DO 6251 L=1,MXLAM LIX=L IL=LAM(3*L-2)/IHOMO + 1 LV1=LAM(3*L-1) LV2=LAM(3*L) DO 6252 IV=1,NVC DO 6252 IVP=1,IV C IVIX(LIX)=L VL(LIX)=0.D0 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 VL(LIX)=VLI(IP,IL) 6252 LIX=LIX+MXLAM 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 GOLFLAM-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.999) 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 IT1=ICX IXNEXT=IT1+MXLAM 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),MXLAM,NPOTL, 2 XEPS,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.999) 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(200),LV(400) COMMON /CMBASE/ DUM(214),IDUM(408) EQUIVALENCE (EV(1),DUM(11)),(LV(1),IDUM(8)) 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 CHARACTER*1 S(200),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(200),SIG3(200) C C COMMON BLOCKS TO COMMUNICATE WITH IOSBIN(BASIS SET) ROUTINES COMMON /CMBASE/DUM(214),IDUM(408) DIMENSION JLEV(400) EQUIVALENCE (NLEV,IDUM(7)), (JLEV(1),IDUM(8)), (IDENT,IDUM(408)) COMMON /IOUTCM/ JMAX,LEVV(200) C COMMON TO GET SYMMETRY INFORMATION (IHOMO1,IHOMO2) FOR ITYPE=3 COMMON/ANGLES/COSANG(3),FACTOR,IH1,IH2 C DATA MXSIG/200/ 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(400) COMMON /CMBASE/DUM(214),IDUM(408) EQUIVALENCE (JLEV(1),IDUM(8)), (NLEV,IDUM(7)) 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 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 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 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(.NOT.IREAD) NSTEP=BIG*STEPS*(RMID-RMIN)/ACOS(-1.D0) 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 MHAACK(IUNIT) * TO ACKNOWLEDGE AUTHORS OF AIRY INTEGRATOR * CURRENT REVISION DATE: 9-OCT-1991 C WRITE (IUNIT, 10) 10 FORMAT 1 (/' +- - - - - - - - - - - - - - - - - - - - - - - - - -', 2 ' - - - - - - - - - - - - +', A /,' + HIBRIDON: MODIFIED LOG DERIVATIVE - AIRY INTEGRATOR', B T79,'+', 3 /,' + ALL PUBLICATIONS RESULTING FROM USE OF THIS INTEGRATOR', 4 ' MUST INCLUDE', T79,'+',/, 5 ' + THE FOLLOWING REFERENCE: ',T79,'+', 6 /,' + M. H. ALEXANDER AND D. E. MANOLOPOULOS, J. CHEM. PHYS.' 7 ,' 86, 2044-2050 (1987) +' 8 /,' +- - - - - - - - - - - - - - - - - - - - - - - - - -', 9 ' - - - - - - - - - - - - +' ) RETURN END SUBROUTINE NEXTE(E,EP,ENEXT,DNRG,KSAVE) C C GIVEN THE S-MATRIX EIGENPHASE SUMS EP(5) AT FIVE EQUALLY SPACED C ENERGIES E(5), ESTIMATE THE POSITION ENEXT OF THE NEAREST C RESONANCE. THE ROUTINE ASSUMES A LINEAR BACKGROUND FOR THE EP'S. C DIFFERENCES ARE USED TO ESTIMATE THREE SUCCESSIVE VALUES OF THE C SECOND DERIVATIVE OF EIGSUM W.R.T. ENERGY, AND THESE SECOND C DERIVATIVES ARE THUS ASSUMED TO ARISE ENTIRELY FROM THE DISTANT C RESONANCE. THE RESONANCE POSITION IS THEN ESTIMATED BY AN C EXTRAPOLATION, BASED ON AN APPROXIMATION TO THE BREIT-WIGNER C FORMULA VALID AT ENERGIES MUCH FURTHER FROM THE RESONANCE THAN C ITS WIDTH. IF ANY OF THE SECOND DERIVATIVES DIFFER IN SIGN, C OR DECREASE WITH INCREASING ENERGY, THEN EITHER THE ENERGIES C INVOLVED ARE NEAR-RESONANT OR NUMERICAL NOISE IS DOMINATING C THE SECOND DERIVATIVES. UNDER THESE CIRCUMSTANCES, THE DNRG C PARAMETER IS INCREASED BY A FACTOR OF 10 TO REDUCE NUMERICAL C NOISE. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE IAMB DIMENSION E(5),EP(5) DATA IAMB/0/ CUBERT(X)=SIGN(ABS(X)**(1.D0/3.D0),X) WRITE(6,600) (I,E(I),EP(I),I=1,5) 600 FORMAT('0****** ESTIMATE PARAMETERS OF DISTANT RESONANCE ', 1 'USING 5 ENERGIES'//(' ENERGY(',I1,') =',F18.10, 2 ' EPSUM/PI =',F19.15)) DNRG=E(2)-E(1) CURV1=(EP(1)-2.D0*EP(2)+EP(3))/(DNRG*DNRG) CC1=CUBERT(CURV1) CURV2=(EP(2)-2.D0*EP(3)+EP(4))/(DNRG*DNRG) CC2=CUBERT(CURV2) CURV3=(EP(3)-2.D0*EP(4)+EP(5))/(DNRG*DNRG) CC3=CUBERT(CURV3) WRITE(6,666)CURV1,CURV2,CURV3 666 FORMAT('0 ESTIMATED EIGENPHASE CURVATURES ARE',3G13.6) CURVSM=CURV1+CURV2+CURV3 IF(CURV1*CURV2.LT.0.D0) GOTO 100 IF(CURV2.LT.CURV1) GOTO 100 IF(CURV2*CURV3.LT.0.D0) GOTO 100 IF(CURV3.LT.CURV2) GOTO 100 IAMB=0 ENEXT1=(CC1*E(2) - CC2*E(3))/(CC1-CC2) ENEXT2=(CC2*E(3) - CC3*E(4))/(CC2-CC3) ENEXT3=(CC1*E(2) - CC3*E(4))/(CC1-CC3) WRITE(6,602)ENEXT1,ENEXT2,ENEXT3 602 FORMAT(' ESTIMATES OF ENERGY ARE',3G22.14) GAM1=ABS(CURV1*(E(2)-ENEXT1)**3) GAM2=ABS(CURV2*(E(3)-ENEXT2)**3) GAM3=ABS(CURV1*(E(2)-ENEXT3)**3) WRITE(6,603)GAM1,GAM2,GAM3 603 FORMAT(' ESTIMATES OF WIDTH ARE',3(7X,G11.4,4X)) ENEXT=(ENEXT1+ENEXT2+ENEXT3)/3.D0 GAM=(GAM1+GAM2+GAM3)/3.D0 ESTEP=ABS(ENEXT-E(3)) WRITE(6,601)ENEXT,GAM 601 FORMAT('0 ESTIMATE RESONANCE ENERGY =',F18.10,' WIDTH =', 1 D11.4) IF(KSAVE.GT.0) WRITE(KSAVE,610) CURV1,CURV2,CURV3,ENEXT,GAM 610 FORMAT(' *** CURVATURES',3G22.14,/' *** GIVE ERES =',F18.10, 1 ' GAM =',D11.4) DNMIN=0.25D0*DNRG DNMAX=4.D0*DNRG DNRG=MAX(0.02D0*ESTEP, 0.3D0*GAM) DNRG=MAX(DNRG,DNMIN) DNRG=MIN(DNRG,DNMAX) ENEXT=ENEXT-2.D0*DNRG RETURN C 100 IAMB=IAMB+1 DNRG=DNRG*10.D0 WRITE(6,699)DNRG 699 FORMAT('0****** CURVATURES MAY BE DOMINATED BY NUMERICAL NOISE:', 1 ' UNSAFE TO ESTIMATE'/8X,'RESONANCE ENERGY.', 2 ' DNRG INCREASED TO',G12.5) IF(KSAVE.GT.0) WRITE(KSAVE,698) CURV1,CURV2,CURV3 698 FORMAT(' *** CURVATURES',3G18.10,' AMBIGUOUS') IF(IAMB.GE.3) GOTO 200 IF(CURVSM.LT.0.D0) ENEXT=E(1)-DNRG*5.D0 IF(CURVSM.GE.0.D0) ENEXT=E(5)+DNRG RETURN C 200 ENEXT=-1.D0 RETURN END SUBROUTINE ODPROP(Y, U, W, Q, Y1, Y2, & RBEGIN, REND, NPT, IREAD, IWRITE, ISCRU, & P, VL, IV, ERED, EINT, CENT, RMLMDA, & MXLAM, NPOTL, ISTART, NODES) C____ VERSION (1/27/93) USES /MEMORY/ ..,IVLFL, ONLY TO CHECK USE OF C____ IV ARRAY. BETTER CODE IN LOOPS 130, 230 POSSIBLE IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ROUTINE TO SOLVE THE SINGLE CHANNEL PROBLEM USING A C MODIFIED LOG DERIVATIVE ALGORITHM. THE POTENTIAL C EVALUATED AT THE MIDPOINT OF EACH SECTOR IS USED AS A C REFERENCE POTENTIAL FOR THE SECTOR. C C THIS VERSION IS WRITTEN TO VECTORISE AS MUCH AS POSSIBLE C LOGICAL IREAD,IWRITE DIMENSION U(NPT),W(NPT),Q(NPT),Y1(NPT),Y2(NPT), 1 P(MXLAM,NPT),VL(NPOTL),IV(NPOTL),EINT(1),CENT(1) C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C NODES=0 C C THIS VERSION USES A CONSTANT STEP SIZE, DR, THROUGHOUT THE C INTEGRATION RANGE, BUT IS WRITTEN SO THAT THIS MAY BE EASILY C CHANGED (THOUGH VECTORISATION WOULD REQUIRE EXPLICIT R ARRAYS). NSTEPS=NPT-1 DR=(REND-RBEGIN)/DBLE(NSTEPS) DR6=DR/6.D0 H=DR/2.D0 C IF(IREAD) GOTO 400 C C FIRST GET POTENTIAL U AT EVEN-NUMBERED POINTS C R=RBEGIN DO 100 I=1,NPT CALL POTENL(0,MXLAM,NPOTL,IDUM1,R,P(1,I),IDUM2) 100 R=R+DR EINTCM=EINT(1)/RMLMDA DO 110 I=1,NPT 110 U(I)=EINTCM DO 130 J=1,NPOTL V=VL(J) IF(V.EQ.0.D0) GOTO 130 IF (IVLFL.GT.0) THEN IVJ=IV(J) ELSE IVJ=J ENDIF DO 120 I=1,NPT 120 U(I)=U(I)+V*P(IVJ,I) 130 CONTINUE R=RBEGIN DO 140 I=1,NPT U(I)=U(I)*RMLMDA+CENT(1)/(R*R) 140 R=R+DR C C NOW GET POTENTIAL W AT ODD-NUMBERED POINTS C R=RBEGIN+H DO 200 I=1,NSTEPS CALL POTENL(0,MXLAM,NPOTL,IDUM1,R,P(1,I),IDUM2) 200 R=R+DR DO 210 I=1,NSTEPS 210 W(I)=EINTCM DO 230 J=1,NPOTL V=VL(J) IF(V.EQ.0.D0) GOTO 230 IF (IVLFL.GT.0) THEN IVJ=IV(J) ELSE IVJ=J ENDIF DO 220 I=1,NPT 220 W(I)=W(I)+V*P(IVJ,I) 230 CONTINUE R=RBEGIN+H DO 240 I=1,NSTEPS W(I)=W(I)*RMLMDA+CENT(1)/(R*R) 240 R=R+DR C C FORM VECTOR OF CORRECTIONS U C Q(1)=0.D0 DO 310 I=2,NPT 310 Q(I)=U(I)-W(I-1) QLAST=Q(NPT)*DR6 DO 320 I=1,NSTEPS 320 U(I)=(U(I)-W(I)+Q(I))*DR6 IF(IWRITE) WRITE(ISCRU) CENT(1),QLAST,W,U GOTO 500 C 400 READ(ISCRU) CSAV,QLAST,W,U C C CORRECT THE CENTRIFUGAL TERM IF DIFFERENT FROM THAT SAVED C DC=CENT(1)-CSAV IF(ABS(DC).LT.1.D-8) GOTO 500 R=RBEGIN+H DO 410 I=1,NSTEPS Q(I)=DC/(R*R) W(I)=W(I)+Q(I) 410 R=R+DR R=RBEGIN U(1)=U(1)+DC/(R*R)-Q(1) R=R+DR DO 420 I=2,NSTEPS U(I)=U(I)+((DC+DC)/(R*R)-Q(I)-Q(I-1))*DR6 420 R=R+DR QLAST=QLAST+(DC/(R*R)-Q(NSTEPS))*DR6 C C NOW GET PROPAGATORS. C THIS LOOP REQUIRES SPECIAL TREATMENT TO VECTORISE ON CRAY C 500 DO 510 I=1,NSTEPS WREF=W(I)-ERED FLAM=0.5D0*SQRT(ABS(WREF)) IF(WREF.LT.0.D0) THEN TN=TAN(FLAM*DR) Y1(I)=FLAM/TN-FLAM*TN Y2(I)=FLAM/TN+FLAM*TN ELSE TN=TANH(FLAM*DR) Y1(I)=FLAM/TN+FLAM*TN Y2(I)=FLAM/TN-FLAM*TN ENDIF Y2(I)=Y2(I)*Y2(I) 510 Q(I)=Y1(I)+U(I) C C INITIALIZE Y IF NECESSARY C IF(ISTART.EQ.1) GOTO 600 WREF=U(1)-ERED Y=1.D30 IF(WREF.GT.0.D0) Y=SQRT(WREF) Y=SIGN(Y,DR) C C FINALLY DO THE PROPAGATION. THIS LOOP IS NOT VECTORISABLE, C SO THE WORK IN IT IS KEPT TO AN ABSOLUTE MINIMUM. C 600 DO 700 I=1,NSTEPS 700 Y=Y1(I)-Y2(I)/(Y+Q(I)) C Y=Y+QLAST RETURN END SUBROUTINE OUTPUT( JTOT, NBASIS, J, L, WVEC, SREAL, SIMAG, 1 AKMAT, CONV, NOPEN, M, MXPAR, WT, INRG, RM, PRNT, TTIME, 2 ENERGY, SIG, JLEV, ISST, IECONV, MINJT, MAXJT, 3 NLEV, NQN, OTOL, DTOL, KSAVE, ISIGU, IPARTU, ISAVEU, ISIGPR) C 1/21/93 NEW DYNAMIC MEMORY HANDLING IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE 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 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 C INTEGER CTIME(2),CDATE(4) CHARACTER CTIME*9,CDATE*11 CHARACTER*4 LABEL(20) CHARACTER*1 STAR,BLANK C COMMON /CMBASE/ ROTI(10),ELVL(204),IDUM(408) C C COMMON BLOCK TO DRIVER FOR RESONANCE SEARCHES C COMMON/EIGSUM/EPSM(5) C EQUIVALENCE (NLVL,IDUM(7)) C DATA STAR/'*'/, BLANK/' '/ DATA EPS/1.D-10/ DATA IPUNCH/7/ C PRINT=PRNT 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*JTOT+1)*PI IF (IEXCH.NE.0) XJ=XJ*WT DO 2000 ICOL=1,NOPEN LEVC=J(NBASIS(ICOL)) LCOL=JLEV(NTOP+LEVC) 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 LROW=JLEV(NTOP+LEVR) 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) + 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('0 FOR JTOT =',I4,'.',I2,' ENERGY(',I3, 1 ') =',F12.2,', MAX CHANGE IN DIAG/OFF-DIAG SIG =',2D12.4, 2 4X,'TIME =',F6.2) ENDIF C IF(ISIGPR.EQ.0) GO TO 5100 IF (PRINT.LE.3) GO TO 5100 WRITE(6,9601) 9601 FORMAT('0',8(' * '),'PARTIAL CROSS SECTIONS',8(' * ')) DO 5200 I=1,NLEVEL 5200 WRITE(6,631) (SIG((II-1)*NLEVEL+I),I,II, II=1,NLEVEL) 631 FORMAT('0',4(F15.6,' FOR SIG(',2I3,')' )/ 1 ( ' ',4(F15.6,' 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 DO 5299 I=1,NLEVEL 5299 WRITE(6,631) (SIG((II-1)*NLEVEL+I+ISTART),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 (ISAVEU.LE.0) GO TO 6500 WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M C WRITE(ISAVEU,803) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M C 803 FORMAT(2I4,E16.8,I4,E16.8,I4) WRITE(ISAVEU) NOPEN, 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 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 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. WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG), 1 MINJT(INRG),MAXJT(INRG),II,I,SIG(IJ) I10=I10+1 101 FORMAT(A1,F19.6,I5,I7,10X,2I5,E20.6) 7100 CONTINUE IF (PRINT.GE.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<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.GT.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 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 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.GT.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 698 FORMAT(/' SIG6 (2/1/93). FOR INITIAL FINAL LEVELS',2I3, 1 ' AVAILABLE STORAGE IS INADEQUATE') 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 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 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 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 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 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 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 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 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 CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, : CDIAG, COFF, NCH) * SUBROUTINE TO DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGO * CORRECTION TERMS IN AIRY PROPAGATOR * ALSO COPIES NEW EIGENVALUES FROM ARRAY EIGNOW INTO ARRAY EIGOLD * AUTHOR: MILLARD ALEXANDER * CURRENT REVISION DATE: 27-SEPT-87 * * --------------------------------------------------------------------- * VARIABLES IN CALL LIST: * EIGNOW: ON ENTRY: VECTOR CONTAINING EIGENVALUES OF WAVEVECTOR MA * IN CURRENT INTERVAL * EIGOLD: ON ENTRY: VECTOR CONTAINING EIGENVALUES OF WAVEVECTOR MA * IN PREVIOUS INTERVAL * ON RETURN: VECTOR CONTAINING EIGENVALUES OF WAVEVECTOR M * IN CURRENT INTERVAL * HP: VECTOR CONTAINING DIAGONAL ELEMENTS OF DERIVATIVE OF * TRANSFORMED HAMILTONIAN MATRIX IN CURRENT INTERVAL * THIS IS THE SAME AS THE NEGATIVE OF THE DIAGONAL ELEMENT * THE WN-TILDE-PRIME MATRIX * DRNOW: WIDTH OF CURRENT INTERVAL * DRMID: DISTANCE BETWEEN MID-POINT OF CURRENT INTERVAL AND MID_P * PREVIOUS INTERVAL * XLARGE: LARGEST OFF-DIAGONAL ELEMTENT IN TRANSFORMED WAVEVECTOR * IN CURRENT INTERVAL * CDIAG: ON RETURN: CONTAINS ESTIMATE OF ERROR DUE TO NEGLECTED * DIAGONAL ELEMENTS OF WN-TILDE-DOUBLE PRIME MATRIX * SEE EQ.(29) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERIN * ALGORITHMS" * COFF: ON RETURN: CONTAINS ESTIMATE OF ERROR DUE TO NEGLECTED * OFF-DIAGONAL ELEMENTS OF WN-TILDE-PRIME MATRIX * SEE EQ.(26) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERIN * ALGORITHMS" * NCH: NUMBER OF CHANNELS * --------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) * REAL CAY, CDIAG, COFF, DRMID, DRNOW, FACTOR, W2P, XLARGE * REAL EIGNOW, EIGOLD, HP * REAL SQRT INTEGER I, NCH * ARRAYS, MUST BE DIMENSIONED AT LEAST NCH DIMENSION EIGNOW(1), EIGOLD(1), HP(1) FACTOR = 2. / (DRMID**2) CAY = 0. CDIAG = 0. DO 30 I = 1 , NCH * --------------------------------------------------------------------- * ESTIMATE SECOND DERIVATIVE OF WAVEVECTOR BY POWER SERIES EXPANSION * 2 2 2 * W(R ) = W(R ) + (R - R ) (DW/DR) + 0.5 (R - R ) (D W/DR ) * 2 1 2 1 R 2 1 R * 1 1 * WHICH CAN BE REARRANGED TO GIVE [SINCE DRMID = R - R AND HP = - (DW/ * 1 2 * 2 2 2 * (D W/DR ) = - 2 [ W(R ) - W(R ) + DRMID * HP(R ) ] / DRMID * R 1 2 * 1 * --------------------------------------------------------------------- W2P = - FACTOR * (EIGNOW(I) - EIGOLD(I) + DRMID * HP(I)) CDIAG = CDIAG + ABS(W2P) CAY = CAY + SQRT (ABS(EIGNOW(I))) 30 CONTINUE CAY = CAY / DBLE(NCH) CDIAG = CDIAG / DBLE(NCH) * CAY NOW CONTAINS AVERAGE WAVEVECTOR MAGNITUDE * CDIAG NOW CONTAINS AVERAGE MAGNITUDE OF THE SECOND DERIVATIVE OF THE * WAVEVECTOR ARRAY * NOW CALCULATE ESTIMATE OF ERROR CDIAG = (DRNOW**3) * CDIAG / 12. COFF = CAY * XLARGE * (DRNOW**3) / 12. * NOW COPY NEW EIGENVALUE ARRAY INTO EIGOLD CALL DCOPY (NCH, EIGNOW, 1, EIGOLD, 1) 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 OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW, : N, NMAX, ITWO, ISCRU) * SUBROUTINE TO EITHER WRITE OR READ TRANSFORMATION MATRIX AND * RELEVANT INFORMATION FROM FILE ISCRU * CALLED FROM SPROPN * AUTHOR: MILLARD ALEXANDER * CURRENT REVISION DATE: 14-FEB-91 * --------------------------------------------------------------------- * VARIABLES IN CALL LIST: * TMAT: N X N MATRIX TO CONTAIN TRANSFORMATION MATRIX * EIGOLD: ARRAY OF DIMENSION N WHICH CONTAINS LOCAL WAVEVECTORS * HP: ARRAY OF DIMENSION N WHICH CONTAINS DERIVATIVES OF HAMILT * MATRIX. THIS IS JUST THE NEGATIVE OF THE DERIVATIVES OF * WAVEVECTOR MATRIX * ESHIFT: AMOUNT LOCAL WAVEVECTORS WILL BE SHIFTED IN SECOND ENERGY * CALCULATION: 2 2 * K (NEW) = K (OLD) + ESHIFT * DRNOW: WIDTH OF CURRENT INTERVAL * RNOW: MIDPOINT OF CURRENT INTERVAL * N: NUMBER OF CHANNELS * NMAX: MAXIMUM ROW DIMENSION OF MATRIX TMAT * ITWO: IF = 0, THEN SUBROUTINE CALLED AT FIRST ENERGY OF MULTIPL * ENERGY CALCULATION, SO TRANSFORMATION MATRIX AND RELEVANT * INFORMATION WILL BE WRITTEN * IF > 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 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 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 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 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 POTENL(ICNTRL, MXLMB, MPOTL, LAM, R, P, ITYP) C LATEST REVISION DATE 30 JUN 1993. C ALLOWS FOR VRTP PROJECTED EXPANSIONS IN IOS CASES. IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE INTEGER CFLAG LOGICAL QOUT,LVRTP CHARACTER*8 QNAME(10), QTYPE(10) C CHARACTER*6 PNAMES C DIMENSION PNAMES(14),LOCN(14),INDX(14) DIMENSION P(MXLMB), LAM(MXLMB) DIMENSION NTERM(360),NPOWER(200),NPUNI(20),LAMBDA(360),H(10) DIMENSION A(200), E(200) DIMENSION PTT(64),WTT(64),PTX(64),WTX(64),PLM(3000),FAC(3000) EQUIVALENCE (MXLAM,MXSYM) COMMON/NPOT/NPTL COMMON/ANGLES/COSANG(3),FACTOR,IHOMO,ICNSYM C NAMELIST/POTL/ RM,EPSIL,MXLAM,MXSYM,LAMBDA,NPOTL,NTERM, 1 A,NPOWER,E,CFLAG,LVRTP,NPT,NPS C DATA PNAMES/'RM','EPSIL','MXLAM','MXSYM','LAMBDA','NPOTL','NTERM', C 1 'A','NPOWER','E','CFLAG','LVRTP','NPT','NPS'/ C DATA INDX/14*0/ C DATA IXMX,IEXMX,NPXMX,MXL,MXPT,MXPLM/200,200,20,360,64,3000/ DATA PLM/3000*0.D0/, FAC/3000*0.D0/ DATA CFLAG/0/, NPT/16/, LVRTP/.FALSE./ DATA QTYPE/'LAMBDA =','ABS(MU)=',' MU = ',' L1 = ', 1 ' L2 = ',' L = ',' V = ','V-PRIME=', 2 ' J = ','J-PRIME='/ C C RM - LENGTH SCALING FACTOR C EPSIL - ENERGY SCALING FACTOR C MXLAM - NUMBER OF POTENTIAL TERMS RETURNED C LAMBDA - SYMMETRY INDICES FOR POTENTIAL C NPOTL - NUMBER OF ELEMENTS OF VL ARRAY (IN BASE) WHICH C CORRESPOND TO EACH ELEMENT OF P ARRAY C NTERM - ARRAY: NTERM(I) IS NUMBER OF TERMS CONTRIBUTING TO P(I) C A - ARRAY OF PRE-EXPONENTIAL (OR PRE-POWER) FACTORS C FIRST NTERM(1) ELEMENTS REFER TO P(1), C NEXT NTERM(2) ELEMENTS REFER TO P(2) ETC. C NPOWER - ARRAY OF POWERS FOR POTENTIAL TERMS C NPOWER HAS SAME ORDERING AS A C NPOWER(J) .EQ. 0 INDICATES EXPONENTIAL C E - ARRAY OF EXPONENTS: EACH ELEMENT OF THIS ARRAY C CORRESPONDS TO A ZERO IN THE NPOWER ARRAY, C IE E(1) CORRESPONDS TO FIRST ZERO, E(2) TO SECOND ETC. C CFLAG - FLAG FOR SCALING POTENTIAL FOR ITYPE = 5 OR 6 C LVRTP - LOGICAL FLAG FOR NON-EXPANDED POTENTIAL C NPT - NUMBER OF GAUSS-LEGENDRE POINTS FOR NON-EXPANDED POTL C NPS - NUMBER OF SECONDARY GAUSSIAN POINTS FOR NON-EXPANDED POTL C (ONLY USED FOR ITYPE=5 AND 6 AT PRESENT) C IF (ICNTRL.GE.0) GOTO 1000 IF (ICNTRL.EQ.-1) GOTO 2000 WRITE(6,633) ICNTRL,R 633 FORMAT('0 *** ERROR IN POTENL, ICNTRL =',I6,' R =',E16.8) STOP C C EVALUATE V(R) C 1000 IX=0 IF (LVRTP) GO TO 1500 IEX=0 DO 1300 I=1,MXLMB SUM=0.D0 NT=NTERM(I) IF (NT.EQ.0) GOTO 1300 IF (NT.LT.0) GOTO 1250 DO 1200 IT=1,NT IX=IX+1 NP=NPOWER(IX) IF(NP.EQ.0) GOTO 1100 TERM=R**NP IF(ICNTRL.EQ.0) GOTO 1200 IF(ICNTRL.EQ.1) TERM=DBLE(NP)*TERM/R IF(ICNTRL.EQ.2) TERM=DBLE(NP*(NP-1))*TERM/(R*R) GOTO 1200 C 1100 IEX=IEX+1 TERM=EXP(E(IEX)*R) IF(ICNTRL.GT.0) TERM=TERM*E(IEX)**ICNTRL 1200 SUM=SUM+A(IX)*TERM GOTO 1300 1250 IF(ICNTRL.EQ.0) CALL VSTAR (I,R,SUM) IF(ICNTRL.EQ.1) CALL VSTAR1(I,R,SUM) IF(ICNTRL.EQ.2) CALL VSTAR2(I,R,SUM) 1300 P(I)=SUM RETURN C C UNEXPANDED POTENTIAL AS EXPLICIT FUNCTION OF ANGLES C SUPPLIED BY ROUTINE VRTP. C IOS CASE 1500 IF(ITSAVE.LT.100) GOTO 1600 CALL VRTP(ICNTRL,R,P) RETURN C C OR EXPLICIT PROJECTION OF LEGENDRE COMPONENTS 1600 DO 1700 I=1,MXLMB 1700 P(I)=0.D0 DO 1800 IPT=1,NPT IOFT=MXLMB*(IPT-1) COSANG(1)=PTT(IPT) DO 1800 IPX=1,NPS IOFX=MXLMB*(IPX-1) COSANG(2)=PTX(IPX) CALL VRTP(ICNTRL,R,SUM) SUM=SUM*WTT(IPT)*WTX(IPX) DO 1800 I=1,MXLMB 1800 P(I)=P(I)+SUM*FAC(IOFX+I)*PLM(IOFT+I) RETURN C C POTENTIAL INITIALISATION C 2000 PI=ACOS(-1.D0) LAMMAX=MIN(MXLMB,MXL) WRITE(6,634) 634 FORMAT('0 STANDARD MOLSCAT POTENL ROUTINE CALLED FOR POTENTIAL.'/ 1 '0 /POTL/ DATA ARE --') C RM=1.D0 EPSIL=1.D0 NPOTL=-1 C C NAMELIST/POTL/ RM,EPSIL,MXLAM,MXSYM,LAMBDA,NPOTL,NTERM, C 1 A,NPOWER,E,CFLAG,LVRTP,NPT,NPS C------------------------------------------------------------------- C ARRAYS FOR NAMELIST SIMULATOR C LOCN(1)=LOC(RM) C LOCN(2)=LOC(EPSIL) C LOCN(3)=LOC(MXLAM) C LOCN(4)=LOC(MXSYM) C LOCN(5)=LOC(LAMBDA) C LOCN(6)=LOC(NPOTL) C LOCN(7)=LOC(NTERM) C LOCN(8)=LOC(A) C LOCN(9)=LOC(NPOWER) C LOCN(10)=LOC(E) C LOCN(11)=LOC(CFLAG) C INDX(11)=4 C LOCN(12)=LOC(LVRTP) C INDX(12)=3 C LOCN(13)=LOC(NPT) C LOCN(14)=LOC(NPS) C CALL NAMLIS('&POTL ',PNAMES,LOCN,INDX,14,IEOF) C------------------------------------------------------------------- READ(5,POTL) C IF(NPOTL.LT.0) NPOTL=MXLAM C C CHECK FOR LVRTP OR MXLAM.LE.0, ("UNEXPANDED" POTENTIAL CASE). C IF(MXLAM.LE.0) LVRTP=.TRUE. IF (.NOT.LVRTP) GO TO 3999 WRITE(6,636) 636 FORMAT('0 POTENTIAL IS **NOT** EXPANDED IN ANGULAR FUNCTIONS.'/ 1 '0 A SUITABLE VRTP ROUTINE MUST BE SUPPLIED.') ITYPE=ITYP-10*(ITYP/10) IF (ITYP.GT.100 .OR. 1 ITYPE.EQ.1 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.5 .OR. ITYPE.EQ.6) 2 GO TO 3010 WRITE(6,637) 637 FORMAT('0 * * * ERROR. SUPPORTED ONLY FOR ITYPE=1,2,5,6 AND FOR', 1 ' IOS CALCULATIONS.') STOP C C CALL VRTP TO INITIALISE AND ALLOW SETTING OF IHOMO, ICNSYM. C N.B. VRTP MAY SET OR USE RM, EPSIL . . . 3010 FACTOR=1.D0 IHOMO=1 ICNSYM=1 ITSAVE=ITYP CALL VRTP(ICNTRL,RM,EPSIL) IF(ITYP.GT.100.AND.MXLAM.LE.0) GOTO 3100 IF (ITYP.GT.100) THEN WRITE(6,699) 699 FORMAT(/' *** NOTE *** REQUESTED PROJECTED EXPANSION IS ' 1 ,'GENERALLY NOT DESIRABLE FOR IOS CALCULATIONS.'/ 2 ' STANDARD IOS/VRTP PROCESSING CAN BE' 3 ,' OBTAINED BY SETTING MXLAM=0 IN &POTL'/) C IN EVALUATION, FLAG TO PROJECT IS ITSAVE.LT.100; RESET ACCORDINGLY ITSAVE=ITSAVE-10*(ITSAVE/10) ENDIF WRITE(6,635) NPT 635 FORMAT(I4,'-POINT GAUSSIAN QUADRATURE REQUESTED TO PROJECT OUT', 1 ' LEGENDRE COMPONENTS') C C GET GAUSS-LEGENDRE QUADRATURE POINTS AND WEIGHTS, C AND CHECK THAT NUMBER OF POINTS IS SENSIBLE. MXLM=0 DO 3011 I=1,MXLAM FAC(I)=DBLE(LAMBDA(I))+0.5D0 3011 MXLM=MAX(MXLM,LAMBDA(I)) MXLM=MXLM+1 IF(MXLM.GT.NPT) WRITE(6,648) NPT,MXLM 648 FORMAT(I4,'-POINT QUADRATURE IS INSUFFICIENT TO PROJECT OUT', 1 ' LEGENDRE COMPONENTS REQUESTED'/' NPT INCREASED TO ',I3, 2 ' ACCORDINGLY') NPT=MAX(NPT,MXLM) IF(NPT.LE.MXPT) GOTO 3012 WRITE(6,649) NPT,MXPT 649 FORMAT('0 ARRAY DIMENSIONS NOT LARGE ENOUGH FOR NPT =',I3/ 1 ' LARGEST VALUE ALLOWED AT PRESENT IS',I4) STOP C 3012 NEXP=NPT CALL GAUSSP(-1.D0,1.D0,NPT,PTT,WTT) IF(NPT.EQ.NEXP) GO TO 3013 WRITE(6,653) NEXP 653 FORMAT(I4,'-POINT QUADRATURE IS NOT AMONG THOSE STORED'/ 1 ' ALTER EITHER NPT OR LAMBDA ARRAY ACCORDINGLY.') STOP 3013 IF(IHOMO.EQ.2) THEN DO 3014 IPT=1,NPT/2 3014 WTT(IPT)=2.D0*WTT(IPT) NPT=(NPT+1)/2 ENDIF C IF (ITYPE.EQ.1) GO TO 3001 IF (ITYPE.EQ.2) GO TO 3002 IF (ITYPE.EQ.5) GO TO 3005 IF (ITYPE.EQ.6) GO TO 3005 WRITE(6,638) ITYPE 638 FORMAT('0 * * * ERROR. NOT SUPPORTED FOR ITYPE =',I4) STOP C C SET UP OTHER QUADRATURE POINTS AND WEIGHTS FOR PROJECTING C POTENTIAL COMPONENTS FOR ITYPE=1,2,5,6 3001 NPS=1 IF(MXLAM*NPT.GT.MXPLM) GOTO 9400 PTX(1)=0.D0 WTX(1)=1.D0 DO 3016 I=1,MXLAM IF(MOD(LAMBDA(I),IHOMO).NE.0) GOTO 3016 FAC(I)=DBLE(LAMBDA(I))+0.5D0 IND=I DO 3015 IPT=1,NPT PLM(IND)=PLEG(LAMBDA(I),PTT(IPT)) 3015 IND=IND+MXLAM 3016 CONTINUE GOTO 3999 C 3002 IF(MXLAM*NPT.GT.MXPLM .OR. MXLAM*NPS.GT.MXPLM) GOTO 9400 DO 3020 I=1,MXLAM L=LAMBDA(3*I-2) IF(MOD(L,IHOMO).NE.0) GOTO 3020 IND=I DO 3019 IPT=1,NPT PLM(IND)=(DBLE(L)+0.5D0)*PLEG(L,PTT(IPT)) 3019 IND=IND+MXLAM 3020 CONTINUE C MAXV=0 DO 3021 I=1,MXLAM MAXV=MAX(MAXV,LAMBDA(3*I)) 3021 MAXV=MAX(MAXV,LAMBDA(3*I-1)) IF(2*MAXV-1.GT.NPS) WRITE(6,670) NPS,MAXV 670 FORMAT('0 *** WARNING IN POTENL - ',I2,'-POINT QUADRATURE NOT ', 1 'ENOUGH FOR MATRIX ELEMENTS UP TO V OR K =',I3) CALL GAUSHP(NPS,PTX,WTX) C C GET HERMITE POLYNOMIALS AND NORMALISE THEM DO 3023 IPX=1,NPS CALL HERM(H,MAXV+1,PTX(IPX)) SUM=SQRT(PI) DO 3022 NV=1,MAXV+1 H(NV)=H(NV)/SQRT(SUM) 3022 SUM=SUM*DBLE(2*NV) IND=MXLAM*(IPX-1) DO 3023 I=1,MXLAM IND=IND+1 3023 FAC(IND)=H(1+LAMBDA(3*I-1))*H(1+LAMBDA(3*I)) GOTO 3999 C 3005 MAXV=0 IF(MXLAM*NPT.GT.MXPLM .OR. MXLAM*NPS.GT.MXPLM) GOTO 9400 DO 3025 I=1,MXLAM 3025 MAXV=MAX(MAXV,LAMBDA(2*I)) WRITE(6,671) NPS 671 FORMAT(I4,'-POINT GAUSSIAN QUADRATURE REQUESTED TO PROJECT OUT', 1 ' PHI COMPONENTS') IF(2*MAXV-1.GT.NPS*ICNSYM) WRITE(6,670) NPS,MAXV DO 3026 IPX=1,NPS PTX(IPX)=PI*DBLE(2*IPX-1)/DBLE(2*ICNSYM*NPS) 3026 WTX(IPX)=SQRT(PI+PI)/DBLE(NPS) DO 3029 I=1,MXLAM L=LAMBDA(2*I-1) M=LAMBDA(2*I) IF(MOD(L+M,IHOMO).NE.0 .OR. MOD(M,ICNSYM).NE.0) GOTO 3029 IND=I DO 3027 IPT=1,NPT PLM(IND)=PASLEG(L,M,PTT(IPT)) 3027 IND=IND+MXLAM IND=I DO 3028 IPX=1,NPS FAC(IND)=COS(DBLE(M*PTX(IPX))) 3028 IND=IND+MXLAM 3029 CONTINUE GOTO 3999 C 3100 IF(ITYP.EQ.102) GO TO 3192 C BELOW IS UNIFIED CODE FOR ITYPE=101,103,105,106 (& 102 W/MXLAM=0) NQPL=1 IF(ITYP.EQ.103) NQPL=3 IF(ITYP.EQ.105 .OR. ITYP.EQ.106) NQPL=2 3190 DO 3101 I=1,NQPL LAM(I)=0 3101 LAMBDA(I)=0 NPOTL=1 MXLAM=1 GOTO 9050 C C SPECIAL CODE FOR ATOM-VIBRATING DIATOM IOS, UNEXPANDED IN ANGLE 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('0 POTENL, ITYPE=102. NEGATIVE MXLAM REQUESTS',I3, 1 ' SYMMETRIES'/'0 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) NPOTL=1 GOTO 9050 C C ATTEMPT TO PROCESS ITYPE AND POTENTIAL DESCRIPTION NUMBERS C 3999 QOUT=.TRUE. NQPL=1 WRITE(6,639) 639 FORMAT('0 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.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('0 * * * WARNING. ITYPE =',I4,' CANNOT BE PROCESSED TO', 1 ' DETERMINE THE POTENTIAL SYMMETRY TYPE') QOUT=.FALSE. GOTO 2100 C 2001 NQPL=1 QNAME(1)=QTYPE(1) WRITE(6,641) 641 FORMAT(' LEGENDRE POLYNOMIALS, P(LAMBDA).') 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.NE.7) GOTO 2100 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) MPOTL=0 DO 2010 I=1,MXLAM 2010 MPOTL=MAX0(MPOTL,LAMBDA(5*I-4)) C SG CHANGE DATED JAN 92 - IS IT COMPATIBLE WITH ITYPE=8? JMH C MPOTL=MPOTL+1 NPOTL=MPOTL+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)') GOTO 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(CFLAG.EQ.1) WRITE(6,646) 646 FORMAT('0 COEFFICIENTS IN POTENTIAL WILL BE MULTIPLIED BY', 1 ' SQRT(4*PI/(2*LAM+1)) TO BRING POTENTIAL INTO CORRECT FORM') GOTO 2100 C 2008 NQPL=2 QNAME(1)=QTYPE(4) QNAME(2)=QTYPE(5) MPOTL=NPTL WRITE(6,647) MPOTL 647 FORMAT(' SURFACE FOURIER COMPONENTS'/' NPOTL =',I2, 1 ' FROM SURBAS') GOTO 2100 C C COMMON POINT TO ALL ITYPE 2100 IF(NQPL*MXLAM.LE.LAMMAX) GOTO 3000 WRITE(6,650) MXLAM,NQPL,LAMMAX 650 FORMAT(' * * * TERMINAL ERROR IN POTENL - MXLAM*NQPL EXCEEDS ', 1 'LAMMAX'/7X,'VALUES ARE',3I6) STOP 3000 IX=0 IEX=0 IQ=0 NPX=0 DO 9000 I=1,MXLAM WRITE(6,651) I 651 FORMAT('0 INTERACTION POTENTIAL FOR SYMMETRY TYPE NUMBER',I3) IF(QOUT) WRITE(6,652) (QNAME(J),LAMBDA(IQ+J),J=1,NQPL) 652 FORMAT(' WHICH HAS ',6(A8,I3,3X)) IQ=IQ+NQPL WRITE(6,654) 654 FORMAT(1X) NT=NTERM(I) 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) GOTO 9100 IF(NPOWER(IX).LT.0) GOTO 8200 IF(NPOWER(IX).EQ.0) GOTO 8000 WRITE(6,655) IX,NPOWER(IX) 655 FORMAT('0 * * * 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) GOTO 9200 IF(E(IEX).LT.0.D0) GOTO 8100 WRITE(6,656) E(IEX) 656 FORMAT('0 * * * 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)) IF(NPX.EQ.0) GOTO 8500 DO 8400 INPX=1,NPX IF(NPOWER(IX).EQ.NPUNI(INPX)) GOTO 8700 8400 CONTINUE 8500 NPX=NPX+1 IF(NPX.GT.NPXMX) GOTO 9300 NPUNI(NPX)=NPOWER(IX) C 8700 CONTINUE GOTO 9000 8800 CALL VINIT(I,RM,EPSIL) 9000 CONTINUE WRITE(6,659) NPX 659 FORMAT('0 NUMBER OF UNIQUE POWERS =',I4) IF(NPX.EQ.0) GOTO 9020 DO 9010 I=1,NPX 9010 WRITE(6,660) I, NPUNI(I) 660 FORMAT(' POWER',I3,' =',I4) 9020 CONTINUE J=MXLAM*NQPL DO 9030 I=1,J 9030 LAM(I)=LAMBDA(I) C C COMMON RETURN POINT FOR ALL INITIALIZATIONS. C SET VALUES BACK IN CALLING PARAMETERS. C 9050 WRITE(6,661) EPSIL,RM,MXLAM,NPOTL 661 FORMAT('0 ENERGY IN UNITS OF EPSILON =',F15.5,' CM-1'/ 1 ' R IN UNITS OF RM =',F15.5,' ANGSTROMS'/ 2 '0 MXLAM =',I5/' NPOTL =',I5) C R=RM P(1)=EPSIL MPOTL=NPOTL MXLMB=MXLAM RETURN C 9100 WRITE(6,9101) IXMX 9101 FORMAT('0 * * * ERROR - IX .GT. IXMX',I4) STOP 9200 WRITE(6,9201) IEXMX 9201 FORMAT('0 * * * ERROR - IEX .GT. IEXMX',I4) STOP 9300 WRITE(6,9301) NPXMX 9301 FORMAT('0 * * * ERROR - NPX .GT. NPXMX',I4) STOP 9400 WRITE(6,9401) MXPLM 9401 FORMAT('0 * * * ERROR - MXLAM*(NPS OR NPT) .GT. MXPLM',I5) STOP END FUNCTION PLEG(N,X) C C SUBROUTINE TO GENERATE HERMITE POLYNOMIALS C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PLEG=1.0D0 IF(N.EQ.0) RETURN P0=1.0D0 P1=X DO 100 K=3,N+1 TEMP=(DBLE(2*K-3)*X*P1 - DBLE(K-2)*P0) / DBLE(K-1) P0=P1 P1=TEMP 100 CONTINUE PLEG=P1 RETURN END SUBROUTINE ASSLEG(P,LMAX,X,N) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P(N) P0=1.D0 P1=X P(1)=P0 P(2)=P1 IND=2 DO 100 L=2,LMAX TEMP=(DBLE(L+L-1)*X*P1-DBLE(L-1)*P0)/DBLE(L) P0=P1 P1=TEMP IND=IND+L P(IND)=P1 100 CONTINUE C C NOW THE ONES FOR K.GT.0 C NOTE THAT THIS ISN'T STABLE FOR HIGH ORDER AND X NEAR +/-1 C SINTH=SQRT(1.D0-X*X) DO 200 K=1,LMAX IND=K*(K+1)/2 DO 200 L=K,LMAX INDM=IND IND=IND+L INDP=IND+1 P(INDP)=-(DBLE(L-K+1)*X*P(IND)-DBLE(L+K-1)*P(INDM))/SINTH 200 CONTINUE RETURN END FUNCTION PASLEG(L,MM,X) C C CALCULATE NORMALISED ASSOCIATED LEGENDRE POLYNOMIALS C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P(450) NREQ=(L+1)*(L+2)/2 IF(NREQ.GT.450) THEN WRITE(6,601) L 601 FORMAT('0 *** ERROR IN PASLEG - NOT ENOUGH STORAGE FOR L=',I3) STOP ENDIF CALL ASSLEG(P,L,X,450) M=ABS(MM) IND=L*(L+1)/2+M+1 FAC=0.5D0*DBLE(L+L+1) DO 100 I=L-M+1,L+M FAC=FAC/DBLE(I) 100 CONTINUE PASLEG=P(IND)*SQRT(FAC) RETURN 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 GAUSHP(NPT,XPT,WHT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION XPT(NPT),WHT(NPT) C C This routine returns guass points and weights for C infinite integrals of the form: C f(x) * exp(-x**2) C the integral should be evaulated as the SUM(i=1,npt) C f(xpt(i)) * wht(i) C C Values taken from: C Stroud and Secrest, "Gaussian Quadrature Formulas" C Prentice-Hall, Inc.: Englewood Cliffs, NJ, 1966. C DIMENSION IOK(5),IST(5) DIMENSION X(13),W(13) DIMENSION X2(1),W2(1) DIMENSION X3(2),W3(2) DIMENSION X4(2),W4(2) DIMENSION X5(3),W5(3) DIMENSION X10(5),W10(5) EQUIVALENCE(X2(1),X( 1)),(W2(1),W( 1)) EQUIVALENCE(X3(1),X( 2)),(W3(1),W( 2)) EQUIVALENCE(X4(1),X( 4)),(W4(1),W( 4)) EQUIVALENCE(X5(1),X( 6)),(W5(1),W( 6)) EQUIVALENCE(X10(1),X( 9)),(W10(1),W( 9)) DATA MX/5/ DATA IOK /2,3,4,5,10/ DATA IST /1,2,4,6,9/ DATA X2( 1)/0.707106781186548D 00/,W2( 1)/0.886226925452758D 00/ DATA X3( 1)/0.122474487139159D 01/,W3( 1)/0.295408975150919D 00/ DATA X3( 2)/0.D0 /,W3( 2)/0.118163590060368D 01/ DATA X4( 1)/0.165068012388578D 01/,W4( 1)/0.813128354472452D-01/ DATA X4( 2)/0.524647623275290D 00/,W4( 2)/0.804914090005513D 00/ DATA X5( 1)/0.202018287045609D 01/,W5( 1)/0.199532420590459D-01/ DATA X5( 2)/0.958572464613819D 00/,W5( 2)/0.393619323152241D 00/ DATA X5( 3)/0.D0 /,W5( 3)/0.945308720482942D 00/ DATA X10( 1)/0.343615911883774D 01/,W10( 1)/0.764043285523262D-05/ DATA X10( 2)/0.253273167423279D 01/,W10( 2)/0.134364574678123D-02/ DATA X10( 3)/0.175668364929988D 01/,W10( 3)/0.338743944554811D-01/ DATA X10( 4)/0.103661082978951D 01/,W10( 4)/0.240138611082315D 00/ DATA X10( 5)/0.342901327223705D 00/,W10( 5)/0.610862633735326D 00/ C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C IF (NPT .LT. 2) GOTO 9999 DO 3000 I=1, MX IF(IOK(I).EQ.NPT) GO TO 3100 IF(IOK(I).LT.NPT) MXTRY=I 3000 CONTINUE WRITE(6,601) NPT,IOK(MXTRY) 601 FORMAT('0 * * * WARNING. Exponential Gaussian Integration: NPT =' + ,I4,' reduced to',I4) NPT=IOK(MXTRY) I=MXTRY 3100 N2=(NPT+1)/2 I1=1 I2=NPT IC=IST(I) DO 2000 I=1,N2 XPT(I1)=-X(IC) XPT(I2)=X(IC) WHT(I1)=W(IC) 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 * * * ERROR! Exponential Gaussian Integration', + ' with NPT =',I5,' requested') C REPLACE WITH SINGLE-POINT: XPT(1)=0. WITH WHT(1)=1. NPT=1 XPT(1)=0.D0 WHT(1)=1.D0 RETURN 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 * COSANG(1) IS THETA, COSANG(2) IS PHI, COSANG(3) RESERVED * C * FOR ITYPE=3. * C * SINCE IHOMO/ICNSYM CANNOT BE DETERMINED BY IOSBGP WITHOUT * C * ANGULAR EXPANSION TERMS, THEY MAY BE SET HERE IN /ANGLES/; * 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(3),FACTOR,IHOMO,ICNSYM 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 BAS9IN(PRTP,IBOUND) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE CHARACTER*8 PRTP(4),QNAME(10) LOGICAL LEVIN,EIN,LCNT DIMENSION ROTI(10),ELEVEL(200),JLEVEL(400) DIMENSION JLEV(1),VL(1),IV(1),CENT(1),J(1),L(1),LAM(1) DIMENSION WT(2) COMMON/CMBASE/ROTI,ELEVEL,EMAX,WT,SPNUC,JMIN,JMAX,J2MIN,J2MAX, 1 JSTEP,J2STEP,NLEVEL,JLEVEL,IDENT 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 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 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(200),JLEVEL(400) COMMON /CMBASE/ A(2),B(2),C(2),DJ,DJK,DK,DT, 1 ELEVEL,EMAX,WT,SPNUC,JMIN,JMAX,J2MIN,IPRTY, 1 JSTEP,J2STEP,NLEVEL,JLEVEL,IDENT 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 BASE (JTOT, JLEV, N, J, L, CINT, EINT, CENT, VL, IV, & MXLAM, NPOTL, LAM, WVEC, WGHT, 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 FUNCTIONS 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 . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE 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=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 THE NUMBER OF LEVELS IS IN NLEV AND NLEVEL. C QUANTUM NOS. AND INDEXING ARE IN JLEVEL(NLEVEL) AND C JLEV(NLEV,NQN). 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,2,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 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 DIMENSION ROTI(10),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2), 1 WEXE(2),WT(2),ELEVEL(200),EEE(211) C C ARRAYS FOR NAMELIST &BASIS C CHARACTER*6 BNAMES(37) C DIMENSION LOCN(37),INDX(37) DIMENSION JLEVEL(400) 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,ISYM,KSET) COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,JMIN,JMAX,J2MIN,J2MAX, 1 JSTEP,J2STEP,NLEVEL,JLEVEL,IDENT COMMON /PRBASE/ ITYPX,NQN,NLEV,MVALUE,IPAR,MPLMIN COMMON/VLSAVE/IVLU C 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,KSET,IVLU 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 4*' ', 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 MXLV IS DIMENSION OF COMMON ARRAY ELEVEL, HALF DIM OF JLEVEL. DATA MXLV/200/ 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'/ C DATA INDX/37*0/ C C SET UP BASIS FUNCTIONS C 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 ICODEX=ICODE IF (IDENT.EQ.0) GO TO 5303 IEXCH=(ICODE-1)/MXPAR3 + 1 IF (WT(IEXCH).NE.0.D0) GO TO 5304 IF (PRINT.GE.3) WRITE(6,690) JTOT,PTP(IEXCH) GO TO 5000 5304 ICODEX=ICODE-MXPAR3*(IEXCH-1) 5303 MVALUE=ICODEX/2 IF (ICODEX-2*MVALUE .EQ. 0) MVALUE=-MVALUE IF (MPLMIN) MVALUE=ICODEX-1 IPAR=MIN0(2,ICODEX) DO 5221 I=1,NLEV C SKIP IF J.LT.MVALUE OR EXCLUDED BY EXCHANGE SYMMETRY. IF (JLEV(IOFF+I).LT.IABS(MVALUE)) GO TO 5221 IF (IBOUND.NE.0 .AND. JTOT.LT.IABS(MVALUE)) GO TO 5221 IF (IDENT.NE.0 .AND. JLEV(I).EQ.JLEV(NLEV+I) .AND. & PARITY(IEXCH+JLEV(2*NLEV+I)+JTOT+JZCSFL*JLEV(IOFF+I)).LE.0.D0) & GO TO 5221 N=N+1 IF (LCNT) GO TO 5221 J(N)=I L(N)=IABS(JTOT+JZCSFL*JLEV(IOFF+I)) 5221 CONTINUE IF (LCNT) GO TO 5000 CALL MCGCPL(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,MVALUE,ITYPE,IEXCH, 1 VL,IV,PRINT) GO TO 8888 C C C CODE BELOW IS FOR RABITZ' EFFECTIVE POTENTIAL METHOD C HERE EACH 'STATE' IS A BASIS FUNCTION AND JTOT=O C 5202 N=0 IF (IDENT.EQ.0) GO TO 8001 IEXCH=ICODE IF (WT(IEXCH).NE.0.D0) GO TO 8001 IF (PRINT.GE.3) WRITE(6,690) JTOT,PTP(IEXCH) 690 FORMAT('0 * * *'/ 1 ' * * * NOTE. FOR JTOT =',I4,A8,'EXCHANGE PARITY SKIPPED' 2 ,' BECAUSE NUCLEAR STATISTICAL WEIGHT = 0.0'/' * * *'/'0') GO TO 5000 8001 DO 5210 I=1,NLEV IF (IDENT.NE.0 .AND. JLEV(I).EQ.JLEV(NLEV+I) .AND. 1 PARITY(IEXCH+JTOT).LE.0.D0) GO TO 5210 N=N+1 IF (LCNT) GO TO 5210 J(N)=I L(N)=JTOT 5210 CONTINUE IF (LCNT) GO TO 5000 GO TO 8000 C C C CODE BELOW OF AUG 74 IS UNIFIED ITYPE=1,2,3,5 CODE. C N.B. BASIS FUNCTIONS ARE ORDERED ON L AS IN GORDON'S CODE. C 5201 N=0 IPAR=ICODE-2*(ICODE/2) IF (IDENT.EQ.0) GO TO 8002 IEXCH=(ICODE+1)/2 IF (WT(IEXCH).NE.0.D0) GO TO 8002 IF (PRINT.GE.3) WRITE(6,690) JTOT,PTP(IEXCH) GO TO 5000 8002 LMAX=JTOT+JMAX LMIN=JTOT-JMAX IF (LMIN.GE.0) GO TO 4101 LMIN=JMIN-JTOT IF (LMIN.LT.0) LMIN=0 4101 DO 4201 LI=LMIN,LMAX JK=IABS(JTOT-LI) JTOP=JTOT+LI DO 4201 I=1,NLEV C GO TO IGO, (9001, 9003, 9005, 9006) 9001 JI=JLEV(I) LPJ=LI+JI+JTOT GO TO 4005 9003 JI=JLEV(2*NLEV+I) C FOR IDENTICAL PARTICLES SKIP IMMEDIATELY IF FUNCTION VANISHES. IF (IDENT.NE.0 .AND. JLEV(I).EQ.JLEV(NLEV+I) .AND. 1 PARITY(IEXCH+JI+LI).LE.0.D0) GO TO 4201 LPJ=JLEV(I)+JLEV(NLEV+I)+LI+JTOT GO TO 4005 9005 JI=JLEV(I) LPJ=JI+JLEV(I+NLEV)+JLEV(I+2*NLEV)+LI+JTOT GO TO 4005 9006 JI=JLEV(I) LPJ=JLEV(2*NLEV+I) LPJ=LPJ+LPJ/2+JI+LI+JTOT GO TO 4005 C 4005 IF ( (LPJ-2*(LPJ/2)) .NE. IPAR) GO TO 4201 IF (JI.LT.JK .OR. JI.GT.JTOP) GO TO 4201 N=N+1 IF (LCNT) GO TO 4201 J(N)=I L(N)=LI 4201 CONTINUE IF (LCNT) GO TO 5000 GO TO 8000 C 5209 CALL BASE9(LCNT,N,JTOT,ICODE,JLEV,NLEV,NQN,J,L) IF(LCNT) GO TO 5000 CALL CPL9(N,ICODE,NPOTL,LAM,MXLAM,NLEV,JLEV,J,L,JTOT, 1 VL,IV,CENT,IBOUND,IEXCH,PRINT) GO TO 8888 C C * * BASIS FUNCTIONS ARE NOW SET-UP IN J(I), L(I), I=1,N. C C STORE MATRIX ELEMENTS OF THE COUPLING POTENTIAL IN VL. 8000 CALL COUPLE(N,ITYPE,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,JTOT, 1 VL,IV,IEXCH,PRINT) GO TO 8888 C C CODE FOR SURFACE SCATTERING C 5208 CALL SURBAS(JLEV, N, J, L, EINT, CENT, VL, IV, 1 MXLAM, NPOTL, LAM, ERED, WVEC, LCNT, THETA, PHI, EMAXK) IF(LCNT) GOTO 5000 C 8888 IF(ITYPE.EQ.8) GO TO 4000 C C NOW CALCULATE THE DIAGONAL MATRIX ELEMENTS OF THE HAMILTONIAN C DO 30 I=1,N C FIRST THE INTERNAL ROTATIONAL ENERGY EINT(I)=CINT * ELEVEL(JLEV(NLEV*(NQN-1)+J(I))) DIF=ERED-EINT(I) WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) C NOW THE CENTRIFUGAL POTENTIAL IF(IBOUND.EQ.0) THEN CENT(I)=DBLE(L(I)*(L(I)+1)) ELSE IF(ITYPE.GE.21 .AND. ITYPE.LE.27) THEN C SPECIAL CASE FOR HELICITY DECOUPLING FOR BOUND STATES JK=JLEV(IOFF+J(I)) CENT(I)=DBLE(JTOT*(JTOT+1)+JK*(JK+1)-2*MVALUE*MVALUE) L(I)=SQRT(CENT(I)) ELSEIF(ITP.NE.9) THEN C ARRIVE HERE IF IBOUND=1 AND NOT BUILT-IN COUPLED STATES. C FOR ITYPE=9, IBOUND=1 IS A FLAG TO LEAVE CENT ALONE. C OTHERWISE, SET IT FROM L AS IF IBOUND=0 CENT(I)=DBLE(L(I)*(L(I)+1)) ENDIF ENDIF 30 CONTINUE C C THIS COMPLETES THE SPECIFICATION OF THE BASIS BY GIVING VALUES C TO ALL RELEVANT MATRIX ELEMENTS C 4000 IF (PRINT.LT.5) GOTO 4020 WRITE(6,300) 300 FORMAT('0 CHANNEL NO. TARGET LEVEL ORBITAL L TARGET ENERGY', 1 '(1/CM)') DO 4010 I=1,N ECI=EINT(I)/CINT 4010 WRITE(6,301) I,J(I),L(I),ECI 301 FORMAT(1X,I9,2I12,F21.7) IF (PRINT.GT.25) CALL CPLOUT(IV,VL,N,NPOTL) 4020 CONTINUE C C COMPUTE STATISTICAL WEIGHT FOR THIS SYMMETRY BLOCK C WGHT=1.D0 IF (IEXCH.GT.0) WGHT=WGHT*WT(MIN0(2,IEXCH)) IF (IPAR.GT.0) WGHT=WGHT*WTM(MIN0(2,IPAR)) 5000 IF(N.LE.0) N=0 RETURN C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY BASIN(NLEVV,JLEV,URED,NQ,NLABV,MXPAR,ITYPP,IOSFLG) C C WRITE(6,610) 610 FORMAT(/'0 /BASIS/ DATA ARE --') C C SET DEFAULT VALUES BEFORE READ(5,BASIS). IOFF=0 NLEVEL=0 JMIN=0 JMAX=0 JSTEP=1 J2MIN=0 J2MAX=0 J2STEP=1 EMAX=0.D0 EMAXK=0.D0 DO 1103 I=1,211 1103 EEE(I)=0.D0 DO 1104 I=1,400 1104 JLEVEL(I)=0 DO 1105 I=1,3 1105 IOSNGP(I)=0 IPHIFL=0 IDENT=0 IEXCH=0 WT(1)=0.D0 WT(2)=0.D0 IPAR=0 WTM(1)=1.D0 WTM(2)=1.D0 MPLMIN=.TRUE. EUNITS=0 JZCSMX=-1 IBOUND=0 JZCSFL=0 IASYMU=0 ISYM=-1 IVLU=0 C C---------------------------------------------------------------- C LOCN ARRAY FOR NAMELIST SIMULATOR C INDX(28)=4 C LOCN(1)=LOC(ROTI) C LOCN(2)=LOC(JMIN) C LOCN(3)=LOC(JMAX) C LOCN(4)=LOC(JSTEP) C LOCN(5)=LOC(ITYPE) C LOCN(6)=LOC(NLEVEL) C LOCN(7)=LOC(JLEVEL) C LOCN(8)=LOC(ELEVEL) C LOCN(9)=LOC(EMAX) C LOCN(10)=LOC(EMAXK) C LOCN(11)=LOC(BE) C LOCN(12)=LOC(ALPHAE) C LOCN(13)=LOC(DE) C LOCN(14)=LOC(A) C LOCN(15)=LOC(B) C LOCN(16)=LOC(C) C LOCN(17)=LOC(WE) C LOCN(18)=LOC(WEXE) C LOCN(19)=LOC(J1MAX) C LOCN(20)=LOC(J1MIN) C LOCN(21)=LOC(J2MAX) C LOCN(22)=LOC(J2MIN) C LOCN(23)=LOC(J1STEP) C LOCN(24)=LOC(J2STEP) C LOCN(25)=LOC(WT) C LOCN(26)=LOC(IDENT) C LOCN(27)=LOC(SPNUC) C LOCN(28)=LOC(EUNITS) C LOCN(29)=LOC(IASYMU) C LOCN(30)=LOC(JZCSMX) C LOCN(31)=LOC(IBOUND) C LOCN(32)=LOC(JZCSFL) C LOCN(33)=LOC(IOSNGP) C LOCN(34)=LOC(IPHIFL) C LOCN(35)=LOC(ISYM) C LOCN(36)=LOC(KSET) C LOCN(37)=LOC(IVLU) C CALL NAMLIS('&BASIS',BNAMES,LOCN,INDX,37,IEOF) C---------------------------------------------------------------- READ(5,BASIS) C C *** CHECK FIRST OF ALL FOR IOS CASES, INDICATED BY ITYPE.GT.100 IF (ITYPE.LT.100) GO TO 1999 C WRITE(6,601) 601 FORMAT('0 ',19('*')/3X,'****** I O S ******'/3X,19('*')) C FORCE CORRECT IOSFLG. NLEVV HAS MXA FOR IOSBIN IOSFLG=1 MXA=NLEVV CALL IOSBIN(NLEVV,ITYPE,JLEV,MXA,IASYMU,IPHIFL,IOSNGP) C RESTORE APPROPRIATE ARGUMENT VARIABLES ITYPP=ITYPE IXNEXT=IXNEXT+MXA RETURN C C *** CONTINUE WITH COUPLED CHANNEL CASES 1999 NLEV=NLEVEL IF(EMAXK.EQ.0.D0) EMAXK=EMAX C CALL ECNV(EUNITS,EFACT) JZCSFL=MAX0(MIN0(JZCSFL,1),-1) IF(ITYPE.EQ.8) GOTO 6902 DO 6901 I=1,210 6901 EEE(I)=EEE(I)*EFACT 6902 EMAX=EMAX*EFACT EMAXK=EMAXK*EFACT C C PROCESS ITYPE . . . C ITP=ITYPE-10*(ITYPE/10) IF(ITP.NE.6) IVLU=0 IF(ITP.EQ.7) ITP=2 IF(ITP.NE.9) GO TO 6837 CALL BAS9IN(PRTP(1,9),IBOUND) GO TO 3100 6837 IF (ITYPE.LE.10) GO TO 3100 IF (ITYPE.LE.20) GO TO 3200 IF (ITYPE.LE.30) GO TO 3300 WRITE(6,663) 663 FORMAT('0 DECOUPLED L-DOMINANT APPROX. OF DEPRISTO AND ALEXANDER', 1 ' WILL BE USED.') GO TO 3100 3300 WRITE(6,662) ITYPE,JZCSFL 662 FORMAT('0 COUPLED STATES APPROXIMATION OF MCGUIRE AND KOURI ', 1 '(C.F. J. CHEM. PHYS. 60, 2488 (1974)) WILL BE USED.'/ 2 '0',10X,'ITYPE =',I3/' ',10X,'L(I) = JTOT + (',I2,') * J(I)') IF(IBOUND.NE.0) WRITE(6,664) 664 FORMAT('0 DIAGONAL CORIOLIS TERM INCLUDED IN CENTRIFUGAL ', 1 'POTENTIAL') GO TO 3100 3200 WRITE(6,661) ITYPE 661 FORMAT('0 *EFFECTIVE POTENTIAL METHOD* WILL BE USED.', 1 ' SEE H. RABITZ, J. CHEM. PHYS. 57, 1718 (1972).'/ 2 '0 ITYPE =',I4) 3100 WRITE(6,600) (PRTP(JJ,ITP),JJ=1,4) 600 FORMAT('0 COLLISION TYPE IS ', 4A8) IF(ITYPE-10*(ITYPE/10).EQ.7) WRITE(6,6840) 6840 FORMAT('0 ITYPE = 10*N+7 OPTION. ALL POTENTIAL MATRICES WILL BE', 1 ' CONSTRUCTED FROM POTENTIAL TERMS IN WHICH DIATOM STRETCHING'/ 2 ' DEPENDENCE IS PROPERLY AVERAGED OVER RELEVANT (V,J) AND', 3 ' (V'',J'') DIATOM INTERNAL STATES.') C C PROCESS EXCHANGE SYMMETRY FOR IDENTICAL PARTICLES CALL IDPART(ITYPE,IDENT,SPNUC,WT) C C DETERMINE EIN AND LEVIN WHICH DENOTE WHETHER ELEVEL AND JLEV ARE C TAKEN FROM INPUT ELEVEL AND JLEVEL OR ARE CALCULATED. C IF (NLEVEL.GT.0) GO TO 7000 LEVIN=.FALSE. EIN=.FALSE. GO TO 7100 7000 LEVIN=.TRUE. EIN=.TRUE. DO 7200 I=1,NLEVEL IF (ELEVEL(I).NE.0.D0) GO TO 7100 7200 CONTINUE C IF WE REACH THIS POINT ELEVEL(I) ARE ALL ZERO. EIN=.FALSE. 7100 IF (EIN .OR. ITP.EQ.6) GO TO 7600 DO 7400 I=1,10 IF (ROTI(I).NE.0.D0) GO TO 7600 7400 CONTINUE WRITE(6,630) 630 FORMAT('0 * * * ERROR. ENERGY LEVELS CAN BE OBTAINED NEITHER ', 1 'FROM ELEVEL NOR ROTI INPUT.') WRITE(6,629) 629 FORMAT('0 * * * EXECUTION TERMINATING.') STOP 7600 CONTINUE C C PROCESS ACCORDING TO ITYPE. C IF (ITYPE.EQ.1.OR.ITYPE.EQ.11.OR.ITYPE.EQ.21.OR.ITYPE.EQ.31) 1 GO TO 1001 IF (ITYPE.EQ.2.OR.ITYPE.EQ.12.OR.ITYPE.EQ.22.OR.ITYPE.EQ.32) 1 THEN IVLFL=0 GO TO 1002 ENDIF IF (ITYPE.EQ.3.OR.ITYPE.EQ.13.OR.ITYPE.EQ.23) GO TO 1003 IF (ITYPE.EQ.5.OR.ITYPE.EQ.15.OR.ITYPE.EQ.25) GO TO 1005 IF (ITYPE.EQ.6.OR.ITYPE.EQ.16.OR.ITYPE.EQ.26) GO TO 1006 IF (ITYPE.EQ.7.OR.ITYPE.EQ.17.OR.ITYPE.EQ.27.OR.ITYPE.EQ.37) 1 THEN IVLFL=1 GO TO 1002 ENDIF IF (ITYPE.EQ.8) GO TO 1008 IF (ITP.EQ.9) GO TO 1009 C C NO IMPLEMENTATION FOR OTHER TYPES OF COLLISION PARTNERS. WRITE(6,611) ITYPE 611 FORMAT('0 ILLEGAL ITYPE =',I8,', EXECUTION TERMINATING.') STOP C C C * * * * * ITYPE = 1 * * * * * C 1001 IVLFL=0 ASSIGN 9001 TO IGO ASSIGN 3901 TO IGODG 1111 NQN=2 QNAME(1)=QTYPE(1) MXPAR=2 CALL SET1(LEVIN,EIN,NLEV,JLEV) IF (ITYPE.LE.10) GO TO 2000 IF (ITYPE.LE.20) GO TO 1311 IF (ITYPE.LE.30) GO TO 1411 C PROCESSING FOR DLD GO TO 1400 C MODIFICATIONS FOR COUPLED STATES . . . 1411 GO TO 1020 C MODIFICATIONS NECESSARY FOR EFFECTIVE POTENTIAL METHOD. . . 1311 ASSIGN 3911 TO IGODG MXPAR=1 GO TO 2000 C C * * * * * ITYPE = 2 OR ITYPE = 7 * * * * * C DIATOM VIB-ROTOR PLUS ATOM - ADDED FEB 76 C 1002 ASSIGN 9001 TO IGO ASSIGN 3902 TO IGODG NQN=3 MXPAR=2 QNAME(1)=QTYPE(1) QNAME(2)=QTYPE(7) CALL SET2(LEVIN,EIN,NLEV,JLEV) IF (ITYPE.LE.10) GO TO 2000 IF (ITYPE.LE.20) GO TO 1312 IF (ITYPE.LE.30) GO TO 1412 GO TO 1400 1412 GO TO 1020 1312 ASSIGN 3912 TO IGODG MXPAR=1 GO TO 2000 C C * * * * * ITYPE = 3 * * * * * C LINEAR ROTOR - LINEAR ROTOR ADDED AUG. 1974. C 1003 NQN=4 IVLFL=0 ASSIGN 9003 TO IGO ASSIGN 3903 TO IGODG QNAME(1)=QTYPE(4) QNAME(2)=QTYPE(5) QNAME(3)=QTYPE(6) MXPAR=2 CALL SET3(LEVIN,EIN,NLEV,JLEV) IF (ITYPE.LE.10) GO TO 7703 IF (ITYPE.LE.20) GO TO 1013 C CHANGES TO ACCOMMODATE COUPLED STATES APPROX. IOFF=2*NLEV C SG (MAR.19.93) USE MPLMIN=.TRUE. EVEN FOR ITYPE=23 W/ IDENT=1 C THIS INTRODUCES AT MOST PARITY(J12+J12P+LM) INTO S-MATRIX C WHICH DOES NOT AFFECT STATE-TO-STATE CROSS SECTIONS C HOWEVER, OUTPUT A WARNING MESSAGE. IF (IDENT.NE.0) WRITE(6,603) 603 FORMAT(/' *** WARNING. FOR ITYPE=23, MPLMIN=TRUE SHOULD GIVE', 1 ' CORRECT STATE-TO-STATE CROSS SECTIONS.'/ 2 ' *** IT MAY GIVE INCORRECT PHASES FOR', 3 ' GENERALIZED CROSS SECTIONS.') C MPLMIN=.FALSE. <-- ORIGINAL C IF (IDENT.EQ.0) MPLMIN=.TRUE. <-- CODE GO TO 1020 C PROCESS JLEVEL TO JLEV FOR 'EPM' CASE 1013 NQN=3 MXPAR=1 ASSIGN 3913 TO IGODG DO 7713 I=1,NLEV JLEV(I)=JLEVEL(2*I-1) JLEV(NLEV+I)=JLEVEL(2*I) 7713 JLEV(2*NLEV+I)=I 7703 IF (IDENT.NE.0) MXPAR=2*MXPAR GO TO 2000 C C C * * * * * ITYPE = 5 * * * * * C 1005 NQN=4 IVLFL=0 ASSIGN 9005 TO IGO ASSIGN 3905 TO IGODG QNAME(1)=QTYPE(1) QNAME(2)=QTYPE(2) QNAME(3)=QTYPE(3) MXPAR=2 CALL SET5(LEVIN,EIN,NLEV,JLEV) IF (ITYPE.LE.10) GO TO 2000 IF (ITYPE.LE.20) GO TO 1015 C MODIFICATIONS FOR COUPLED STATES. . . GO TO 1020 C MODIFICATIONS FOR EFFECTIVE POTENTIAL . . . 1015 ASSIGN 3915 TO IGODG MXPAR=1 GO TO 2000 C C * * * ITYPE = 6 * * * C ASYMMETRIC TOP - ATOM ADDED JULY 76 AT MPI, MUNCHEN. C 1006 ASSIGN 9006 TO IGO ASSIGN 3906 TO IGODG IVLFL=0 QNAME(1)=QTYPE(1) QNAME(2)=QTYPE(8) QNAME(3)=QTYPE(3) QNAME(4)=QTYPE(9) QNAME(5)=QTYPE(9) NQN=6 MXPAR=2 CALL SET6(LEVIN,EIN,NLEV,JLEV,JLEV,EFACT,IASYMU) IF (ITYPE.LE.10) GO TO 2000 IF (ITYPE.LE.20) GO TO 1316 IF (ITYPE.LE.30) GO TO 1416 C ADDITIONAL PROCESSING FOR COUPLED STATES. 1416 GO TO 1020 C ADDITIONAL PROCESSING FOR EFFECTIVE POTENTIAL. 1316 MXPAR=1 ASSIGN 3916 TO IGODG GO TO 2000 C 1009 ASSIGN 3909 TO IGODG C N.B. CODE HERE OR IN SET9 SHOULD ASSIGN APPROPRIATE IVLFL CALL SET9(LEVIN,EIN,NLEV,JLEV,NQN,QNAME,MXPAR,NLABV) GOTO 2000 C C **** MCGUIRE COUPLED STATES APPROX. **** C **** ALSO FOR DLD OF DEPRISTO AND ALEXANDER 1020 WTM(1)=1.D0 WTM(2)=1.D0 IF (.NOT.MPLMIN) GO TO 1400 WTM(2)=2.D0 WRITE(6,604) 604 FORMAT(/' *** NOTE. IN CS CALCULATION MINUS/PLUS M-VALUE ', & 'ASSUMED TO BE IDENTICAL.') 1400 MJMX=0 DO 1121 I=1,NLEV 1121 MJMX=MAX0(MJMX,JLEV(IOFF+I)) IF (JZCSMX.LT.0) GO TO 1221 WRITE(6,6221) JZCSMX 6221 FORMAT('0 * * * NOTE. IN CS OR DLD APPROXIMATION SUBSPACE IS ', & 'LIMITED BY JZCSMX =',I3,'. CROSS SECTIONS BETWEEN HIGHER J ', & 'NO GOOD.') MJMX=MIN0(MJMX,JZCSMX) 1221 MXPAR=MJMX+1 IF (.NOT.MPLMIN) MXPAR=MXPAR+MJMX IF (ITYPE.EQ.31 .OR. ITYPE.EQ.32 .OR. ITYPE.EQ.37) 1 MXPAR=MXPAR+MJMX IF (ITYPE.NE.23) GO TO 2000 MXPAR3=MXPAR IF (IDENT.NE.0) MXPAR=2*MXPAR GO TO 2000 C C * * * ITYPE = 8 * * * C ATOM - SURFACE SCATTERING: ADDED AT WATERLOO, DEC 1982 C 1008 NQN=3 C IVLFL SET TO REFLECT USE OF IV() ARRAY IN EXTANT ITYPE=8 CODES. IVLFL=1 ASSIGN 3918 TO IGODG QNAME(1)=QTYPE(4) QNAME(2)=QTYPE(5) CALL SET8(LEVIN,EIN,NLEV,JLEV,URED) GO TO 2000 C C FINAL BOOKKEEPING. C 2000 IXNEXT = IXNEXT + NLEV*NQN NQ = NQN QNAME(NQN)=QTYPE(10) C IF(NLEVEL.LE.MXLV) GOTO 1224 WRITE(6,619) NLEVEL 619 FORMAT('0 **** ERROR IN BASE. NOT ENOUGH STORAGE FOR',I4, 1 ' LEVELS - TERMINATING') STOP 1224 NLEVV=NLEV ITYPP=ITYPE ITYPX=ITYPE IF(ITYPE-10*(ITYPE/10).EQ.7) ITYPX=ITYPE-5 C C AFTER MAY 76 IPAR USED IN PLACE OF IEXCH FOR CS WEIGHTING. C WRITE(6,620) (QNAME(I),I=1,NQN) 620 FORMAT('0 LEVEL ENERGY(1/CM) ',10A8) JJ=NLEV*(NQN-1) DO 2100 I=1,NLEV JTOP=JJ+I 2100 WRITE(6,621) I,ELEVEL(JLEV(JJ+I)),(JLEV(JI),JI=I,JTOP,NLEV) 621 FORMAT(' ',I4,F18.7,I6,9(I8) ) C C ALLOW FOR INITIALIZATION OF COUPLE/MCGCPL ROUTINES CALL COUPLX CALL MCGCPX RETURN C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ENTRY DEGENF(J2,J1,DEGEN) C C RETURNS DEGENERACY FACTOR FOR DENOMINATOR OF CROSS-SECTION CALC. C IN OUTPUT. J1 IS INITIAL, J2 IS FINAL LEVEL. C MODIFIED AUG. 74 SO THAT LEVELS REFER TO JLEVEL VALUES. C GO TO IGODG,(3901,3902,3903,3905,3906,3909,3911,3912,3913, 1 3915,3916,3918) 3901 JI=JLEVEL(J1) DEGEN=DBLE(2*JI+1) RETURN 3902 JI=JLEVEL(2*J1-1) DEGEN=DBLE(2*JI+1) RETURN 3903 JI1=JLEVEL(2*J1-1) JI2=JLEVEL(2*J1) DEGEN=DBLE((2*JI1+1)*(2*JI2+1)) IF (IDENT.EQ.0) RETURN IF (JI1.EQ.JI2) DEGEN=DEGEN/2.D0 IF (JLEVEL(2*J2-1).EQ.JLEVEL(2*J2)) DEGEN=DEGEN/2.D0 RETURN 3905 JI=JLEVEL(3*J1-2) DEGEN=DBLE(2*JI+1) RETURN 3906 JI=JLEVEL(2*J1-1) DEGEN=DBLE(2*JI+1) RETURN 3909 CALL DEGEN9(J1,J2,DEGEN) RETURN C C FOLLOWING ARE DEGENERACY DENOMINATORS FOR EPM COUNTING CORRECTION. 3911 JI1=JLEVEL(J1) JF1=JLEVEL(J2) DEGEN=SQRT(DBLE(2*JI1+1)/DBLE(2*JF1+1)) RETURN 3912 JI1=JLEVEL(2*J1-1) JF1=JLEVEL(2*J2-1) DEGEN=SQRT(DBLE(2*JI1+1)/DBLE(2*JF1+1)) RETURN 3913 JI1=JLEVEL(2*J1-1) JI2=JLEVEL(2*J1) JF1=JLEVEL(2*J2-1) JF2=JLEVEL(2*J2) DEGEN=SQRT(DBLE((2*JI1+1)*(2*JI2+1)) / 1 DBLE((2*JF1+1)*(2*JF2+1)) ) IF (IDENT.EQ.0) RETURN IF (JI1.EQ.JI2) DEGEN=DEGEN/2.D0 IF (JF1.EQ.JF2) DEGEN=DEGEN/2.D0 RETURN 3915 JI1=JLEVEL(3*J1-2) JF1=JLEVEL(3*J2-2) DEGEN=SQRT(DBLE(2*JI1+1)/DBLE(2*JF1+1)) RETURN 3916 JI1=JLEVEL(2*J1-1) JF1=JLEVEL(2*J2-1) DEGEN=SQRT(DBLE(2*JI1+1)/DBLE(2*JF1+1)) RETURN 3918 DEGEN=1.D0 RETURN END SUBROUTINE CHECK6(N,JL,A) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION JL(N,6),A(1) DATA EPS/7.D-6/ WRITE(6,600) 600 FORMAT('0 CHECK6. INPUT FUNCTIONS WILL BE CHECKED FOR ', & 'ORTHOGONALITY.') NERR=0 DO 1000 I1=2,N DO 1000 I2=1,I1-1 C SEE IF SAME J-VALUE IF (JL(I2,1).NE.JL(I1,1)) GO TO 1000 C CHECK THAT NK AGREE NK1=JL(I1,5) NK2=JL(I2,5) 3000 IF (NK1.EQ.NK2) GO TO 1001 WRITE(6,699) I1,I2,NK1,NK2 699 FORMAT('0 ***** CHECK6 ERROR. FOR LEVELS',2I4,', NK NOT EQUAL.', & 2I5) NERR=NERR+1 GO TO 1000 1001 SUM=0.D0 DO 1100 II=1,NK1 1100 SUM=SUM+A(JL(I1,4)+II)*A(JL(I2,4)+II) IF (ABS(SUM).LE.EPS) GO TO 1000 WRITE(6,698) I1,I2,SUM 698 FORMAT('0 ***** CHECK6 ERROR. LEVEL',2I4,' ARE NOT ORTHOGONAL.', & ' OVERLAP =',D12.4) NERR=NERR+1 1000 CONTINUE IF (NERR.LE.0) RETURN WRITE(6,697) NERR 697 FORMAT('0 *****'/' ***** CHECK6. NUMBER OF ERRORS =',I4/ 1 ' ***** EXECUTION TERMINATING UNLESS CHECK6 MODIFIED'/ 2 ' *****') STOP END SUBROUTINE COUPLE(N,ITYPE,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,JTOT, 1 VL,IV,IEX,PRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE LFIRST INTEGER PRINT DIMENSION LAM(1),JLEV(NLEV,3),J(N),L(N) DIMENSION VL(1),IV(1) LOGICAL LFIRST,ODD C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA EPS/1.D-10/ C CONST IS FACTOR (4.*PI)**(-3/2) DATA CONST/2.24483902656458321D-2/ C C STATEMENT FUNCTIONS Z(I)=DBLE(I+I+1) ODD(I)=I-2*(I/2).NE.0 C SQRTHF=SQRT(.5D0) C IF (ITYPE.EQ.1 .OR. ITYPE.EQ.31) GO TO 8001 IF (ITYPE.EQ.2 .OR. ITYPE.EQ.32) GO TO 8002 IF (ITYPE.EQ.7 .OR. ITYPE.EQ.37) GO TO 8007 IF (ITYPE.EQ.3) GO TO 8003 IF (ITYPE.EQ.5) GO TO 8005 IF (ITYPE.EQ.6) GO TO 8006 IF (ITYPE.EQ.11) GO TO 6001 IF (ITYPE.EQ.12) GO TO 6002 IF (ITYPE.EQ.13) GO TO 6003 IF (ITYPE.EQ.15) GO TO 6005 IF (ITYPE.EQ.16) GO TO 6006 IF (ITYPE.EQ.17) GO TO 6007 WRITE(6,698) ITYPE 698 FORMAT('0 * * * ERROR. COUPLING MATRIX ELEMENTS NOT IMPLEMENTED', 1 ' FOR ITYPE =',I12) STOP C C COUPLING FOR ATOM + RIGID LINEAR ROTOR C THIS VERSION BY JMH, JUNE 93, TO REDUCE NON-VECTORIZABLE CODE C 8001 IF (IVLFL.NE.0) GO TO 9999 DO 1511 LL=1,MXLAM NNZ=0 I=LL JSAV=-1 LSAV=-1 ITJ=IXNEXT ITL=ITJ+2*LAM(LL)+1 IT6=ITL+2*LAM(LL)+1 IXNEXT=IT6+2*LAM(LL)+1 J6JMAX=2*LAM(LL)+1 NUSED=0 CALL CHKSTR(NUSED) DO 1501 ICOL=1,N JCOL=JLEV(J(ICOL),1) C C GET ALL ZERO-PROJECTION 3J SYMBOLS FOR THIS JCOL, LAMBDA C IF (JCOL.NE.JSAV) THEN CALL J3J000(DBLE(JCOL),DBLE(LAM(LL)),IVALJ,X(ITJ),XJMIN) JMIN=IABS(JCOL-LAM(LL)) JMAX=JCOL+LAM(LL) JSAV=JCOL ENDIF C C GET ALL ZERO-PROJECTION 3J SYMBOLS FOR THIS LCOL, LAMBDA C IF (L(ICOL).NE.LSAV) THEN CALL J3J000(DBLE(L(ICOL)),DBLE(LAM(LL)),IVALL,X(ITL),XLMIN) LMIN=IABS(L(ICOL)-LAM(LL)) LMAX=L(ICOL)+LAM(LL) LSAV=L(ICOL) ENDIF LSAV6=-1 C DO 1501 IROW=1,ICOL JROW=JLEV(J(IROW),1) IF (JROW.LT.JMIN .OR. JROW.GT.JMAX 1 .OR. L(IROW).LT.LMIN .OR. L(IROW).GT.LMAX 2 .OR. ODD(JROW+JMAX) .OR. ODD(L(IROW)+LMAX)) THEN VL(I)=0.D0 ELSE C C GET ALL 6J SYMBOLS FOR THIS JCOL, LCOL, JROW, LAMBDA, JTOT, C CHECKING WHETHER LROW HAS CHANGED SINCE THE LAST CALL TO J6J C IF (L(IROW).NE.LSAV6) THEN IVAL6=J6JMAX CALL J6J(DBLE(L(IROW)),DBLE(JTOT),DBLE(L(ICOL)),DBLE(JCOL), 1 DBLE(LAM(LL)),IVAL6,XJMIN6,X(IT6)) JMIN6=INT(XJMIN6) LSAV6=L(IROW) ENDIF IF (JROW.LT.JMIN6 .OR. JROW.GE.JMIN6+IVAL6) THEN VL(I)=0.D0 ELSE C C CALCULATE THE PERCIVAL-SEATON COEFFICIENT USING THE STORED C 3-J AND 6-J SYMBOLS. C C ARRIVE HERE ONLY IF THE TRIANGLE RELATIONSHIPS ARE SATISFIED, C AND IF JCOL+LAMBDA+JROW AND LCOL+LAMBDA+LROW ARE EVEN. C NOTE THAT ONLY 3-J SYMBOLS FOR WHICH THIS IS TRUE ARE STORED. C INDJ=ITJ+(JROW-JMIN)/2 INDL=ITL+(L(IROW)-LMIN)/2 IND6=IT6+JROW-JMIN6 VL(I)=SQRT(Z(JCOL)*Z(JROW)*Z(L(ICOL))*Z(L(IROW))) 2 *X(INDJ)*X(INDL)*X(IND6) IF (ODD(JCOL+JROW+JTOT)) VL(I)=-VL(I) IF (VL(I).NE.0.D0) NNZ=NNZ+1 ENDIF ENDIF 1501 I=I+NPOTL IF (NNZ.LE.0) WRITE(6,612) JTOT,LL 612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING ', 1 'COEFFICIENTS ARE 0.0 FOR SYMMETRY',I4) IXNEXT=ITJ 1511 CONTINUE RETURN C C COUPLING FOR VIBROTOR - ATOM C 8002 IF (IVLFL.NE.0) GO TO 9999 DO 1512 LL=1,MXLAM LLL=LAM(3*LL-2) JV1=LAM(3*LL-1) JV2=LAM(3*LL) NNZ=0 I=LL JSAV=-1 LSAV=-1 ITJ=IXNEXT ITL=ITJ+2*LLL+1 IT6=ITL+2*LLL+1 IXNEXT=IT6+2*LLL+1 J6JMAX=2*LLL+1 NUSED=0 CALL CHKSTR(NUSED) DO 1502 ICOL=1,N JCOL=JLEV(J(ICOL),1) JVCOL=JLEV(J(ICOL),2) C C GET ALL ZERO-PROJECTION 3J SYMBOLS FOR THIS JCOL, LAMBDA C IF (JCOL.NE.JSAV) THEN CALL J3J000(DBLE(JCOL),DBLE(LLL),IVALJ,X(ITJ),XJMIN) JMIN=IABS(JCOL-LLL) JMAX=JCOL+LLL JSAV=JCOL ENDIF C C GET ALL ZERO-PROJECTION 3J SYMBOLS FOR THIS LCOL, LAMBDA C IF (L(ICOL).NE.LSAV) THEN CALL J3J000(DBLE(L(ICOL)),DBLE(LLL),IVALL,X(ITL),XLMIN) LMIN=IABS(L(ICOL)-LLL) LMAX=L(ICOL)+LLL LSAV=L(ICOL) ENDIF LSAV6=-1 C DO 1502 IROW=1,ICOL JROW=JLEV(J(IROW),1) JVROW=JLEV(J(IROW),2) IF (JROW.LT.JMIN .OR. JROW.GT.JMAX 1 .OR. L(IROW).LT.LMIN .OR. L(IROW).GT.LMAX 2 .OR. ODD(JROW+JMAX) .OR. ODD(L(IROW)+LMAX) 3 .OR. .NOT. ((JVCOL.EQ.JV1 .AND. JVROW.EQ.JV2) 4 .OR. (JVCOL.EQ.JV2 .AND. JVROW.EQ.JV1))) THEN VL(I)=0.D0 ELSE C C GET ALL 6J SYMBOLS FOR THIS JCOL, LCOL, JROW, LAMBDA, JTOT, C CHECKING WHETHER LROW HAS CHANGED SINCE THE LAST CALL TO J6J C IF (L(IROW).NE.LSAV6) THEN IVAL6=J6JMAX CALL J6J(DBLE(L(IROW)),DBLE(JTOT),DBLE(L(ICOL)),DBLE(JCOL), 1 DBLE(LLL),IVAL6,XJMIN6,X(IT6)) JMIN6=INT(XJMIN6) LSAV6=L(IROW) ENDIF IF (JROW.LT.JMIN6 .OR. JROW.GE.JMIN6+IVAL6) THEN VL(I)=0.D0 ELSE C C CALCULATE THE PERCIVAL-SEATON COEFFICIENT USING THE STORED C 3-J AND 6-J SYMBOLS. C C ARRIVE HERE ONLY IF THE TRIANGLE RELATIONSHIPS ARE SATISFIED, C AND IF JCOL+LAMBDA+JROW AND LCOL+LAMBDA+LROW ARE EVEN. C NOTE THAT ONLY 3-J SYMBOLS FOR WHICH THIS IS TRUE ARE STORED. C INDJ=ITJ+(JROW-JMIN)/2 INDL=ITL+(L(IROW)-LMIN)/2 IND6=IT6+JROW-JMIN6 VL(I)=SQRT(Z(JCOL)*Z(JROW)*Z(L(ICOL))*Z(L(IROW))) 2 *X(INDJ)*X(INDL)*X(IND6) IF (ODD(JCOL+JROW+JTOT)) VL(I)=-VL(I) IF (VL(I).NE.0.D0) NNZ=NNZ+1 ENDIF ENDIF 1502 I=I+NPOTL IF (NNZ.LE.0) WRITE(6,612) JTOT,LL IXNEXT=ITJ 1512 CONTINUE RETURN C C COUPLING MATRIX ELEMENTS FOR LINEAR ROTOR - LINEAR ROTOR. C THESE ARE EVALUATED BY CPL3 USING STORED JTOT-INDEPENDENT C PARTS. LFIRST INDICATES WHETHER THESE ARE ALREADY STORED. C TO ALLOW STACKING &INPUT DECKS W/LASTIN=0, LFIRST MUST BE C RESET BY CALL TO ENTRY COUPLX FOR EACH SET OF INPUT. C 8003 IF (IVLFL.NE.0) GO TO 9999 CALL CPL3(N,MXLAM,LAM,NLEV,JLEV,J,L,JTOT,VL,IEX,PRINT,LFIRST) RETURN C C *** ITYPE = 5 - NEAR SYMMETRIC TOP CODE C N.B. JLEV(I,) HAS J, ABS(K), PARITY. C *** MODIFIED SEPT. 75 FOR ODD MU VALUES . . . C 8005 IF (IVLFL.NE.0) GO TO 9999 DO 1555 LL=1,MXLAM NNZ=0 I=LL LM=LAM(2*LL-1) MU=LAM(2*LL) DO 1565 ICOL=1,N J1=JLEV(J(ICOL),1) K1=JLEV(J(ICOL),2) IS1=JLEV(J(ICOL),3) DO 1565 IROW=1,ICOL J2=JLEV(J(IROW),1) K2=JLEV(J(IROW),2) IS2=JLEV(J(IROW),3) VL(I)=0.D0 C IV(I)=LL PARFCT=(1.D0+PARITY(J1+J2+IS1+IS2+LM+MU))*.5D0 IF (PARFCT.LT.EPS) GO TO 1565 C SPECIAL NORMALIZATION FOR K1 AND/OR K2 =0. IF (K1.EQ.0) PARFCT=PARFCT*SQRTHF IF (K2.EQ.0) PARFCT=PARFCT*SQRTHF KDIF=K2-K1 IF (IABS(KDIF).NE.MU) GO TO 1505 WPAR=1.D0 IF (KDIF.LT.0) WPAR=PARITY(MU) C CONTRIBUTION FROM (J1,K1,L1/Y(LM,MU)/J2,K2,L2). VL(I) = VL(I) + & WPAR*PARFCT*FSYMTP(J1,K1,L(ICOL),J2,K2,L(IROW),JTOT,LM,KDIF) 1505 KSUM=K2+K1 IF (IABS(KSUM).NE.MU) GO TO 1515 C CONTRIBUTION FROM (J1,-K1,L1/ Y(LM,MU) / J2,K2,L2) C N.B. FOR K1=0 AND/OR K2=0, WE RECOMPUTE SAME FSYMTP. VL(I) = VL(I) + 1 PARFCT * PARITY(IS1) * 2 FSYMTP(J1,-K1,L(ICOL),J2,K2,L(IROW),JTOT,LM,KSUM) 1515 IF (VL(I).NE.0.D0) NNZ=NNZ+1 1565 I=I+NPOTL IF (NNZ.EQ.0) WRITE(6,612) JTOT,LL 1555 CONTINUE RETURN C C *** ITYPE=6 OBTAINED VIA CALL TO SET6/CPL6 C 8006 CALL CPL6(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,JLEV,NLEV,PRINT,LFIRST) RETURN C C *** ITYPE=7 MAKES NON-TRIVIAL USE OF THE IV ARRAY C 8007 IF (IVLFL.LE.0) GO TO 9999 II=NPOTL*N*(N+1)/2 DO 1547 I=1,II VL(I)=0.D0 IV(I)=0.D0 1547 CONTINUE C NZERO=0 DO 1527 LL=1,MXLAM LLL=LAM(5*LL-4) NV=LAM(5*LL-3) NJ=LAM(5*LL-2) NV1=LAM(5*LL-1) NJ1=LAM(5*LL) NNZ=0 JSAV=-1 LSAV=-1 ITJ=IXNEXT ITL=ITJ+2*LLL+1 IT6=ITL+2*LLL+1 IXNEXT=IT6+2*LLL+1 J6JMAX=2*LLL+1 NUSED=0 CALL CHKSTR(NUSED) C II=0 DO 1517 ICOL=1,N JVCOL=JLEV(J(ICOL),2) IF(JVCOL.NE.NV .AND. JVCOL.NE.NV1) THEN II=II+ICOL GOTO 1517 ENDIF JCOL=JLEV(J(ICOL),1) C C GET ALL ZERO-PROJECTION 3J SYMBOLS FOR THIS JCOL, LAMBDA C IF (JCOL.NE.JSAV) THEN CALL J3J000(DBLE(JCOL),DBLE(LLL),IVALJ,X(ITJ),XJMIN) JMIN=IABS(JCOL-LLL) JMAX=JCOL+LLL JSAV=JCOL ENDIF C C GET ALL ZERO-PROJECTION 3J SYMBOLS FOR THIS LCOL, LAMBDA C IF (L(ICOL).NE.LSAV) THEN CALL J3J000(DBLE(L(ICOL)),DBLE(LLL),IVALL,X(ITL),XLMIN) LMIN=IABS(L(ICOL)-LLL) LMAX=L(ICOL)+LLL LSAV=L(ICOL) ENDIF LSAV6=-1 C DO 1507 IROW=1,ICOL JVROW=JLEV(J(IROW),2) JROW=JLEV(J(IROW),1) II=II+1 I=(II-1)*NPOTL+LLL+1 IF (.NOT.(JROW.LT.JMIN .OR. JROW.GT.JMAX 1 .OR. L(IROW).LT.LMIN .OR. L(IROW).GT.LMAX 2 .OR. ODD(JROW+JMAX) .OR. ODD(L(IROW)+LMAX)) 3 .AND. ( 4 (JVCOL.EQ.NV.AND.JCOL.EQ.NJ .AND. JVROW.EQ.NV1.AND.JROW.EQ.NJ1) 5 .OR. 6 (JVCOL.EQ.NV1.AND.JCOL.EQ.NJ1 .AND. JVROW.EQ.NV.AND.JROW.EQ.NJ) 7 )) THEN C C GET ALL 6J SYMBOLS FOR THIS JCOL, LCOL, JROW, LAMBDA, JTOT, C CHECKING WHETHER LROW HAS CHANGED SINCE THE LAST CALL TO J6J C IF (L(IROW).NE.LSAV6) THEN IVAL6=J6JMAX CALL J6J(DBLE(L(IROW)),DBLE(JTOT),DBLE(L(ICOL)),DBLE(JCOL), 1 DBLE(LLL),IVAL6,XJMIN6,X(IT6)) JMIN6=INT(XJMIN6) LSAV6=L(IROW) ENDIF C C CALCULATE THE PERCIVAL-SEATON COEFFICIENT USING THE STORED C 3-J AND 6-J SYMBOLS. C C ARRIVE HERE ONLY IF THE TRIANGLE RELATIONSHIPS ARE SATISFIED, C AND IF JCOL+LAMBDA+JROW AND LCOL+LAMBDA+LROW ARE EVEN. C NOTE THAT ONLY 3-J SYMBOLS FOR WHICH THIS IS TRUE ARE STORED. C IF (JROW.GE.JMIN6 .AND. JROW.LT.JMIN6+IVAL6) THEN INDJ=ITJ+(JROW-JMIN)/2 INDL=ITL+(L(IROW)-LMIN)/2 IND6=IT6+JROW-JMIN6 VL(I)=SQRT(Z(JCOL)*Z(JROW)*Z(L(ICOL))*Z(L(IROW))) 2 *X(INDJ)*X(INDL)*X(IND6) IF (ODD(JCOL+JROW+JTOT)) VL(I)=-VL(I) IF (VL(I).NE.0.D0) THEN IV(I)=LL NNZ=NNZ+1 ELSE IV(I)=0 ENDIF ENDIF ENDIF 1507 CONTINUE 1517 CONTINUE IF (NNZ.LE.0) THEN NZERO=NZERO+1 IF(PRINT.GE.14) WRITE(6,612) JTOT,LL ENDIF IXNEXT=ITJ 1527 CONTINUE IF (NZERO.GT.0 .AND. PRINT.LT.14) WRITE(6,620) JTOT,NZERO 620 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING ', 1 'COEFFICIENTS ARE 0.0 FOR',I5,' POTENTIAL SYMMETRY TYPES') RETURN C C CODING BELOW IS FOR EFFECTIVE POTENTIAL METHOD OF H. RABITZ. C N.B. MATRIX ELEMENTS ARE INDEPENDENT OF JTOT (PARTIAL WAVE) C AND COULD BE COMPUTED ONCE AND SAVED. C 6001 IF (IVLFL.NE.0) GO TO 9999 DO 6100 LL=1,MXLAM NNZ=0 I=LL DO 6200 ICOL=1,N J1P=JLEV(J(ICOL),1) DO 6200 IROW=1,ICOL J1=JLEV(J(IROW),1) C IV(I)=LL VL(I)=PARITY((IABS(J1P-J1)+J1P+J1)/2) * 1 SQRT(SQRT(Z(J1P)*Z(J1))/Z(LAM(LL))) * THREEJ(J1P,LAM(LL),J1) IF (VL(I).NE.0.D0) NNZ=NNZ+1 6200 I=I+NPOTL IF (NNZ.EQ.0) WRITE(6,612) JTOT,LL 6100 CONTINUE RETURN 6002 IF (IVLFL.NE.0) GO TO 9999 DO 6102 LL=1,MXLAM LLL=LAM(3*LL-2) JV1=LAM(3*LL-1) JV =LAM(3*LL) NNZ=0 I=LL DO 6202 ICOL=1,N J1P=JLEV(J(ICOL),1) JVC=JLEV(J(ICOL),2) DO 6202 IROW=1,ICOL J1=JLEV(J(IROW),1) JVR=JLEV(J(IROW),2) VL(I)=0.D0 C IV(I)=LL IF ((JVC.EQ.JV.AND.JVR.EQ.JV1) .OR. (JVC.EQ.JV1.AND.JVR.EQ.JV)) & VL(I)=PARITY((IABS(J1P-J1)+J1P+J1)/2) * 2 SQRT(SQRT(Z(J1P)*Z(J1))/Z(LLL))*THREEJ(J1P,LLL,J1) IF (VL(I).NE.0.D0) NNZ=NNZ+1 6202 I=I+NPOTL IF (NNZ.EQ.0) WRITE(6,612) JTOT,LL 6102 CONTINUE RETURN 6003 IF (IVLFL.NE.0) GO TO 9999 DO 6300 LL=1,MXLAM NNZ=0 I=LL LM1=LAM(3*LL-2) LM2=LAM(3*LL-1) LM=LAM(3*LL) DO 6400 ICOL=1,N J1P=JLEV(J(ICOL),1) J2P=JLEV(J(ICOL),2) DO 6400 IROW=1,ICOL C IV(I)=LL J1=JLEV(J(IROW),1) J2=JLEV(J(IROW),2) PARFCT=PARITY((IABS(J1+J2-J1P-J2P)+J1+J2+J1P+J2P)/2) 1 *CONST*SQRT(Z(LM)*SQRT(Z(J1)*Z(J2)*Z(J1P)*Z(J2P))) VL(I) = PARFCT*THREEJ(J1,LM1,J1P)*THREEJ(J2,LM2,J2P) IF (IEX.EQ.0) GO TO 6093 C C *** N.B. THE FORMULATION BELOW ASSUMES THAT POTENTIAL IS SYMMETRIC TO C *** INTERCHANGE OF L1, L2. I.E. A(L1,L2,L) = A(L2,L1,L) MUST BOTH C *** BE PRESENT IN INTERACTION POTENTIAL. VL(I)=VL(I)+PARITY(IEX+JTOT)*PARFCT 1 *THREEJ(J1,LM1,J2P)*THREEJ(J2,LM2,J1P) IF (J1.EQ.J2) VL(I)=VL(I)*SQRTHF IF (J1P.EQ.J2P) VL(I)=VL(I)*SQRTHF 6093 IF (VL(I).NE.0.D0) NNZ=NNZ+1 6400 I=I+NPOTL 6300 CONTINUE RETURN 6005 IF (IVLFL.NE.0) GO TO 9999 DO 6555 LL=1,MXLAM NNZ=0 I=LL LM=LAM(2*LL-1) MU=LAM(2*LL) DO 6565 ICOL=1,N J1=JLEV(J(ICOL),1) K1=JLEV(J(ICOL),2) IS1=JLEV(J(ICOL),3) DO 6565 IROW=1,ICOL J2=JLEV(J(IROW),1) K2=JLEV(J(IROW),2) IS2=JLEV(J(IROW),3) C IV(I)=LL VL(I)=0.D0 PARFCT=(1.D0+PARITY(J1+J2+IS1+IS2+LM+MU))*.5D0 IF (PARFCT.LT.EPS) GO TO 6565 IF (K1.EQ.0) PARFCT=PARFCT*SQRTHF IF (K2.EQ.0) PARFCT=PARFCT*SQRTHF KDIF=K2-K1 IF (IABS(KDIF).NE.MU) GO TO 6505 WPAR=1.D0 IF (KDIF.LT.0) WPAR=PARITY(MU) VL(I)=VL(I)+WPAR*PARFCT*ESYMTP(J1,K1,J2,K2,LM,KDIF) 6505 KSUM=K2+K1 IF (IABS(KSUM).NE.MU) GO TO 6515 C (J1, -K1 / Y(LM,MU) / J2, K2) - - - - - VL(I)=VL(I)+PARFCT*PARITY(IS1)*ESYMTP(J1,-K1,J2,K2,LM,KSUM) 6515 IF (VL(I).NE.0.D0) NNZ=NNZ+1 6565 I=I+NPOTL IF (NNZ.EQ.0) WRITE(6,612) JTOT,LL 6555 CONTINUE RETURN C 6006 CALL ASYME(N,J,L,MXLAM,LAM,VL,IV,JLEV,JLEV,NLEV) RETURN C 6007 IF (IVLFL.LE.0) GO TO 9999 I=1 DO 6047 LL=1,NPOTL DO 6047 ICOL=1,N DO 6047 IROW=1,ICOL VL(I)=0.D0 I=I+1 6047 CONTINUE NZERO=0 DO 6017 LL=1,MXLAM LLL=LAM(5*LL-4) NV=LAM(5*LL-3) NJ=LAM(5*LL-2) NV1=LAM(5*LL-1) NJ1=LAM(5*LL) NNZ=0 II=0 DO 6057 ICOL=1,N NVC=JLEV(J(ICOL),2) NJC=JLEV(J(ICOL),1) DO 6057 IROW=1,ICOL NVR=JLEV(J(IROW),2) NJR=JLEV(J(IROW),1) II=II+1 IF (.NOT.( 1 (NV.EQ.NVC.AND.NJ.EQ.NJC .AND. NV1.EQ.NVR.AND.NJ1.EQ.NJR) .OR. 2 (NV.EQ.NVR.AND.NJ.EQ.NJR .AND. NV1.EQ.NVC.AND.NJ1.EQ.NJC))) 3 GO TO 6057 I=(II-1)*NPOTL+LLL+1 VL(I)=PARITY((IABS(NJC-NJR)+NJC+NJR)/2) * 1 SQRT(SQRT(Z(NJC)*Z(NJR))/Z(LLL))*THREEJ(NJC,LLL,NJR) IV(I)=LL NNZ=NNZ+1 6057 CONTINUE IF (NNZ.GT.0) GO TO 6017 IF (PRINT.GE.14) WRITE(6,612) JTOT,LL NZERO=NZERO+1 6017 CONTINUE IF (NZERO.GT.0 .AND. PRINT.LT.14) WRITE(6,620) JTOT,NZERO RETURN C 9999 WRITE(6,699) IVLFL,ITYPE 699 FORMAT(/' COUPLE (JAN 93). IVLFL =',I6, 1 ' INCONSISTENT WITH ITYPE =',I6) STOP C ENTRY COUPLX LFIRST=.TRUE. 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 CPL21(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) C C 30 DEC 93. INCORPORATES JMH (V12) USE OF J3J000 C W/ SG (V12X) LOGIC. THIS CORRECTS BUG IN NEW RESTART CODE. C ALL MV = 0,MAX(MVALUE) ARE CALCULATED EVEN IF LOWER ONES ARE C NOT NEEDED, E.G., BECAUSE OF MSET,MHI. C CS COUPLING MATRIX FOR LINEAR ROTOR-ATOM (ITYPE=21) 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 SPECIFICATIONS FOR ARGUMENTS DIMENSION LAM(MXLAM),JLEV(NLEV),J(N),VL(1) INTEGER PRINT LOGICAL LFIRST C LOGICAL ODD,NOMEM 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)= 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 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(/' CPL21 (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(/' CPL21 (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 DO 3200 IL=1,MXLAM LM=LAM(IL) JSAV=-1 ITJ=IXNEXT IXNEXT=ITJ+LM+LM+1 NUSED=0 CALL CHKSTR(NUSED) DO 3201 I1=1,NLEV J1=JLEV(I1) 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 J2=JLEV(I2) 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(/' CPL21 (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 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) DO 3503 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 IX=IXM+(LL-1)*NL12+IX12 VL(I)=X(ISTART-IX) C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY IF (MVALUE.LT.0.AND.ODD(J1+J2+LM)) VL(I)=-VL(I) 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, 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(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 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 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 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 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 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 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 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,RMIN,RTURN,IK,P,VL,IV,ERED,EINT, 1 CENT,RMLMDA,DIAG,MXLAM,NPOTL,XEPS,ITYPE,IPRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RMLAST DIMENSION W(N,N),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N),DIAG(N) C C SUBROUTINE TO FIND A SUITABLE STARTING POINT FOR INTEGRATION C CALL RMSET(W,N,RMIN,RTURN,IK,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL,XEPS,ITYPE,-1,IPRINT) DO 100 I=1,20 RMINX=RMIN CALL RMSET(W,N,RMIN,RTURN,IK,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 2 MXLAM,NPOTL,XEPS,ITYPE,+1,IPRINT) IF(RMIN.EQ.RMLAST) GOTO 200 RMLAST=RMIN RMIN=STEFF(RMINX,RMIN,I) IF(ABS((RMINX-RMIN)/RMIN).LE.1.D-2) GOTO 200 100 CONTINUE 200 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 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 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 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 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 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 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 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 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 MCGCPL(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,MVALUE,ITYPE, 1 IEX,VL,IV,PRINT) 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.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.NE.0) GO TO 9999 XM=DBLE(MVALUE) DO 1512 LL=1,MXLAM NNZ=0 I=LL LLL=LAM(3*LL-2) JV =LAM(3*LL-1) JV1=LAM(3*LL) DO 1502 ICOL=1,N JCOL=JLEV(J(ICOL),1) JVC=JLEV(J(ICOL),2) DO 1502 IROW=1,ICOL JROW=JLEV(J(IROW),1) JVR=JLEV(J(IROW),2) VL(I)=0.D0 C IV(I)=LL IF ((JVR.EQ.JV1.AND.JVC.EQ.JV). OR. (JVR.EQ.JV.AND.JVC.EQ.JV1)) & VL(I)=PARITY(MVALUE)*SQRT(Z(JROW)*Z(JCOL))* & THREEJ(JROW,LLL,JCOL)* & THRJ(DBLE(JROW),DBLE(LLL),DBLE(JCOL),-XM,Z0,XM) IF (VL(I).NE.0.D0) NNZ=NNZ+1 1502 I=I+NPOTL IF (NNZ.LE.0 .AND. PRINT.GE.2) WRITE(6,612) MVALUE,LL 1512 CONTINUE 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 5000 IF (IVLFL.NE.0) GO TO 9999 CALL CPL25(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) RETURN C 6000 CALL CPL26(N,MXLAM,LAM,NLEV,JLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) RETURN C C ITYPE=7 7000 IF (IVLFL.LE.0) GO TO 9999 XM=DBLE(MVALUE) I=1 DO 1547 LL=1,NPOTL DO 1547 ICOL=1,N DO 1547 IROW=1,ICOL VL(I)=0.D0 I=I+1 1547 CONTINUE NZERO=0 DO 1517 LL=1,MXLAM LLL=LAM(5*LL-4) NV=LAM(5*LL-3) NJ=LAM(5*LL-2) NV1=LAM(5*LL-1) NJ1=LAM(5*LL) NNZ=0 II=0 DO 1507 ICOL=1,N NVC=JLEV(J(ICOL),2) NJC=JLEV(J(ICOL),1) DO 1507 IROW=1,ICOL NVR=JLEV(J(IROW),2) NJR=JLEV(J(IROW),1) II=II+1 IF(.NOT.( 1 (NV.EQ.NVC.AND.NJ.EQ.NJC .AND. NV1.EQ.NVR.AND.NJ1.EQ.NJR) .OR. 2 (NV.EQ.NVR.AND.NJ.EQ.NJR .AND. NV1.EQ.NVC.AND.NJ1.EQ.NJC))) 3 GO TO 1507 I=(II-1)*NPOTL+LLL+1 VL(I)=PARITY(MVALUE)*SQRT(Z(NJR)*Z(NJC))* 1 THREEJ(NJR,LLL,NJC)* 2 THRJ(DBLE(NJR),DBLE(LLL),DBLE(NJC),-XM,Z0,XM) IV(I)=LL NNZ=NNZ+1 1507 CONTINUE IF(NNZ.GT.0) GO TO 1517 IF(PRINT.GE.14) WRITE(6,612) MVALUE,LL NZERO=NZERO+1 1517 CONTINUE IF(NZERO.GT.0 .AND. PRINT.LT.14) WRITE(6,620) MVALUE,NZERO RETURN C 9999 WRITE(6,699) IVLFL,ITYPE 699 FORMAT(/' MCGCPL (JAN 93). IVLFL =',I6, 1 ' INCONSISTENT WITH ITYPE =',I6) STOP C 612 FORMAT('0 * * * NOTE. FOR MVALUE, LAM =',2I4,' ALL COUPLING ', 1 'COEFFICIENTS ARE ZERO.') 620 FORMAT('0 * * * NOTE. FOR MVALUE =',I4,' ALL COUPLING ', 1 'COEFFICIENTS ARE ZERO FOR',I5,' POTENTIAL SYMMETRY TYPES.') C ENTRY MCGCPX LFIRST=.TRUE. RETURN END C C C SUBROUTINE ORDER(I,J) C C SUBROUTINE TO REARRANGE TWO FOURIER COMPONENTS INTO C A UNIQUELY DEFINED EQUIVALENT PAIR. C C EQUIV = .TRUE. IF THE TWO LATTICE VECTORS ARE EQUIVALENT C ORTHOG = .TRUE. IF THE LATTICE VECTORS ARE ORTHOGONAL C HEX = .TRUE. IF LATTICE HAS HEXAGONAL SYMMETRY C CURRENTLY SET UP FOR HEXAGONAL LATTICE, AS IN H-XE-C C LOGICAL HEX, ORTHOG, EQUIV COMMON/LATSYM/HEX,ORTHOG,EQUIV C 5 IF(.NOT.EQUIV .OR. IABS(I).GE.IABS(J)) GOTO 10 K=I I=J J=K 10 IF(I.GE.0) GOTO 20 I=-I J=-J 20 CONTINUE IF(ORTHOG) J=IABS(J) IF(.NOT.HEX .OR. J.LE.0) RETURN K=I I=J J=J-K GOTO 5 END FUNCTION PARITY(I) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARITY=1.D0 IF((I/2)*2-I.NE.0) PARITY=-1.D0 RETURN END FUNCTION PLM(L,MM,X) C C COMPUTES NORMALIZED ASSOC. LEGENDRE POLYNOMIALS BY RECURSION. C THE VALUES RETURNED ARE NORMALIZED FOR INTEGRATION OVER X C (I.E. INTEGRATION OVER COS THETA BUT NOT PHI). C NOTE THAT THE NORMALIZATION GIVES C PLM(L,0,1)=SQRT(L+0.5) C PLM(L,0,X)=SQRT(L+0.5) P(L,X) C FOR M.NE.0, THE VALUE RETURNED DIFFERS FROM THE USUAL C DEFINITION OF THE ASSOCIATED LEGENDRE POLYNOMIAL C (E.G. EDMONDS PAGES 23-24) C BY A FACTOR OF (-1)**M*SQRT(L+0.5)*SQRT((L-M)!/(L+M)!) C THUS THE SPHERICAL HARMONICS ARE C CLM = PLM * EXP(I*M*PHI) / SQRT(L+0.5) C YLM = PLM * EXP(I*M*PHI) / SQRT(2*PI) C C PROGRAM OF R. NERF MODIFED BY S. GREEN. C MOD FEB. 82 BY S.G. ACCORDING TO R.T PACK'S SUGGESTION C FOR IMPROVED ACCURACY LARGE ABS(X) C MODIFIED AUG 88 BY S.G. TO KEEP RAT FROM BLOWING UP AT LARGE L C BY INCLUDING FACTOR (-Z)**L IN PRECEDING LOOP C ERROR IN STMT. NO. 211 CORRECTED MAY 93 BY SG C IMPLICIT DOUBLE PRECISION (A-H,O-Z) M=IABS(MM) IF ( M.GT.L .OR. L.LT.0) GO TO 9999 XL=L XM=M P1=1.D0 P2=X IF(L.EQ.0) GO TO 20 C *** USE ALTERNATE RECURSION FOR LARGE M OR LARGE ABS(X) IF (M.EQ.0) GO TO 10 XTEST=0.49999D0*(1.D0+1.D0/XM) MTEST=L/3 IF (M.GT.MTEST .OR. ABS(X).GT.XTEST) GO TO 210 C *** 10 DO 100 I=1,L XI=I P3=((2.D0*XI+1.D0)*X*P2-XI*P1)/(XI+1.D0) P1=P2 100 P2=P3 IF (M.EQ.0) GO TO 20 C AT END OF LOOP P1=P(L,0,X) IF (ABS(X).GT.1.D0) GO TO 9999 Z=SQRT(1.D0-X*X) IF (Z.LE.1.D-10) GO TO 999 201 P2=(XL+1.D0)*(P2-X*P1)/Z DO 200 I=1,M XI=I P3=-2.D0*X/Z*P2*XI-(XL+XI)*(XL-XI+1.D0)*P1 P1=P2 200 P2=P3 GO TO 20 C *** C BELOW RECURS DOWN IN M, AS SUGGESTED BY R. T PACK 210 IF (ABS(X).GT.1.D0) GO TO 9999 Z=SQRT(1.D0-X*X) IF (Z.LE.1.D-10) GO TO 999 C CALCULATE RATIO OF FACTORIALS FOR PLL RAT=1.D0 XI=0.D0 DO 211 I=1,L XI=XI+1.D0 211 RAT=-0.5D0*Z*(XL+XI)*RAT C CALCULATE PLL ---- N.B. ABOVE INCL (-Z)**L COMPUTATION C P1=RAT*(-Z)**L P1=RAT IF (M.EQ.L) GO TO 20 P2=P1 P1=-X*P2/Z IF (M.EQ.L-1) GO TO 20 LM1=L-M-1 C RECUR DOWNWARD IN M DO 213 I=1,LM1 MU=L-I-1 XMU=MU P3=P2 P2=P1 P1=2.D0*(XMU+1.D0)*X*P2/Z+P3 213 P1=-P1/((XL-XMU)*(XL+XMU+1.D0)) GO TO 20 C *** C NORMALIZATION . . . 20 XNORM=(2.D0*XL+1.D0)/2.D0 IF (M.LE.0) GO TO 1000 XLM=XL+1.D0 XLP=XL DO 1100 I=1,M XLM=XLM-1.D0 XLP=XLP+1.D0 1100 XNORM=XNORM/(XLM*XLP) 1000 PLM=P1*SQRT(XNORM) RETURN 9999 WRITE(6,699) L,MM,X 699 FORMAT('0 * * * ERROR. ARGUMENT OUT OF RANGE FOR PLM(',2I6,D16.8, 1 ' ).') C IF Z=0, THEN X=1 AND PLM(1.)=0 FOR M.GT.0. C IN THAT CASE, WE HAVE BRANCHED TO 999 999 PLM=0.D0 RETURN END SUBROUTINE QAPROP(Q, T, U, W, Y, NSQ, & RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, & EIVAL, Y1, Y2, Y3, Y4, N, & P, VL, IV, ERED, EINT, CENT, RMLMDA, DIAG, & MXLAM, NPOTL, ISTART, NODES) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C ROUTINE TO SOLVE THE CLOSE COUPLED EQUATIONS USING A C MODIFIED LOG DERIVATIVE ALGORITHM. THE COUPLING MATRIX C EVALUATED AT THE MID POINT OF EACH SECTOR IS USED AS A C REFERENCE POTENTIAL FOR THE SECTOR. C LOGICAL IREAD,IWRITE DIMENSION Q(NSQ),T(NSQ),U(NSQ),W(NSQ),Y(NSQ), & EIVAL(N),Y1(N),Y2(N),Y3(N),Y4(N) DIMENSION P(MXLAM),VL(2),IV(2),EINT(N),CENT(N),DIAG(N) C NODES=0 ESHIFT=ERED ERED=0.D0 C C THIS VERSION USES A CONSTANT STEP SIZE, DR, THROUGHOUT THE C INTEGRATION RANGE, BUT IS WRITTEN SO THAT THIS MAY BE EASILY C CHANGED. C IF (ISTART.EQ.0) THEN IF (IREAD) GO TO 40 DR=(REND-RBEGIN)/DBLE(NSTEPS) R=RBEGIN CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) IFAIL=0 CALL F02ABF(U,N,N,EIVAL,T,N,DIAG,IFAIL) C C Q MATRIX IS USED TO HOLD CORRECTION TO Y4 FROM PREVIOUS C SECTOR. INITIALISE IT FOR THE FIRST SECTOR. C DO 20 IJ=1,NSQ Q(IJ)=0.D0 20 CONTINUE IF (IWRITE) WRITE (ISCRU) DR,EIVAL GO TO 60 40 READ (ISCRU) DR,EIVAL 60 CONTINUE C C INITIALISE Y MATRIX C DO 80 IJ=1,NSQ Y(IJ)=0.D0 80 CONTINUE II=-N SGN=SIGN(1.D0,DR) DO 100 I=1,N II=II+N+1 WREF=EIVAL(I)-ESHIFT Y(II)=SGN*1.D30 IF(WREF.GT.0.D0) Y(II)=SGN*SQRT(WREF) 100 CONTINUE ELSE C C ISTART=1: Y ALREADY CONTAINS LOG DERIVATIVE MATRIX C IN THE ASYMPTOTIC BASIS. MUST STILL C INITIALISE Q (AS ABOVE) AND T (UNITY) IF FIRST ENERGY: C IF (IREAD) GO TO 119 R=RBEGIN CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) DO 110 IJ=1,NSQ Q(IJ)=0.D0 T(IJ)=0.D0 110 CONTINUE II=-N DO 111 I=1,N II=II+N+1 T(II)=1.D0 111 CONTINUE 119 CONTINUE ENDIF C C C PROPAGATION LOOP BEGINS HERE C C DO 500 KSTEP=1,NSTEPS IF (IREAD) GO TO 180 R=R+0.5D0*DR CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) C C CALCULATE CORRECTION TO Y1(K) C DO 120 IJ=1,NSQ U(IJ)=U(IJ)-W(IJ) 120 CONTINUE CR=DR/6.D0 DO 140 IJ=1,NSQ U(IJ)=CR*U(IJ) 140 CONTINUE C C PLUS CORRECTION TO Y4(K-1) C DO 160 IJ=1,NSQ U(IJ)=U(IJ)+Q(IJ) 160 CONTINUE C C TRANSFORM CORRECTION TO OLD BASIS C CALL TRNSFM(T,U,Q,N,.FALSE.,.TRUE.) IF (IWRITE) WRITE (ISCRU) U GO TO 200 180 READ (ISCRU) U 200 CONTINUE C C APPLY CORRECTION TO Y MATRIX IN OLD BASIS C DO 220 IJ=1,NSQ Y(IJ)=Y(IJ)+U(IJ) 220 CONTINUE C C DIAGONALISE COUPLING MATRIX AND CALCULATE SECTOR TO SECTOR C TRANSFORMATION MATRIX, Q. C IF (IREAD) GO TO 260 IFAIL=0 CALL F02ABF(W,N,N,EIVAL,U,N,DIAG,IFAIL) CALL DGEMUL(T,N,'T',U,N,'N',Q,N,N,N,N) DO 240 IJ=1,NSQ T(IJ)=U(IJ) 240 CONTINUE IF (IWRITE) WRITE (ISCRU) DR,EIVAL,Q GO TO 280 260 READ (ISCRU) DR,EIVAL,Q 280 CONTINUE C C TRANSFORM Y MATRIX TO NEW BASIS C CALL TRNSFM(Q,Y,U,N,.FALSE.,.TRUE.) C C CONSTRUCT FIRST ORDER MAGNUS SECTOR PROPAGATORS C HALF ANGLE FORMULAE ARE USED FOR MAXIMUM OPACITY. C NCHECK=0 WMAX=24.D0/(DR*DR) DO 300 I=1,N WREF=EIVAL(I)-ESHIFT FLAM=0.5D0*SQRT(ABS(WREF)) IF (WREF.LT.0.D0) THEN TN=TAN(FLAM*DR) Y1(I)=FLAM/TN-FLAM*TN Y2(I)=FLAM/TN+FLAM*TN ELSE IF (WREF.GT.WMAX) NCHECK=NCHECK+1 C IF (WREF.GT.0.D0) THEN TH=TANH(FLAM*DR) Y1(I)=FLAM/TH+FLAM*TH Y2(I)=FLAM/TH-FLAM*TH ENDIF Y3(I)=Y2(I) Y4(I)=Y1(I) 300 CONTINUE C C PROPAGATE Y MATRIX ACROSS THE SECTOR C II=-N DO 320 I=1,N II=II+N+1 Y(II)=Y(II)+Y1(I) 320 CONTINUE C CALL SYMINV(Y,N,N,NCOUNT) IF (NCOUNT.GT.N) GO TO 900 IF (RBEGIN.GT.REND) NCOUNT=N-NCOUNT IF (NCHECK.EQ.0) NODES=NODES+NCOUNT C IJ=0 DO 340 J=1,N DO 340 I=1,N IJ=IJ+1 Y(IJ)=-Y3(I)*Y(IJ)*Y2(J) 340 CONTINUE II=-N DO 360 I=1,N II=II+N+1 Y(II)=Y(II)+Y4(I) 360 CONTINUE C IF (IREAD) GO TO 500 R=R+0.5D0*DR CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) C C CALCULATE CORRECTION TO Y4(K) C DO 380 IJ=1,NSQ Q(IJ)=U(IJ)-W(IJ) 380 CONTINUE CR=DR/6.D0 DO 400 IJ=1,NSQ Q(IJ)=CR*Q(IJ) 400 CONTINUE C C *** COULD CHANGE DR HERE *** C 500 CONTINUE C C C PROPAGATION LOOP ENDS HERE C C IF (IWRITE) WRITE (ISCRU) T,Q IF (IREAD ) READ (ISCRU) T,Q C C TRANSFORM Y MATRIX TO ASYMPTOTIC BASIS C CALL TRNSP(T,N) CALL TRNSFM(T,Y,W,N,.FALSE.,.TRUE.) C C APPLY FINAL CORRECTION IN ASYMPTOTIC BASIS C DO 520 IJ=1,NSQ Y(IJ)=Y(IJ)+Q(IJ) 520 CONTINUE ERED=ESHIFT RETURN C 900 WRITE (6,1000) KSTEP 1000 FORMAT('0***** MATRIX INVERSION ERROR IN QAPROP AT ', & 'STEP K = ',I6,' RUN HALTED.') STOP END SUBROUTINE RMSET(W,N,RMIN,RTURN,IK,P,VL,IV,ERED,EINT,CENT,RMLMDA, 1 DIAG,MXLAM,NPOTL,XEPS,ITYPE,IFLAG,PRINT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE RMSAVE DIMENSION W(N,N),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N),DIAG(N) INTEGER PRINT C C ESTIMATE NEW RMIN BY CONSIDERING THE DIAGONAL POTENTIAL IN THE C LOWEST LYING CHANNEL. APPROXIMATE THIS POTENTIAL BY A RAMP FROM C THE PREVIOUS CLASSICAL TURNING POINT OF THIS DIAGONAL POTENTIAL C TO A POSITION HALFWAY BETWEEN THIS TURNING POINT AND THE C PREVIOUS RMIN. REQUIRE THE QUANTAL WAVEFUNCTION FOR THIS C RAMP (I.E. AN AIRY FUNCTION) TO HAVE DECAYED TO A SPECIFIED VALUE. C (THE CONTROL OF THIS OPTION IS A LITTLE INVOLVED. PLEASE EXAMINE C THE CODE CAREFULLY BEFORE CHANGING ANYTHING.) C C *** MODIFIED 11/01/89 BY SG, AS NOTED. C IF(IFLAG.GT.0) GO TO 200 CRISIS=RTURN C *** 11/01/89 ADD - RMSAVE=RMIN C FIRST CALL TO THE ROUTINE. BEFORE ESTIMATING A VALUE FOR RMIN, C FIND CLASSICAL TURNING POINT OF DIAGONAL POTENTIAL IN LOWEST- C LYING CHANNEL. C 90 RMIN=RTURN CALL WAVMAT(W,N,RMIN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) NOPEN=0 IK=1 V1=DIAG(1) DO 100 I=1,N DIF=ERED-EINT(I) IF(DIF.GT.0.D0) NOPEN=NOPEN+1 IF(DIAG(I).GE.V1) GO TO 100 IK=I V1=DIAG(I) 100 CONTINUE RTURN=1.0001D0*RMIN DO 120 II=1,100 CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) V2=DIAG(IK) DO 110 IJ=1,N IF(DIAG(IJ).LT.V2) GOTO 90 110 CONTINUE DV1=(V2-V1)/(RTURN-RMIN) RMIN=RTURN V1=V2 DRTURN=-V1/DV1 RTURN=RTURN+DRTURN IF(DRTURN.GT.1.D8) GO TO 140 IF(RTURN.LE.0.D0 .AND. ITYPE.NE.8) GO TO 140 IF(ABS(DRTURN/RTURN).LE.1.D-3) GO TO 160 120 CONTINUE 140 RTURN=CRISIS RMIN=0.5D0*RTURN IF(NOPEN.GT.0 .OR. PRINT.GE.3) WRITE(6,602) RTURN 602 FORMAT('0***** WARNING IN RMSET - CANNOT FIND CLASSICAL TURNING ', 1 'POINT IN LOWEST-LYING CHANNEL.'/7X,'USE GUESS OF',F8.4) GOTO 200 160 IF(PRINT.GE.3) WRITE(6,603)RTURN 603 FORMAT('0 INNER CLASSICAL TURNING POINT AT R =',F8.4/) IF(PRINT.GE.5) WRITE(6,604) 604 FORMAT(' RMSET MAKES SUCCESSIVE ESTIMATES OF RMIN:') RMIN=0.5D0*RTURN C C FIND NEW RMIN C 200 RMID=0.5D0*(RMIN+RTURN) CALL WAVMAT(W,N,RMID,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) IK=1 V1=DIAG(1) DO 220 I=1,N IF(DIAG(I).GE.V1) GO TO 220 IK=I V1=DIAG(I) 220 CONTINUE CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, 1 MXLAM,NPOTL) V2=DIAG(IK) CC=(V2*RMID-V1*RTURN)/(RMID-RTURN) BB=(V2-V1)/(RMID-RTURN) IF(BB.GT.0.D0) GO TO 240 C IF(PRINT.GE.5) WRITE(6,605) 11/01/89 --- WRITE(6,605) RMSAVE 605 FORMAT('0***** ERROR IN RMSET - CANNOT FIND NEW RMIN BECAUSE', 1 ' DIAGONAL POTENTIAL IN LOWEST CHANNEL HAS +VE GRADIENT'/ 2 ' ***** USE VALUE SAVED FROM INITIAL CALL =',F8.3) RMN=RMSAVE GO TO 300 C C XEPS IS THE REQUIRED AIRY FUNCTION ARGUMENT C 240 RMN=(CC-XEPS*BB**(2.D0/3.D0))/BB IF(PRINT.GE.5) WRITE(6,608) RMN 608 FORMAT(1X,F8.4) IF(RMN.GT.0.D0 .OR. ITYPE.EQ.8) GOTO 300 RMN= RMSAVE IF(PRINT.GE.3) WRITE(6,606)RMN 606 FORMAT('+ UNPHYSICAL: TRY SAVED RMIN VALUE=',F8.4) 300 RMIN=RMN RETURN END SUBROUTINE SET6(LEVIN,EIN,NLEV,JLEV,ATAU,EFACT,IUNIT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) 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 MAR 11,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 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(4),ELEVEL(200),EMAX, & WT(2),SPNUC,JMIN,JMAX,J2MIN,J2MAX,JSTEP,J2STEP,NLEVEL, & JLEVEL(400),IDENT C DATA IDU/5/ DATA PI/3.14159 26535 89793 D0/ 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 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 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) RETURN ENDIF IF (IUNIT.GT.0 .AND. IUNIT.LT.100) GO TO 1000 WRITE(6,601) IUNIT,IDU 601 FORMAT('0 ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, ', & 'DEFAULTED TO ',I4) IUNIT=IDU C 1000 WRITE(6,602) IUNIT 602 FORMAT('0 ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', & I4) IF (.NOT.LEVIN) NLEVEL=100000 IF (LEVIN) WRITE(6,603) NLEVEL 603 FORMAT(' ',10X,I6,' LEVELS SPECIFIED BY NLEVEL.') NLEV=0 IOFF=0 NKVAL=0 DO 2000 III=1,NLEVEL 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 IF (LEVIN) GO TO 2080 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 =',2I6,F15.5,' SKIPPED SINCE 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 =',2I6,F15.5,' ) SKIPPED DUE TO E &MAX =',F15.5) 2070 NLEV=NLEV-1 READ( IUNIT,501,END=9100) (ATAU(IOFF+NKVAL+1),I=1,NK) GO TO 2000 2090 CONTINUE C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR INCOMING JLEV. IOFF=IOFF+6 IF (NKVAL.LE.0) GO TO 2010 DO 2020 I=1,NKVAL 2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I) 2010 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 JLEV(6*NLEV)=NLEV 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 C 2000 CONTINUE C 2400 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) C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . . IF (IOFF.EQ.6*NLEV) GO TO 2411 WRITE(6,698) IOFF, NLEV 698 FORMAT('0 DEBUGGING INFO. IOFF,NLEV =',2I6) 2411 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 SEE THAT ENERGIES ARE NOT ALL IDENTICALLY ZERO. DO 2500 I=1,NLEV IF (ELEVEL(I).NE.0.D0) GO TO 2510 2500 CONTINUE IF (AE(1).NE.0.D0 .OR. BE(1).NE.0.D0 .OR. CE(1).NE.0.D0) GOTO 2600 WRITE(6,609) 609 FORMAT('0 * * * ERROR. ENERGIES CAN BE OBTAINED NEITHER FROM EIN & NOR ROTI DATA.') WRITE(6,699) STOP 2600 WRITE(6,610) 610 FORMAT('0 * * * ERROR. CANNOT CALCULATE ENERGIES FROM ROTI.') C =*=**=*=*=*=*=*=*=****=*=*=*=*=*=*=*=*==*=*=*=*=*= WRITE(6,699) STOP 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) SAVE LOGICAL EIN DIMENSION JLEV(1),ATAU(1) DIMENSION ROTI(10),WT(2),ELEVEL(200),JLEVEL(400) COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,JMIN,JMAX,J2MIN,IPAR, 1 JSTEP,J2STEP,NLEVEL,JLEVEL,IDENT 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 SETBAS IMPLICIT DOUBLE PRECISION (A-H,O-Z) SAVE C LOGICAL LEVIN,EIN INTEGER NLEV,JLEV(1) C C COMMON BLOCK FOR BASIS DATA DIMENSION ROTI(10),ALPHAE(2),BE(2),DE(2),WE(2),WEXE(2),A(2),B(2), 1 C(2),WT(2),ELEVEL(200) DIMENSION JLEVEL(400) 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,JMIN,JMAX,J2MIN,J2MAX, 1 JSTEP,J2STEP,NLEVEL,JLEVEL,IDENT C C ENTRY SET1(LEVIN,EIN,NLEV,JLEV) IF (LEVIN) GO TO 1902 WRITE(6,601) JMIN,JMAX,JSTEP 601 FORMAT('0 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('0 TARGET ROTATIONAL LEVELS TAKEN FROM &BASIS (JLEVEL) INPU 1T. 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('0 TARGET ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) 634 FORMAT(27X,'CORRECTED FOR ALPHA(E) =',F10.6) IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) 635 FORMAT(27X,'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('0 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('0 * * * ERROR. FOR ITYPE=2 &BASIS MUST SPECIFY NLEVEL AND 1 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('0 TARGET ENERGY LEVELS COMPUTED FROM WE =',F10.4, 1 ', B(E) =',F10.4,', WITH ZERO ENERGY AT V=0, J=0.') IF (WEXE(1).NE.0.D0) WRITE(6,636) WEXE(1) 636 FORMAT(11X,'CORRECTED FOR WEXE =',F10.4) IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(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 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('0 TARGET ROTOR LEVELS COMPUTED FROM J1MIN =',I3, 1 ', J1MAX =',I3,', J1STEP =',I2/ 2 '0 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('0 TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS (JLEVE 1L) 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('0 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('0 TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS (ELEVE 1L) 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 JLEVEL(I+1)=JJ JLEVEL(I+2)=KK JLEVEL(I+3)=2 I=I+3 NLEVEL=NLEVEL+1 IF(KK.EQ.0) GOTO 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('0 ENERGY LEVELS COMPUTED FROM ZEROTH ORDER NEAR-SYMMETRIC 1TOP FORMULA'/10X,'ROTATIONAL CONSTANTS ARE A, B, C (1/CM) =', 2 3F12.4/10X,'N.B. THESE MOMENTS MUST CORRESPOND RESPECTIVELY TO X, 4 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 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 FUNCTION SUMLEG(COEFF,NP,X) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C SUMLEG EVALUATES A LEGENDRE SERIES AT A GIVEN ANGLE THETA, USING C THE RECURSION RELATIONSHIP FOR LEGENDRE POLYNOMIALS. C C ON INPUT, COEFF IS THE LEGENDRE SERIES, STARTING AT P0 C NP IS THE ORDER OF THE LEGENDRE SERIES C X IS COS(THETA) C DIMENSION COEFF(NP) IF(NP.GE.1) GOTO 1 WRITE(6,601)NP 601 FORMAT(/' **** ERROR IN SUMLEG: NP =',I5) STOP 1 SUMLEG=COEFF(1) IF(NP.EQ.1) RETURN SUMLEG=SUMLEG+X*COEFF(2) IF(NP.EQ.2) RETURN P0=1.D0 P1=X DO 10 K=3,NP TEMP=(DBLE(K+K-3)*X*P1 - DBLE(K-2)*P0) / DBLE(K-1) P0=P1 P1=TEMP 10 SUMLEG=SUMLEG+P1*COEFF(K) 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 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(10),ELEVEL(200),EMAX,WT(2),SPNUC,J1MIN,J1MAX, 1 J2MIN,J2MAX,J1STEP,J2STEP,NLEVEL,JLEVEL(400),IDENT 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 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 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(202),Y(202) DATA MUNG/0/,MXIX/202/ 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 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 FUNCTION DSIXJ(XJ1,XJ2,XJ5,XJ4,XJ3,XJ6) C MODFIED BY S. GREEN 20 AUG 93 TO PASS DIMENSION OF XJ6J IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER(MXDIM=200) DIMENSION XJ6J(MXDIM) IVAL=MXDIM CALL J6J(XJ2,XJ3, 1 XJ4,XJ5,XJ6, 3 IVAL,XJ1MIN,XJ6J) IND=1+NINT(XJ1-XJ1MIN) DSIXJ=0.D0 IF(IND.GE.1 .AND. IND.LE.IVAL) DSIXJ=XJ6J(IND) 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 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 DNINEJ(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION XJ9J(200) DATA MXDIM/200/ C IVAL=MXDIM CALL J9J(X1,Y1, X2,Y2,Z2,X3,Y3,Z3,IVAL,Z1MIN,XJ9J) IND=1+NINT(Z1-Z1MIN) DNINEJ=0.D0 IF(IND.GE.1 .AND. IND.LE.IVAL) DNINEJ=XJ9J(IND) 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 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) C C COMPUTE THE RADIAL PARTS OF THE POTENTIAL C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE. CALL POTENL(0,MXLAM,NPOTL,IDUM1,R,P,IDUM2) C TO ALLOW A PERTURBATION IN BOUND PROGRAMS ... 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 RSQ=1.D0/(R*R) DO 20 I=1,N W(I,I) = W(I,I) + EINT(I) + RSQ*CENT(I) - ERED 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.NE.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 DO 2 J=1,N DO 2 K=1,J 2 W(K,J)=0.D0 DO 5 LL=1,NPOTL READ(IVLU) (VL(I),I=1,N*(N+1)/2) I=1 DO 4 J=1,N CALL DAXPY(J,P(LL),VL(I),1,W(1,J),1) 4 I=I+J 5 CONTINUE 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 CHKSTR(NUSED) C NEW ROUTINE FOR DYNAMIC STORAGE HANDLING (SG:1/21/93) C C NUSED.LT.0 ON ENTRY RESETS HIH2O (HIGH-WATER MARK) C NOTE: IT IS *NOT* NECESSARY TO PASS NUSED DOWN TO ALL ROUTINES C WHICH CALL CHKSTR. HOWEVER, A NON-NEGATIVE VALUE MUST C BE SUPPLIED TO PREVENT RESETTING HIH2O, MX. C C MAXMAX WILL SAVE ORIGINAL (MAXIMUM) SIZE OF X-ARRAY IN CASE MX IS C REDUCED TO PROVIDE 'PERMANENT' STORAGE AT TOP OF MEMORY C THIS IS CURRENTLY NOT USED. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER HIH2O SAVE HIH2O,MAXMAX C C DYNAMIC STORAGE COMMON BLOCK ... COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) C DATA MAXMAX/0/ C C NEGATIVE INPUT NUSED IS SIGNAL TO RESET HIH2O C WE MIGHT ALSO WANT TO THEN SET MX=MAX0(MX,MAXMAX) IF (NUSED.LT.0) THEN C WRITE(6,601) MX,MAXMAX <<-- DEBUGGING OUTPUT 601 FORMAT(/' CHKSTR(JAN 93) INITIALIZATION CALL. MX,MAXMAX',2I10) HIH2O=0 MX=MAX0(MX,MAXMAX) ENDIF C C STORAGE REQUIREMENT FOR CURRENT CALL IS ITOP=IXNEXT-1 ITOP=IXNEXT-1 IF (ITOP.GT.MX) THEN WRITE(6,600) ITOP,MX,MAXMAX 600 FORMAT(/' CHKSTR. CANNOT PROVIDE REQUESTED STORAGE.'/ 1 10X,'CURRENT REQUEST =',I12/ 2 10X,'CURRENT LIMIT =',I12/ 3 10X,'ORIGINAL LIMIT =',I12) STOP ELSE HIH2O=MAX(HIH2O,ITOP) MAXMAX=MAX(MAXMAX,MX) NUSED=HIH2O C IF (MX->MAXMAX) IS ALSO ALLOCATED, BELOW IS APPROPRIATE... IF (MAXMAX.NE.MX) NUSED=NUSED+(MAXMAX-MX) ENDIF 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 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 MASK 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 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