saboi
/
molscat_14
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
molscat_14/v14_new.f

19257 lines
632 KiB
Fortran
Raw Permalink Blame History

C THIS ROUTINE IS THE MAIN PROGRAM FOR MOLSCAT VERSION 14
C WITH DYNAMIC SPACE ALLOCATION CAPABILITY.
C
C INCREASE MXDIM AS NECESSARY TO PROVIDE SUFFICIENT WORKSPACE.
C IXNEXT,NIPR ARE INITIALIZED IN DRIVER
C IVLFL IS ALSO SET IN DRIVER; COULD BE CHANGED BY BASIN ROUTINES
C
PARAMETER (MXDIM=100000000)
DOUBLE PRECISION X
DIMENSION X(MXDIM)
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X
C
MX=MXDIM
C
C CALL PRINCIPAL MOLSCAT/BOUND SUBROUTINE
C
CALL DRIVER
STOP
END
SUBROUTINE DRIVER
C***********************************************************************
C
C ------ MOLSCAT - J.M. HUTSON AND S.GREEN - VERSION 14 - JUL 94 -----
C
C MAIN DRIVER FOR QUANTUM MOLECULAR SCATTERING PROGRAM
C
C REVISION HISTORY SINCE VERSION 7 OF SHELDON GREEN'S QCPE PROGRAM
C (MAY 79):
C
C VARIOUS NEW PROPAGATORS HAVE BEEN ADDED SINCE EARLY VERSIONS.
C THE COMPLETE LIST IN VERSION 12 IS:
C
C INTFLG =-1 : WKB METHOD FOR SINGLE CHANNEL, SINGLE TURNING POINT
C INTFLG = 2 : DEVOGELAERE'S PROPAGATOR
C INTFLG = 3 : WALKER-LIGHT R-MATRIX PROPAGATOR
C INTFLG = 4 : HYBRID LOG-DERIVATIVE / VIVS (VIVAS) PROPAGATOR
C INTFLG = 5 : JOHNSON'S LOG-DERIVATIVE PROPAGATOR
C INTFLG = 6 : MANOLOPOULOS'S DIABATIC MODIFIED
C LOG-DERIVATIVE PROPAGATOR
C INTFLG = 7 : MANOLOPOULOS'S QUASIADIABATIC MODIFIED
C LOG-DERIVATIVE PROPAGATOR
C INTFLG = 8 : ALEXANDER-MANOLOPOLOUS MODIFIED LOG-DERIVATIVE
C AIRY PROPAGATOR (HIBRIDON)
C VERSION 8: CHANGES MADE BY CHRIS ASHTON (1982) AND JEREMY HUTSON
C (1982-4) AT WATERLOO AND CAMBRIDGE UNIVERSITIES.
C
C (1) ENTIRE PROGRAM CONVERTED TO DOUBLE PRECISION
C
C (2) GORDON ALGORITHM (INTFLG=1) REMOVED.
C
C (3) LOOP OVER "PARITY CASES" IN DRIVER HAS BEEN MADE EXPLICIT
C FOR CLARITY.
C
C (4) EIGENPHASE SUM CALCULATION AND RESONANCE SEARCH OPTION
C INCORPORATED. NEW OUTPUT CHANNEL (KSAVE) WITH OPTIONAL
C UNFORMATTED OUTPUT ON CHANNEL ISAVEU.
C
C (5) COLLISION TYPE ITYPE=10*N+7 HAS BEEN ADDED,
C FOR AN ATOM HITTING A DIATOMIC VIB-ROTOR, WHERE THE
C POTENTIAL MATRIX IS CONSTRUCTED BY DOING PROPERLY THE
C AVERAGING OF POTENTIAL TERMS OVER (V,J) AND (V',J') DIATOM
C INTERNAL STATES.
C
C (6) COLLISION TYPE ITYPE=8 ADDED, FOR ELASTIC SCATTERING OF ATOMS
C FROM CORRUGATED SURFACES. USES SUBROUTINE SURBAS TO SET UP
C THE BASIS SET. THE LOOPS IN DRIVER OVER JTOT AND M ARE USED
C TO LOOP OVER ANGLES THETA AND PHI RESPECTIVELY.
C
C (7) THE STORAGE OF THE COUPLING ARRAY VL HAS BEEN REARRANGED. THE
C METHOD OF CONSTRUCTING POTENTIAL MATRICES FROM IT HAS BEEN
C CHANGED, AND IN PARTICULAR A NEW INDEXING ARRAY IV HAS BEEN
C INTRODUCED.
C
C***********************************************************************
C
C VERSION 9 (APR 86): JMH AND SG CODES UNIFIED
C
C (9) IOS CODE RE-INCORPORATED FROM SG'S PROGRAM.
C IT IS ACCESSED BY SETTING ITYPE = 100 + 'ITYPE'
C
C (10) MANOLOPOULOS'S DIABATIC AND ADIABATIC MODIFIED LOG-DERIVATIVE
C PROPAGATORS ADDED (INTFLG=6 AND 7 RESPECTIVELY).
C
C***********************************************************************
C
C SG VERSION 10 (AUG 91):
C
C (10) NEW PRBR/IOSPB FOR OFF-DIAGONAL LINESHAPE CROSS SECTIONS,
C WITH HAS IN-CORE SIMULATION OF DIRECT ACCESS FILES.
C OUTPUT CROSS-SECTIONS NOW MULTIPLIED BY JSTEP (FOR JTOT).
C
C (11) ALEXANDER/MANOLOPOULOS MODIFIED LOG-DERIVATIVE/AIRY PROPAGATOR
C ADDED AS INTFLG=8. INTERFACED BY TIM PHILLIPS (NASA/GISS)
C
C VERSION 11 (JUN 92): JMH AND SG CODES INTEGRATED AGAIN.
C
C (12) LOOP OVER ENERGY IN DRIVER MODIFIED TO SIMPLIFY PARALLELISATION
C
C (13) ISAVEU OUTPUT MODIFIED TO USE UNFORMATTED WRITES
C
C (14) USAGE OF LINEAR ALGEBRA AND BLAS ROUTINES UNIFIED
C
C AND THE FOLLOWING ENHANCEMENTS ADDED FROM JMH'S CODE:
C
C (15) BASE9 INTERFACE ADDED
C
C (16) POTENL ENHANCED TO EVALUATE RADIAL STRENGTH FUNCTIONS BY
C QUADRATURE FOR ITYPE=1, 2, 5 AND 6.
C
C (17) CODE ADDED TO CALCULATE ASYMMETRIC TOP ENERGIES AND WAVEFUNCTION
C FROM ROTATIONAL CONSTANTS. MECHANISM FOR SELECTING ASYMMETRIC
C TOP STATES TO BE INCLUDED GENERALISED
C
C (18) CODE FOR ATOM-SPHERICAL TOP SCATTERING ADDED
C
C***********************************************************************
C
C VERSION 12 (MAY 93)
C
C (19) DYNAMIC STORAGE HANDLING COMPLETELY REORGANIZED.
C
C (20) VECTOR/MATRIX ROUTINES RATIONALIZED TO USE LAPACK AND BLAS.
C
C (21) IV() ARRAY USED ONLY FOR 'NON-TRIVIAL' CASES.
C
C (22) OPTION TO WRITE VL ARRAY TO DISC TO AVOID EXCESSIVE MEMORY USE.
C
C (23) SOME CODE FOR COUPLING VL MATRIX ELEMENTS MODIFIED TO AVOID
C UNNECESSARY RECALCULATION OF NJ COEFFICIENTS
C
C***********************************************************************
C
C VERSTION 13 (SG EXPERIMENTAL VERSION) APR 94, BUT CONTAINED IN V14
C
C (24) IV ARRAY INTRODUCED FOR ITYPE=2 CASES
C
C (25) EXPANDED POTENL CAPABILITIES
C
C (26) BIGGER DIMENSIONS: /CMBASE/ ...ELEVEL(1000),...,JLEVEL(4000),...
C ALSO ADD ISYM(10),ISYM2(10); REORGANIZED ORDERING
C
C (27) CHANGES TO CALLING SEQUENCE FOR OUTINT/OUTPCH; IEXCH NOW CORRECT
C ON ISAVEU TAPE; BASE/OUTPCH RECOGNIZE CS SIGMA WHICH ARE
C NOT COMPLETE.
C
C***********************************************************************
C
C VERSION 14 (JUL 94)
C
C (28) ISAVEU TAPE FORMAT CHANGE: NOPEN WITH JTOT,INRG,...,M,NOPEN REC
C
C (29) FILE='FILENAME' REMOVED FROM OPEN STATEMENTS
C
C (30) FLAG FOR NCAC,DTOL,OTOL INCREASED TO JTOTU=999999
C
C (31) RESTART ABILITIES (IRSTRT) FROM ISAVEU
C
C (32) ITYPE=4 CODE (ASYMMETRIC TOP - LINEAR ROTOR) ADDED
C
C (33) COMMON /CMBASE/ ALTERED TO ALLOW MORE SPACE FOR LEVELS AND
C INTRODUCE EXTRA INPUT VARIABLES FOR HANDLING FUTURE EXTENSIONS.
C THIS CHANGE REQUIRES SIMILAR CHANGES IN BASE9 ROUTINES.
C
C (34) HANDLING OF TOTAL ENERGIES CHANGED IN PRESSURE BROADENING WITH
C IFEGEN=2 OPTION: AVOID CALCULATING S MATRICES THAT ARE NOT USED.
C
C***********************************************************************
C
C EXTERNAL UNITS FOR MASSES ARE ATOMIC MASS UNITS (CARBON MASS/12)
C EXTERNAL UNITS FOR ENERGIES ARE WAVENUMBERS
C EXTERNAL UNITS FOR LENGTH RM ARE ANGSTROMS
C ALL OTHER LENGTHS ARE IN UNITS OF RM
C
C INTFLG CONTROLS METHOD OF SOLVING EQUATIONS. NPOTL AND MXLAM
C FOR SUM OVER ANGULAR DEPENDENCE OF POTENTIAL, NQN IS NO. OF
C QUANTUM NUMBERS NECESSARY TO DESCRIBE COLLISION PARTNERS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C ***** PROGRAM DIMENSION LIMITATIONS *****
C ENERGY,TEMP,LINE DIMENSIONS LIMITED BY VALUES ...
PARAMETER(MXNRG=100,MXLN=200,MXTEMP=5)
C
INTEGER EUNITS,PRNTLV,PRINT,SHRINK
CHARACTER*4 EUNITC
C
C ARRAY TO HOLD TIME AND DATE
C INTEGER CTIME(2),CDATE(4)
CHARACTER CTIME*9,CDATE*11
C
C TYPES FOR COMMON/LDVVCM/
LOGICAL IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM
LOGICAL LCALC,ALDONE
LOGICAL IREAD,IWRITE
LOGICAL LWARN
C
C DOUBLE PRECISION LABEL(10)
CHARACTER*80 LABEL
CHARACTER*80 LABL
CHARACTER*1 TITLE(80),TIT(120),TIT2(120),BL
CHARACTER*8 PDATE
CHARACTER*8 CWD(2)
EQUIVALENCE (LABL,TITLE(1))
C
C FOLLOWING ARRAYS ALL HAVE DIMENSION MXNRG. MXNRG IS THE MAXIMUM
C ALLOWED NUMBER OF TOTAL ENERGIES PER RUN.
DIMENSION ENERGY(MXNRG)
DIMENSION IECONV(MXNRG),ISST(MXNRG),MINJT(MXNRG),MAXJT(MXNRG)
C
C VARIABLES DIMENSIONED FOR NO. OF LINES IN PRES. BROAD. CALC.
C N.B. PRBRIN STILL MAX NO. LINES = 2*MXLN DESPITE OFF-DIAG CHANGES
DIMENSION LINE(2*MXLN),LTYPE(MXLN)
EQUIVALENCE (ILSU,IPRBRU), (NLPRBR,IFLS)
C
DIMENSION TEMP(MXTEMP)
C
C VARIABLES TO TEST PARTIAL WAVE CONVERGENCE
DIMENSION TEST(2)
EQUIVALENCE (TEST(1),DTOL),(TEST(2),OTOL)
C
DIMENSION NLABV(9)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY
C IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINPER W/ VL ARRAY.
C NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2.
C E.G. FOR IBM R*8/I*4, NIPR=2. AN INTEGER ARRAY OF DIM. N
C CAN BE STORED IN A REAL ARRAY OF DIMENSION (N+NIPR-1)/NIPR.
C
C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS
COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RSTART,RSTOP,XEPS,
1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA,
2 NOPEN,JKEEP,ISCRU,MAXSTP
C
C EXTRA COMMON BLOCK FOR LDVIVS
COMMON/LDVVCM/XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP,
1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE
C
C COMMON BLOCK FOR WKB INTEGRATOR
COMMON/WKBCOM/NGMP(3)
C
C COMMON BLOCK TO SUBROUTINE OUTPUT FOR USE IN RESONANCE SEARCHES
COMMON/EIGSUM/EPSM(5)
C
C COMMON BLOCK FOR AIRPRP ARGUMENTS IN MANOLOPOLOUS/ALEXANDER
C PROPAGATOR
COMMON/HIBRIN/POWRX,DRAIRY,IABSDR
C
COMMON/VLSAVE/IVLU
C
NAMELIST /INPUT/ LABEL,RMIN,RMAX,IRMSET,IRXSET,URED,ISCRU,ISIGPR
1 ,ITHROW,STEST,NNRG,ENERGY,DNRG,JTOTL,JTOTU,JSTEP,MSET,MHI,NCAC
2 ,PRNTLV,INTFLG,MXSIG,STEPS,STABIL,NTEMP,NGAUSS,TEMP,EUNITS
3 ,ISIGU,IPARTU,ILSU,IPRBRU,IFLS,NLPRBR,LINE,IFEGEN,LTYPE,MAXSTP
4 ,TOLHI,RVIVAS,RVFAC,XSQMAX,ALPHA1,ALPHA2,IALPHA,EUNITC
5 ,IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM
6 ,ISAVEU,DTOL,OTOL,KSAVE,DR,DRNOW,DRMAX,RMID,VTOL,ICONV
7 ,THETLW,THETST,PHILW,PHIST,MXPHI,SHRINK,LASTIN
8 ,MMAX,LMAX,NGMP
9 ,VMAX,TMAX,TOLLO,CTOL,UTEST,TOLER,TOL,MXXX,MNNN
A ,POWRX,DRAIRY,IABSDR,NNRGPG,IRSTRT
C
EQUIVALENCE (MXPAR,MXPHI), (RMID,RVIVAS), (DR,DRNOW),
1 (TOL,TOLER,TOLHI)
C
C NGPT,LMAX, MMAX, AND NGMP(3) ARE VARIABLES ADDED FOR
C COMPATIBILITY WITH THE IOS PROGRAMS
C VARIABLES VMAX,...,MNNN ADDED FOR COMPATIBILITY WITH S.GREEN CODE
C (MOSTLY GORDON INTEGRATOR). ALSO TOL, TOLER, DRNOW
C
C RMIN IS THE RADIUS AT WHICH THE INTEGRATION IS BEGUN
C RMAX IS THE OUTER RADIUS TO WHICH THE INTEGRATION MUST EXTEND
C MAXSTP IS MAX NO. OF STEPS IN RADIAL INTEGRATION (INTFLG=3 ONLY)
C
C ARRAYS FOR NAMELIST SIMULATOR
C CHARACTER*6 INAMES
C DIMENSION INAMES(89),LOCN(89),INDX(89)
C
C DATA INAMES/'LABEL','RMIN','RMAX','IRMSET','IRXSET',
C 1 'URED','ISCRU','ISIGPR',
C 1 'ITHROW','STEST','NNRG','ENERGY','DNRG',
C 2 'JTOTL','JTOTU','JSTEP','MSET','MHI','NCAC',
C 2 'PRNTLV','INTFLG','MXSIG','STEPS','STABIL',
C 3 'NTEMP','NGAUSS','TEMP','EUNITS','ISIGU','IPARTU','ILSU',
C 4 'IPRBRU','IFLS','NLPRBR','LINE','IFEGEN','LTYPE','MAXSTP',
C 4 'TOLHI','RVIVAS','RVFAC','XSQMAX','ALPHA1','ALPHA2','IALPHA',
C 5 'IALFP','IV','IVP','IVPP','NUMDER','ISHIFT','IDIAG','IPERT',
C 6 'ISYM','ISAVEU','DTOL','OTOL','KSAVE','DR','DRNOW','DRMAX',
C 7 'RMID','VTOL','ICONV','THETLW','THETST','PHILW','PHIST',
C 8 'MXPHI','SHRINK','LASTIN','MMAX','LMAX','NGMP','VMAX',
C 9 'TMAX','TOLLO','CTOL','UTEST','TOLER','TOL','MXXX','MNNN'
C A 'PWRX','DRAIRY','IABSDR','NNRGPG','IRSTRT','EUNITC'/
C DATA INDX/88*0/
C
C DATA LABEL/10*' '/
DATA CWD/' ','(8-BYTE)'/
DATA CTIME/' '/,CDATE/' '/
DATA IPROGM/14/, PDATE/'(MAR 95)'/
DATA TITLE/80*' '/, BL/' '/
DATA TIT/120*'='/, TIT2/120*'-'/
C
DATA LTYPE/MXLN*-1/
C
C NLABV ARRAY CONTAINS NUMBER OF LABELS PER SYMMETRY TERM FOR EACH
C VALUE OF ITYPE (ITYPE=4 ADDED JUL 94 TRP/SG)
DATA NLABV/1,3,3,4,2,2,5,2,1/
C
C THE PHYSICAL CONSTANTS USED ARE COMBINED IN THE SINGLE NUMBER BFCT.
C BFCT IS 0.5*(HBAR**2) IN UNITS OF (ATOMIC MASS UNITS)*(WAVENUMBERS)
C *(ANGSTROMS**2).
C THE FOLLOWING VALUE IS FROM THE 1973 PHYSICAL CONSTANTS.
DATA BFCT/16.857630D0/
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C CALL ROUTINE TO MASK FLOATING-POINT UNDERFLOW.
CALL MASK
C
C STORE VALUE OF MX IN CASE IT NEEDS TO BE RESET;
C NEEDED IN FUTURE CODE WHICH USES MAXMAX/MX TO ALLOCATE
C 'PERMANENT' STORAGE FOR A RUN W/ MULTIPLE (LASTIN=0) INPUT DECKS
MXSAVE=MX
100 MX=MXSAVE
CALL GCLOCK(TFIRST)
CALL GDATE(CDATE)
CALL GTIME(CTIME)
WRITE(6,110) IPROGM,PDATE,CDATE,CTIME,IPROGM,PDATE
110 FORMAT(2X,8('----MOLSCAT----')/' |',120X,'|'/' |',24X,
1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ',
2 'AND S. GREEN',23X,'|'/' |',29X,'VERSION 1 BY S. GREEN ',
3 '(NOV 1973); THIS IS VERSION',I3,1X,A8,29X,'|'/
4 ' |',120X,'|'/' |',44X,'RUN ON ',A11,2X,
5 'AT ',A9,44X,'|'/' |',120X,'|'/2X,8('----MOLSCAT----')//
6 2X,'PUBLICATIONS RESULTING FROM THE USE OF THIS PROGRAM SHOULD ',
7 'REFER TO'/2X,'J. M. HUTSON AND S. GREEN, MOLSCAT COMPUTER ',
8 'CODE, VERSION',I3,1X,A8 /
9 2X,'DISTRIBUTED BY COLLABORATIVE COMPUTATIONAL PROJECT NO. 6 ',
A 'OF THE SCIENCE AND ENGINEERING RESEARCH COUNCIL (UK)')
C
C INITIALIZE STORAGE PARAMETERS IN /MEMORY/
NIPR=2
IXNEXT=1
C SET IVLFL TO 1 TO ENSURE STORAGE COMPATIBILITY W/ VERSION 11
IVLFL=1
C SET NUSED.LT.0 AND CALL CHKSTR TO RESET COUNTER FOR EACH &INPUT.
NUSED=-1
CALL CHKSTR(NUSED)
C
C SET INITIAL VALUES BEFORE READ(5,INPUT) . . .
C
LWARN=.FALSE.
IOSFLG=0
NGMP(1)=8
NGMP(2)=1
NGMP(3)=16
NNRG=0
NNRGPG=1
DNRG=0.D0
NTEMP=0
NGAUSS=3
JSTEP=1
JTOTL=-1
JTOTU=-1
MSET=0
MHI=0
MXSIG=0
ISIGPR=0
ITHROW=0
DTOL=0.3D0
OTOL=.005D0
NCAC=4
ISIGU = 0
IPARTU=0
ISAVEU=0
KSAVE=0
ILSU=11
IFLS=0
IFEGEN=0
ICONV=0
INTFLG=4
RMIN=0.8D0
RMAX=10.D0
STEST=1.D-4
STEPS=10.D0
STABIL=5.D0
ISCRU=0
IRMSET=9
IRXSET=1
DR=2.D-2
RMID=9999.D0
RVFAC=0.D0
DRMAX=5.D0
VTOL=1.D-06
MAXSTP=10000
TOLHI=0.001D0
XSQMAX=1.D04
ALPHA1=1.D0
ALPHA2=1.5D0
IALPHA=6
IALFP=.FALSE.
IV=.TRUE.
IVP=.FALSE.
IVPP=.FALSE.
NUMDER=.FALSE.
ISHIFT=.FALSE.
IDIAG=.FALSE.
IPERT=.TRUE.
ISYM=.TRUE.
EUNITS=0
EUNITC=' '
PRNTLV=0
MXPHI=1
THETLW=0.D0
THETST=0.D0
PHILW=0.D0
PHIST=0.D0
SHRINK=1
LASTIN=1
PI=ACOS(-1.D0)
POWRX=3.D0
DRAIRY=-1.D0
IABSDR=0
IRSTRT=0
C
C READ &INPUT DATA.
C OPEN(5,STATUS='OLD',SHARED,READONLY)
C----------------------------------------------------------------
C ARRAYS FOR NAMELIST SIMULATOR
C LOCN(1)=LOC(LABEL)
C LOCN(2)=LOC(RMIN)
C LOCN(3)=LOC(RMAX)
C LOCN(4)=LOC(IRMSET)
C LOCN(5)=LOC(IRXSET)
C LOCN(6)=LOC(URED)
C LOCN(7)=LOC(ISCRU)
C LOCN(8)=LOC(ISIGPR)
C LOCN(9)=LOC(ITHROW)
C LOCN(10)=LOC(STEST)
C LOCN(11)=LOC(NNRG)
C LOCN(12)=LOC(ENERGY)
C LOCN(13)=LOC(DNRG)
C LOCN(14)=LOC(JTOTL)
C LOCN(15)=LOC(JTOTU)
C LOCN(16)=LOC(JSTEP)
C LOCN(17)=LOC(MSET)
C LOCN(18)=LOC(MHI)
C LOCN(19)=LOC(NCAC)
C LOCN(20)=LOC(PRNTLV)
C INDX(20)=4
C LOCN(21)=LOC(INTFLG)
C LOCN(22)=LOC(MXSIG)
C LOCN(23)=LOC(STEPS)
C LOCN(24)=LOC(STABIL)
C LOCN(25)=LOC(NTEMP)
C LOCN(26)=LOC(NGAUSS)
C LOCN(27)=LOC(TEMP)
C LOCN(28)=LOC(EUNITS)
C INDX(28)=4
C LOCN(29)=LOC(ISIGU)
C LOCN(30)=LOC(IPARTU)
C LOCN(31)=LOC(ILSU)
C LOCN(32)=LOC(IPRBRU)
C LOCN(33)=LOC(IFLS)
C LOCN(34)=LOC(NLPRBR)
C LOCN(35)=LOC(LINE)
C LOCN(36)=LOC(IFEGEN)
C LOCN(37)=LOC(LTYPE)
C LOCN(38)=LOC(MAXSTP)
C LOCN(39)=LOC(TOLHI)
C LOCN(40)=LOC(RVIVAS)
C LOCN(41)=LOC(RVFAC)
C LOCN(42)=LOC(XSQMAX)
C LOCN(43)=LOC(ALPHA1)
C LOCN(44)=LOC(ALPHA2)
C LOCN(45)=LOC(IALPHA)
C LOCN(46)=LOC(IALFP)
C LOCN(47)=LOC(IV)
C LOCN(48)=LOC(IVP)
C LOCN(49)=LOC(IVPP)
C LOCN(50)=LOC(NUMDER)
C LOCN(51)=LOC(ISHIFT)
C LOCN(52)=LOC(IDIAG)
C LOCN(53)=LOC(IPERT)
C LOCN(54)=LOC(ISYM)
C DO 115 I=46,54
C 115 INDX(I)=3
C LOCN(55)=LOC(ISAVEU)
C LOCN(56)=LOC(DTOL)
C LOCN(57)=LOC(OTOL)
C LOCN(58)=LOC(KSAVE)
C LOCN(59)=LOC(DR)
C LOCN(60)=LOC(DRNOW)
C LOCN(61)=LOC(DRMAX)
C LOCN(62)=LOC(RMID)
C LOCN(63)=LOC(VTOL)
C LOCN(64)=LOC(ICONV)
C LOCN(65)=LOC(THETLW)
C LOCN(66)=LOC(THETST)
C LOCN(67)=LOC(PHILW)
C LOCN(68)=LOC(PHIST)
C LOCN(69)=LOC(MXPHI)
C LOCN(70)=LOC(SHRINK)
C INDX(70)=4
C LOCN(71)=LOC(LASTIN)
C LOCN(72)=LOC(MMAX)
C LOCN(73)=LOC(LMAX)
C LOCN(74)=LOC(NGMP)
C LOCN(75)=LOC(VMAX)
C LOCN(76)=LOC(TMAX)
C LOCN(77)=LOC(TOLLO)
C LOCN(78)=LOC(CTOL)
C LOCN(79)=LOC(UTEST)
C LOCN(80)=LOC(TOLER)
C LOCN(81)=LOC(TOL)
C LOCN(82)=LOC(MXXX)
C LOCN(83)=LOC(MNNN)
C LOCN(84)=LOC(POWRX)
C LOCN(85)=LOC(DRAIRY)
C LOCN(86)=LOC(IABSDR)
C LOCN(87)=LOC(NNRGPG)
C LOCN(88)=LOC(IRSTRT)
C LOCN(89)=LOC(EUNITC)
C
C CALL NAMLIS('&INPUT',INAMES,LOCN,INDX,89,IEOF)
C IF(IEOF.EQ.1) GOTO 1040
C--------------------------------------------------------------
READ(5,INPUT,END=1040)
C
WRITE(6,120)
120 FORMAT(//' /INPUT/ DATA ARE --')
WRITE(LABL,'(A80)') LABEL
WRITE(6,130) LABL
130 FORMAT(/' RUN LABEL = ',A80)
DO 140 IST=1,80
IF(TITLE(IST).NE.BL) GOTO 150
140 CONTINUE
GOTO 190
150 DO 160 IND=1,80
IF(TITLE(81-IND).NE.BL) GOTO 170
160 CONTINUE
GOTO 190
170 IND=81-IND
NST=(119-IND+IST)/2
TIT(NST)=BL
TIT2(NST)=BL
DO 180 I=IST,IND
NST=NST+1
TIT(NST)=TITLE(I)
TIT2(NST)=TITLE(I)
180 CONTINUE
TIT(NST+1)=BL
TIT2(NST+1)=BL
C
190 AMXKB=MX/128.D0
IF (NIPR.EQ.1.OR.NIPR.EQ.2) THEN
WRITE(6,200) MX,CWD(NIPR),AMXKB
200 FORMAT(/' SCRATCH CORE STORAGE ALLOCATION IS',I10,A8,
1 ' WORDS (',F10.2,' KBYTES)')
WRITE(6,202) NIPR
202 FORMAT(2X,I1,' INTEGER(S) CAN BE STORED IN EACH WORD.')
ELSE
WRITE(6,204) NIPR
204 FORMAT(/' *** ILLEGAL NIPR =',I10)
ENDIF
C
PRINT=PRNTLV
C
C PROCESS INTFLG -- REQUESTED PROPAGATOR -- AND ITS INPUT DATA.
C
WRITE(6,210) INTFLG
210 FORMAT(/' INTEGRATOR REQUESTED BY INPUT VALUE INTFLG =',I3)
220 FORMAT(/' ***** ERROR - NO IMPLEMENTATION FOR THIS INTFLG'
1 ,' - RUN HALTED.')
240 FORMAT(/' COUPLED EQUATIONS SOLVED BY METHOD OF DEVOGELAERE.')
250 FORMAT(/' INTEGRATION PARAMETERS ARE RMIN =',F7.2/
1 30X,'RMAX =',F7.2/30X,'STEST =',D11.2/30X,'STEPS =',
2 F6.1,' (PER WAVELENGTH)'/30X,'STABIL =',F6.1,' (STEPS PER',
3 ' STABILIZATION)')
270 FORMAT(/' COUPLED EQUATIONS SOLVED BY WALKER-LIGHT R-MATRIX',
1 ' PROPAGATOR ALGORITHM'//' PARAMETERS ARE',5X,'RMIN =',
2 F7.2,8X,'DR = ',G8.2/21X,'RMAX =',F7.2,8X,
3 'VTOL =',D9.2/21X,'RMID =',F7.2,8X,'MAXSTP =',I9)
271 FORMAT(/' RVFAC =',F7.2,' OVERRIDES INPUT RMID')
300 FORMAT(/' COUPLED EQUATIONS SOLVED BY LOG DERIVATIVE METHOD ',
1 'OF JOHNSON')
310 FORMAT(/' INTEGRATION PARAMETERS ARE RMIN =',F7.2,8X,
1 'STEPS = ',F7.1/33X,'RMAX =',F7.2)
320 FORMAT(/' CHANGING TO VARIABLE INTERVAL / VARIABLE STEP METHOD',
1 ' AT LONG RANGE'//' INTEGRATION PARAMETERS ARE RVIVAS =',
2 F7.2,8X,'DR =',G8.2/
3 33X,'RMAX =',F7.2,8X,'DRMAX =',F8.2/
4 56X,'ALPHA1 = ',F7.2/33X,'XSQMAX =',G7.1,8X,'ALPHA2 = ',F7.2/
5 33X,'TOLHI =',G7.1,8X,'IALPHA =',I8/33X,'ISHIFT =',L7,8X,
6 'IV =',L8/33X,'IPERT =',L7,8X,'IVP =',L8/33X,
7 'IALFP =',L7,8X,'IVPP =',L8/33X,'ISYM =',L7,8X,
8 'NUMDER =',L8)
340 FORMAT(/' COUPLED EQUATIONS SOLVED BY DIABATIC ',
1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS')
350 FORMAT(/' COUPLED EQUATIONS SOLVED BY QUASIADIABATIC ',
1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS')
352 FORMAT(33X,'IABSDR =',I4)
353 FORMAT(33X,'OVERRIDES STEPS PARAMETER WITH DR =',F9.3)
354 FORMAT(/' AIRY PARAMETERS ','RMID =',F10.4/
2 33X,'DRAIRY=',F10.4/33X,'TOLHI=',F13.6/
3 33X,'POWRX =',F8.2)
355 FORMAT(/' DRAIRY.LT.0 TAKES INITIAL AIRY STEP SIZE FROM'
1 ,' MODIFIED LOG-DERIVATIVE VALUE.')
356 FORMAT(/' TOLHI.GE.1 -- AIRY STEP SIZE INCREASED BY'
1 ,' FACTOR OF TOLHI AT EACH STEP')
357 FORMAT(/' TOLHI.LT.1 -- AIRY STEPS ADJUSTED TO MAINTAIN'
1 ,' APPROX. ACCURACY VIA PERTURBATION THEORY AND POWRX.')
370 FORMAT(/' EQUATIONS SOLVED BY WKB APPROXIMATION WITH GAUSS-'
1 ,'MEHLER INTEGRATION. SEE R. T PACK, JCP 60, 633 (1974).'/
2 /' NOTE THAT THIS IS IMPLEMENTED ONLY FOR ONE CHANNEL',
3 ' CASES, E.G., IOS CALCULATIONS.'/
4 /' INTEGRATION PARAMETERS ARE RMIN =',D15.4/
5 30X,'STEST =',D14.4/30X,'NGMP =',I6,' (',I2,')',I3)
C
IF(INTFLG.EQ.2) THEN
WRITE(6,240)
C STABIL=MIN(STABIL,STEPS/2.D0)
WRITE(6,250) RMIN,RMAX,STEST,STEPS,STABIL
GO TO 380
ENDIF
C
IF(INTFLG.EQ.3) THEN
WRITE(6,270) RMIN,DR,RMAX,VTOL,RMID,MAXSTP
IF(RVFAC.GT.0.D0 .AND. IRMSET.GT.0) WRITE(6,271) RVFAC
GO TO 380
ENDIF
C
IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN
IF(IDIAG) THEN
IV=.TRUE.
IVP=.TRUE.
IVPP=.TRUE.
ISHIFT=.TRUE.
IPERT=.TRUE.
ENDIF
IF(INTFLG.EQ.5) RVIVAS=RMAX
WRITE(6,300)
WRITE(6,310) RMIN,STEPS,RVIVAS
IF(INTFLG.EQ.4) WRITE(6,320) RVIVAS,DR,RMAX,DRMAX,ALPHA1,XSQMAX,
1 ALPHA2,TOLHI,IALPHA,ISHIFT,IV,IPERT,IVP,IALFP,IVPP,ISYM,NUMDER
GO TO 380
ENDIF
C
IF(INTFLG.EQ.6) THEN
WRITE(6,340)
WRITE(6,310) RMIN,STEPS,RMAX
GO TO 380
ENDIF
C
IF(INTFLG.EQ.7) THEN
WRITE(6,350)
WRITE(6,310) RMIN,STEPS,RMAX
GO TO 380
ENDIF
C
IF(INTFLG.EQ.8) THEN
CALL MHAACK(6)
WRITE(6,310) RMIN,STEPS,RMAX
WRITE(6,352) IABSDR
IF(IABSDR.EQ.1) WRITE(6,353) DR
WRITE(6,354) RMID,DRAIRY,TOLHI,POWRX
IF(RVFAC.GT.0.D0.AND.IRMSET.GT.0) WRITE(6,271) RVFAC
IF(DRAIRY.LT.0.D0) WRITE(6,355)
IF(TOLHI.GE.1.D0) THEN
WRITE(6,356)
ELSE
WRITE(6,357)
ENDIF
GO TO 380
ENDIF
C
IF(INTFLG.EQ.-1) THEN
WRITE(6,370) RMIN,STEST,NGMP
GO TO 380
ENDIF
C
WRITE(6,220)
STOP
C
380 JKEEP=-1
XEPS=-1.D0
DEEP=1.D30
IF(IRXSET.GT.0) WRITE(6,381) IRXSET
381 FORMAT(/' IRXSET =',I3,' OPTION. RMAX ADJUSTED AUTOMATICALLY ',
1 'FOR EACH NEW JTOT,MVAL')
IF(IRMSET.LE.0) GOTO 420
WRITE(6,390) IRMSET
390 FORMAT(/' IRMSET =',I3,' OPTION. RMIN CHOSEN AUTOMATICALLY ',
1 'FOR EACH NEW JTOT')
C
C XEPS IS SUCH THAT AIRY(XEPS) APPROX. EQUALS 10**(-IRMSET)
C
XEPS=(-1.5D0*LOG(4.D0*SQRT(PI)*
1 10.D0**(-IRMSET)))**(2.D0/3.D0)
C>>SG 1/18/93 BELOW REMOVED AT SUGGESTION OF JMH
C IF(ISCRU.EQ.0 .AND. NNRG.NE.1) SHRINK=0
IF(INTFLG.NE.3 .OR. SHRINK.NE.1) GOTO 420
DEEP=2.D0+XEPS**1.5D0/1.5D0
WRITE(6,400)
400 FORMAT(22X,'AND DEEPLY CLOSED CHANNELS ',
1 'DROPPED IN LONG-RANGE REGION')
IF(NNRG.NE.1 .AND. ISCRU.NE.0) WRITE(6,410)
410 FORMAT(22X,'NOTE THAT BASIS SET CONTRACTION IS PERFORMED FOR ',
1 'ENERGY(1),'/22X,'SO THAT SUBSEQUENT ENERGIES MUST NOT BE ',
2 'SIGNIFICANTLY HIGHER.')
C
420 ISAV=0
IF(JTOTL.EQ.JTOTU .AND. MSET.GT.0) ISAV=1
IF(ISCRU.LT.0) ISAV=-ISAV
ISCRU=IABS(ISCRU)
C
IF(ISCRU.EQ.0) THEN
IF(NNRG.GT.1.OR.NTEMP.GT.0) WRITE(6,430)
430 FORMAT(/' ***** WARNING - NO SCRATCH FILE SPECIFIED BY ISCRU ',
1 'PARAMETER - FULL CALCULATION WILL BE DONE AT EACH ENERGY')
ELSE
IF(ISAV.EQ.-1) THEN
WRITE(6,440) ISCRU
440 FORMAT(/' ENERGY-INDEPENDENT MATRICES SAVED FROM A ',
1 'PREVIOUS RUN WILL BE READ FROM UNIT',I3)
OPEN(ISCRU,FORM='UNFORMATTED',STATUS='OLD')
ELSE
WRITE(6,450) ISCRU
450 FORMAT(/' ENERGY-INDEPENDENT MATRICES WILL BE SAVED ',
1 'TEMPORARILY ON UNIT',I3)
OPEN(ISCRU,FORM='UNFORMATTED',STATUS='UNKNOWN')
ENDIF
ENDIF
C
WRITE(6,470) URED
470 FORMAT(/' REDUCED MASS FOR COLLISION =',F14.9,' A.M.U.')
IF(JTOTL.LT.0) JTOTL=0
IF(JTOTU.LT.JTOTL) JTOTU=999999
WRITE(6,480) JTOTL,JTOTU,JSTEP
480 FORMAT(/' CONTROL DATA FOR TOTAL ANGULAR MOMENTUM IS'/
1 7X,'JTOT FROM',I4,' TO',I6,' IN STEPS OF',I4)
IF(JTOTU.GE.999999) WRITE(6,490) NCAC,DTOL,OTOL
490 FORMAT(/' JTOT SERIES WILL BE TERMINATED WHEN MAX CHANGE IN ',
1 'CROSS SECTIONS IS LESS THAN TOLERANCE FOR NCAC =',I3,
2 ' CONSECUTIVE JTOT'/25X,
3 'DIAGONAL (DTOL) AND OFF-DIAGONAL (OTOL) TOLERANCES ARE',2F9.5)
IF(JTOTU.GE.999999.AND.NNRGPG.GT.1) WRITE(6,491) NNRGPG
491 FORMAT(/' N.B. CONVERGENCE CHECKING IS DONE FOR ENERGY GROUPS',
1 ' OF NNRGPG =',I4)
IF(MSET.GT.0 .AND. MHI.LE.0) MHI=MSET
IF(MSET.GT.0) WRITE(6,500) MSET,MHI
500 FORMAT(/' CALCULATIONS WILL BE FOR SYMMETRY BLOCK ("PARITY ',
1 'CASES")',I4,' TO',I4)
C
C PROCESS TOTAL ENERGIES
C
CALL ECNV(EUNITS,EUNITC,EFACT)
IF(NNRG.GT.0 .AND. DNRG.EQ.0.D0 .AND. ABS(EFACT-1.D0).GT.1.D-3
1 .AND. ICONV.EQ.0) WRITE(6,510) (ENERGY(I),I=1,NNRG)
510 FORMAT(/' INPUT ENERGY LIST IS'/(16X,7D16.6))
IF(NTEMP.LE.0) GOTO 520
C OVERRIDE ENERGY INPUT WITH TEMP INPUT
NTEMP=MIN0(NTEMP,MXTEMP)
CALL EAVG(NTEMP,TEMP,NGAUSS,ENERGY,NNRG,MXNRG)
NPR=NNRG
GOTO 590
520 ISRCH=0
NPR=NNRG
C
C PROCESS A NEGATIVE INPUT NNRG FOR RESONANCE SEARCH OPTION
C
IF(NNRG.GE.0 .OR. DNRG.EQ.0.D0 .OR. JTOTL.NE.JTOTU .OR.
1 MSET.LE.0 .OR. KSAVE.LE.0) GOTO 530
ISRCH=1
NNRG=5*(IABS(NNRG)/5)
MXN=5*(MXNRG/5)
NNRG=MIN0(NNRG,MXN)
NNRGPG=5
NPR=5
C
530 NNRG=MIN0(MXNRG,NNRG)
NPR=MIN0(MXNRG,NPR)
IF(NNRG.GT.0) GOTO 550
WRITE(6,540)
540 FORMAT(/' ***** ERROR - NO INPUT ENERGIES SPECIFIED - RUN HALTED')
STOP
550 IF(NNRG.LE.1 .OR. (DNRG.EQ.0.D0 .AND. ICONV.EQ.0)) GOTO 570
DO 560 I=2,NPR
560 ENERGY(I)=ENERGY(1)+(I-1)*DNRG
570 DO 580 I=1,NPR
580 ENERGY(I)=ENERGY(I)*EFACT
590 WRITE(6,600) NNRG
600 FORMAT(/' CONTROL DATA FOR TOTAL ENERGIES. CALCULATIONS WILL ',
1 'BE PERFORMED FOR',I4,' VALUES')
DO 610 I=1,NPR
ENEV=ENERGY(I)/8065.5410D0
610 WRITE(6,620) I,ENERGY(I),ENEV
620 FORMAT(7X,'ENERGY NO.',I4,' =',F17.9,' (1/CM) =',F17.12,' E.V.')
C
IF(ISRCH.EQ.1) WRITE(6,630)
630 FORMAT(/' RESONANCE SEARCH OPTION. ONLY FIRST 5 ENERGIES ',
1 'GIVEN. OTHERS WILL BE DETERMINED INTERACTIVELY.')
C
IF(IFLS.GT.0 .AND. IFEGEN.GT.0) WRITE(6,640)
640 FORMAT(/' THESE ENERGY VALUES WILL BE USED AS RELATIVE (CENTER',
1 ' OF MASS) VALUES AND LIST MAY BE MODIFIED ACCORDINGLY.')
C
IF(NUMDER) WRITE(6,641)
641 FORMAT(/' NUMDER=.TRUE. POTENTIAL DERIVATIVE WILL BE COMPUTED',
& ' NUMERICALLY FROM POTENTIAL.')
WRITE(6,650) PRINT,ISIGPR,ITHROW
650 FORMAT(/' PRINT LEVEL (PRNTLV) =',I3,' OTHER PRINT CONTROLS',
1 ' ISIGPR =',I2,' ITHROW =',I2)
WRITE(6,660)
660 FORMAT(/' ',30('===='))
C
C INITIALIZE BASIS (BASIN/IOSBIN)
C COMBINED MOLSCAT (BASIN) AND IOS (IOSBIN) -- APR 86
C IOSBIN GRABS STORAGE IN ATAU=JLEV=X (ITYPE=6 ONLY). MAX AVAILABLE
C PASSED INITIALLY IN NLEV; SET6I/IOSBIN MUST UPDATE
C IC ACCORDINGLY. N.B. IOS CASE ALSO USES NLEV TO PASS 'NVC'
C FROM BASIN/IOSBIN TO IOSDRV.
C BASIN TAKES STORAGE FOR JLEV=X, AND ALSO RESETS IC ACCORDINGLY;
C FOR THIS CASE, NLEV INITIALIZED TO MAXIMUM AVAILABLE IN X().
IXJLEV=IXNEXT
NLEV=MX
C IXNEXT REMOVED FROM ARGUMENT LIST: JMH, 10 NOV 93
CALL BASIN(NLEV,X(IXJLEV),URED,NQN,NLABV(9),MXPAR,ITYPE,IOSFLG)
C BASE ROUTINE INCREMENTS IXNEXT BY AMOUNT OF STORAGE IN JLEV.
CALL CHKSTR(NUSED)
WRITE(6,660)
C
C INITIALIZE POTENTIAL.
C
ILAM=IXNEXT
MXLAM=NIPR*(MX-ILAM+1)
CALL POTENL(-1,MXLAM,NPOTL,X(ILAM),RM,EPSIL,ITYPE)
C THIS READS (5, POTL). RM AND EPSIL ARE SET HERE.
C RM IS A LENGTH PARAMETER (IN ANGSTROMS)
C EPSIL IS AN ENERGY PARAMETER IN WAVENUMBERS.
ITYP=MOD(ITYPE,10)
C INCREMENT IXNEXT FOR STORAGE TAKEN FOR LAM(NLABV,MXLAM)
IXNEXT=IXNEXT+(MXLAM*NLABV(ITYP)+NIPR-1)/NIPR
CALL IVCHK(IVLFL,PRNTLV,ITYPE,NLABV,MXLAM,NPOTL,X(ILAM))
WRITE(6,660)
C
C COMPUTE SOME DIMENSIONLESS PARAMETERS
C
C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO DEBROGLIE WAVELENGTH
RMLMDA=URED*RM*RM*EPSIL/BFCT
C CINT IS THE FACTOR TO REDUCE THE ROTATIONAL CONSTANTS
CINT = RMLMDA/EPSIL
C
C ***
IF(IOSFLG.LE.0) GOTO 670
C ***
C *** THIS IS WHERE IOS CODE DIVERGES - CALL IOS CODE AND SKIP TO EXIT
C ***
IF (IRSTRT.NE.0) THEN
WRITE(6,*) ' *** RESTART REQUESTED WITH IOS RUN - NOT ALLOWED'
WRITE(6,*) ' *** MODIFY INPUT DECK AND RESUBMIT'
STOP
ENDIF
CALL IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC,
1 IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX,
2 IPROGM,URED,LABL,NUMDER,
3 X(ILAM),MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC,
4 DEEP,PRINT,NLEV,ISAVEU,TFIRST,RM,EPSIL,RMIN,RMAX)
CALL GCLOCK(TLAST)
TOTIME=TLAST-TFIRST
GOTO 1020
C
C PROCESS PRESSURE-BROADENING LINE-SHAPE INPUT PARAMETERS.
C
670 IF(IFLS.GT.0) THEN
CALL PRBRIN(IFLS,LINE,LTYPE,MXLN,ILSU,NNRG,ENERGY,MXNRG,IFEGEN,
1 X(IXJLEV),PRINT)
IF(IFEGEN.GT.0) NPR=NNRG
WRITE(6,660)
IF(KSAVE.EQ.0) GOTO 690
WRITE(6,680) IFLS,KSAVE
680 FORMAT(/' ****** WARNING. IFLS =',I3,' AND KSAVE =',I3,' ARE ',
1 'INCOMPATIBLE. KSAVE IS RESET TO ZERO')
KSAVE=0
ENDIF
C
C INITIALIZE OUTPUT ROUTINE.
C OUTPUT TAKES AN ADDITIONAL AMOUNT OF STORAGE
C FOR SIG AT X(IXNEXT) AND INCREASES IXNEXT ACCORDINGLY.
C
690 IOUT=IXNEXT
C NOTE THAT IXNEXT WILL BE CHANGED BY OUTINT
CALL OUTINT(LABL,ENERGY,NNRG,NLEV,NQN,X(IXJLEV),X(IOUT),IXNEXT,
1 IECONV,URED,ITYPE,KSAVE,ISST,MINJT,MAXJT,ISIGU,IPARTU,ISAVEU,
2 IPROGM,MXSIG,ISIGPR,JSTEP,IRSTRT)
CALL CHKSTR(NUSED)
IC1=IXNEXT
C PROCESS RESTART REQUEST ...
MXP=0
CALL RESTRT(IRSTRT,ISAVEU,JTOTL,JSTEP,MXPAR,MSET,MHI,
1 LABEL,ITYPE,NLEV,NQN,URED,IPROGM,
2 X(IXJLEV),NNRG,ENERGY,MXNRG,
3 X(IOUT),ISST,IECONV,MINJT,MAXJT,ISIGU,IPARTU,KSAVE,
4 OTOL,DTOL,X(IC1),X(IC1),MRSTRT,IERST,MXP,PRINT)
WRITE(6,660)
C
EFIRST=ENERGY(1)*CINT
CALL GCLOCK(TITIME)
TTIME=TITIME-TFIRST
WRITE(6,700) TTIME,NUSED
700 FORMAT(/' INITIALIZATION DONE. TIME WAS',F7.2,' CPU SECS.',I10,
1 ' WORDS OF STORAGE USED.')
IF(PRINT.LT.4) WRITE(6,710) TIT
710 FORMAT('1',120A1)
IF(PRINT.GE.4.AND.ITHROW.EQ.0) WRITE(6,720)
720 FORMAT('1')
C
C ************** LOOP OVER JTOT VALUES BEGINS HERE. ******************
C
DO 990 JTOT=JTOTL,JTOTU,JSTEP
IF(PRINT.GE.1 .AND. PRINT.LE.4) WRITE(6,730) JTOT
730 FORMAT(/' ANGULAR MOMENTUM JTOT =',I4/2X,7('****'))
THETA=THETLW+THETST*DBLE(JTOT)
C
C *************** LOOP OVER SYMMETRY BLOCKS BEGINS HERE **************
C
DO 980 M=1,MXPAR
PHI=PHILW+PHIST*DBLE(M-1)
IF(MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) GO TO 980
IF (IRSTRT.GE.2.AND.JTOT.EQ.JTOTL.AND.M.LT.MRSTRT) THEN
WRITE(6,736) M,IRSTRT
736 FORMAT(' *** SKIPPING MVALUE =',I3,' DUE TO IRSTRT =',I3)
GO TO 980
ENDIF
IF(PRINT.LT.4) GOTO 760
IF(ITHROW.NE.0) WRITE(6,710) TIT
IF(ITHROW.EQ.0) WRITE(6,740) TIT
740 FORMAT(/' ',120A1)
WRITE(6,750) JTOT,M
750 FORMAT(/' TOTAL ANGULAR MOMENTUM, JTOT =',I5,' SYMMETRY',
1 ' BLOCK =',I4)
760 CONTINUE
C
C CHOOSE BASIS FUNCTIONS
C
CALL BASE (JTOT,X(IXJLEV),N,X,X,CINT,X,X,X,X,MXLAM,NPOTL,X(ILAM),
1 X,WGHT,IEXCH,THETA,PHI,M,.TRUE.,EFIRST,NLEV,PRINT)
C
C MOLD IS A REMNANT OF THE PREVIOUS "PARITY CASE" PROCESSING.
C MXP IS USED IN CONVERGENCE CHECKING, MOLD IS PASSED TO PRBR
C
MOLD=-M
IF(M.EQ.MXPAR.AND.N.LE.0) MOLD=0
MXP=MAX0(MXP,IABS(MOLD))
IF(M.EQ.MXPAR) MOLD=0
C
C N IS THE NUMBER OF BASIS FUNCTIONS
C SKIP THIS JTOT,M IF NO CHANNELS
C
C IF(N.LE.0) GOTO 980 <<- SG: FIXES ISIGU BUG
IF(N.LE.0) GOTO 770
NSQ = N*N
C
C ALLOCATE STORAGE FOR COUPLED EQUATION SOLVER.
C
C ALLOCATE STORAGE COMMON TO ALL SCATTERING. . .
C IS0-IS9 ARE SREAL,SIMAG,K-MATRIX,VL,IV,EINT,CENT,WVEC,L,NBASIS
C NOTE THAT INTEGER ARRAYS OF LENGTH N ARE NOT REDUCED BY NIPR
C IC1 IS IXNEXT AFTER ALLOCATIONS OF BASIN, POTENL, OUTINT ...
ISJ=IC1
IS0=ISJ+N
IS1=IS0+NSQ
IS2=IS1+NSQ
IS3=IS2+NSQ
NV=N*(N+1)/2
IF(IVLU.EQ.0) NV=NV*NPOTL
IS4=IS3+NV
IS5=IS4
IF(IVLFL.GT.0) IS5=IS4+(NV+NIPR-1)/NIPR
IS6=IS5+N
IS7=IS6+N
IS8=IS7+N
IS9=IS8+N
IXNEXT=IS9+N
C
C SET UP SOME STORAGE POINTERS FOR LATER USE IN CONVRG
C
IF(ICONV.GT.0) THEN
IS10=IXNEXT
IS11=IS10+NSQ
IXNEXT=IS11+NSQ
ENDIF
IC2=IXNEXT
CALL CHKSTR(NUSED)
C IXNEXT/IC2 REFLECT STORAGE ALWAYS NEEDED FOR THIS JTOT,PARITY.
C
C SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE
C
CALL BASE(JTOT,X(IXJLEV),N,X(ISJ),X(IS8),CINT,X(IS5),X(IS6),
1 X(IS3),X(IS4),MXLAM,NPOTL,X(ILAM),X(IS7),WGHT,IEXCH,THETA,
2 PHI,M,.FALSE.,EFIRST,NLEV,PRINT)
C
C CHECK THAT RMAX IS BEYOND CENTRIFUGAL BARRIER
C
CALL FINDRX(ENERGY,X(IS5),X(IS6),NPR,N,CINT,RMAX,RSTOP,
1 NOPMAX,IRXSET,PRINT)
IF(INTFLG.EQ.5) RVIVAS=RSTOP
RSTART=RMIN
C
C ****************** LOOP OVER ENERGIES BEGINS HERE ******************
C
770 NELOOP=(NNRG+NNRGPG-1)/NNRGPG
JHI=0
ICODE=0
ALDONE=.TRUE.
DO 966 IEL=1,NELOOP
JLO=JHI+1
JHI=MIN(JHI+NNRGPG,NNRG)
C
C SEE WHETHER THIS BLOCK OF ENERGIES CAN BE SKIPPED
C
LCALC=.FALSE.
DO 775 J=JLO,JHI
IF(IECONV(J).LT.0 .AND. IECONV(J).GT.-2*MXP) THEN
WRITE(6,772) JTOT,J
772 FORMAT(/' * * * WARNING. JTOT =',2I5,'-TH ENERGY PREVIOUSLY ',
1 'FAILED TO CONVERGE.')
LCALC=.TRUE.
ELSEIF(IECONV(J).EQ.0) THEN
LCALC=.TRUE.
ELSEIF(IECONV(J).GT.0) THEN
IF(JTOTU.LT.999999 .OR. IECONV(J).LT.NCAC*MXP) LCALC=.TRUE.
ENDIF
775 CONTINUE
C
IF(.NOT.LCALC) GOTO 966
ALDONE=.FALSE.
DO 960 J=JLO,JHI
IF(N.LE.0) THEN
CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT))
GOTO 960
ENDIF
C
C IF THIS IS A PRESSURE BROADENING CALC AND THIS S-MATRIX
C WILL NOT BE USED, SKIP IT
C
IF(IFLS.GT.0 .AND. IFEGEN.GE.2) THEN
CALL PRBCNT(J,X(ISJ),N,IUSE)
IF(IUSE.EQ.0) THEN
LWARN=.TRUE.
IF(PRINT.GE.4) WRITE(6,777) JTOT,M,J,ENERGY(J)
777 FORMAT(/' ****** S MATRIX FOR JTOT =',I5,' M =',I4,3X,
1 'ENERGY(',I3,') =',F18.9,/9X,'WILL NOT BE USED ',
2 'IN PRESSURE BROADENING CALCULATION: SKIPPING')
IF(IECONV(J).GE.0) IECONV(J)=IECONV(J)+1
CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT))
GOTO 960
ENDIF
ENDIF
C
IF (IRSTRT.EQ.3.AND.JTOT.EQ.JTOTL.AND.M.EQ.MRSTRT.AND.J.LT.IERST)
1 GO TO 960
ETOT=ENERGY(J)
ERED=ETOT*CINT
IF(ICODE.EQ.0) THEN
EFIRST=ERED
ICODE=1
ENDIF
ESHIFT=ERED-EFIRST
C
C ICODE CONTROLS WHETHER POTENTIAL INFORMATION IS READ FROM CHANNEL
C ICODE=1 CALCULATES INFORMATION AND STORES IT
C ICODE=2 (SET AFTER 1ST ENERGY) READS STORED INFORMATION
C
IF(PRINT.GE.4) THEN
IF(ITHROW.EQ.0) THEN
WRITE(6,740) TIT2
ELSE
WRITE(6,710) TIT2
ENDIF
WRITE(6,780) JTOT,M,J,ETOT
780 FORMAT(/' JTOT =',I5,' SYMMETRY BLOCK =',I4,' ENERGY(',
1 I3,') =',F18.9,' (1/CM)')
ENDIF
C
C FOR SURFACE SCATTERING AT SUBSEQUENT ENERGY,
C GET CORRESPONDING THETA FOR PRINTING
C
IF(ITYPE.EQ.8 .AND. J.NE.1) THEN
SINTH=SIN(THETA*PI/180.D0)
SINTH=SINTH**2*ENERGY(1)/ETOT
IF(SINTH.GT.1.D0) GOTO 960
THETJ=ASIN(SQRT(SINTH))*180.D0/PI
WRITE(6,795) J,ETOT,THETJ
795 FORMAT(/' NOTE: K VECTORS PARALLEL TO SURFACE WERE ',
1 'CALCULATED FOR ENERGY(1)'/' SUBSEQUENT ENERGY(',I3,') =',
2 F10.4,' CORRESPONDS TO THETA =',F10.4,' DEGREES')
ENDIF
C
C TEMPORARY STORAGE FOR HEADER, FINDRM
C
IT1=IXNEXT
IT2=IT1+MXLAM
IT3=IT2+N
IT4=IT3+N
IT5=IT4+N
IXNEXT=IT5+N
CALL CHKSTR(NUSED)
C
CALL HEADER(X(IS1),X(IS2),N,NSQ,X(IT1),X(IS3),X(IS4),X(IS5),
1 X(IS6),X(IT2),MXLAM,NPOTL,ICODE,ISAV,EFIRST)
C
IF(ICODE.EQ.1 .AND. IRMSET.GT.0) THEN
C FOR IRMSET > 0 OPTION, CHOOSE APPROPRIATE RMIN
RSTART=RMIN
CALL FINDRM(X(IS1),N,RSTART,RTURN,IK,X(IT1),X(IS3),X(IS4),ERED,
1 X(IS5),X(IS6),RMLMDA,X(IT2),X(IT3),X(IT4),X(IT5),MXLAM,NPOTL,
2 IRMSET,ITYPE,PRINT)
IF(RVFAC.NE.0.D0) THEN
RMID=RVFAC*RTURN
IF(PRINT.GE.3.AND.RSTOP.GT.RMAX) WRITE(6,799) RSTOP,RMAX
799 FORMAT(' RMID OBTAINED FROM RTURN EVEN THOUGH RSTOP.GT.RMAX',
1 2F8.2)
IF(PRINT.GE.3) WRITE(6,800) RMID,RVFAC
800 FORMAT(/' RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3)
ENDIF
ELSE
RTURN=RMIN
IK=1
ENDIF
C
C RESET IXNEXT TO RECOVER TEMPORARY STORAGE FROM HEADER AND FINDRM
C
IXNEXT=IT1
C
C SOLVE COUPLED EQUATIONS.
C PROPAGATORS ARE CALLED FROM SUBROUTINE STORAG
C
CALL STORAG(INTFLG,N,MXLAM,NV,NPOTL,
1 ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9,
2 ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT,NUMDER)
C
CALL GCLOCK(TJTIME)
TTIME=(TJTIME-TITIME)
TITIME=TJTIME
C
IF(NOPEN.GT.0) THEN
C RESET ICODE TO ALLOW "SUBSEQUENT ENERGY" CALCULATIONS
ICODE=2
ELSE
IF(PRINT.GE.4) WRITE(6,900) JTOT,M,J,ETOT,TTIME
900 FORMAT(/' ****** NO OPEN CHANNELS FOR JTOT =',I5,3X,
1 'M =',I4,' ENERGY(',I3,') =',F18.9,10X,'STEP TIME =',
2 F6.2,' SECS')
IF(IECONV(J).GE.0) IECONV(J)=IECONV(J)+1
GOTO 960
ENDIF
C
C FORCE IRSTRT=0 SO THAT ISAVEU WILL BE UPDATED.
IRSTRX=0
C AUG 95 (SG) ADDED N TO PAREMETER LIST SO IT CAN BE PRINTED
CALL OUTPUT(JTOT,X(IS9),X(ISJ),X(IS8),X(IS7),X(IS0),X(IS1),
1 X(IS2),CONV,NOPEN,M,MXPAR,WGHT,IEXCH,J,RM,PRINT,TTIME,
2 ENERGY,X(IOUT),X(IXJLEV),ISST,IECONV,MINJT,MAXJT,
3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRX,N)
C
IF(ICONV.GT.0) CALL CONVRG(J,X(IS0),X(IS1),X(IS10),X(IS11))
IF(IECONV(J).LT.0 .OR. IFLS.LE.0) GOTO 940
C
C TEMPORARY STORAGE FOR PRBR -- THESE ARE INTEGERS, COULD USE NIPR
IT1=IXNEXT
IT2=IT1+N
IT3=IT2+N
IT4=IT3+N
IXNEXT=IT4+N
CALL CHKSTR(NUSED)
CALL PRBR(JTOT,MOLD,NOPEN,J,RM,
1 X(IS9),X(ISJ),X(IS8),X(IS7),
2 X(IS0),X(IS1),X(IT1),X(IT2),X(IT3),X(IT4),
3 X(IXJLEV),MXPAR,WGHT,PRINT,ILSU)
C RECOVER TEMPORARY STORAGE ...
IXNEXT=IT1
C
940 IF(PRINT.GE.5) WRITE(6,950) JTOT,M,J,ETOT,TTIME
950 FORMAT(/' FINISHED JTOT =',I5,' M =',I4,' ENERGY(',I3,
1 ') =',F18.9,10X,'STEP TIME =',F8.2,' SECS')
C
960 CONTINUE
C
C RESONANCE SEARCH OPTION - GENERATE NEXT 5 ENERGIES
C
IF(ISRCH.EQ.0) GOTO 964
CALL NEXTE(ENERGY(JLO),EPSM,ENEW,DNRG,KSAVE)
IF(JHI.EQ.NNRG) GOTO 964
IF(ENEW.LE.0.D0) GOTO 1000
JST=JHI+1
JND=JHI+5
WRITE(6,600) NNRG
DO 962 JJ=JST,JND
ENERGY(JJ)=ENEW+(JJ-JST)*DNRG
ENEV=ENERGY(JJ)/8065.541D0
WRITE(6,620) JJ,ENERGY(JJ),ENEV
962 CONTINUE
964 CONTINUE
C
966 CONTINUE
C
C ******************** END OF LOOP OVER ENERGIES *********************
C
IF(ALDONE) THEN
WRITE(6,968) DTOL,OTOL,NCAC
968 FORMAT(///' CALCULATION TERMINATED BY CONVERGENCE OF TOTAL ',
1 'CROSS SECTIONS.'//' DIAGONAL AND OFF-DIAGONAL TOLERANCES ',
2 'WERE ',2F9.5,' NCAC =',I3)
GOTO 1000
ENDIF
C
IF(PRINT.GE.2 .AND. PRINT.LT.5) WRITE(6,970)
970 FORMAT(/)
C RESTORE ERED TO FIRST ENERGY VALUE.
ERED = EFIRST
980 CONTINUE
C
C ****************** END OF LOOP OVER SYMMETRY BLOCKS ****************
C
IF(IFLS.GT.0) CALL PRBOUT(JSTEP)
990 CONTINUE
C
C ******************** END OF LOOP OVER JTOT VALUES ******************
C
C END OF RUN BOOKKEEPING
C
1000 CALL OUTPCH(X(IOUT),ENERGY,NNRG,MINJT,MAXJT,ISIGPR,LABL,ISIGU,
1 LWARN)
IF(IFLS.GT.0) WRITE(6,710) TIT
IF(IFLS.GT.0) CALL PRBOUT(JSTEP)
IF(IFLS.GT.0) CALL DACLOS
CALL GCLOCK(TLAST)
TOTIME=TLAST-TFIRST
C MAKE SURE WE HAVE NUSED FOR KSAVE BY CALLING CHKSTR
CALL CHKSTR(NUSED)
IF(KSAVE.GT.0) WRITE(KSAVE,1010) TOTIME,TTIME,NUSED
1010 FORMAT(/' TOTAL CPU =',F9.2,' SECS LAST CYCLE =',
1 F8.2,' SECS NUSED =',I8)
C
C *** IOS CALCULATION (IOSFLG.GT.0) REJOINS CODE BELOW
C ASCERTAIN 'HIGH-WATER' MARK IN STORAGE FROM CHKSTR.
C MX MAY HAVE BEEN REDUCED, SO USE MXSAVE FOR ALLOCATED STORAGE
C
1020 CALL CHKSTR(NUSED)
WRITE(6,1030) IPROGM,PDATE,TOTIME,NUSED,MXSAVE
1030 FORMAT(///' ',8('----MOLSCAT----')/' |',120X,'|'/' |',13X,
1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ',
2 'AND S. GREEN, VERSION',I3,1X,A8,13X,'|'/
3 ' |',120X,'|'/' |',13X,'THIS RUN USED',F11.2,' CPU SECS ',
4 'AND',I10,' OF THE ALLOCATED',I10,' WORDS OF STORAGE',14X,
5 '|'/' |',120X,'|'/' ',8('----MOLSCAT----') )
IF(LASTIN.EQ.0) GOTO 100
1040 RETURN
END
SUBROUTINE AIRPRP (Z, W, TMAT, VECNOW, VECNEW,
+ EIGOLD, EIGNOW, HP, Y1, Y2, CC, Y4, XF, REND, DRNOW, EN,
+ TOLAI, POWR, ESHIFT, NCH, ITWO, IREAD, IWRITE, IPRINT,
$ ISCRU, P, MXLAM, VL, IV, RMLMDA, EINT, CENT, NPOTL)
C
* AIRY ZEROTH-ORDER PROPAGATOR FROM R=XF TO R=REND
* FOR REFERENCE SEE M. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS
* J. CHEM. PHYS. 81, 4510 (1984)
* AND M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR
* REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..."
* J. CHEM. PHYS. 86, 2044 (1987)
* AUTHOR: MILLARD ALEXANDER
* CURRENT REVISION DATE: 4-FEB-1991
* ----------------------------------------------------------------------
* ADAPTED TO MOLSCAT 4/91 BY TRP@NASAGISS
* ADAPTED TO MOLSCAT VERSION 11 BY JMH, JUN 92
*-----------------------------------------------------------------------
* DEFINITION OF VARIABLES IN CALL LIST:
* Z: MATRIX OF MAXIMUM DIMENSION NCH*NCH
* ON ENTRY Z CONTAINS THE INITIAL Z-MATRIX AT R=XF
* ON RETURN Z CONTAINS THE Z-MATRIX AT R=REND
* W, TMAT, VECNOW
* , VECNEW: SCRATCH MATRICES OF DIMENSION AT LEAST NCH*NCH
* EIGOLD, EIGNOW
* , HP, Y1, Y2
* , CC, Y4: SCRATCH VECTORS OF DIMENSION AT LEAST NCH
* XF: ON ENTRY: CONTAINS INITIAL VALUE OF INTERPARTICLE D
* ON EXIT: CONTAINS FINAL VALUE OF INTERPARTICLE DIS
* THIS IS EQUAL TO REND IF NORMAL TERMINATI
* OTHERWISE AN ERROR MESSAGE IS PRINTED
* DRNOW: ON ENTRY: CONTAINS INITIAL INTERVAL SIZE
* ON EXIT: CONTAINS FINAL INTERVAL SIZE
* EN: COLLISION ENERGY IN ATOMIC UNITS
* TOLAI: PARAMETER TO DETERMINE STEP SIZES
* IF TOLAI .LT. 1, THEN ESTIMATED ERRORS ARE USED TO
* DETERMINE NEXT STEP SIZES FOLLOWING THE PROCEDURE O
* IN M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGOR
* IF TOLAI .GE. 1, THEN STEP SIZES ARE CONTROLLED BY
* ALGORITHM: DRNEXT = TOLAI * DRNOW
* POWR: POWER AT WHICH STEP SIZES INCREASE
C
C
* LOGICAL VARIABLES:
* ISYM: IF .TRUE., PROPAGATION ASSUMES SYMMETRY OF Y MATRIX
* ----------------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H, O-Z)
LOGICAL ISYM
INTEGER I, IEND, IERR, ITWO, IZERO, KSTEP, MAXSTP,
: NCH, NPT, NSKIP
* REAL CDIAG, CMAX, COFF, DRFIR, DRMID, DRNOW, EN, ESHIFT, FACT,
* : ONE, POWR, REND, RLAST, RMIN, RNEW, RNEXT, RNOW, ROLD,
* : SPCMN, SPCMX, TOLAI, XF, XLARGE, ZERO
* REAL CC, EIGNOW, EIGOLD, HP,Y1, Y2, Y4
* REAL TMAT, VECNEW, VECNOW, W, Z
EXTERNAL CORR, TRNSFM, OUTMAT, POTENT, DAXPY, DCOPY,
: SYMINV, SPROPN, DSCAL, TRNSP, WAVEIG
* MATRIX DIMENSIONS (ROW DIMENSION = NCH, MATRICES STORED COLUMN BY CO
DIMENSION Z(1), W(1), TMAT(1), VECNOW(1), VECNEW(1)
* VECTORS DIMENSIONED NCH
DIMENSION EIGOLD(1), EIGNOW(1), HP(1), Y1(1), Y2(1), CC(1), Y4(1)
DIMENSION P(1),VL(1),IV(1),EINT(1),CENT(1)
C
DATA IZERO, IONE, ZERO, ONE /0, 1, 0.D0, 1.D0/
DATA ISYM /.TRUE./
C
* ----------------------------------------------------------------------
C
ERED = EN
RMIN = XF
SPCMX = 0.D0
SPCMN = 0.D0
IF (ITWO .GT. 0) GO TO 60
SPCMN = REND - RMIN
* DETERMINE LOCAL WAVEVECTORS AT RMIN TO USE IN ESTIMATING SECOND DERIV
* HP AND Y1 ARE USED AS SCRATCH VECTORS HERE
CALL WAVEIG (W, EIGOLD, HP, Y1, RMIN, NCH, P, MXLAM, VL, IV,
1 RMLMDA, ERED, EINT, CENT, NPOTL)
* LOCAL WAVEVECTORS AT RMIN ARE RETURNED IN EIGOLD
DRFIR = DRNOW
DRMID = DRNOW * 0.5D0
RLAST = XF
ROLD = XF
RNOW = RLAST + DRMID
RNEXT = RLAST + DRNOW
* DEFINE LOCAL BASIS AT RNOW AND CARRY OUT TRANSFORMATIONS
* VECNEW IS USED AS SCRATCH MATRIX AND Y1 IS USED AS SCRATCH VECTOR HER
CALL POTENT (W, VECNOW, VECNEW, EIGNOW, HP, Y1,
+ RNOW, DRNOW, EN, XLARGE, NCH,
$ P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL)
* VECNOW IS TRANSFORMATION FROM FREE BASIS INTO LOCAL BASIS
* IN FIRST INTERVAL
* E.G. P1=VECNOW ; SEE EQ.(23) OF
* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."
* STORE VECNOW IN TMAT
CALL DCOPY (NCH*NCH, VECNOW, 1, TMAT, 1)
* DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGONAL
* CORRECTION TERMS
CALL CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, CDIAG,
: COFF, NCH)
MAXSTP = ( (REND-XF) / DRNOW ) * 5
XF = REND
IF (IPRINT.GT.40) THEN
WRITE (6, 40)
40 FORMAT(/' ** AIRY PROPAGATION (NO DERIVATIVES):')
WRITE (6, 50)
50 FORMAT(' STEP RNOW', 5X, 5HDRNOW, 5X, 5HCDIAG, 6X, 4HCOFF)
END IF
60 IEND = 0
IF (ITWO .LT. 0) GO TO 70
IF (ITWO .EQ. 0) WRITE(ISCRU) MAXSTP
IF (ITWO. GT. 0) READ(ISCRU) MAXSTP
* WRITE OR READ RELEVANT INFORMATION
CALL OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW,
: NCH, NCH, ITWO, ISCRU)
C
C
* START AIRY PROPAGATION
C
* ----------------------------------------------------------------------
70 DO 200 KSTEP = 1, MAXSTP
NSTEP=KSTEP
C
* TRANSFORM LOG-DERIV MATRIX FROM LOCAL BASIS IN LAST INTERVAL TO
* LOCAL BASIS IN PRESENT INTERVAL. SEE EQ.(23) OF
* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."
* W IS USED AS SCRATCH MATRIX HERE, AND Y1 IS SCRATCH ARRAY
C
CALL TRNSP ( TMAT, NCH)
CALL TRNSFM ( TMAT, Z, W, NCH, .FALSE., ISYM )
C
* TMAT IS NO LONGER NEEDED
* SOLVE FOR LOG-DERIVATIVE MATRIX AT RIGHT-HAND SIDE OF
* PRESENT INTERVAL. THIS USES NEW ALGORITHM OF MANALOPOULOS AND ALEXAN
* NAMELY
* (N) (N) -1 (N) (N)
* Z = - Y [ Y + Z ] Y + Y
* N+1 2 1 N 2 4
* WHERE Y , Y , AND Y ARE THE (DIAGONAL) ELEMENTS OF THE "IMBEDDING
* 1 2 4
* PROPAGATOR DEFINED IN ALEXANDER AND MANOLOPOULOS
* DETERMINE THESE DIAGONAL MATRICES FOR PROPAGATION OF LOG-DERIV MATRIX
* EQS. (38)-(44) OF M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR
* REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..."
C
CALL SPROPN ( DRNOW, EIGOLD, HP, Y1, Y4, Y2, NCH)
C
* SET UP MATRIX TO BE INVERTED
* NSKIP IS SPACING BETWEEN DIAGONAL ELEMENTS OF MATRIX STORED COLUMN BY
C
NSKIP = NCH + 1
CALL DAXPY (NCH, ONE, Y1, 1, Z, NSKIP)
C
* INVERT (Y + Z )
* 1 N
C
CALL SYMINV (Z, NCH, NCH, IERR)
CALL DSYFIL ('U', NCH, Z, NCH)
IF (IERR .GT. NCH) THEN
WRITE (6, 80)
80 FORMAT (' *** INSTABILITY IN SYMINV IN AIRPRP.')
STOP
END IF
C
* -1
* EVALUATE - Y ( Y + Z ) Y
* 2 1 N 2
* IN THE NEXT LOOPS EVALUATE THE FULL, RATHER THAN LOWER TRIANGLE
C
NPT = 1
DO 85 I = 1, NCH
FACT = Y2(I)
CALL DSCAL (NCH, FACT, Z(NPT), 1)
NPT = NPT + NCH
85 CONTINUE
* -1
* Z NOW CONTAINS ( Y + Z ) Y , THIS IS G(N-1,N) IN THE LOCAL BASI
* 1 N 2
C
DO 110 I = 1, NCH
FACT = - Y2(I)
CALL DSCAL (NCH, FACT, Z(I), NCH)
110 CONTINUE
C
* ADD ON Y
* 4
CALL DAXPY (NCH, ONE, Y4, 1, Z, NSKIP)
C
IF (ITWO .GT. 0) GO TO 160
C
C
* OBLIGATORY WRITE OF STEP INFORMATION IF DEVIATIONS FROM LINEAR
* POTENTIAL ARE UNUSUALLY LARGE
* THIS IS ONLY DONE IF TOLAI .LT. 1, IN WHICH CASE THE LARGEST CORRECTI
* IS USED TO ESTIMATE THE NEXT STEP
C
IF (TOLAI .LT. 1.) THEN
CMAX = MAX (CDIAG, COFF)
IF (CMAX .GT. (5. * TOLAI)) THEN
WRITE (6,125)
125 FORMAT
: (' ** ESTIMATED CORRECTIONS LARGER THAN 5*TOLAI IN AIRPRP')
IF (KSTEP .EQ. 1) THEN
WRITE (6, 130)
130 FORMAT (' THE INITIAL VALUE OF DRNOW (SPAC*FSTFAC) IS',
: ' PROBABLY TOO LARGE')
ELSE
WRITE (6, 140)
140 FORMAT
: (' CHECK FOR DISCONTINUITIES OR UNPHYSICAL OSCILLATIONS',
: /,' IN YOUR POTENTIAL')
END IF
IF (IPRINT.LT.41) THEN
WRITE (6, 50)
WRITE (6,150) KSTEP, RNOW, DRNOW, CDIAG, COFF
END IF
END IF
END IF
C
C
* WRITE OUT INFORMATION ABOUT STEP JUST COMPLETED
C
IF (IPRINT.GT.40) THEN
WRITE (6,150) KSTEP, RNOW, DRNOW, CDIAG, COFF
150 FORMAT (I6, 4E10.3)
END IF
C
C
* GET SET FOR NEXT STEP
C
160 IF (IEND .EQ. 1) GO TO 250
IF (ITWO .GT. 0) GO TO 180
C
C
* IF TOLAI .LT. 1, PREDICT NEXT STEP SIZE FROM LARGEST CORRECTION
C
IF (TOLAI .LT. 1.) THEN
C
* NOTE THAT THE FOLLOWING STATEMENT IS SLIGHTLY DIFFERENT FROM EQ. (30
* OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ... AND THA
* THE STEP-SIZE ALGORITHM IS ONLY APPROXIMATELY RELATED TO ANY REAL
* ESTIMATE OF THE ERROR COFF AND CDIAG SHOULD BE APPROXIMATELY TOLAI, S
* FROM EQ. (27):
* DRNOW(AT N+1) = (12 TOLAI/KBAR(N+1)W(N+1)-TILDA')**(1/3)
* WHICH IS APPROXIMATELY = (12 TOLAI/KBAR(N)W(N)-TILDA')**(1/3)
* = ((12 COFF/KBAR W-TILDA') (TOLAI/COFF))**(1/3
* = DRNOW(AT N) (TOLAI/COFF)**(1/3)
* OR FROM EQ. (29):
* DRNOW = DRNOW (TOLAI/CDIAG)**(1/3)
* THEN, USING THE LARGER ERROR AND ALLOWING POW TO VARY:
C
CSG>>
FACTOR=(TOLAI/CMAX) ** (1./POWR)
CSG LIMIT INCREMENT/DECREMENT FOR STABILITY ...
IF (FACTOR.GT.2.D0) FACTOR=2.D0
IF (FACTOR.LE.0.1D0) FACTOR=1.D-1
DRNOW = DRNOW * FACTOR
CSG<< DRNOW = DRNOW * (TOLAI/CMAX) ** (1. / POWR)
ELSE
C
* IF TOLAI .GE. 1, THEN
* MINIMUM STEP SIZE IS FIRST INTERVAL WIDTH
C
IF (KSTEP .EQ. 1) SPCMN = DRNOW
C
* AND NEXT STEP SIZE IS TOLAI * PRESENT STEP SIZE
C
DRNOW = TOLAI * DRNOW
END IF
C
* DRNOW IS STEP SIZE IN NEXT INTERVAL
C
RLAST = RNEXT
RNEXT = RNEXT + DRNOW
IF (RNEXT .LT. REND) GO TO 170
IEND = 1
RNEXT = REND
DRNOW = RNEXT - RLAST
170 RNEW = RLAST + 0.5D0 * DRNOW
IF (KSTEP .GT. 1 .AND. IEND .NE. 1) THEN
IF (TOLAI .LT. 1) THEN
IF (DRNOW .LT. SPCMN) SPCMN = DRNOW
END IF
IF (DRNOW .GT. SPCMX) SPCMX = DRNOW
END IF
DRMID = RNEW - RNOW
C
C
* RESTORE EIGENVALUES
C
CALL DCOPY (NCH, EIGNOW, 1, EIGOLD, 1)
C
* DEFINE LOCAL BASIS AT RNEW AND CARRY OUT TRANSFORMATIONS
* TMAT IS USED AS SCRATCH MATRIX AND Y1 IS USED AS SCRATCH VECTOR HERE
C
CALL POTENT (W, VECNEW, TMAT, EIGNOW, HP, Y1,
+ RNEW, DRNOW, EN, XLARGE, NCH,
$ P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL)
C
C
* DETERMINE MATRIX TO TRANSFORM LOG-DERIV MATRIX INTO NEW INTERVAL
* SEE EQ. (22) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS
C
CALL DGEMUL(VECNEW, NCH, 'N', VECNOW, NCH, 'T', TMAT, NCH,
1 NCH, NCH, NCH)
CALL DCOPY (NCH*NCH, VECNEW, 1, VECNOW, 1)
C
C
* RESTORE RADIUS VALUES
C
RNOW = RNEW
C
C
* DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGONAL
* CORRECTION TERMS
C
CALL CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, CDIAG,
: COFF, NCH)
IF (ITWO .LT. 0) GO TO 200
IF (IEND .EQ. 1) RNOW = - RNOW
C
C
* WRITE OR READ RELEVANT INFORMATION
C
180 CALL OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW,
: NCH, NCH, ITWO, ISCRU)
IF (ITWO .EQ. 0) GO TO 200
C
C
* NEGATIVE RNOW IS CUE FOR LAST STEP IN SECOND ENERGY CALCULATION
C
IF (RNOW .GT. 0.D0) GO TO 200
RNOW = - RNOW
IEND = 1
C
C
* GO BACK TO START NEW STEP
C
200 CONTINUE
C
C
* THE FOLLOWING STATEMENT IS REACHED ONLY IF THE INTEGRATION HAS
* NOT REACHED THE ASYMPTOTIC REGION IN MAXSTP STEPS
C
WRITE (6,210) MAXSTP, RNEXT
C
IF(IPRINT.GT.40) WRITE(6,210) MAXSTP,RNEXT
C
210 FORMAT (' *** AIRY PROPAGATION NOT FINISHED IN', I4,
: ' STEPS: R-FIN SET TO', F8.4,' ***',/)
XF = RNEXT
250 CONTINUE
IF (ITWO .LT. 0) GO TO 260
CALL OUTMAT (VECNOW, EIGOLD, HP, ESHIFT, DRNOW, XF, NCH,
: NCH, ITWO, ISCRU)
C
C
* TRANSFORM LOG-DERIV MATRIX INTO FREE BASIS. TRANSFORMATION MATRIX IS
* JUST VECNOW-TRANSPOSE; SEE EQ.(24) OF M.H. ALEXANDER, "HYBRID QUANTUM
* SCATTERING ALGORITHMS ..."
260 CALL TRNSFM (VECNOW, Z, W, NCH, .FALSE., ISYM )
C
IF (IPRINT.LT.41) GO TO 318
IF (ITWO .LT. 0) WRITE (6,280)
IF (ITWO .EQ. 0) WRITE (6,290)
IF (ITWO .GT. 0) WRITE (6,300)
280 FORMAT (' ** AIRY PROPAGATION - FIRST ENERGY;',
: ' TRANSFORMATION MATRICES NOT WRITTEN')
290 FORMAT (' ** AIRY PROPAGATION - FIRST ENERGY;',
: ' TRANSFORMATION MATRICES WRITTEN')
300 FORMAT (' ** AIRY PROPAGATION - SECOND ENERGY;',
: ' TRANSFORMATION MATRICES READ')
WRITE (6,305) RMIN, REND, TOLAI, NSTEP
WRITE (6,310) SPCMN, SPCMX, POWR
305 FORMAT (' RBEGIN =', F7.3, ' REND =', F7.3,
: ' TOLAI =', 1PE8.1, ' NINTERVAL =', I3)
310 FORMAT (' DR-MIN =', F7.3, ' DR-MAX =', F8.3,
: ' POWER =', F4.1)
C
318 CONTINUE
IF(IPRINT.LT.35) GO TO 319
IF (ITWO .LT. 0) WRITE (6,280)
IF (ITWO .EQ. 0) WRITE (6,290)
IF (ITWO .GT. 0) WRITE (6,300)
319 CONTINUE
C
IF(IPRINT.LT.3) GO TO 320
WRITE (6, 315) RMIN, REND, SPCMN, SPCMX, NSTEP
315 FORMAT (' ** AIRY: RSTART =' ,F7.3,' REND =',F7.3,
: ' DRMIN =',F7.3, ' DRMAX =',F7.3,' NSTEP =', I4)
320 CONTINUE
RETURN
END
SUBROUTINE AIRYMP (X, FTHETA, FPHI, XMMOD, XNMOD)
* SUBROUTINE TO RETURN THE MODULI AND PHASES OF THE AIRY FUNCTIONS AND
* DERIVATIVES
* AUTHOR: MILLARD ALEXANDER
* CURRENT REVISION DATE: 23-SEPT-87
* ----------------------------------------------------------------------
* VARIABLES IN CALL LIST:
* X ARGUMENT OF AIRY FUNCTIONS
* FTHETA, XMMOD ON RETURN: CONTAIN THE (DOUBLE PRECISION)
* PHASE AND MODULUS OF AI(X) AND BI(X) (
* BELOW).
* FPHI, XNMOD ON RETURN: CONTAIN THE (DOUBLE PRECISION)
* PHASE AND MODULUS OF AI'(X) AND BI'(X)
* BELOW).
* ----------------------------------------------------------------------
* FOR NEGATIVE X
* ----------------------------------------------------------------------
* THE MODULI AND PHASES ARE DEFINED BY
* AI(-X) = M(X) COS[THETA(X)]
* BI(-X) = M(X) SIN[THETA(X)]
* AI'(-X) = N(X) COS[PHI(X)]
* BI'(-X) = N(X) SIN[PHI(X)]
* IN OTHER WORDS
* 2 2 2
* M(X) = SQRT[ AI(X) + BI(X) ]
* 2 2 2
* N(X) = SQRT[ AI'(X) + BI'(X) ]
* THETA(X) = ATAN [ BI(X) / AI(X) ]
* PHI(X) = ATAN [ BI'(X) / AI'(X) ]
* TO DETERMINE THESE MODULI AND PHASES WE USE THE SUBROUTINE
* SCAIRY, WRITTEN BY D. MANOLOPOULOS (SEPT. 1986)
* THIS SUBROUTINE RETURNS THE FOLLOWING QUANTITIES:
* SCAI, SCBI, SCAIP, SCPIB, AND ZETA, WHERE
C FOR X .LT. -5.0
C AI(X) = SCAI * COS(ZETA) + SCBI * SIN(ZETA)
C BI(X) = SCBI * COS(ZETA) - SCAI * SIN(ZETA)
C AI'(X) = SCAIP * COS(ZETA) + SCBIP * SIN(ZETA)
C BI'(X) = SCBIP * COS(ZETA) - SCAIP * SIN(ZETA)
C WHERE ZETA = (2/3) * (-X) ** (3/2) + PI/4
C
C FOR -5.0 .LE. X .LE. 0.0
C
C AI(X) = SCAI
C BI(X) = SCBI
C AI'(X) = SCAIP
C BI'(X) = SCBIP
C AND ZETA = 0
* ----------------------------------------------------------------------
* FOR POSITIVE X
* ----------------------------------------------------------------------
* THE MODULI AND PHASES ARE DEFINED BY
* AI(X) = M(X) SINH[THETA(X)]
* BI(X) = M(X) COSH[THETA(X)]
* AI'(X) = N(X) SINH[PHI(X)]
* BI'(X) = N(X) COSH[PHI(X)]
* IN OTHER WORDS
* 2 2 2
* M(X) = SQRT[ BI(X) - AI(X) ]
* 2 2 2
* N(X) = SQRT[ BI'(X) - AI'(X) ]
* THETA(X) = ATANH [ AI(X) / BI(X) ]
* PHI(X) = ATANH [ AI'(X) / BI'(X) ]
* HERE THE THE EXPONENTIALLY SCALED AIRY FUNCTIONS
* AI(X), AI'(X), BI(X), BI'(X) ARE:
* AI(X) = AI(X) * EXP[ZETA]
* AI'(X) = AI'(X) * EXP[ZETA]
* BI(X) = BI(X) * EXP[-ZETA]
* BI'(X) = BI'(X) * EXP[-ZETA]
* TO DETERMINE THESE MODULI AND PHASES WE USE THE SUBROUTINE
* SCAIRY, WRITTEN BY D. MANOLOPOULOS (SEPT. 1986)
* THIS SUBROUTINE RETURNS THE FOLLOWING QUANTITIES:
* SCAI, SCBI, SCAIP, SCPIB, AND ZETA
* IN TERMS OF WHICH THE EXPONENTIALLY SCALED AIRY FUNCTIONS ARE DEFINED
* AI(X) = SCAI * EXP(-ZETA)
* BI(X) = SCBI * EXP(+ZETA)
* AI'(X) = SCAIP * EXP(-ZETA)
* BI'(X) = SCBIP * EXP(+ZETA)
* WHERE ZETA = (2/3) * X ** (3/2)
*
* ----------------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DOUBLE PRECISION X, FTHETA, FPHI, XMMOD, XNMOD, SCAI,
: SCBI, SCAIP, SCBIP, ZETA, RATIO
CALL SCAIRY (X, SCAI, SCBI, SCAIP, SCBIP, ZETA)
IF ( X .LE. 0.D0) THEN
XMMOD = SQRT( SCAI ** 2 + SCBI ** 2)
XNMOD = SQRT( SCAIP ** 2 + SCBIP ** 2)
FTHETA = ATAN2 (SCBI, SCAI)
FPHI = ATAN2 (SCBIP, SCAIP)
IF (X .LT. (-5.0D0) ) THEN
FTHETA = FTHETA - ZETA
FPHI = FPHI - ZETA
END IF
ELSE
XMMOD = SQRT( - SCAI ** 2 + SCBI ** 2)
XNMOD = SQRT( - SCAIP ** 2 + SCBIP ** 2)
RATIO = SCAI / SCBI
FTHETA = 0.5 * LOG ( (1.D0 + RATIO) / (1.D0 - RATIO) )
RATIO = SCAIP / SCBIP
FPHI = 0.5 * LOG ( (1.D0 + RATIO) / (1.D0 - RATIO) )
END IF
RETURN
END
SUBROUTINE ASROT(J,EVEC,H,EVAL,WKS,NH)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
LOGICAL TD,EVLIST
DIMENSION EVEC(NH,NH),H(NH,NH),EVAL(NH),WKS(NH)
DIMENSION WT(2),ELEVEL(1000),JLEVEL(4000),ISYM(10),ISYM2(10),
1 ROTI(2)
COMMON /CMBASE/ A(2),B(2),C(2),DJ,DJK,DK,DT,ROTI,
1 ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL,JMIN,JMAX,JSTEP,ISYM,J2MIN,
1 J2MAX,J2STEP,ISYM2,JHALF,IDENT,MXJL,MXEL
DATA EVLIST/.FALSE./
C
C DO THE ACTUAL CALCULATION FOR A GIVEN J
C
ALPHA=0.5D0*(A(1)+B(1))
BETA=C(1)-ALPHA
GAMMA=0.25D0*(A(1)-B(1))
TD = A(1).EQ.B(1) .AND. B(1).EQ.C(1)
C
JJ=J*(J+1)
NK=J+J+1
DO 100 IR=1,NK
KR=IR-J-1
DO 100 IC=1,IR
KC=IC-J-1
TERM=0.D0
IF(KR.EQ.KC) THEN
TERM=ALPHA*DBLE(JJ)+BETA*DBLE(KC*KC)
1 -DJ*DBLE(JJ*JJ)-DJK*DBLE(JJ*KC*KC)-DK*KC**4
IF(TD) TERM=TERM+0.5D0*DT*DBLE(-3*JJ*(JJ-2)+30*(JJ-2)*KC*KC
1 -35*KC*KC*(KC*KC-1))
ELSEIF(KR-KC.EQ.2) THEN
KMID=(KR+KC)/2
TERM=GAMMA*SQRT(DBLE((JJ-KR*KMID)*(JJ-KC*KMID)))
ELSEIF(KR-KC.EQ.4 .AND. TD) THEN
TERM=1.25D0*DT*SQRT(DBLE((JJ-KC*(KC+1))*(JJ-(KC+1)*(KC+2)))
1 *DBLE((JJ-(KC+2)*(KC+3))*(JJ-(KC+3)*(KC+4))))
ENDIF
H(IR,IC)=TERM
100 CONTINUE
IFAIL=0
CALL F02ABF(H,NH,NK,EVAL,EVEC,NH,WKS,IFAIL)
C
WRITE(6,603) J,(EVAL(IC),IC=1,NK)
603 FORMAT('0 CALCULATED ROTATIONAL LEVELS FOR J =',I3,' ARE'/
1 (8X,9F12.5))
C
C IF THE RAW EIGENVECTORS ARE DEGENERATE, THEY MAY NOT HAVE
C PROPER SYMMETRY. SEEK DEGENERATE SETS AND FORCE SYMMETRY ON THEM.
C ALSO PRINT SPHERICAL TOP SYMMETRY LABELS IF ANY DEGENERATE SETS
C ARE PRESENT.
C
CALL DMSYM(J,NK,EVAL,EVEC,H,WKS)
C
IF(EVLIST) THEN
WRITE(6,604)
604 FORMAT('0 EIGENVECTOR COEFFICIENTS:')
DO 200 IR=1,NK
KR=IR-J-1
WRITE(6,605) J,KR,(EVEC(IR,IC),IC=1,NK)
605 FORMAT(2I4,9F12.8/(8X,9F12.8))
200 CONTINUE
ENDIF
RETURN
END
SUBROUTINE AXSCAT(N, NSQ, MXLAM, NPOTL,
1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB,
2 P, Y1, Y2, Y3, Y4, VECNOW, VECNEW, EIGOLD, EIGNOW, HP,
3 ICODE, IPRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C ---------------------------------------------------------------
C THIS IS TIM PHILLIP'S INTERFACE OF ALEXANDER HIBRIDON
C CODES TO MOLSCAT: SCATTERING CALC USING DAPROP AND THEN
C AIRPRP. ON EXIT SR AND SI CONTAIN THE S-MATRIX.
C SR IS USED INTERNALLY TO HOLD THE LOG DERIVATIVE MATRIX
C ICODE.EQ.2 FOR SUBSEQUENT ENERGIES.
C ---------------------------------------------------------------
C REORGANIZED BY SG (2/2/93): CORRECTS NSTEPS=0 PROBLEM, BUT
C ALSO CALCULATES SOMEWHAT DIFFERENT STEP SIZES FROM EARLIER CODE.
C ---------------------------------------------------------------
C
C DIMENSION STATEMENTS FOR ARGUMENT LIST
C
DIMENSION U(NSQ),Y1(N),Y2(N),Y3(N),Y4(N)
DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ),
& EINT(N),CENT(N),WVEC(N),L(N),NB(N)
DIMENSION VECNOW(NSQ),VECNEW(NSQ),EIGOLD(N),EIGNOW(N),HP(N)
C
LOGICAL IREAD,IWRITE, LLD,LAIRY
C
C COMMON BLOCKS TO COMMUNICATE WITH PROPAGATORS
C THE FOLLOWING VARIABLES FROM COMMON/DRIVE/ ARE USED WITH THIS
C PROPAGATOR: STEPS,RMIN,RMAX,ERED,RMLMDA,NOPEN,ISCRU,TOLHI,RMID,
C AND SOMETIMES DR
C
COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR,
1 DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA,
2 NOPEN,JKEEP,ISCRU,MAXSTP
C
COMMON/HIBRIN/POWRX,DRAIRY,IABSDR
C
C SET UP TO USE UNIT (ISCRU)
IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0
IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0
C ---------------------------------------------------------------
IF((.NOT.IREAD) .AND. IWRITE) THEN
ITWO = 0
ELSE IF(IREAD .AND. (.NOT.IWRITE)) THEN
ITWO = 1
ELSE IF((.NOT.IREAD) .AND. (.NOT.IWRITE)) THEN
ITWO = -1
ELSE
WRITE(6,*) ' ILLEGAL IREAD/IWRITE COMBINATION '
WRITE(6,*) ' BOTH SIMULTANEOUSLY TRUE '
STOP
END IF
C--------------------------------------------------------------------
C
C DECIDE WHICH CALCULATIONS TO DO.
C ON THE ASSUMPTION THAT RMIN.LT.RMAX THERE ARE THREE CASES
C 1) RMID.LE.RMIN.LT.RMAX
C 2) RMIN.LT.RMID.LT.RMAX
C 3) RMIN.LT.RMAX.LE.RMID
C CODE BELOW SETS FOLLOWING LLD LAIRY RSWTCH
C CASE 1 F T RMIN
C CASE 2 T T RMID
C CASE 3 T F RMAX
C INTEGRATION RANGES ARE THEN DAPROP: RMIN -> RSWTCH
C AIRY: RSWTCH -> RMAX
C--------------------------------------------------------------------
RBEGIN=RMIN
REND=RMAX
LLD=RBEGIN.LT.RMID
LAIRY=RMID.LT.REND
RSWTCH=MIN(REND,RMID)
RSWTCH=MAX(RSWTCH,RBEGIN)
C
C CALCULATE WAVEVECTORS AND STEP SIZE
WMAX=0.D0
NOPEN=0
DO 20 I=1,N
DIF=ERED-EINT(I)
WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF)
WMAX=MAX(WMAX,WVEC(I))
NB(I)=I
IF (DIF.GT.0.D0) NOPEN=NOPEN+1
20 CONTINUE
IF (NOPEN.EQ.0) RETURN
C
IF (IREAD) GO TO 40
PI=ACOS(-1.D0)
DRLD=PI/(WMAX*STEPS)
IF (IABSDR .EQ. 1 .AND. DR .GT. 0.D0) DRLD=DR
NSTEPS=(RSWTCH-RBEGIN)/DRLD
IF (IWRITE) WRITE (ISCRU) RBEGIN,RSWTCH,REND,DRLD,NSTEPS
GO TO 60
40 READ (ISCRU) RBEGIN,RSWTCH,REND,DRLD,NSTEPS
60 CONTINUE
C
C SET REND FOR YTOK, AND RESET RSWTCH IN CASE WE DON'T CALL AIRPRP
RYON=REND
REND=RSWTCH
RSWTCH=RBEGIN
C
LLD=LLD .AND. NSTEPS.GT.0
IF (LLD) THEN
RSWTCH=REND
C PROPAGATE LOG DERIVATIVE THROUGH FIRST SEGMENT.
C ISTART=0 REQUESTS INITIALIZATION OF LOG-DERIVATIVE MATRIX
ISTART=0
CALL DAPROP(U, SR, N,
1 RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU,
2 Y1, Y2, Y3, Y4,
3 P, VL, IV, ERED, EINT, CENT, RMLMDA,
4 MXLAM, NPOTL, ISTART, NODES)
C -------------------------------------------------------------
IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,RSWTCH,NSTEPS
1000 FORMAT(' AXSCAT. LOG DERIVATIVE MATRIX INTEGRATED FROM ',
& F12.4,' TO ',F12.4,' IN ',I6,' STEPS.')
ELSE
C INITIALIZE LOG-DERIVATIVE MATRIX IF DAPROP NO CALLED
DO 42 I=1,NSQ
42 SR(I)=0.D0
DO 43 I=1,NSQ,N+1
43 SR(I)=1.D30
IF (IPRINT.GE.3) WRITE (6,1010)
1010 FORMAT(' AXSCAT. DAPROP NOT CALLED: LOG DERIVATIVE MATRIX ',
& 'INITIALIZED.')
ENDIF
C
C USE AIRY PROPAGATOR FOR THE REMAINDER OF THE SCATTERING REGION
C
IF (.NOT.LAIRY) GO TO 41
REND=RYON
DRA=DRLD
IF (DRAIRY .GT. 0.D0) DRA = DRAIRY
CALL AIRPRP(SR,U,SI,VECNOW,VECNEW,EIGOLD,EIGNOW,HP,
1 Y1,Y2,Y3,Y4,RSWTCH,
2 REND,DRA,ERED,TOLHI,POWRX,ESHIFT,N,
3 ITWO,IREAD,IWRITE,IPRINT,ISCRU,P,MXLAM,VL,IV,RMLMDA,
4 EINT,CENT,NPOTL)
C
C SORT CHANNELS BY ASYMPTOTIC ENERGY
C
41 CONTINUE
IF (N.EQ.1) GO TO 100
NM1=N-1
DO 80 I=1,NM1
IP1=I+1
DO 80 J=IP1,N
IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 80
IT=NB(I)
NB(I)=NB(J)
NB(J)=IT
80 CONTINUE
C
C CALCULATE K AND S MATRICES
C
100 CALL YTOK(NB,WVEC,L,N,NOPEN,Y1,Y2,Y3,Y4,SR,SI,U,REND)
CALL KTOS(U,SR,SI,NOPEN)
RETURN
END
SUBROUTINE BAS9IN(PRTP,IBOUND)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE
CHARACTER*8 PRTP(4),QNAME(10)
LOGICAL LEVIN,EIN,LCNT
DIMENSION ROTI(12),ELEVEL(1000),JLEVEL(4000),
1 ISYM(10),ISYM2(10),WT(2)
DIMENSION JLEV(1),VL(1),IV(1),CENT(1),J(1),L(1),LAM(1)
COMMON/CMBASE/ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL,
1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT
2 ,MXJL,MXEL
C
C BAS9IN IS CALLED ONCE FOR EACH SCATTERING SYSTEM (USUALLY ONCE
C PER RUN) AND CAN READ IN ANY BASIS SET INFORMATION NOT CONTAINED
C IN NAMELIST BLOCK &BASIS. IT MUST ALSO HANDLE THE FOLLOWING
C VARIABLES AND ARRAYS:
C
C PRTP SHOULD BE RETURNED AS A CHARACTER STRING DESCRIBING THE
C COLLISION TYPE
C IDENT CAN BE SET>0 IF A COLLISION OF IDENTICAL PARTICLES IS
C BEING CONSIDERED AND SYMMETRISATION IS REQUIRED.
C HOWEVER, THIS WOULD REQUIRE EXTRA CODING IN IDPART.
C IBOUND CAN BE SET>0 IF THE CENTRIFUGAL POTENTIAL IS NOT OF THE
C FORM L(L+1)/R**2; IF IBOUND>0, THE CENT ARRAY MUST BE
C RETURNED FROM ENTRY CPL9
C
IBOUND=1
PRTP(1)=' BODY-F'
PRTP(2)='IXED ATO'
PRTP(3)='M-DIATOM'
PRTP(4)=' '
RETURN
C
ENTRY SET9(LEVIN,EIN,NLEV,JLEV,NQN,QNAME,MXPAR,NLABV)
C
C SET9 IS CALLED ONCE FOR EACH SCATTERING SYSTEM. IT SETS UP:
C MXPAR, THE NUMBER OF DIFFERENT SYMMETRY TYPES ("PARITY CASES")
C NLEVEL AND JLEVEL, UNLESS LEVIN IS .TRUE.;
C JLEV AND NLEV;
C ELEVEL, UNLESS EIN IS .TRUE.
C IF THE LOGICAL VARIABLES ARE .TRUE. ON ENTRY, THE CORRESPONDING
C QUANTITIES WERE INPUT EXPLICITLY IN NAMELIST BLOCK &BASIS.
C IF EIN IS .FALSE., THE MOLECULAR CONSTANTS MUST HAVE BEEN SUPPLIED
C IN THE &BASIS ARRAY ROTI: THE PROGRAMMER MAY USE THESE IN ANY WAY
C HE LIKES, BUT SHOULD OUTPUT THEM HERE FOR CHECKING.
C NOTE THAT JLEVEL CONTAINS JUST THE QUANTUM NUMBERS NECESSARY TO
C SPECIFY THE THRESHOLD ENERGY (AND ELEVEL CONTAINS THE CORRESPONDING
C ENERGIES WHEREAS JLEV CONTAINS ALL THE CHANNEL QUANTUM NUMBERS EXCEPT
C THE ORBITAL L, WHICH MAY BE A SUPERSET. THE LAST COLUMN OF THE JLEV
C ARRAY CONTAINS A POINTER TO THE ENERGY IN THE ELEVEL ARRAY.
C
MXPAR=2
NLABV=1
IF(LEVIN) GOTO 220
NLEVEL=0
NLEV=0
DO 210 I=JMIN,JMAX,JSTEP
NLEVEL=NLEVEL+1
JLEVEL(NLEVEL)=I
C NL IS NUMBER OF SETS OF INTERNAL QUANTUM NUMBERS FOR THIS LEVEL
NL=1+MIN(J2MAX,I)
NLEV=NLEV+NL
210 CONTINUE
GOTO 230
220 WRITE(6,602)
602 FORMAT('0 BASIS FUNCTIONS TAKEN FROM &BASIS (JLEVEL) INPUT')
C
C IF NLEV AND NLEVEL ARE DIFFERENT, IT MAY BE NECESSARY TO BUILD UP JLEV
C IN A DIFFERENT ORDER AND REARRANGE IT LATER - SEE SET3 CODING IN SETBAS
230 NQN=3
QNAME(1)=' J '
QNAME(2)=' |K| '
C LOOP OVER LEVELS AGAIN, THIS TIME SETTING UP JLEV
II=0
IJ=0
DO 250 I=JMIN,JMAX,JSTEP
II=II+1
DO 250 K=0,MIN(J2MAX,I)
IJ=IJ+1
JLEV(IJ)=I
JLEV(NLEV+IJ)=K
JLEV(NLEV*(NQN-1)+IJ)=II
250 CONTINUE
C
IF(EIN) GOTO 280
WRITE(6,604) ROTI(1)
604 FORMAT('0 ENERGY LEVELS CALCULATED FROM B =',F10.5)
C
DO 270 I=1,NLEVEL
JI=JLEVEL(I)
ELEVEL(I)=ROTI(1)*DBLE(JI*(JI+1))
270 CONTINUE
RETURN
C
280 WRITE(6,605)
605 FORMAT('0 ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL) INPUT')
RETURN
C
ENTRY BASE9(LCNT,N,JTOT,ICODE,JLEV,NLEV,NQN,J,L)
C
C BASE9 IS CALLED EITHER TO COUNT THE ACTUAL NUMBER OF CHANNEL BASIS
C FUNCTIONS OR ACTUALLY TO SET THEM UP (IN THE J AND L ARRAYS).
C IT IS CALLED FOR EACH TOTAL J (JTOT) AND PARITY CASE (ICODE).
C IF LCNT IS .TRUE. ON ENTRY, JUST COUNT THE BASIS FUNCTIONS. OTHERWISE, SET
C UP J (POINTER TO JLEV) AND L (ORBITAL ANGULAR MOMENTUM) FOR EACH CHANNEL.
C THIS MUST TAKE INTO ACCOUNT JTOT AND ICODE.
C ONE IMPORTANT OVERALL EFFECT IS THAT THE THRESHOLD ENERGY IS IN
C ELEVEL(JLEV(NLEV*(NQN-1)+J(I)). CHECK THIS!
C
N=0
DO 320 I=1,NLEV
K=JLEV(NLEV+I)
IF(K.GT.JTOT) GOTO 320
IF(K.EQ.0 .AND. ICODE.EQ.1) GOTO 320
N=N+1
IF(LCNT) GOTO 310
J(N)=I
L(N)=JTOT
310 CONTINUE
320 CONTINUE
RETURN
C
ENTRY CPL9(N,ICODE,NPOTL,LAM,MXLAM,NLEV,JLEV,J,L,JTOT,
1 VL,IV,CENT,IBOUND,IEXCH,IPRINT)
C
C CPL9 IS CALLED AFTER BASE9 FOR EACH JTOT AND ICODE, TO SET UP THE
C POTENTIAL COUPLING COEFFICIENTS VL.
C IF IBOUND>0, IT ALSO SETS UP THE CENTRIFUGAL COEFFICIENTS CENT.
C INDICES SPECIFYING THE MXLAM DIFFERENT POTENTIAL SYMMETRIES ARE IN
C THE FIRST XX*MXLAM ELEMENTS OF LAM; THE STRUCTURE OF THE LAM ARRAY
C (AND THE VALUE OF XX) IS CHOSEN BY THE PROGRAMMER, AND MUST
C CORRESPOND WITH THAT USED IN SUBROUTINE POTENL.
C NPOTL IS THE NUMBER OF DIFFERENT POTENTIAL TERMS WHICH CONTRIBUTE TO
C EACH MATRIX ELEMENT (SEE SUBROUTINE WAVVEC). IT SOMETIMES SAVES
C A SIGNIFICANT AMOUNT OF SPACE IF IT CAN BE LESS THAN MXLAM.
C
ROOT2=SQRT(2.D0)
NPOTL=MXLAM
DO 550 LL=1,MXLAM
LM=LAM(LL)
NNZ=0
I=LL
DO 540 ICOL=1,N
JC=JLEV(J(ICOL))
KC=JLEV(J(ICOL)+NLEV)
DO 540 IROW=1,ICOL
JR=JLEV(J(IROW))
KR=JLEV(J(IROW)+NLEV)
VL(I)=0.D0
IV(I)=LL
IF(KR.NE.KC) GOTO 510
ISUM=LM+JR+JC
IF(ISUM-2*(ISUM/2).NE.0 .OR. LM.GT.JC+JR) GOTO 540
VL(I)=PARITY3(KC)*SQRT(DBLE(JC*(JC+1)*JR*(JR+1)))*THREEJ(JC,LM,JR)
1 *THRJ(DBLE(JC),DBLE(LM),DBLE(JR),DBLE(KC),0.D0,DBLE(-KC))
IF(VL(I).NE.0.D0) NNZ=NNZ+1
GOTO 540
510 IF(LM.GE.0 .OR. JR.NE.JC .OR. IABS(KR-KC).GT.1) GOTO 540
VL(I)=SQRT(DBLE((JC*(JC+1)-KR*KC)*(JTOT*(JTOT+1)-KR*KC)))
IF(JC.EQ.0 .NEQV. JR.EQ.0) VL(I)=ROOT2*VL(I)
IF(VL(I).NE.0.D0) NNZ=NNZ+1
540 I=I+NPOTL
IF(NNZ.EQ.0) WRITE(6,612) JTOT,LL
612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING',
1 ' COEFFICIENTS ARE 0.0 FOR POTENTIAL SYMMETRY',I4)
550 CONTINUE
C
C NOW THE CENTRIFUGAL POTENTIAL
DO 570 I=1,N
JC=JLEV(J(I))
KC=JLEV(J(I)+NLEV)
CENT(I)=DBLE(JTOT*(JTOT+1)+JC*(JC+1)-2*KC*KC)
570 CONTINUE
RETURN
C
ENTRY DEGEN9(J1,J2,RESULT)
C
C DEGEN9 IS CALLED TO OBTAIN THE DEGENERACY FACTOR FOR THE DENOMINATOR
C OF A CROSS-SECTION CALCULATION; IT DOES NOT MATTER FOR BOUND STATES.
C
C JI=JLEVEL(J1)
C RESULT=DBLE(2*JI+1)
RETURN
END
SUBROUTINE BASE (JTOT, JLEV, N, J, L, CINT, EINT, CENT, VL, IV,
& MXLAM, NPOTL, LAM, WVEC, WGHT, IEXCH, THETA, PHI,
& ICODE, LCNT, ERED, NLEVV, PRINT)
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C . CHANGED APR 1986 TO COMBINE BASIN & IOSBIN HANDLING.
C . CHANGED JAN 1988 TO ALLOW USER-DEFINED BASIS (ITYPE=9)
C . CHANGED MAR 1993 TO SET MPLMIN=TRUE FOR ITYPE=23,IDENT=1
C . CHANGED NOV 1993 TO USE IXNEXT DIRECTLY IN PLACE OF IC.
C . IC REMOVED FROM ARGUMENT LIST OF BASIN AND SET6.
C . CHANGED JAN 1994 TO USE IV() INDEXING FOR ITYP=10*N + 2
C . APR 1994 TO INCLUDE IEXCH IN PARAMETER LIST
C NEW ORDERING OF ITYPE=23 'PARITY CASES'
C . CHANGED JUL 1994 FOR VERSION 14
C . AUG 1994 TO INTEGRATE ITYPE = 4 CODE TO VERSION 14
C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE
C BELOW IS BEGINNING OF A LIMITED SAVE LIST
C SAVE ITP,ITYPE,IOFF,IBOUND,JZCSFL,EMAXK,WTM,IGO,IGODG,MJMX
C IDENT,WT,JMAX,JMIN -- IN CMBASE
C NLEV,NQN,MPLMIN -- IN PRBASE
C
C BASE HANDLES QUANTUM BASIS SETS FOR SCATTERING CALCULATION.
C
C ITYPE DESCRIBES TARGET-PROJECTILE TYPES.
C CURRENT IMPLEMENTATION FOR
C ITYPE=1 LINEAR RIGID ROTOR HIT BY AN ATOM
C ITYPE=2 DIATOMIC VIB-ROTOR HIT BY AN ATOM
C ITYPE=3 LINEAR RIGID ROTOR - LINEAR RIGID ROTOR
C ITYPE=4 RIGID ASYMMETRIC TOP HIT BY LINEAR RIGID ROTOR
C ITYPE=5 NEAR-SYMMETRIC TOP RIGID ROTOR HIT BY AN ATOM
C ITYPE=6 ASYMMETRIC TOP RIGID ROTOR HIT BY AN ATOM.
C ITYPE=7 DIATOMIC VIB-ROTOR HIT BY AN ATOM, WHERE A FULL
C SET OF EXPECTATION VALUES OF THE INTERMOLECULAR
C POTENTIAL BETWEEN (V,J) AND (V',J') DIATOM INTERNAL
C STATES IS SUPPLIED
C ITYPE=8 ATOM-SURFACE SCATTERING
C
C ITYPE=ITYPE+10 FOR EFFECTIVE POTENTIAL METHOD OF RABITZ.
C ITYPE=ITYPE+20 FOR COUPLED STATES OF MCGUIRE-KOURI.
C ITYPE=ITYPE+30 FOR DLD METHOD OF DEPRISTO AND ALEXANDER.
C
C
C ENTRY BASIN
C READS AND PROCESSES &BASIS DATA TO DESCRIBE ASYMPTOTIC LEVELS.
C QUANTUM NOS. AND INDEXING ARE IN JLEVEL(NLEVEL) AND
C JLEV(NLEV,NQN), IN DIFFERENT FORMATS.
C ASYMPTOTIC ENERGIES ARE IN ELEVEL(NLEVEL).
C
C MAIN ENTRY BASE
C SETS UP BASIS FOR EACH PARTIAL CALCULATION FROM ASYMPTOTIC
C LEVELS (STORED IN JLEV) COUPLED WITH COLLISION ORBITAL ANGULAR
C MOMENTUM.
C LCNT=.TRUE. MEANS ONLY COUNT NUMBER OF CHANNELS
C LCNT=.FALSE. MEANS SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE.
C ICODE (=1...MXPAR) IS AN INDEX FOR THE CURRENT SYMMETRY BLOCK.
C IPAR AND IEXCH SUBDIVIDE ICODE=1,MXPAR INTO
C 1) PARITY, IPAR=0 (EVEN), 1 (ODD)
C 2) EXCHANGE SYM., IEXCH=0 (NO EXCHANGE), 1 (ODD), 2 (EVEN).
C IT IS NECESSARY TO SET FOLLOWING --
C ASYMPTOTIC LEVEL IN J, ORBITAL ANGULAR MOMENTUM IN L,
C ASYMPTOTIC ENERGY IN EINT, CENTRIFUGAL ENERGY IN CENT,
C AND COUPLING MATRIX ELEMENTS IN VL.
C
C EXTRA FEATURE ADDED AT UNIV. OF WATERLOO MAY 82. ARRAY IV
C IS AN INDEX ARRAY SUCH THAT VL(I) IS A COEFFICIENT FOR
C TERM NUMBER IV(I) IN THE POTENTIAL ARRAY RETURNED BY
C SUBROUTINE POTENL. THE INTRODUCTION OF THIS ARRAY ONLY
C MAKES ANY REAL DIFFERENCE FOR ITYPE=10*N+7, FOR WHICH IT
C ENABLES LARGE ECONOMIES IN STORAGE FOR THE VL ARRAY.
C ** 1/27/93 IV ARRAY USED IF AND ONLY IF IVLFL.GT.0 **
C NPOTL IS THE NUMBER OF "CHUNKS" OF SIZE N*(N+1)/2 WHICH
C COMPRISE VL AND IV. NPOTL=MXLAM EXCEPT FOR ITYPE=10*N+7 AND 8.
C FOR ITYPE=10*N+7, NPOTL IS EQUAL TO K+1, WHERE K IS THE
C INDEX OF THE HIGHEST ORDER LEGENDRE POLYNOMIAL ACTUALLY
C PRESENT IN THE POTENTIAL.
C FOR ITYPE=8, NPOTL=1.
C
C ADDITIONAL CHANGE MADE MAY 82. THE VL ARRAY IS NOW STORED
C SO THAT THE POTENTIAL SYMMETRY TERM IS MOST RAPIDLY VARYING,
C RATHER THAN THE CHANNEL INDICES AS BEFORE. THIS IS TO KEEP
C PAGING TO A MINIMUM IN SUBROUTINE WAVMAT.
C
C ENTRY DEGEN PROVIDES DEGENERACY INFORMATION FOR USE IN OUTPUT.
C
DIMENSION CENT(NLEVV),EINT(NLEVV),WVEC(NLEVV),VL(NLEVV),IV(NLEVV)
LOGICAL LCNT,EIN,LEVIN,MPLMIN,LSIG
INTEGER J(NLEVV),L(NLEVV),LAM(MXLAM),JLEV(NLEVV)
INTEGER PRINT,EUNITS
CHARACTER*4 EUNITC
CHARACTER*8 QNAME(10),QTYPE(10),PRTP(4,9),PTP(2)
DIMENSION WTM(2),IOSNGP(3)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C COMMON BLOCK FOR BASIS DATA
C 2 AUG 94 V14 VERSION OF CMBASE; ISYM NO LONGER EQUIV J2MAX
C DIMENSIONS OF JLEVEL,ELEVEL SET HERE AND HELD IN /CMBASE/MXJL,MXEL
PARAMETER (MXJLVL=4000,MXELVL=1000)
DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2),
1 WEXE(2),WT(2),ELEVEL(MXELVL),EEE(1016)
DIMENSION JLEVEL(MXJLVL),ISYM(10),ISYM2(10)
EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)),
1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),(JSTEP,J1STEP),
2 (ROTI(1),EEE(1)), (ROTI(7),WE(1),DJ ), (ROTI(8),DJK),
3 (ROTI(9),WEXE(1),DK), (J2MAX,KSET)
COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC, NLEVEL,JLEVEL,JMIN,
1 JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT,MXJL,MXEL
C
COMMON /PRBASE/ ITYPX,NQN,NLEV,MVALUE,IPTY,MPLMIN
C
COMMON/VLSAVE/IVLU
C
C ARRAYS FOR NAMELIST &BASIS
C CHARACTER*6 BNAMES(40)
C DIMENSION LOCN(40),INDX(40)
C
C V14: ISYM2, JHALF ADDED TO NAMELIST
NAMELIST /BASIS/ ROTI,JMIN,JMAX,JSTEP,ITYPE
1 ,NLEVEL,JLEVEL,ELEVEL,EMAX,EMAXK,BE,ALPHAE,DE,A,B,C,WE,WEXE
2 ,J1MAX,J1MIN,J2MAX,J2MIN,J1STEP,J2STEP
3 ,WT,IDENT,SPNUC,EUNITS,EUNITC,IASYMU,JZCSMX,IBOUND,JZCSFL
4 ,IOSNGP,IPHIFL,ISYM,ISYM2,KSET,IVLU,JHALF
C
DATA QTYPE/ ' J ', ' K ',
1 ' PRTY ', ' J1 ', ' J2 ', ' J12 ',
2 ' V ', ' TAU ',' ','SIG INDX'/
DATA PRTP/' LINEAR',' RIGID R','OTOR - ',' ATOM. ',
1 ' DIATOM','IC VIB-R','OTOR - ',' ATOM. ',
2 ' LINEAR',' ROTOR -',' LINEAR ','ROTOR. ',
3 ' ASYMME','TRIC TOP',' - LINEA','R ROTOR.',
4 'ATOM - N','EAR SYM.',' TOP RIG','ID ROTOR',
5 ' ASYMME','TRIC TOP',' - ATOM ',' ',
6 4*' ',
7 ' ATOM -',' CORRUGA','TED SURF','ACE ',
8 4*' '/
DATA PTP/', ODD ',', EVEN '/
C
C
C DATA BNAMES/'ROTI','JMIN','JMAX','JSTEP','ITYPE',
C 1 'NLEVEL','JLEVEL','ELEVEL','EMAX','EMAXK',
C 2 'BE','ALPHAE','DE','A','B','C','WE','WEXE',
C 2 'J1MAX','J1MIN','J2MAX','J2MIN','J1STEP','J2STEP',
C 3 'WT','IDENT','SPNUC','EUNITS','IASYMU','JZCSMX','IBOUND',
C 4 'JZCSFL','IOSNGP','IPHIFL','ISYM','KSET','IVLU','ISYM2',
C 5 'JHALF','EUNITC'/
C DATA INDX/40*0/
C
C SET UP BASIS FUNCTIONS
C
IEXCH=0
IPAR=0
C
IF (ITYPE.EQ.8) GO TO 5208
IF (ITP.EQ.9) GO TO 5209
IF (ITYPE.LE.10) GO TO 5201
IF (ITYPE.LE.20) GO TO 5202
IF (ITYPE.LE.30) GO TO 5203
C
C CODE FOR DECOUPLED L-DOMINANT APPROX OF ALEXANDER
C
5204 N=0
LAMBDA=ICODE-1
DO 4001 I=1,NLEV
JI=JLEV(I)
LI=JTOT+LAMBDA-JI
IF (LI.LT.IABS(JTOT-JI) .OR. LI.GT.(JTOT+JI) ) GO TO 4001
N=N+1
IF (LCNT) GO TO 4001
J(N)=I
L(N)=LI
4001 CONTINUE
IF (LCNT) GO TO 5000
GO TO 8000
C
C CODE BELOW FOR MCGUIRE-KOURI J-Z CONSERVING COUPLED STATES APPROX.
C
5203 N=0
C>SG CODE BELOW IS REVISED APR 94 -- NEW ORDERING OF PARITY CASES
IF (MPLMIN) THEN
IF (IDENT.EQ.0) THEN
MVALUE=ICODE-1
IF (ITYPE.EQ.25.AND.ISYM(1).NE.-1) THEN
IBLOCK=1+MVALUE/(MJMX+1)
MVALUE=MOD(MVALUE,MJMX+1)
KREQ=IBLOCK-1
ENDIF
ELSE
IEXCH=2-MOD(ICODE,2)
MVALUE=(ICODE+1)/2-1
IF (WT(IEXCH).EQ.0.D0) THEN
IF (PRINT.GE.3) WRITE(6,690) JTOT,ICODE,PTP(IEXCH)
GO TO 5000
ENDIF
ENDIF
ELSE
C CODE BELOW IS FOR MPLMIN=.FALSE. (NOT USED, BUT COULD BE REVIVED)
IF (IDENT.EQ.0) THEN
WRITE(6,*) ' *** BASE (APR 94). MPLMIN=.FALSE. .AND. IDENT.'
1 ,'EQ.0 ARE NOT ALLOWED'
STOP
ELSE
ICD=(ICODE+1)/2
MVALUE=ICD/2
IF (ICD-2*(ICD/2).EQ.0) MVALUE=-MVALUE
ENDIF
ENDIF
C SET IPAR (=1 FOR MVALUE=0, =2 OTHERWISE)
IPAR=1
IF (MVALUE.NE.0) IPAR=2
C<SG END OF APR 94 REVISIONS
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.
1 PARITY3(IEXCH+JLEV(2*NLEV+I)+JTOT+JZCSFL*JLEV(IOFF+I)).LE.0.D0)
2 GO TO 5221
IF (ITYPE.EQ.25 .AND. ISYM(1).NE.-1 .AND. JLEV(NLEV+I).NE.KREQ)
1 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,ICODE,PTP(IEXCH)
690 FORMAT(' ***'/
1 ' *** NOTE. JTOT =',I4,'.',I2,A8,'EXCHANGE SKIPPED'
2 ,' BECAUSE WEIGHT = 0.0'/' ***')
GO TO 5000
8001 DO 5210 I=1,NLEV
IF (IDENT.NE.0 .AND. JLEV(I).EQ.JLEV(NLEV+I) .AND.
1 PARITY3(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 (EXCEPT 8 & 9) CODE.
C N.B. BASIS FUNCTIONS ARE ORDERED ON L AS IN GORDON'S CODE.
C
5201 N=0
IPTY=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,ICODE,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, 9004, 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 PARITY3(IEXCH+JI+LI).LE.0.D0) GO TO 4201
LPJ=JLEV(I)+JLEV(NLEV+I)+LI+JTOT
GO TO 4005
9004 JI = JLEV(I)
JAY1 = JLEV(2*NLEV + I)
JAY2 = JLEV(NLEV + I)
LPJ = JLEV(4*NLEV + I)
C LINE BELOW CORRECTED 1 NOV 94 BY SG
LPJ = LPJ + LPJ/2 + JAY1 + JAY2 + LI + JTOT
GO TO 4005
9005 JI=JLEV(I)
LPJ=JI+JLEV(I+NLEV)+JLEV(I+2*NLEV)+LI+JTOT
C FOR SYMMETRIC TOP WITH ISYM OPTION, SKIP IF THIS K NOT WANTED
IF (ISYM(1).NE.-1) THEN
KREQ=(ICODE-1)/2
IF (JLEV(NLEV+I).NE.KREQ) GO TO 4201
ENDIF
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. IPTY) 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) GO TO 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 FROM ENERGY('SIG-INDEX')
C APR 94, ALLOW FOR NEG SIG-INDEX
EINT(I)=CINT * ELEVEL(IABS(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) GO TO 4020
WRITE(6,300)
300 FORMAT(/' 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 AFTER MAY 76 IPAR USED IN PLACE OF IEXCH FOR CS WEIGHTING.
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(//' /BASIS/ DATA ARE --')
C
C SET LIMITS IN /CMBASE/
MXEL=MXELVL
MXJL=MXJLVL
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
C BELOW ZEROS ELEVEL,ROTI,EMAX,WT,SPNUC
DO 1103 I=1,MXEL+16
1103 EEE(I)=0.D0
DO 1104 I=1,MXJL
1104 JLEVEL(I)=0
DO 1105 I=1,3
1105 IOSNGP(I)=0
IPHIFL=0
IDENT=0
WT(1)=0.D0
WT(2)=0.D0
WTM(1)=1.D0
WTM(2)=1.D0
MPLMIN=.TRUE.
EUNITS=0
EUNITC=' '
JZCSMX=-1
IBOUND=0
JZCSFL=0
IASYMU=0
IVLU=0
JHALF=1
DO 1106 I=1,10
ISYM(I)=-1
1106 ISYM2(I)=-1
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 LOCN(38)=LOC(ISYM2)
C LOCN(39)=LOC(JHALF)
C LOCN(40)=LOC(EUNITC)
C CALL NAMLIS('&BASIS',BNAMES,LOCN,INDX,40,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(/' ',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,EUNITC,EFACT)
JZCSFL=MAX0(MIN0(JZCSFL,1),-1)
IF (ITYPE.EQ.8) GO TO 6902
C BELOW APPLIES EFACT TO ROTI,ELEVEL
DO 6901 I=1,MXEL+12
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 .AND. ITYP.NE.9) 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(/' DECOUPLED L-DOMINANT APPROX. OF DEPRISTO AND ',
1 'ALEXANDER WILL BE USED.')
GO TO 3100
3300 WRITE(6,662) ITYPE,JZCSFL
662 FORMAT(/' COUPLED STATES APPROXIMATION OF MCGUIRE AND KOURI ',
1 '(C.F. J. CHEM. PHYS. 60, 2488 (1974)) WILL BE USED.'//
2 11X,'ITYPE =',I3/11X,'L(I) = JTOT + (',I2,') * J(I)')
IF (IBOUND.NE.0) WRITE(6,664)
664 FORMAT(/' DIAGONAL CORIOLIS TERM INCLUDED IN CENTRIFUGAL ',
1 'POTENTIAL')
GO TO 3100
3200 WRITE(6,661) ITYPE
661 FORMAT(/' *EFFECTIVE POTENTIAL METHOD* WILL BE USED.',
1 ' SEE H. RABITZ, J. CHEM. PHYS. 57, 1718 (1972).'//
2 ' ITYPE =',I4)
3100 WRITE(6,600) (PRTP(JJ,ITP),JJ=1,4)
600 FORMAT(/' COLLISION TYPE IS ', 4A8)
IF (ITYPE-10*(ITYPE/10).EQ.7) WRITE(6,6840)
6840 FORMAT(/' 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 MODIFIED AUG 94 TO ALLOW NEGATIVE NLEVEL FOR ITYPE=6
C NOTE: ITYPE = 4 CODE DOES NOT USE LEVIN,EIN
IF (ITP.EQ.4) GO TO 7600
IF (NLEVEL.GT.0) GO TO 7000
LEVIN=.FALSE.
EIN=.FALSE.
IF (ITP.EQ.6.AND.NLEVEL.LT.0) GO TO 7001
GO TO 7100
7000 LEVIN=.TRUE.
7001 EIN=.TRUE.
DO 7200 I=1,ABS(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(/' * * * ERROR. ENERGY LEVELS CAN BE OBTAINED NEITHER ',
1 'FROM ELEVEL NOR ROTI INPUT.')
WRITE(6,629)
629 FORMAT(/' * * * EXECUTION TERMINATING.')
STOP
C
C PROCESS ACCORDING TO ITYPE.
C
C IVLFL=0 EXCEPT FOR ITYPE'S = 2, 7, 8
7600 IVLFL=0
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 GO TO 1002
IF (ITYPE.EQ.3.OR.ITYPE.EQ.13.OR.ITYPE.EQ.23) GO TO 1003
IF (ITYPE.EQ.4.OR.ITYPE.EQ.24) GO TO 1004
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 GO TO 1002
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(/' ILLEGAL ITYPE =',I8,', EXECUTION TERMINATING.')
STOP
C
C * * * * * ITYPE = 1 * * * * *
C
1001 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
IVLFL=1
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
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 PARITY3(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
C APR 94: STATEMENT BELOW WAS LOST IN VERSIONS 9-12
NLEV=NLEVEL
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 * * * * * ITYPE = 4 * * * * *
C ASYMMETRIC TOP - LINEAR RIGID ROTOR, AUG 90 GISS (TRP)
C
1004 NQN = 8
ASSIGN 9004 TO IGO
ASSIGN 3904 TO IGODG
QNAME(1) = QTYPE(6)
QNAME(2) = QTYPE(5)
QNAME(3) = QTYPE(4)
QNAME(4) = QTYPE(8)
QNAME(5) = QTYPE(3)
QNAME(6) = QTYPE(9)
QNAME(7) = QTYPE(9)
MXPAR = 2
CALL SET4(NLEV,JLEV,JLEV,EFACT,IASYMU)
IF (ITYPE .LE. 10) GO TO 2000
GO TO 1020
C
C * * * * * ITYPE = 5 * * * * *
C
1005 NQN=4
ASSIGN 9005 TO IGO
ASSIGN 3905 TO IGODG
QNAME(1)=QTYPE(1)
QNAME(2)=QTYPE(2)
QNAME(3)=QTYPE(3)
MXPAR=2
IF (ISYM(1).NE.-1) MXPAR=ISYM(1)*MXPAR
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
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)
GO TO 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(' *** NOTE. CS OR DLD APPROXIMATION SUBSPACE IS ',
& 'LIMITED BY JZCSMX =',I3/13X,'CROSS SECTIONS BETWEEN HIGHER J ',
& 'INACCURATE.')
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.EQ.23.AND.IDENT.NE.0) MXPAR=2*MXPAR
IF (ITYPE.EQ.25.AND.ISYM(1).NE.-1) MXPAR=ISYM(1)*MXPAR
C ADJUST SIG INDEX TO BE NEGATIVE IF J-VALUE IS GREATER THAN JZCSMX
LSIG=.FALSE.
IXT=(NQN-1)*NLEV
C MODIFIED FOR ITYPE=24 29 JUL 94 (SG)
IF (ITYPE.EQ.23.OR.ITYPE.EQ.24) THEN
IF (ITYPE.EQ.23) IOX=0
IF (ITYPE.EQ.24) IOX=2*NLEV
DO 2001 I=1,NLEV
C TWO ROTORS; COMPARE J1+J2 W/ MJMX
IF (JLEV(IOX+I)+JLEV(NLEV+I).LE.MJMX) GO TO 2001
JLEV(IXT+I)=-JLEV(IXT+I)
LSIG=.TRUE.
2001 CONTINUE
ELSE
DO 2002 I=1,NLEV
C ALL OTHER CASES; N.B. IOFF=0 FOR THESE (J IS 1ST QUANT NO.)
IF (JLEV(IOFF+I).LE.MJMX) GO TO 2002
JLEV(IXT+I)=-JLEV(IXT+I)
LSIG=.TRUE.
2002 CONTINUE
ENDIF
IF (LSIG) WRITE(6,672)
672 FORMAT(' *** NOTE. CROSS SECTIONS INCOMPLETE BECAUSE OF JZCSMX',
1 ' WILL BE MARKED NEGATIVE'/
2 ' AND PRINTED ONLY IF ISIGPR.GE.2')
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.MXEL) GO TO 1224
WRITE(6,619) NLEVEL
619 FORMAT(/' **** 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
WRITE(6,620) (QNAME(I),I=1,NQN)
620 FORMAT(/' LEVEL ENERGY(1/CM) ',10A8)
JJ=NLEV*(NQN-1)
DO 2100 I=1,NLEV
JTOP=JJ+I
2100 WRITE(6,621) I,ELEVEL(IABS(JLEV(JJ+I))),(JLEV(JI),JI=I,JTOP,NLEV)
621 FORMAT(1X,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,3904,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
3904 JI1=JLEVEL(3*J1-2)
JI2=JLEVEL(3*J1)
DEGEN=DBLE((2*JI1+1)*(2*JI2+1))
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 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 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 CHKSTR(NUSED)
C NEW ROUTINE FOR DYNAMIC STORAGE HANDLING (SG:1/21/93)
C REVISED 2 FEB 94 TO REFLECT USAGE OF UPPER X() IN HIH2O
C
C NUSED.LT.0 ON ENTRY RESETS HIH2O (HIGH-WATER MARK)
C ALSO RESETS MX=MAXMAX
C HIH2O DOES NOT REFLECT USE OF THE TOP OF X()
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
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, MX
IF (NUSED.LT.0) THEN
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
MAXMAX=MAX(MAXMAX,MX)
NEED=ITOP+(MAXMAX-MX)
HIH2O=MAX(HIH2O,NEED)
NUSED=HIH2O
ENDIF
RETURN
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 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 COUPLE(N,ITYPE,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,JTOT,
1 VL,IV,IEX,PRINT)
C MODIFIED FOR ITYPE=4 BY SG 29 JUN 94
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.4) GO TO 8004
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 MAKING USE OF IV() (SG, JAN 94)
C
8002 IF (IVLFL.LE.0) GO TO 9999
II=NPOTL*N*(N+1)/2
DO 1542 I=1,II
VL(I)=0.D0
1542 IV(I)=0.D0
C
NZERO=0
DO 1522 LL=1,MXLAM
LLL=LAM(3*LL-2)
NV=LAM(3*LL-1)
NV1=LAM(3*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 1512 ICOL=1,N
JVCOL=JLEV(J(ICOL),2)
IF(JVCOL.NE.NV .AND. JVCOL.NE.NV1) THEN
II=II+ICOL
GOTO 1512
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 1502 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. JVROW.EQ.NV1 )
5 .OR.
6 (JVCOL.EQ.NV1 .AND. JVROW.EQ.NV )
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
1502 CONTINUE
1512 CONTINUE
IF (NNZ.LE.0) THEN
NZERO=NZERO+1
IF(PRINT.GE.14) WRITE(6,612) JTOT,LL
ENDIF
IXNEXT=ITJ
1522 CONTINUE
IF(NZERO.GT.0 .AND. PRINT.GT.0.AND.PRINT.LT.14)
1 WRITE(6,620) JTOT,NZERO
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 ITYPE4 OBTAINED VIA CALL TO CPL4
8004 CALL CPL4(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,JLEV,NLEV,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+PARITY3(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=PARITY3(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 * PARITY3(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.GT.0.AND.PRINT.LT.14)
1 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)=PARITY3((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.LE.0) GO TO 9999
NZERO=NPOTL*N*(N+1)/2
DO 6042 I=1,NZERO
VL(I)=0.D0
6042 IV(I)=0
NZERO=0
DO 6102 LL=1,MXLAM
LLL=LAM(3*LL-2)
NV=LAM(3*LL-1)
NV1=LAM(3*LL)
NNZ=0
II=0
DO 6202 ICOL=1,N
NVC=JLEV(J(ICOL),2)
NJC=JLEV(J(ICOL),1)
DO 6202 IROW=1,ICOL
NVR=JLEV(J(IROW),2)
NJR=JLEV(J(IROW),1)
II=II+1
IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC))
1 THEN
I=(II-1)*NPOTL+LLL+1
VL(I)=PARITY3((IABS(NJC-NJR)+NJC+NJR)/2) *
1 SQRT(SQRT(Z(NJC)*Z(NJR))/Z(LLL))*THREEJ(NJC,LLL,NJR)
IV(I)=LL
IF (VL(I).NE.0.D0) NNZ=NNZ+1
ENDIF
6202 CONTINUE
IF (NNZ.GT.0) GO TO 6102
IF (PRINT.GE.14) WRITE(6,612) JTOT,LL
NZERO=NZERO+1
6102 CONTINUE
IF(NZERO.GT.0 .AND. PRINT.GT.0.AND.PRINT.LT.14)
1 WRITE(6,620) JTOT,NZERO
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=PARITY3((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)+PARITY3(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+PARITY3(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=PARITY3(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*PARITY3(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
NZERO=NPOTL*N*(N+1)/2
DO 6047 I=1,NZERO
VL(I)=0.D0
6047 IV(I)=0
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)=PARITY3((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.GT.0.AND.PRINT.LT.14)
1 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 CPL21(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST)
C
C 30 DEC 93. INCORPORATES JMH (V12) USE OF J3J000
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)=DBLE(I+I+1)
ODD(I)=I-2*(I/2).NE.0
C
C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION
IF (LFIRST) THEN
IFIRST=-1
LFIRST=.FALSE.
NOMEM=.FALSE.
ENDIF
C
XM=MVALUE
PM=1.D0
IF (ODD(MVALUE)) PM=-1.D0
C
IF (IFIRST.GT.-1) GO TO 3500
C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS
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 CPL22(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,MVALUE,
1 IV,VL,PRINT,LFIRST)
C
C CS COUPLING MATRIX FOR VIBRATING ROTOR-ATOM (ITYPE=22)
C SG (MAR 94) USES IV(), I.E., IVLFL=1
C SAVES COUPLING MATRIX FOR MV=0,MX IN UPPER X() ARRAY
C USES J3J000 ROUTINE AS PER JMH CPL21 CODE
C STORES ON J OR NLEV, DEPENDING ON WHICH IS SMALLER
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE NOMEM,NL12,IXMX,ISTART,IFIRST,LOGIX,JTOP
C SPECIFICATIONS FOR ARGUMENTS
DIMENSION LAM(3,MXLAM),JLEV(NLEV),J(N),VL(1),IV(1)
INTEGER PRINT
LOGICAL LFIRST
C
LOGICAL ODD,NOMEM,LOGIX
DATA Z0/0.D0/
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C STATEMENT FUNCTION DEFINITIONS
Z(I)=DBLE(I+I+1)
ODD(I)=I-2*(I/2).NE.0
C
C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION
IF (LFIRST) THEN
IFIRST=-1
LFIRST=.FALSE.
NOMEM=.FALSE.
ENDIF
C
XM=MVALUE
PM=1.D0
IF (ODD(MVALUE)) PM=-1.D0
C
IF (IFIRST.GT.-1) GO TO 3500
C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS.
C LOGIX=.TRUE. IF JTOP IS SMALLER THAN NLEV (SO STORE ON J)
JTOP=0
DO 3400 I=1,NLEV
3400 JTOP=MAX(JTOP,JLEV(I))
LOGIX=JTOP.LT.NLEV
IF (LOGIX) THEN
NL12=(JTOP+1)*(JTOP+2)/2
ELSE
NL12=NLEV*(NLEV+1)/2
ENDIF
IXMX=NL12*NPOTL
ISTART=MX+1
C
3500 MVABS=IABS(MVALUE)
C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE
C IF NOT, TRY TO STORE THEM IN XCPL().
IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900
MV=IFIRST+1
C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY.
3600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 3610
IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX*(IFIRST+1)
602 FORMAT(/' CPL22 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT',
1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X,
2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12)
NOMEM=.TRUE.
GO TO 3900
C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL
3610 NAVAIL=MX-IXNEXT+1
IF (IXMX.LE.NAVAIL) GO TO 3601
IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL
692 FORMAT(/' CPL22 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL='
1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9)
C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES
NOMEM=.TRUE.
GO TO 3900
C
C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL
C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING W/ MV=0)
3601 MX=MX-IXMX
IX=MV*IXMX
C
PMV=1.D0
IF (ODD(MV)) PMV=-1.D0
C CODE BELOW FROM V12 (DEC 94) CPL21 CODE
C EXCEPT LIMIT ON IL LOOP AND VALUE OF LM
IF (LOGIX) THEN
ITOP=JTOP+1
ELSE
ITOP=NLEV
ENDIF
DO 3200 IL=1,NPOTL
LM=IL-1
JSAV=-1
ITJ=IXNEXT
IXNEXT=ITJ+LM+LM+1
NUSED=0
CALL CHKSTR(NUSED)
DO 3201 I1=1,ITOP
IF (LOGIX) THEN
J1=I1-1
ELSE
J1=JLEV(I1)
ENDIF
IF (J1.NE.JSAV) THEN
CALL J3J000(DBLE(J1),DBLE(LM),IVALJ,X(ITJ),XJMIN)
JMIN=IABS(J1-LM)
JMAX=J1+LM
JSAV=J1
ENDIF
DO 3201 I2=1,I1
IF (LOGIX) THEN
J2=I2-1
ELSE
J2=JLEV(I2)
ENDIF
IX=IX+1
IF (J2.LT.JMIN .OR. J2.GT.JMAX
1 .OR. J1.LT.MV .OR. J2.LT.MV
1 .OR. ODD(J2+JMAX)) THEN
X(ISTART-IX)=0.D0
ELSE
INDJ=ITJ+(J2-JMIN)/2
IF (MV.EQ.0) THEN
X(ISTART-IX)=PMV*SQRT(Z(J1)*Z(J2))*X(INDJ)**2
ELSE
X(ISTART-IX)=PMV*SQRT(Z(J1)*Z(J2))*X(INDJ)*
1 THRJ(DBLE(J1),DBLE(LM),DBLE(J2),-DBLE(MV),0.D0,DBLE(MV))
ENDIF
ENDIF
3201 CONTINUE
3200 IXNEXT=ITJ
C
IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL
693 FORMAT(/' CPL22 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3
1 /' REQUIRED AND AVAILABLE STORAGE =',2I9)
C
C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED.
IFIRST=MV
C
C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES.
MV=MV+1
IF (MV.LE.MVABS) GO TO 3600
C
C START BY ZEROING VL, IV ARRAYS
3900 NTOP=NPOTL*N*(N+1)/2
DO 3999 I=1,NTOP
VL(I)=0.D0
3999 IV(I)=0
IF (MVABS.GT.IFIRST) GO TO 3800
C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL
IXM=MVABS*IXMX
DO 3513 LL=1,MXLAM
NNZ=0
LM=LAM(1,LL)
NV=LAM(2,LL)
NV1=LAM(3,LL)
C ICR COUNTS ICOL,IROW LOOP; NEEDED FOR IXVL (VL INDEX)
ICR=0
DO 3503 ICOL=1,N
I1=J(ICOL)
J1=JLEV(I1)
NVC=JLEV(NLEV+I1)
DO 3503 IROW=1,ICOL
I2=J(IROW)
J2=JLEV(I2)
NVR=JLEV(NLEV+I2)
ICR=ICR+1
IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC))
1 THEN
C FIRST GET INDEX IN VL, IV
IXVL=(ICR-1)*NPOTL+LM+1
C THEN GET INDEX OF STORED COUPLING COEFFICIENT, DEPENDING ON LOGIX
IF (LOGIX) THEN
IF (J1.GT.J2) THEN
IX12=(J1+1)*J1/2+J2+1
ELSE
IX12=(J2+1)*J2/2+J1+1
ENDIF
ELSE
IF (I1.GT.I2) THEN
IX12=I1*(I1-1)/2+I2
ELSE
IX12=I2*(I2-1)/2+I1
ENDIF
ENDIF
IX=IXM+LM*NL12+IX12
IV(IXVL)=LL
VL(IXVL)=X(ISTART-IX)
IF (VL(IXVL).NE.0.D0) NNZ=NNZ+1
C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NEC
IF (MVALUE.LT.0.AND.ODD(J1+J2+LM)) VL(IXVL)=-VL(IXVL)
ENDIF
3503 CONTINUE
IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVALUE,LL
612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ',
& 'COEFFICIENTS ARE 0.')
3513 CONTINUE
RETURN
C
C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM
3800 DO 1511 LL=1,MXLAM
LM=LAM(1,LL)
NV=LAM(2,LL)
NV1=LAM(3,LL)
XLM=LM
NNZ=0
C ICR COUNTS ICOL,IROW LOOP; NEEDED FOR IXVL (VL INDEX)
ICR=0
DO 1501 ICOL=1,N
JCOL=JLEV(J(ICOL) )
XJCOL=JCOL
NVC=JLEV(NLEV+J(ICOL))
DO 1501 IROW=1,ICOL
JROW=JLEV(J(IROW) )
XJROW=JROW
NVR=JLEV(NLEV+J(IROW))
ICR=ICR+1
IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC))
1 THEN
IXVL=(ICR-1)*NPOTL+LM+1
IV(IXVL)=LL
VL(IXVL)=PM*SQRT(Z(JROW)*Z(JCOL))*
& THREEJ(JROW,LM,JCOL)*
& THRJ(XJROW,XLM,XJCOL,-XM,Z0,XM)
IF (VL(IXVL).NE.0.D0) NNZ=NNZ+1
ENDIF
1501 CONTINUE
IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVALUE,LL
1511 CONTINUE
RETURN
END
SUBROUTINE CPL23(N,MXLAM,LAM,NLEV,JLEV,J,L,MVALUE,IEX,VL,PRINT,
1 LFIRST)
C CS COUPLING MATRIX FOR LINEAR ROTOR-LINEAR ROTOR (ITYPE=23)
C SAVES M-INDEPENDENT PARTS USING NEW DYNAMIC STORAGE
C AND IVLFL IN VERSION '12X' OF MOLSCAT.
C VERSION 5. LINEAR XCPL NOW STORED BACKWARDS IN HI LOCS OF X().
C JAN 93 IVLFL CHECKED BEFORE CALL CPL23 AND IV NO LONGER USED
C M-INDEPENDENT PARTS (9-J) STORED IROW.GE.ICOL.
C M-DEPENDENT (3J) PARTS STORED IF MEMORY ALLOWS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE NOMEM,NL12,J12MX,NJ12,NXPM,NLM,IHL,IXEX,IXTJ,IXMX,ISTART
1 ,IFIRST
C
INTEGER PRINT
INTEGER LAM(2),JLEV(NLEV,3),J(2),L(2)
LOGICAL ODD,NOMEM,LFIRST
DIMENSION VL(2)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DATA SQRTHF/.70710678118654753D0/, Z0/0.D0/
DATA PIFCT/2.24483902656458321D-2/
Z(I)=DBLE(I+I+1)
ODD(I)=I-2*(I/2).NE.0
C
C INITIALIZE IFIRST IF LFIRST IS SET TO TRUE
IF (LFIRST) THEN
IFIRST=-2
LFIRST=.FALSE.
NOMEM=.FALSE.
ENDIF
XM=MVALUE
C
PM=PARITY3(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))*PARITY3(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)=PARITY3(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)+PARITY3(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+PARITY3(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*PARITY3(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+PARITY3(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*PARITY3(IS1)*
& GSYMTP(J1,-K1,J2,K2,MVALUE,LM,KSUM)
5585 IF (ABS(VL(I)).GE.1.D-5) NNZ=NNZ+1
5565 I=I+MXLAM
IF (NNZ.EQ.0) WRITE(6,612) MVALUE,LL
5555 CONTINUE
RETURN
END
SUBROUTINE CPL3(N,MXLAM,LAM,NLEV,JLEV,J,L,JTOT,VL,IEX,PRINT,
1 LFIRST)
C COUPLING MATRIX ELEMENTS FOR LINEAR ROTOR-LINEAR ROTOR (ITYPE=3)
C JAN 93 CODE TO SAVE JTOT-INDEPENDENT PARTS IN DEDICATED STORAGE
C WORKS W/ NEW DYNAMIC STORAGE CAPABILITIES. IVLFL CHECKED
C BEFORE CALL CPL3 AND IV NO LONGER USED.
C
C LOWER DIAGONAL OF XCPL IS STORED FOR MAIN COUPLING ELEMENTS
C BUT EXCHANGE PART REQUIRES FULL MATRIX (NLEV,NLEV) STORAGE.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE IXEX,ISTART,IFIRST
LOGICAL ODD,LFIRST
INTEGER PRINT
DIMENSION LAM(1),JLEV(NLEV,3),J(1),L(1)
DIMENSION VL(1)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C CONST IS FACTOR (4.*PI)**(-3/2)
DATA CONST/2.24483902656458321D-2/, SQRTHF/.70710678118654753D0/
C STATEMENT FUNCTIONS
ODD(I)=I-2*(I/2).NE.0
Z(I)=DBLE(I+I+1)
C
C INITIALIZE IFIRST IF LFIRST IS SET TRUE
IF (LFIRST) THEN
IFIRST=0
LFIRST=.FALSE.
ENDIF
C
NLSQ=NLEV*NLEV
NL12=NLEV*(NLEV+1)/2
IF (IFIRST.GT.0) GO TO 8030
C
C FIRST TIME THROUGH EVALUATE JTOT-INDEPENDENT PARTS OF VL()
IXMX=NL12*MXLAM
IXEX=IXMX
IF (IEX.GT.0) IXMX=IXEX+NLSQ*MXLAM
NAVAIL=MX-IXNEXT+1
IF (IXMX.LE.NAVAIL) GO TO 3010
WRITE(6,699) NLEV,MXLAM,IEX,IXMX,NAVAIL
699 FORMAT(/' ***** CPL3 (JAN 93) NLEV,MXLAM,IEX =',3I4
1 /' REQUIRED STORAGE MORE THAN AVAILABLE',2I9)
STOP
C UPDATE STORAGE POINTERS. NB WE STORE XPCL BACKWARDS AT TOP OF X()
3010 ISTART=MX+1
MX=MX-IXMX
DO 3100 LL=1,MXLAM
LM1=LAM(3*LL-2)
LM2=LAM(3*LL-1)
LM=LAM(3*LL)
IL12=0
DO 3100 I1=1,NLEV
J1=JLEV(I1,1)
J2=JLEV(I1,2)
J12=JLEV(I1,3)
DO 3100 I2=1,I1
IL12=IL12+1
J1P=JLEV(I2,1)
J2P=JLEV(I2,2)
J12P=JLEV(I2,3)
C INDEX FOR XCPL(IL12,LL,1), I.E., SYMMETRIZED
IX=(LL-1)*NL12+IL12
FACTOR=CONST*Z(LM)*SQRT((Z(LM1)*Z(LM2))*(Z(J1)*Z(J2)*Z(J12))*
1 (Z(J1P)*Z(J2P)*Z(J12P)))
JSUM=J1+J2+J12P
IF (ODD(JSUM)) FACTOR=-FACTOR
X(ISTART-IX)=THREEJ(LM1,J1P,J1)*THREEJ(LM2,J2P,J2)*
1 XNINEJ(J12P,J2P,J1P,J12,J2,J1,LM,LM2,LM1)*FACTOR
IF (IEX.EQ.0) GO TO 3100
C INDEX FOR XCPL(I2,I1,LL,2), I.E., UNSYMMETRIZED
IE=(LL-1)*NLSQ+(I1-1)*NLEV+I2
IF (J1.EQ.J2) THEN
X(ISTART-IXEX-IE)=X(ISTART-IX)
ELSE
X(ISTART-IXEX-IE)=THREEJ(LM1,J1P,J2)*THREEJ(LM2,J2P,J1)*
1 XNINEJ(J12P,J2P,J1P,J12,J1,J2,LM,LM2,LM1)*FACTOR
ENDIF
IF (I1.EQ.I2) GO TO 3100
C ELSE WE NEED TO STORE I1<->I2 VALUES
IE=(LL-1)*NLSQ+(I2-1)*NLEV+I1
IF (J1P.EQ.J2P) THEN
X(ISTART-IXEX-IE)=X(ISTART-IX)
ELSE
X(ISTART-IXEX-IE)=THREEJ(LM1,J2P,J1)*THREEJ(LM2,J1P,J2)*
1 XNINEJ(J12P,J1P,J2P,J12,J2,J1,LM,LM2,LM1)*FACTOR
ENDIF
3100 CONTINUE
IF (PRINT.GT.3) WRITE(6,697) NLEV,MXLAM,IEX,IXMX,NAVAIL
697 FORMAT(/' CPL3 (JAN 93). ',
1 ' JTOT-INDEPENDENT PARTS OF COUPLING MATRIX STORED',
2 '. NLEV, MXLAM, IEX =',3I4/
3 19X,'REQUIRED AND AVAILABLE STORAGE =',2I9)
C RESET IFIRST
IFIRST=1
C
C EVALUATE VL() USING STORED JTOT-INDEPENDENT PARTS
8030 DO 1513 LL=1,MXLAM
NNZ=0
I=LL
LM=LAM(3*LL)
DO 1503 ICOL=1,N
LV=L(ICOL)
I1=J(ICOL)
J1=JLEV(I1,1)
J2=JLEV(I1,2)
J12=JLEV(I1,3)
DO 1503 IROW=1,ICOL
LVP=L(IROW)
I2=J(IROW)
J1P=JLEV(I2,1)
J2P=JLEV(I2,2)
J12P=JLEV(I2,3)
C GET JTOT-DEPENDENT PARTS
XFACT=SQRT(Z(LV)*Z(LVP))*THREEJ(LM,LVP,LV)
1 *SIXJ(LVP,LV,J12P,J12,LM,JTOT)
IF (ODD(JTOT)) XFACT=-XFACT
C GET JTOT-INDEPENDENT PARTS FROM XCPL.
C BELOW IS FOR SYMMETRIZED MAIN PART
IF (I1.GE.I2) THEN
IL12=I1*(I1-1)/2+I2
ELSE
IL12=I2*(I2-1)/2+I1
ENDIF
IX=(LL-1)*NL12+IL12
VL(I)=XFACT*X(ISTART-IX)
IF (IEX.EQ.0) GO TO 1593
C ***
C *** N.B. CODE BELOW ASSUMES THAT SYMMETRICALLY RELATED POTENTIAL TERMS
C *** I.E. A(LM1,LM2,LM) AND A(LM2,LM1,LM) ARE BOTH PRESENT IN POTL.
C ***
C BELOW IS FOR XCPL(I2,I1,LL,IEX) STORAGE ORDER
IE=(LL-1)*NLSQ+(I1-1)*NLEV+I2
IF (J1.NE.J2) GO TO 1594
T=VL(I)
GO TO 1595
1594 T=XFACT*X(ISTART-IXEX-IE)
1595 JSUM=IEX+J1+J2-J12+LV
IF (ODD(JSUM)) T=-T
VL(I)=VL(I)+T
IF (J1.EQ.J2) VL(I)=VL(I)*SQRTHF
IF (J1P.EQ.J2P) VL(I)=VL(I)*SQRTHF
1593 IF (VL(I).NE.0.D0) NNZ=NNZ+1
1503 I=I+MXLAM
IF (NNZ.LE.0.AND.PRINT.GE.4) WRITE(6,612) JTOT, LL
612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING ',
1 'COEFFICIENTS ARE 0.0 FOR SYMMETRY',I4)
1513 CONTINUE
RETURN
END
SUBROUTINE CPL4(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,ATAU,NLEV,
1 PRINT,LFIRST)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE IFIRST,NOMEM,NL12,IXMX,ISTART
C COUPLING MATRIX ELEMENTS FOR ITYPE=4 (CPL4) & ITYPE=24 (CPL24)
C SPECIFICATIONS FOR PARAMETER LIST
INTEGER J(N),L(N),LAM(2),JLEV(2)
INTEGER PRINT
DIMENSION ATAU(2),VL(2)
LOGICAL LFIRST
C
INTEGER P1,Q1,P2,P
LOGICAL ODD,NOMEM
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
COMMON /VLSAVE/ IVLU
C
DATA PI/3.141592653589793D0/
DATA EPS/1.D-8/, Z0/0.D0/
C
C STATEMENT FUNCTIONS ...
F(NN) = DBLE(NN+NN+1)
ODD(I) = I-2*(I/2).NE.0
C
IF (LFIRST) THEN
IFIRST=-1
LFIRST=.FALSE.
NOMEM=.FALSE.
ENDIF
IF (IFIRST.GT.-1) GO TO 5500
IF (NOMEM) GO TO 5900
NL12=NLEV*(NLEV+1)/2
IXMX=NL12*MXLAM
ISTART=MX+1
NAVAIL=ISTART-IXNEXT
IF (IXMX.LE.NAVAIL) GO TO 5100
IF (PRINT.GE.3) WRITE(6,694) IXMX,NAVAIL
694 FORMAT(/' CPL4 (JUL 93). UNABLE TO STORE JTOT-INDEPENDENT PART'
1 /' REQUIRED AND AVAILABLE STORAGE =',2I9)
NOMEM=.TRUE.
GO TO 5900
5100 IX=0
DO 5200 LL=1,MXLAM
P1 = LAM(4*LL-3)
Q1 = LAM(4*LL-2)
P2 = LAM(4*LL-1)
P = LAM(4*LL)
XP1 = P1
XQ1 = Q1
DO 5201 IC=1,NLEV
JC=JLEV(IC)
J1C = JLEV(IC + 2*NLEV)
J2C = JLEV(IC + NLEV)
XJC = JC
XJ1C = J1C
XJ2C = J2C
ISTC = JLEV(IC + 5*NLEV)
NKC = JLEV(IC + 6*NLEV)
DO 5201 IR=1,IC
IX=IX+1
JR=JLEV(IR)
J1R = JLEV(IR + 2*NLEV)
J2R = JLEV(IR + NLEV)
XJR=JR
XJ1R = J1R
XJ2R = J2R
ISTR=JLEV(IR+5*NLEV)
NKR=JLEV(IR+6*NLEV)
XCPL=Z0
KKC=-J1C
DO 5300 KC=1,NKC
C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL.
IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 5300
XKC=KKC
KKR=-J1R
DO 5400 KR=1,NKR
C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL.
IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 5400
XKR=KKR
C AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)*PARITY3(KKR)
AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)
IF (ODD(KKR)) AF=-AF
IF (KKR-KKC.NE.Q1) GO TO 5401
XCPL=XCPL+AF*THRJ(XJ1R,XP1,XJ1C,-XKR,XQ1,XKC)
IF (Q1.EQ.0) GO TO 5400
5401 IF (KKC-KKR.NE.Q1) GO TO 5400
C ADJUST FOR (-1)**MU IN POTENTIAL. . .
AF=AF*PARITY3(P1+Q1+P2+P)
XCPL=XCPL+AF*THRJ(XJ1R,XP1,XJ1C,-XKR,-XQ1,XKC)
5400 KKR=KKR+1
5300 KKC=KKC+1
C NOW GET 'CONSTANT FACTORS'
XFCT=PARITY3(JR-J1C+J2C)
1 *SQRT(F(J2R)*F(J2C)*F(P)*F(P2)*F(JR)*F(JC)*F(J1C)*F(J1R))
2 *THREEJ(J2R,P2,J2C)*XNINEJ(JC,JR,P,J1C,J1R,P1,J2C,J2R,P2)
3 /4.D0/PI
5201 X(ISTART-IX)=XCPL*XFCT
5200 CONTINUE
IF (PRINT.GT.3) WRITE(6,695) IXMX
695 FORMAT(/' CPL4 (JUL 93). JTOT-INDEPENDENT PARTS OF COUPLING',
1 ' MATRIX STORED.'/
2 ' REQUIRED STORAGE =',I8)
C RESET MX, IFIRST TO REFLECT STORED VALUES
MX=MX-IXMX
IFIRST=0
C
C NOW GET COUPLING MATRIX ELEMENTS FROM STORED PARTS
5500 PJT=PARITY3(JTOT)
IF (IVLU.GT.0) REWIND IVLU
DO 5600 LL=1,MXLAM
P1 = LAM(4*LL-3)
Q1 = LAM(4*LL-2)
P2 = LAM(4*LL-1)
P = LAM(4*LL)
C
PPP = PARITY3(P)
IX1=(LL-1)*NL12
NNZ=0
IF (IVLU.EQ.0) THEN
IX=LL
ELSE
IX=1
ENDIF
C
DO 5700 IC=1,N
INJ12P = J(IC)
JC=JLEV(INJ12P)
LC=L(IC)
C
DO 5700 IR=1,IC
INJ12=J(IR)
JR=JLEV(INJ12)
LR=L(IR)
C
XFACT = PJT*PPP*THREEJ(LR,P,LC)*SIXJ(LR,JR,LC,JC,JTOT,P)
1 *SQRT(F(LR)*F(LC))
IF (INJ12.GE.INJ12P) THEN
IX2=INJ12*(INJ12-1)/2+INJ12P
ELSE
IX2=INJ12P*(INJ12P-1)/2+INJ12
ENDIF
INDX=IX1+IX2
C
IF (X(ISTART-INDX).EQ.0.D0) THEN
VL(IX) = 0.D0
ELSE
VL(IX)=XFACT*X(ISTART-INDX)
ENDIF
IF (VL(IX).NE.0.D0) NNZ=NNZ+1
IF (IVLU.EQ.0) THEN
IX=IX+MXLAM
ELSE
IX=IX+1
ENDIF
5700 CONTINUE
IF (NNZ.EQ.0.AND.PRINT.GT.3) WRITE(6,697) P1,Q1,P2,P
IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2)
5600 CONTINUE
RETURN
C
C IF WE CANNOT STORE PARTIAL COUPLING MATRIX, RECALCULATE.
5900 ASSIGN 3001 TO IGO1
ASSIGN 3011 TO IGO2
GO TO 3000
C
ENTRY CPL24(N,MXLAM,LAM,NLEV,JLEV,ATAU,J,MVAL,VL,PRINT,LFIRST)
C
C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION
IF (LFIRST) THEN
IFIRST=-1
LFIRST=.FALSE.
NOMEM=.FALSE.
ENDIF
C
IF (IFIRST.GT.-1) GO TO 4500
C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS
NL12=NLEV*(NLEV+1)/2
IXMX=NL12*MXLAM
ISTART=MX+1
C
4500 MVABS=IABS(MVAL)
C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE
C IF NOT, TRY TO STORE THEM IN XCPL().
IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 4900
MV=IFIRST+1
C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY.
4600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 4610
IF (PRINT.GE.1) WRITE(6,642) MV,ISTART-1,MX,IXMX*(IFIRST+1)
642 FORMAT(/' CPL24 (JUL 93). HIGH MEMORY FRAGMENTED. CANNOT',
1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X,
2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12)
NOMEM=.TRUE.
GO TO 4900
C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL
4610 NAVAIL=MX-IXNEXT+1
IF (IXMX.LE.NAVAIL) GO TO 4601
IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL
692 FORMAT(/' CPL24 (JUL 93). UNABLE TO STORE 3-J VALUES FOR MVAL='
1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9)
C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES
NOMEM=.TRUE.
GO TO 4900
C
C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL
4601 MX=MX-IXMX
C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0)
IX=MV*IXMX
DO 4200 LL=1,MXLAM
P1 = LAM(4*LL-3)
Q1 = LAM(4*LL-2)
P2 = LAM(4*LL-1)
P = LAM(4*LL)
DO 4201 IC=1,NLEV
JC=JLEV(IC)
J1C = JLEV(IC+2*NLEV)
J2C = JLEV(IC+ NLEV)
ISTC=JLEV(IC+5*NLEV)
NKC=JLEV(IC+6*NLEV)
DO 4201 IR=1,IC
JR=JLEV(IR)
J1R = JLEV(IR+2*NLEV)
J2R = JLEV(IR+ NLEV)
ISTR=JLEV(IR+5*NLEV)
NKR=JLEV(IR+6*NLEV)
IX=IX+1
XCPL=Z0
KKC=-J1C
DO 4300 KC=1,NKC
C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL.
IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 4300
KKR=-J1R
DO 4400 KR=1,NKR
C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL.
IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 4400
AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)
IF (KKR-KKC.NE.Q1) GO TO 4401
XCPL=XCPL+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C,
1 JR,JC,MVAL,P1,Q1,P2,P)
IF (Q1.EQ.0) GO TO 4400
4401 IF (KKC-KKR.NE.Q1) GO TO 4400
C ADJUST FOR (-1)**MU IN POTENTIAL. . .
C AF=AF*PARITY3(MU)
IF (ODD(P1+Q1+P2+P)) AF = -AF
XCPL=XCPL+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C,
1 JR,JC,MVAL,P1,-Q1,P2,P)
4400 KKR=KKR+1
4300 KKC=KKC+1
4201 X(ISTART-IX)=XCPL
4200 CONTINUE
IF(PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL
693 FORMAT(/' CPL24 (JUL 93). 3J VALUES STORED FOR MVALUE =',I3,
1 /,' REQUIRED AND AVAILABLE STORAGE =',2I9)
IFIRST = MV
C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES.
MV=MV+1
IF (MV.LE.MVABS) GO TO 4600
C
4900 IF (MVABS.GT.IFIRST) GO TO 4800
C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL
IXM=MVABS*IXMX
IF (IVLU.GT.0) REWIND IVLU
DO 4513 LL=1,MXLAM
P1 = LAM(4*LL-3)
Q1 = LAM(4*LL-2)
P2 = LAM(4*LL-1)
P = LAM(4*LL)
NNZ=0
IF (IVLU.EQ.0) THEN
IX=LL
ELSE
IX=1
ENDIF
DO 4503 ICOL=1,N
I1=J(ICOL)
JC=JLEV(I1)
DO 4503 IROW=1,ICOL
I2=J(IROW)
JR=JLEV(I2)
IF (I1.GT.I2) THEN
IX12=I1*(I1-1)/2+I2
ELSE
IX12=I2*(I2-1)/2+I1
ENDIF
IXX=IXM+(LL-1)*NL12+IX12
VL(IX)=X(ISTART-IXX)
C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY
C FOR PARITY OF THRJ(JR,P ,JC, MVAL,0,-MVAL)
IF (MVAL.LT.0.AND.ODD(JC+JR+P )) VL(IX)=-VL(IX)
IF (VL(IX).NE.Z0) NNZ=NNZ+1
IF (IVLU.EQ.0) THEN
IX=IX+MXLAM
ELSE
IX=IX+1
ENDIF
4503 CONTINUE
IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVAL,LL
612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ',
& 'COEFFICIENTS ARE 0.')
IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2)
4513 CONTINUE
RETURN
C
C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM VIA OLD CODE
4800 ASSIGN 3002 TO IGO1
ASSIGN 3022 TO IGO2
GO TO 3000
C
C -------------------- OLD CODE REJOINS HERE ---------------------
C
3000 IF (IVLU.GT.0) REWIND IVLU
C
C ----- LOOP OVER RADIAL SURFACES -----
C
DO 3100 LL=1,MXLAM
P1 = LAM(4*LL-3)
Q1 = LAM(4*LL-2)
P2 = LAM(4*LL-1)
P = LAM(4*LL)
NNZ=0
IF (IVLU.EQ.0) THEN
IX=LL
ELSE
IX=1
ENDIF
C
DO 3200 IC=1,N
JC = JLEV(J(IC) )
J1C = JLEV(J(IC) + 2*NLEV)
J2C = JLEV(J(IC) + NLEV)
ISTC = JLEV(J(IC) + 5*NLEV)
NKC = JLEV(J(IC) + 6*NLEV)
C
DO 3200 IR=1,IC
JR = JLEV(J(IR) )
J1R = JLEV(J(IR) + 2*NLEV)
J2R = JLEV(J(IR) + NLEV)
ISTR = JLEV(J(IR) + 5*NLEV)
NKR = JLEV(J(IR) + 6*NLEV)
C
VL(IX)=0.D0
KKC=-J1C
C
C ----- LOOP OVER EXPANSION COEFFICIENTS. -----
C ----- SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. -----
C
DO 3300 KC=1,NKC
IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 3300
KKR=-J1R
C
DO 3400 KR=1,NKR
IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 3400
AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)
IF (KKR-KKC.NE.Q1) GO TO 3500
GO TO IGO1,(3001,3002)
3001 VL(IX)=VL(IX)+AF
1 *QSYMTP(J1R,KKR,J1C,KKC,J2R,J2C,L(IR),L(IC),
2 JR,JC,JTOT,P1,Q1,P2,P)
GO TO 3009
3002 VL(IX)=VL(IX)+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C,
1 JR,JC,MVAL,P1,Q1,P2,P)
3009 IF (Q1.EQ.0) GO TO 3400
3500 IF(KKC-KKR.NE.Q1) GO TO 3400
AF = AF*PARITY3(P1+P2+P+Q1)
GO TO IGO2(3011,3022)
3011 VL(IX)=VL(IX)+AF
1 *QSYMTP(J1R,KKR,J1C,KKC,J2R,J2C,L(IR),L(IC),
2 JR,JC,JTOT,P1,-Q1,P2,P)
GO TO 3400
3022 VL(IX)=VL(IX)+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C,
1 JR,JC,MVAL,P1,-Q1,P2,P)
3400 KKR=KKR+1
C
3300 KKC=KKC+1
C
IF (VL(IX).NE.0.D0) NNZ=NNZ+1
IF(IVLU .EQ. 0) THEN
IX = IX + MXLAM
ELSE
IX = IX + 1
ENDIF
3200 CONTINUE
IF (NNZ.EQ.0.AND.PRINT.GT.3) WRITE(6,697) P1,Q1,P2,P
697 FORMAT(' * * * NOTE. ALL COUPLING COEFFICIENTS ARE ZERO FOR P1,
& Q1, P2, P = ', 4I4)
3100 CONTINUE
RETURN
END
SUBROUTINE CPLOUT(IV,V,N,NPOTL)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION IV(1), V(1)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C THIS ROUTINE PRINTS OUT THE COUPLING MATRIX ELEMENTS.
WRITE(6,602) NPOTL
602 FORMAT('0 COUPLING MATRIX ELEMENTS BETWEEN CHANNELS FOR',I4,
1 ' SYMMETRIES.')
IF (IVLFL.GT.0) THEN
IMAX=0
DO 1000 I=1,N
DO 1000 J=1,I
IMIN=IMAX+1
IMAX=IMAX+NPOTL
WRITE(6,600) I,J
600 FORMAT('0 FOR CHANNEL ',I3,' TO CHANNEL',I4)
WRITE(6,601) (IV(IJ),V(IJ),IJ=IMIN,IMAX)
601 FORMAT(' ',7(I3,1X,F12.5))
1000 CONTINUE
ELSE
IMIN=0
DO 2000 I=1,N
DO 2000 J=1,I
WRITE(6,600) I,J
WRITE(6,601) (LL,V(IMIN+LL),LL=1,NPOTL)
2000 IMIN=IMIN+NPOTL
ENDIF
RETURN
END
SUBROUTINE DAPROP(U, Y, N,
& RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU,
& Y14, Y23, ESHIFT, DIAG,
& P, VL, IV, ERED, EINT, CENT, RMLMDA,
& MXLAM, NPOTL, ISTART, NODES)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C ROUTINE TO SOLVE THE CLOSE COUPLED EQUATIONS USING AN
C IMPROVED LOG DERIVATIVE ALGORITHM. THE DIAGONAL OF THE
C COUPLING MATRIX EVALUATED AT THE MIDPOINT OF EACH SECTOR
C IS USED AS A REFERENCE POTENTIAL FOR THE SECTOR.
C
LOGICAL IREAD,IWRITE
DIMENSION U(N,N),Y(N,N),Y14(N),Y23(N),ESHIFT(N),DIAG(N)
DIMENSION P(MXLAM),VL(2),IV(2),EINT(N),CENT(N)
C
NODES=0
ESAVE=ERED
DO 20 I=1,N
ESHIFT(I)=EINT(I)-ERED
EINT(I)=0.D0
20 CONTINUE
ERED=0.D0
C
C THIS VERSION USES A CONSTANT STEP SIZE THROUGHOUT THE
C INTEGRATION RANGE, WITH NSTEPS STEPS BETWEEN RBEGIN AND REND.
C
H=(REND-RBEGIN)/DBLE(2*NSTEPS)
D1=H*H/3.D0
D2=2.D0*D1
D4=-D1/16.D0
HALF=0.5D0*H
C
IF (IREAD) GO TO 60
NSAVE=0
R=RBEGIN
CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
DO 40 J=1,N
DO 40 I=J,N
U(I,J)=D1*U(I,J)
40 CONTINUE
IF (IWRITE) WRITE (ISCRU) DIAG,U
GO TO 80
60 READ (ISCRU) DIAG,U
80 CONTINUE
C
C ISTART=0/1 MEANS THAT INITIAL LOG DERIVATIVE MATRIX ISN'T/IS
C ALREADY IN Y. DEFAULT IS 0.
C
IF(ISTART.EQ.1) GO TO 140
SGN=1.D0
IF(REND.LT.RBEGIN) SGN=-1.D0
DO 120 J=1,N
DO 100 I=J,N
100 Y(I,J)=0.D0
WREF=DIAG(J)+ESHIFT(J)
Y(J,J)=SGN*1.D30
IF(WREF.GT.0.D0) Y(J,J)=SGN*SQRT(WREF)
120 CONTINUE
140 CONTINUE
C
DO 160 J=1,N
DO 160 I=J,N
Y(I,J)=H*Y(I,J)+U(I,J)
160 CONTINUE
C
DO 500 KSTEP=1,NSTEPS
IF (IREAD) GO TO 260
R=R+H
CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
DO 200 J=1,N
DO 200 I=J,N
U(I,J)=D4*U(I,J)
200 CONTINUE
DO 220 I=1,N
U(I,I)=0.125D0
220 CONTINUE
CALL SYMINV(U,N,N,KOUNT)
IF (KOUNT.GT.N) GO TO 900
NSAVE=NSAVE+KOUNT
DO 240 I=1,N
U(I,I)=U(I,I)-8.D0
240 CONTINUE
IF (IWRITE) WRITE (ISCRU) DIAG,U
GO TO 280
260 READ (ISCRU) DIAG,U
280 CONTINUE
C
DO 300 I=1,N
WREF=DIAG(I)+ESHIFT(I)
ARG=HALF*SQRT(ABS(WREF))
IF (WREF.LT.0.D0) THEN
TN=TAN(ARG)
Y14(I)=ARG/TN-ARG*TN
Y23(I)=ARG/TN+ARG*TN
ELSE
C IF (WREF.GT.0.D0) THEN
TH=TANH(ARG)
Y14(I)=ARG/TH+ARG*TH
Y23(I)=ARG/TH-ARG*TH
ENDIF
U(I,I)=U(I,I)+2.D0*Y14(I)
Y14(I)=Y14(I)-D1*DIAG(I)
Y14(I)=MAX(Y14(I),0.D0)
Y(I,I)=Y(I,I)+Y14(I)
300 CONTINUE
C
CALL SYMINV(Y,N,N,KOUNT)
IF (KOUNT.GT.N) GO TO 900
NODES=NODES+KOUNT
DO 320 J=1,N
DO 320 I=J,N
Y(I,J)=U(I,J)-Y23(I)*Y(I,J)*Y23(J)
320 CONTINUE
CALL SYMINV(Y,N,N,KOUNT)
IF (KOUNT.GT.N) GO TO 900
NODES=NODES+KOUNT
C
IF (IREAD) GO TO 360
R=R+H
CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
IF (KSTEP.EQ.NSTEPS) D2=D1
DO 340 J=1,N
DO 340 I=J,N
U(I,J)=D2*U(I,J)
340 CONTINUE
IF (IWRITE) WRITE (ISCRU) U
GO TO 380
360 READ (ISCRU) U
380 CONTINUE
C
DO 400 J=1,N
DO 400 I=J,N
Y(I,J)=U(I,J)-Y23(I)*Y(I,J)*Y23(J)
400 CONTINUE
DO 420 I=1,N
Y(I,I)=Y(I,I)+Y14(I)
420 CONTINUE
500 CONTINUE
C
HI=1.D0/H
DO 520 J=1,N
DO 520 I=J,N
Y(I,J)=HI*Y(I,J)
Y(J,I)=Y(I,J)
520 CONTINUE
C
DO 540 I=1,N
EINT(I)=ESHIFT(I)+ESAVE
540 CONTINUE
ERED=ESAVE
IF(IWRITE) WRITE(ISCRU) NSAVE
IF(IREAD) READ (ISCRU) NSAVE
NODES=NODES-NSAVE
RETURN
C
900 WRITE (6,1000) KSTEP
1000 FORMAT('0***** MATRIX INVERSION ERROR IN DAPROP AT ',
& 'STEP K = ',I6,' RUN HALTED.')
STOP
END
SUBROUTINE DASCAT(N, NSQ, MXLAM, NPOTL,
1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB,
2 P, Y1, Y2, Y3, Y4,
3 ICODE, IPRINT, IC)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C *** ---------------------------------------------------------------
C *** ROUTINE TO PERFORM A SCATTERING CALCULATION USING DAPROP.
C *** ON EXIT SR AND SI CONTAIN THE S MATRIX.
C *** SR IS USED INTERNALLY TO HOLD THE LOG DERIVATIVE MATRIX
C *** IN ORDER TO ECONOMISE ON WORKSPACE.
C *** ---------------------------------------------------------------
C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGIES.
C ***
C DIMENSION STATEMENTS FOR ARGUMENT LIST
DIMENSION U(NSQ),Y1(N),Y2(N),Y3(N),Y4(N)
DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ),
& EINT(N),CENT(N),WVEC(N),L(N),NB(N)
C
COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR,
1 DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA,
2 NOPEN,JKEEP,ISCRU,MAXSTP
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C THE FOLLOWING VARIABLES FROM COMMON/DRIVE/ ARE USED WITH THIS
C PROPAGATOR: STEPS,RMIN,RMAX,ERED,RMLMDA,NOPEN,ISCRU
C
LOGICAL IREAD,IWRITE
C ----------------------------------------------------------------
C SET UP TO USE UNIT (ISCRU)
IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0
IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0
C ---------------------------------------------------------------
C
C CALCULATE WAVEVECTORS AND STEP SIZE
C
WMAX=0.D0
NOPEN=0
DO 20 I=1,N
DIF=ERED-EINT(I)
WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF)
WMAX=MAX(WMAX,WVEC(I))
NB(I)=I
IF (DIF.GT.0.D0) NOPEN=NOPEN+1
20 CONTINUE
IF (NOPEN.EQ.0) RETURN
C
IF (IREAD) GO TO 40
PI=ACOS(-1.D0)
NSTEPS=WMAX*STEPS*(RMAX-RMIN)/PI
RBEGIN=RMIN
REND=RMAX
IF (IWRITE) WRITE (ISCRU) RBEGIN,REND,NSTEPS
GO TO 60
40 READ (ISCRU) RBEGIN,REND,NSTEPS
60 CONTINUE
ISTART=0
C
C PROPAGATE LOG DERIVATIVE MATRIX THROUGH THE SCATTERING REGION
C ---------------------------------------------------------------
IF(N.EQ.1) GOTO 90
CALL DAPROP(U, SR, N,
& RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU,
& Y1, Y2, Y3, Y4,
& P, VL, IV, ERED, EINT, CENT, RMLMDA,
& MXLAM, NPOTL, ISTART, NODES)
C ---------------------------------------------------------------
IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,REND,NSTEPS
1000 FORMAT('0 DAPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ',
& F12.4,' TO ',F12.4,' IN ',I6,' STEPS.')
C
C SORT CHANNELS BY ASYMPTOTIC ENERGY
C
NM1=N-1
DO 80 I=1,NM1
IP1=I+1
DO 80 J=IP1,N
IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 80
IT=NB(I)
NB(I)=NB(J)
NB(J)=IT
80 CONTINUE
GOTO 100
C
C SPECIAL CASE FOR EFFICIENT SINGLE CHANNEL CALCULATIONS
C 1/21/93 CHANGES TO DYNAMIC STORAGE: N.B IT5 FROM STORAG IS
C PASSED AS ARGUMENT IC TO FOLLOW CODING IN EARLIER VERSIONS.
C
90 NPT=NSTEPS+1
ISVMEM=IXNEXT
IT1=IC
IT2=IT1+NPT
IT3=IT2+NPT
IT4=IT3+NPT
IT5=IT4+NPT
IC1=IT5+NPT
ITP=IT3
IC2=ITP+NPT*MXLAM
IXNEXT=MAX0(IC1,IC2)
NUSED=0
CALL CHKSTR(NUSED)
CALL ODPROP(SR, X(IT1), X(IT2), X(IT3), X(IT4), X(IT5),
& RBEGIN, REND, NPT, IREAD, IWRITE, ISCRU,
& X(ITP), VL, IV, ERED, EINT, CENT, RMLMDA,
& MXLAM, NPOTL, ISTART, NODES)
C RESTORE STORAGE POINTER TO RECOVER TEMPORARY STORAGE.
IXNEXT=ISVMEM
C ---------------------------------------------------------------
IF (IPRINT.GE.3) WRITE (6,1010) RBEGIN,REND,NSTEPS
1010 FORMAT('0 ODPROP. LOG DERIVATIVE INTEGRATED FROM ',
& F12.4,' TO ',F12.4,' IN ',I6,' STEPS.')
C
C CALCULATE K AND S MATRICES
C
100 CALL YTOK(NB,WVEC,L,N,NOPEN,Y1,Y2,Y3,Y4,SR,SI,U,REND)
CALL KTOS(U,SR,SI,NOPEN)
RETURN
END
SUBROUTINE DASIZE(ILSU,MXREC)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE MXUSED,IX
PARAMETER (NREC=20000)
DIMENSION IX(6,NREC)
DIMENSION IR2(2),IS2(2)
EQUIVALENCE (R,IR1,IR2(1)),(S,IS1,IS2(1))
COMMON /ASSVAR/IDA
C
C DYNAMIC STORAGE COMMON BLOCK ...
C NEEDED FOR NIPR; PREVIOUSLY PASSED IN COMMON /INTPAC/
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DATA MAX/NREC/
C
MXREC=MAX
ILSU=999
WRITE(6,601) MAX
601 FORMAT( ' *** *** NUMBER OF SIMULATED RECORDS =',I7)
RETURN
C
ENTRY DAOPEN
MXUSED=0
WRITE(6,600)
600 FORMAT(/' *** *** IN-CORE DA SIMULATION ROUTINE HAS CONTROL.',
1 /' *** *** DA FILE WILL NOT BE USED.')
C
IF(NIPR.EQ.1 .OR. NIPR.EQ.2) GOTO 1000
WRITE(6,602) NIPR
602 FORMAT(' *** ERROR IN DASIZE/DAOPEN: NIPR =',I3,' INVALID')
STOP
1000 RETURN
C
ENTRY DARD1(I1,I2,I3,I4,I5,I6)
I1=IX(1,IDA)
I2=IX(2,IDA)
I3=IX(3,IDA)
I4=IX(4,IDA)
I5=IX(5,IDA)
I6=IX(6,IDA)
RETURN
C
ENTRY DAWR1(I1,I2,I3,I4,I5,I6)
MXUSED=MAX0(MXUSED,IDA)
IX(1,IDA)=I1
IX(2,IDA)=I2
IX(3,IDA)=I3
IX(4,IDA)=I4
IX(5,IDA)=I5
IX(6,IDA)=I6
RETURN
C
ENTRY DARD2(I1,I2,X1,X2)
I1=IX(1,IDA)
I2=IX(2,IDA)
IF(NIPR.EQ.1) THEN
IR1=IX(3,IDA)
IS1=IX(4,IDA)
ELSE
IR2(1)=IX(3,IDA)
IR2(2)=IX(4,IDA)
IS2(1)=IX(5,IDA)
IS2(2)=IX(6,IDA)
ENDIF
X1=R
X2=S
RETURN
C
ENTRY DAWR2(I1,I2,X1,X2)
MXUSED=MAX0(MXUSED,IDA)
IX(1,IDA)=I1
IX(2,IDA)=I2
R=X1
S=X2
IF(NIPR.EQ.1) THEN
IX(3,IDA)=IR1
IX(4,IDA)=IS1
ELSE
IX(3,IDA)=IR2(1)
IX(4,IDA)=IR2(2)
IX(5,IDA)=IS2(1)
IX(6,IDA)=IS2(2)
ENDIF
RETURN
C
ENTRY DACLOS
WRITE(6,610) MXUSED,MAX
610 FORMAT(/' *** IN-CORE DA SIMULATOR USED',I10,' OF THE',I10,
1 ' ALLOCATED RECORDS')
RETURN
END
SUBROUTINE DELRD(DR,CDIAG,COFF,TOL,DRMAX,E1,EN,RNOW,RMAX)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C-------------------------------------------------------------------
C THIS ROUTINE IS MODIFIED VERSION OF ROY GORDON'S QCPE PROGRAM.
C THIS VERSION FOR SCATTERING CALCULATION
C-------------------------------------------------------------------
C ADJUST THE STEP SIZE TO TRY TO KEEP MAX(CDIAG,COFF) = TOL
RTOL = 0.80D0*TOL
C-------------------------------------------------------------------
C FIND CORRECTION FACTOR FROM DIAGONAL PERTURBATIONS
C-------------------------------------------------------------------
IF (CDIAG .NE. 0.D0) GO TO 100
C-------------------------------------------------------------------
C CASE IN WHICH DIAGONAL PERTURBATIONS VANISH
C-------------------------------------------------------------------
DFACT = 2.5D0
GO TO 110
C-------------------------------------------------------------------
C DIAGONAL PERTURBATIONS VARY ROUGHLY AS THE FIFTH POWER OF STEP SIZE
C-------------------------------------------------------------------
100 DFACT = (RTOL/CDIAG)**0.333D0
C-------------------------------------------------------------------
C FIND CORRECTION FACTOR FROM OFF-DIAGONAL PERTURBATIONS
C-------------------------------------------------------------------
110 IF (COFF .NE. 0.D0) GO TO 120
C-------------------------------------------------------------------
C CASE IN WHICH OFF-DIAGONAL PERTURBATIONS VANISH
C-------------------------------------------------------------------
OFACT = 2.5D0
GO TO 130
C-------------------------------------------------------------------
C OFF-DIAGONAL PERTURBATIONS VARY ROUGHLY AS CUBE OF STEP SIZE
C-------------------------------------------------------------------
120 OFACT = (RTOL/COFF)**0.333D0
C-------------------------------------------------------------------
C FIND MINIMUM FACTOR
C-------------------------------------------------------------------
130 FACTOR = MIN(DFACT,OFACT)
IF (EN .GT. 0.D0) GO TO 150
IF (E1 .GT. 0.D0) GO TO 140
C-------------------------------------------------------------------
C THIS IS REACHED ONLY WHEN ALL CHANNELS ARE IN THEIR CLASSICALLY
C FORBIDDEN REGIONS. THEN ACCURACY IS QUITE SENSITIVE TO CHANGES
C IN STEP SIZE.
C HENCE IN THIS REGION MAKE ONLY CAUTIOUS CHANGES IN STEP SIZE
C-------------------------------------------------------------------
IF (FACTOR .GT. 1.15D0) FACTOR = 1.15D0
GO TO 170
C-------------------------------------------------------------------
C THIS IS REACHED WHEN SOME CHANNELS ARE CLASSICAL AND OTHERS NOT
C-------------------------------------------------------------------
140 IF (FACTOR .GT. 1.20D0) FACTOR = 1.20D0
GO TO 170
C-------------------------------------------------------------------
C THIS IS REACHED WHEN ALL CHANNELS ARE CLASSICAL.
C THEN THE STEP SIZE IS OFTEN INCREASING RAPIDLY, AND ALSO THE
C ACCURACY VARIES MORE SLOWLY WITH STEP SIZE.
C THUS WE MAKE BOLDER INCREASES IN THE STEP SIZE, TO KEEP THE
C CORRECTIONS OF THE SAME ORDER OF MAGNITUDE AS BEFORE
C TEST TO SEE HOW FAR WE HAVE INTEGRATED
C-------------------------------------------------------------------
150 IF (RNOW .GT. (0.10D0*RMAX)) GO TO 160
IF (FACTOR .GT. 1.6D0) FACTOR = 1.6D0
GO TO 170
C-------------------------------------------------------------------
C CHOOSE FACTOR IN FAR AYSMPTOTIC REGION
C-------------------------------------------------------------------
160 IF (FACTOR .GT. 2.5D0) FACTOR = 2.5D0
C-------------------------------------------------------------------
C SET NEW STEP SIZE
C-------------------------------------------------------------------
170 DR = DR*FACTOR
C-------------------------------------------------------------------
C CHECK AGAINST DRMAX AND EXCESSIVE GROWTH OF CLOSED CHANNELS
C-------------------------------------------------------------------
IF (EN .GE. 0.D0) GO TO 175
DREXP = 4.D0/SQRT(-EN)
IF (DR .GT. DREXP) DR = DREXP
175 IF (DR .GT. DRMAX) DR = DRMAX
IF (DR .LT. 1.0D-06*DRMAX) GO TO 180
RETURN
180 WRITE (6,1000) DR,CDIAG,COFF,TOL,DRMAX,E1,EN,RNOW,RMAX
STOP
C-------------------------------------------------------------------
C FORMATS
C-------------------------------------------------------------------
1000 FORMAT('0 * * * ERROR IN DELRD. STEP SIZE =',E20.6,
1 ' IS TOO SMALL'/'0',24X,'PARAMETERS PASSED ARE',
2 ' CDIAG, COFF, TOL, DRMAX, E1, EN, RNOW, RMAX'/
4 25X,9(E10.3,1X))
C----------------***END-DELRD***------------------------------------
END
SUBROUTINE DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,
1 MXLAM,NPOTL,NUMDER)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE RSAVE
LOGICAL NUMDER
C
C EVALUATES THE IDER'TH DERIVATIVE OF THE POTENTIAL MATRIX AT RADIUS
C W = VCOUPL + VCENT
C ORDER OF THE REAL SYMMETRIC MATRIX W IS N
C THE FULL MATRIX IS COMPUTED
C VL IS THE PREVIOUSLY COMPUTED MATRIX OF THE COUPLING POTENTIAL
C IV IS AN INDEX ARRAY MAPPING P ONTO VL, SUCH THAT VL(I) IS
C A COEFFICIENT TO MULTIPLY P(IV(I))
C CENT(I) IS L*(L+1) FOR THE I-TH CHANNEL
C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO THE DEBROGLIE
C WAVELENGTH AT RELATIVE ENERGY EPSILON
C RMLMDA = 2.*URED*RM**2*EPSIL/HBAR**2
C RMLMDA MULTIPLIES THE POTENTIAL IN UNITS OF EPSIL
C
DIMENSION W(N,N),VL(1),IV(1),CENT(N),P(MXLAM)
DATA DEL/1.D-3/, RSAVE/-999.D0/
C
IF(NUMDER) GOTO 5
C
C COMPUTE THE RADIAL PARTS OF THE POTENTIAL ANALYTICALLY
CALL POTENL(IDER,MXLAM,NPOTL,IDUM1,R,P,IDUM2)
C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE.
GOTO 14
C
C NUMERICAL DERIVATIVE OPTION.
C NOTE THAT IF IDER = 2 THIS ASSUMES THAT
C THE POTENTIAL ITSELF IS ALREADY IS ALREADY IN THE FIRST
C MXLAM ELEMENTS OF P. THIS IS NOT TRUE IF DERMAT HAS BEEN
C CALLED MORE RECENTLY THAN WAVMAT, SO THE IDER = 2 CALL
C MUST PRECEDE THE IDER = 1 CALL.
C
C FIRST SEE WHETHER DERMAT HAS BEEN CALLED BEFORE FOR THIS
C VALUE OF R, AND IF SO SKIP POTENTIAL EVALUATIONS
C
5 IF(R.EQ.RSAVE) GOTO 8
RSAVE=R
RR=R-DEL
CALL POTENL(0,MXLAM,NPOTL,IDUM1,RR,P(MXLAM+1),IDUM2)
RR=R+DEL
CALL POTENL(0,MXLAM,NPOTL,IDUM1,RR,P(2*MXLAM+1),IDUM2)
C
8 DO 10 I=1,MXLAM
P1=P(MXLAM+I)
P2=P(2*MXLAM+I)
IF(IDER.EQ.1) P(I) = (P2-P1)/(2.D0*DEL)
10 IF(IDER.EQ.2) P(I) = (P2+P1-2.D0*P(I)/RMLMDA)/(DEL*DEL)
C
14 DO 15 I=1,MXLAM
15 P(I)=RMLMDA*P(I)
C
CALL WAVVEC(VL,P,IV,W,N,NPOTL)
C
C NOW COMPUTE THE DIAGONAL CONTRIBUTIONS W(I,I).
C
IF(IDER.EQ.1) RSQ=-2.D0/R**3
IF(IDER.EQ.2) RSQ= 6.D0/R**4
DO 20 I=1,N
W(I,I) = W(I,I) + RSQ*CENT(I)
20 CONTINUE
RETURN
END
SUBROUTINE DGEMUL(A,LDA,TRANSA,B,LDB,TRANSB,C,LDC,L,M,N)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER*1 TRANSA,TRANSB
CALL DGEMM(TRANSA,TRANSB,L,N,M,1.D0,A,LDA,B,LDB,0.D0,C,LDC)
RETURN
END
SUBROUTINE DMSYM(J,NK,EVAL,EVEC,EVEC2,WKS)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE SYMPRT
PARAMETER (IDMAX=3)
LOGICAL SYMPRT
CHARACTER*1 CSUB,REPNAM(3)
DIMENSION SMAT(IDMAX,IDMAX),SVEC(IDMAX,IDMAX),SIG(IDMAX)
DIMENSION EVAL(NK),EVEC(-J:J,NK),EVEC2(-J:J,NK),WKS(NK)
DATA SYMPRT/.FALSE./
DATA REPNAM/'A','E','F'/
DATA TOL/1.D-8/
C
C THE MATRIX DIAGONALISATION MAY RETURN EIGENVECTORS THAT ARE
C AWKWARD LINEAR COMBINATIONS OF DEGENERATE PAIRS/SETS.
C THIS ROUTINE FINDS SYMMETRISED COMBINATIONS
C THAT ARE EITHER EVEN OR ODD WITH RESPECT TO K -> -K
C BY CONSTRUCTING AND DIAGONALISING THE MATRIX REPRESENTATION
C OF SIGMA(XZ) FOR EACH DEGENERATE SET.
C
IMAX=0
DO 1000 IC=1,NK
IF(IC.LE.IMAX) GOTO 1000
C
C LOOK FOR DEGENERATE EIGENVECTORS
C
DO 200 JC=IC,NK
IF(ABS(EVAL(JC)-EVAL(IC)).GT.TOL) GOTO 200
IMAX=JC
200 CONTINUE
C
IDEG=1+IMAX-IC
IF(IDEG.GT.IDMAX) GOTO 1100
IF(IDEG.EQ.1) GOTO 920
IF(IDEG.GE.3) SYMPRT=.TRUE.
C
C NOW CONSTRUCT THE MATRIX REPRESENTATION
C
DO 400 L=1,IDEG
LC=IC+L-1
DO 400 M=1,IDEG
MC=IC+M-1
SMAT(M,L)=0.D0
DO 400 K=-J,J
SMAT(M,L)=SMAT(M,L)+EVEC(K,MC)*EVEC(-K,LC)
400 CONTINUE
C
IFAIL=0
CALL F02ABF(SMAT,IDMAX,IDEG,SIG,SVEC,IDMAX,WKS,IFAIL)
C
C COPY OLD EIGENVECTORS INTO SIG AND CONSTRUCT NEW ONES
C
DO 500 L=1,IDEG
LC=IC+L-1
DO 500 K=-J,J
EVEC2(K,L)=EVEC(K,LC)
500 CONTINUE
C
DO 600 L=1,IDEG
LC=IC+L-1
DO 600 K=-J,J
EVEC(K,LC)=0.D0
DO 600 M=1,IDEG
EVEC(K,LC)=EVEC(K,LC)+SVEC(M,L)*EVEC2(K,M)
600 CONTINUE
C
C THERE IS STILL A POSSIBILITY THAT EVEN AND ODD K ARE MIXED,
C BUT ONLY FOR TWO ADJACENT EIGENVECTORS. CHECK FOR THIS
C AND FIX IT IF IT IS FOUND
C
DO 900 L=1,IDEG-1
LC=IC+L-1
DO 700 K=-J,J-1
IF(ABS(EVEC(K,LC)*EVEC(K+1,LC)).LT.TOL) GOTO 700
THETA=ATAN2(EVEC(K,LC),EVEC(K,LC+1))
CO=COS(THETA)
SI=SIN(THETA)
GOTO 800
700 CONTINUE
GOTO 900
800 CONTINUE
C
C ARRIVE HERE IF THERE IS MIXING
C
DO 850 K=-J,J
TEMP =CO*EVEC(K,LC)-SI*EVEC(K,LC+1)
EVEC(K,LC)=SI*EVEC(K,LC)+CO*EVEC(K,LC+1)
EVEC(K,LC+1)=TEMP
850 CONTINUE
900 CONTINUE
C
C SPECIAL CODE TO WORK OUT SYMMETRY LABEL FOR SPHERICAL TOP
C
920 IF(.NOT.SYMPRT) GOTO 1000
CSUB=' '
IF(IDEG.EQ.2) GOTO 950
CSUB='1'
IF(J.LT.2) GOTO 950
DO 940 L=1,IDEG
LC=IC+L-1
IF(EVEC(2,LC)**2.GT.TOL) CSUB='2'
940 CONTINUE
C
950 WRITE(6,601) EVAL(LC),REPNAM(IDEG),CSUB
601 FORMAT(' ENERGY LEVEL AT',F12.5,' HAS SYMMETRY ',2A1)
C
1000 CONTINUE
RETURN
C
1100 WRITE(6,699) IDEG,IDMAX
STOP
699 FORMAT('0*** ERROR IN DMSYM: DEGENERACY',I3,' IS TOO LARGE ',
1 'FOR DIMENSION IDMAX =',I3)
END
SUBROUTINE DSYFIL(UPLO, N, A, LDA)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER*1 UPLO
DIMENSION A(LDA,N)
C
C SUBROUTINE TO FILL IN THE SECOND TRIANGLE OF A SYMMETRIC MATRIX.
C IF UPLO='L', THE LOWER TRIANGLE IS FILLED IN
C IF UPLO='U', THE UPPER TRIANGLE IS FILLED IN
C
IF(UPLO.EQ.'L') THEN
DO 10 J=1,N-1
10 CALL DCOPY(N-J,A(J,J+1),LDA,A(J+1,J),1)
ELSEIF(UPLO.EQ.'U') THEN
DO 20 J=1,N-1
20 CALL DCOPY(N-J,A(J+1,J),1,A(J,J+1),LDA)
ENDIF
C
RETURN
END
SUBROUTINE DVFREE(UJ,UJP,UN,UNP,WRONS,L,N,WV,R,NB)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C DOUBLE PRECISION ASYMPTOTIC FUNCTIONS FOR MATCHING TO S-MATRIX.
DIMENSION UJ(N),UJP(N),UN(N),UNP(N),WRONS(N),WV(N)
DIMENSION L(N),NB(N)
DO 3000 I=1,N
NX=NB(I)
DW=WV(NX)
DARG=DW*R
CALL RBES(L(NX),DARG,UJ(NX),UJP(NX),UN(NX),UNP(NX))
UJP(NX)=UJP(NX)*DW
UNP(NX)=UNP(NX)*DW
3000 WRONS(NX)=(UJ(NX)*UNP(NX)-UJP(NX)*UN(NX))/SQRT(DW)
RETURN
END
SUBROUTINE DVSCAT(N,NSQ,MXLAM,NPOTL,
1 SR,SI,A,VL,IV,EINT,CENT,WV,L,NB,
2 P,Y,YP,F,XM,YM,DIAG,ESHIFT,ICODE,PRINT)
C
C DEVOGELAERE INTEGRATION (DOUBLE PRECISION)
C INCLUDING START ROUTINE, SUPPRESSION OF CLOSED-CHANNEL GROWTH
C AND S-MATRIX DETERMINATION IN ASYMPTOTIC LIMIT.
C FOLLOWS OUTLINE OF PAUL MCGUIRE'S PROGRAM.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
LOGICAL IREAD,IWRITE,END
INTEGER L(N),NB(N),IV(1)
INTEGER PRINT
DIMENSION Y(NSQ,4),YP(NSQ,2),F(NSQ,4),A(NSQ),XM(NSQ),YM(NSQ),
1 DIAG(N),P(MXLAM),SR(NSQ),SI(NSQ),VL(2),EINT(N),CENT(N),WV(N)
DIMENSION R(4)
C
C INDICES ON Y, YP, F ARE (ITH SOLN. COMP, NTH SOLN, KTH R-VALUE)
C
C COMMON FROM DRIVER
COMMON/DRIVE/STEST,STEPS,STAB,CONV,RMIN,RMAX,DUMMY(8),
1 ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP
C
C STEPS IS NO. OF STEPS PER (SHORTEST) WAVELENGTH.
C STAB IS NUMBER OF STEPS TAKEN BEFORE STABILIZATION.
C
C MAX. NUMBER OF TRIALS TO CONVERGE S-MATRIX IN ASYMPTOTIC REGION.
DATA MXSTRY/20/
C
IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0
IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0
IF(IREAD .AND. PRINT.GE.5) WRITE(6,668)
668 FORMAT('0 DEVOGELAERE PROPAGATION WILL USE STORED INITIAL R,',
1 ' STEP SIZE AND POTENTIAL MATRICES')
C
C ZERO STORAGE . . .
C
NP1=N+1
DO 800 IJ=1,NSQ
SR(IJ)=0.D0
800 SI(IJ)=0.D0
DO 900 I=1,2
DO 900 IJ=1,NSQ
900 YP(IJ,I)=0.D0
DO 1000 I=1,4
DO 1000 IJ=1,NSQ
Y(IJ,I)=0.D0
1000 F(IJ,I)=0.D0
C
NSTRY=0
RMSAVE=RMAX
C
C ********** START INTEGRATION **********
CALL DVSTRT(RMIN,STEPS,ERED,RMLMDA,N,MXLAM,NPOTL,NOPEN,PRINT,
& A,DIAG,P,VL,IV,EINT,CENT,NB,WV,Y(1,2),YP(1,1),HH,
& ISCRU,IREAD,IWRITE)
IF (NOPEN.LE.0) GOTO 9000
NSTAB=STAB
NSTAB=MAX0(NSTAB,1)
H2=HH/2.D0
R(2)=RMIN
NSTEP=1
C GET F(,,2) FROM Y(,,2)
R4=R(2)
IF(.NOT.IREAD) GOTO 1200
READ(ISCRU) A
DO 1100 IJ=1,NSQ,NP1
1100 A(IJ)=A(IJ)-ESHIFT
GOTO 1300
1200 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
IF(IWRITE) WRITE(ISCRU) A
1300 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,2),N,0.D0,F(1,2),N)
CALL DAXPY(NSQ,1.D0,F(1,2),1,Y(1,2),1)
CALL DAXPY(NSQ,-H2,YP(1,1),1,Y(1,1),1)
CALL DAXPY(NSQ,0.5D0*H2*H2,F(1,2),1,Y(1,1),1)
C GET F(,,1) FROM THIS Y(,,1). NEEDS POTENTIAL AT R(1)
R(1)=R(2)-H2
R4=R(1)
IF(.NOT.IREAD) GOTO 1800
READ(ISCRU) A
DO 1700 IJ=1,NSQ,NP1
1700 A(IJ)=A(IJ)-ESHIFT
GOTO 1900
1800 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
IF(IWRITE) WRITE(ISCRU) A
1900 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,1),N,0.D0,F(1,1),N)
C
C ********** MAIN BODY OF ITERATION **********
C PROPAGATE FROM (-1/2) AND (0) TO (1/2) AND (1).
2000 CONTINUE
CALL DAXPY(NSQ,1.D0,Y(1,2),1,Y(1,3),1)
CALL DAXPY(NSQ,H2,YP(1,1),1,Y(1,3),1)
CALL DAXPY(NSQ,H2*H2*4.D0/6.D0,F(1,2),1,Y(1,3),1)
CALL DAXPY(NSQ,-H2*H2/6.D0,F(1,1),1,Y(1,3),1)
R(3)=R(2)+H2
R4=R(3)
IF(.NOT.IREAD) GOTO 2200
READ(ISCRU) A
DO 2100 IJ=1,NSQ,NP1
2100 A(IJ)=A(IJ)-ESHIFT
GOTO 2300
2200 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
2300 IF(IWRITE) WRITE(ISCRU) A
CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,3),N,0.D0,F(1,3),N)
CALL DAXPY(NSQ,1.D0,Y(1,2),1,Y(1,4),1)
CALL DAXPY(NSQ,HH,YP(1,1),1,Y(1,4),1)
CALL DAXPY(NSQ,HH*HH/6.D0,F(1,2),1,Y(1,4),1)
CALL DAXPY(NSQ,HH*HH/3.D0,F(1,3),1,Y(1,4),1)
R(4)=R(3)+H2
R4=R(4)
IF(.NOT.IREAD) GOTO 2700
READ(ISCRU) A
DO 2600 IJ=1,NSQ,NP1
2600 A(IJ)=A(IJ)-ESHIFT
GOTO 2800
2700 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
IF(IWRITE) WRITE(ISCRU) A
2800 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,4),N,0.D0,F(1,4),N)
CALL DAXPY(NSQ,1.D0,YP(1,1),1,YP(1,2),1)
CALL DAXPY(NSQ,HH/6.D0,F(1,2),1,YP(1,2),1)
CALL DAXPY(NSQ,HH/6.D0,F(1,4),1,YP(1,2),1)
CALL DAXPY(NSQ,HH*4.D0/6.D0,F(1,3),1,YP(1,2),1)
NSTEP=NSTEP+1
C
C ********** THIS ENDS DEVOGELAERE CYCLE **********
C
NOPLOC=0
DO 2900 I=1,NSQ,NP1
2900 IF(A(I).LT.0.D0) NOPLOC=NOPLOC+1
C
END=R4.GT.RMAX .AND. NOPLOC.GE.NOPEN
IF(IREAD) READ(ISCRU) END
IF(END) GOTO 3000
C
C ********** STABILIZATION EVERY NSTAB STEPS **********
4000 IF(NSTEP-NSTAB*(NSTEP/NSTAB).NE.0) GOTO 5000
IF (PRINT.GT.12) WRITE(6,673) R(4)
673 FORMAT(' STABILIZATION DONE AT R =',E12.4)
C FIRST 2 COLS OF Y AND F AND ALSO A USED AS SCRATCH IN STABIL.
CALL STABIL(N,NB,Y(1,4),YP(1,2),F(1,3),F(1,4),
& A,Y(1,1),Y(1,2),F(1,1),F(1,2))
C
C ********** RE-INITIALIZE FOR NEXT CYCLE OF INTEGRATION *********
5000 R(1)=R(3)
R(2)=R(4)
IF(IWRITE) WRITE(ISCRU) IREAD
CALL DCOPY(NSQ,YP(1,2),1,YP(1,1),1)
CALL DCOPY(NSQ,Y(1,3),1,Y(1,1),1)
CALL DCOPY(NSQ,Y(1,4),1,Y(1,2),1)
CALL DCOPY(NSQ,F(1,3),1,F(1,1),1)
CALL DCOPY(NSQ,F(1,4),1,F(1,2),1)
DO 5200 IJ=1,NSQ
YP(IJ,2)=0.D0
Y(IJ,3)=0.D0
5200 Y(IJ,4)=0.D0
GOTO 2000
C
3000 CONTINUE
IF ((PRINT.GE.2.AND.NSTRY.LE.0) .OR. PRINT.GE.12)
& WRITE(6,601) NSTEP,R(4)
601 FORMAT(' INTEGRATION REACHED ASYMPTOTIC LIMIT IN',
& I5,' STEPS. R =',D12.4)
C
C ********** ASYMPTOTIC REGION - CALCULATE S-MATRIX **********
NOPSQ=NOPEN*NOPEN
C USE FIRST 2 COLS OF Y AND F FOR REGULAR AND IRREGULAR BESSEL FNS.
C AND DERIVATIVES - UJ, UJP, UN, AND UNP.
C USE FIRST COL. OF A FOR WRONSKIAN/SQRT(WV).
CALL DVFREE(Y(1,1),Y(1,2),F(1,1),F(1,2),A,L,NOPEN,WV,R(4),NB)
C FORM TRANSPOSE OF X- AND Y- MATRICES
DO 3200 J=1,NOPEN
IJ=J
DO 3100 I=1,NOPEN
NX=NB(I)
NY=NX+N*(J-1)
XM(IJ)=(F(NX,2)*Y(NY,4)-F(NX,1)*YP(NY,2)) / A(NX)
YM(IJ)=(Y(NX,2)*Y(NY,4)-Y(NX,1)*YP(NY,2)) / A(NX)
3100 IJ=IJ+NOPEN
3200 CONTINUE
C GET K-MATRIX FROM SOLN TO LINEAR EQNS,REPLACES RHS
DO 3300 I=1,NOPSQ
3300 A(I)=YM(I)
CALL DGESV(NOPEN,NOPEN,XM,NOPEN,Y,A,NOPEN,IER)
IF (IER.EQ.0) GOTO 3400
WRITE(6,688)
688 FORMAT('0 * * * WARNING. LOSS OF ACCURACY IN SOLVING FOR K.')
CALL OUTERR(11)
C
C FORCE SYMMETRY ON K-MATRIX AND CALCULATE S MATRIX
C
3400 CALL RSYM(NOPEN, A, STEST, PRINT)
CALL KTOS(A,XM,YM,NOPEN)
C
C TEST FOR CONVERGENCE OF SR, SI
C
TEST=0.D0
DO 3500 I=1,NOPSQ
TEST=MAX(TEST,ABS(SR(I)-XM(I)),ABS(SI(I)-YM(I)))
SR(I)=XM(I)
3500 SI(I)=YM(I)
C
IF(IREAD) GOTO 9000
IF(TEST.GT.STEST) GOTO 3600
IF(PRINT.GE.2) WRITE(6,686) NSTRY,R(4),TEST
686 FORMAT(' S-MATRIX CONVERGED AFTER',I3,' TRIES IN ',
& 'ASYMPTOTIC REGION. R =',D12.4,'. TEST =',E12.4)
GOTO 9000
3600 IF(NSTRY.GT.0 .AND. PRINT.GE.2) WRITE(6,687) NSTRY,R(4),TEST
687 FORMAT(' S-MATRIX NOT CONVERGED AFTER',I3,
& ' TRIES. R =',D12.4,'. LARGEST CHANGE =',D12.4)
IF (NSTRY.LT.MXSTRY) GOTO 3700
C SET 'CONV' FLAG FOR OUTPUT ROUTINE. . .
CONV=-1.D0
GOTO 9000
3700 NSTRY=NSTRY+1
RMAX=RMAX+STEPS*HH
GOTO 5000
C
C COMMON RETURN POINT
C RESTORE RMAX
9000 RMAX=RMSAVE
IF(IWRITE) WRITE(ISCRU) IWRITE
RETURN
END
SUBROUTINE DVSTRT(R,STEPS,ERED,RMLMDA,N,MXLAM,NPOTL,NOPEN,PRINT,
& W,DIAG,P,VL,IV,EINT,CENT,NB,WV,U,UP,HH,ISCRU,IREAD,IWRITE)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
INTEGER PRINT
LOGICAL SURF,IREAD,IWRITE
DIMENSION W(N,N),DIAG(N),P(2),VL(2),IV(1),EINT(N),CENT(N),NB(N),
& WV(N),U(N,N),UP(N,N)
C
C PROVIDE STARTING SOLUTION AND DERIVATIVE FOR DEVOGELAERE.
C ALSO PICK STEP SIZE, HH.
C STEPS IS NO. OF STEPS PER (SHORTEST) WAVELENGTH.
C THIS IS SIMPLEST VERSION, SIMILAR TO THAT OF MCGUIRE.
C
RSAVE=R
SURF=R.LT.0.D0
DRMIN=ABS(R/STEPS)
C
C * * * * * ORDER BASIS FUNCTIONS ON INCREASING INTERNAL ENERGY.
DO 3000 I=1,N
3000 NB(I)=I
IF (N.LE.1) GO TO 1000
NM1=N-1
DO 3100 I=1,NM1
IP1=I+1
DO 3100 J=IP1,N
IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 3100
IT=NB(I)
NB(I)=NB(J)
NB(J)=IT
3100 CONTINUE
C
C * * * * * SEE THAT ALL CHANNELS (IN FREE BASIS) ARE CLOSED.
IF(IREAD) GOTO 2000
1000 CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
IF(PRINT.GT.12) WRITE(6,698) R,(P(I),I=1,MXLAM)
698 FORMAT('0 POTENTIAL ARRAY AT R =',F10.4/(10(1X,D12.5)))
DO 1100 I=1,N
IF (PRINT.GT.12) WRITE(6,699) I,W(I,I)
699 FORMAT(' FOR CHANNEL',I4, ' V(RMIN) - E =',D13.4)
IF (W(I,I).GT.0.D0) GO TO 1100
R=R-DRMIN
IF(SURF .OR. R.GT.0.D0) GO TO 1000
WRITE(6,600)
600 FORMAT('0 * * * ERROR. RMIN LESS THAN ZERO IN DVSTRT.',
1 ' POTENTIAL MAY BE UNPHYSICAL')
STOP
1100 CONTINUE
C
IF(R.NE.RSAVE) WRITE(6,602)RSAVE,R
602 FORMAT('0 * * * WARNING. DVSTRT HAS CHANGED RMIN FROM ',F6.2,
& ' TO ',F6.2,' TO ENSURE THAT ALL CHANNELS ARE LOCALLY CLOSED')
C
C * * * * * INITIALIZE U, UP.
2000 DO 4000 I=1,N
DO 4000 J=1,N
U(I,J)=0.D0
UP(I,J)=0.D0
IF (I.EQ.NB(J)) UP(I,J)=1.D-8
4000 CONTINUE
C * * * * * INITIALIZE NOPEN, WV. PICK STEP SIZE.
NOPEN=0
BIG=0.D0
DO 5000 I=1,N
DIF=ERED-EINT(I)
IF (DIF.LE.0.D0) GO TO 5100
NOPEN=NOPEN+1
5100 WV(I)=SIGN(SQRT(ABS(DIF)),DIF)
5000 BIG=MAX(BIG,WV(I))
IF (NOPEN.LE.0) RETURN
C CALCULATE STEP SIZE FROM LARGEST WVEC.
HH=3.1416D0/(BIG*STEPS)
IF(IWRITE) WRITE(ISCRU) R,HH
IF(IREAD) READ(ISCRU) R,HH
IF (PRINT.GE.2) WRITE(6,601) R,HH
601 FORMAT('0 INTEGRATION STARTED AT RMIN =',D12.4,
& '. STEP SIZE =',D12.4)
RETURN
END
SUBROUTINE EAVG(NT,T,NGP,E,NNRG,MXNRG)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION E(1),T(1)
DIMENSION A(20),W(20)
C THIS ROUTINE SETS UP ENERGIES FOR NGP-POINT GAUSS-LAGUERRE INTEG.
C AT SPECIFIED TEMPERATURES (DEG. KELVIN).
DATA XK/.6950305D0/
DATA A/.585786437627D0, 3.414213562373D0,
2 0.415774556783D0, 2.294280360279D0, 6.289945082937D0,
3 0.322547689619D0, 1.745761101158D0, 4.536620296921D0,
4 9.395070912301D0, 0.263560319718D0, 1.413403059107D0,
5 3.596425771041D0, 7.085810005859D0, 12.640800844276D0,
6 6*0.D0/
DATA W/ 0.853553390593D0, 0.146446609407D0, 0.711093009929D0,
8 0.278517733569D0, 0.103892565016D-1, 0.603154104342D0,
9 0.357418692438D0, 0.388879085150D-1, 0.539294705561D-3,
A 0.521755610583D0, 0.398666811083D0, 0.759424496817D-1,
B 0.361175867992D-2, 0.233699723858D-4, 6*0.D0/
NGP=MAX0(2,MIN0(6,IABS(NGP)))
IST=NGP*(NGP-1)/2-1
WRITE(6,600) NGP
600 FORMAT('0 ENERGY VALUES WILL BE GENERATED TO FACILITATE',I4,
1 '-POINT GAUSS-LAGUERRE INTEGRATION OVER BOLTZMANN DISTRIBUTION')
NN=0
DO 1000 I=1,NT
IF (NN+NGP.LE.MXNRG) GO TO 1010
WRITE(6,601) I,T(I)
601 FORMAT('0 * * * WARNING. NOT ENOUGH SPACE IN ENERGY() TO PROCESS
1TEMP(',I3,' ) =',F8.2)
GO TO 1000
1010 XT=XK*T(I)
WRITE(6,602) T(I),XT
602 FORMAT('0 FOR TEMP =',F8.2,' DEG. K =',F8.2,' (1/CM), THE
1AVERAGE IS APPROXIMATELY THE SUM OF')
DO 1100 J=1,NGP
EN=XT*A(IST+J)
WT=A(IST+J)*W(IST+J)
NN=NN+1
E(NN)=EN
1100 WRITE(6,603) WT,EN
603 FORMAT(15X,F13.8, ' * SIG( E =',F12.4,' ) ')
1000 CONTINUE
NNRG=MIN0(MXNRG,MAX0(NNRG,NN))
RETURN
END
SUBROUTINE ECNV(EUNITS,EUNITC,TOCM)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C THIS ROUTINE ACCEPTS AN INTEGER, EUNITS, OR A CHARACTER*4, EUNITC,
C AND DETERMINES "UNITS" AND ACCORDINGLY A CONVERSION FACTOR TO (1/CM).
C EUNITC TAKES PRECEDENCE; VERSION OF 21 MAR 95
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 (IN EUNITC) CORRESPONDING TO THE 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*4 EUNITC,BLANKS
CHARACTER*8 LTYP(9)
DIMENSION ECONV(9)
DATA LTYP/' 1/CM',' K ',' MHZ',' GHZ',' EV ',' ERG', ' AU',
1 'KJ/MOL','KCAL/MOL'/
DATA BLANKS/' '/
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
IF (EUNITC.EQ.BLANKS) THEN
IF (EUNITS.EQ.0) THEN
WRITE(6,600)
600 FORMAT(/' INPUT ENERGY VALUES ASSUMED TO BE IN UNITS OF ',
1 '1/CM BY DEFAULT.')
TOCM=1.D0
ELSEIF (EUNITS.GT.0.AND.EUNITS.LE.MXUNIT) THEN
IVAL=EUNITS
WRITE(6,601) LTYP(IVAL),IVAL
601 FORMAT(/' INPUT ENERGY VALUES CONVERTED FROM ',A8,/5X,'TO',
1 ' INTERNAL WORKING UNITS OF 1/CM DUE TO INTEGER INPUT =',I4)
TOCM=ECONV(IVAL)
ELSE
WRITE(6,699) EUNITS,(I,LTYP(I),I=1,MXUNIT)
699 FORMAT(/' *** ECNV. INPUT EUNITS = ',I6,' CANNOT BE ',
1 'PROCESSED. ALLOWED VALUES ARE'/(11X,I2,2X,A8/))
STOP
ENDIF
ELSE
CALL ECNVX(EUNITC,IVAL)
TOCM=ECONV(IVAL)
ENDIF
RETURN
END
SUBROUTINE ECNVX(EUNITS,IVAL)
C
C THIS ROUTINE CONVERTS A 4 CHARACTER INPUT -- EUNITS --
C INTO THE CORRESPONDING INTEGER VALUE -- IVAL.
C VERSION OF 21 MAR 95.
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,
1 LC,LM,LK,LH,LZ,LE,LV,LR,LG,LA,LU,LL,LJ
CHARACTER*4 EUNITS
CHARACTER*8 LTYP(9)
DATA LTYP/' 1/CM',' K ',' MHZ',' GHZ',' EV ',' ERG', ' AU',
1 'KJ/MOL','KCAL/MOL'/
DATA MX/9/
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'/,
3 LC/'c'/,LM/'m'/,LK/'k'/,LH/'h'/,LZ/'z'/,LE/'e'/,LV/'v'/,
4 LR/'r'/,LG/'g'/,LA/'a'/,LU/'u'/,LL/'l'/,LJ/'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.OR.L4(II).EQ.LC) GO TO 3001
IF (L4(II).EQ.K.OR.L4(II).EQ.LK) GO TO 3002
IF (L4(II).EQ.M.OR.L4(II).EQ.LM) GO TO 3003
IF (L4(II).EQ.G.OR.L4(II).EQ.LG) GO TO 3004
IF (L4(II).EQ.E.OR.L4(II).EQ.LE) GO TO 3005
2001 IF (L4(II).EQ.A.OR.L4(II).EQ.LA) GO TO 3006
GO TO 2991
C FOR EACH ALLOWED FIRST LETTER, SEARCH FOR NEXT IN KEYWORDS. . .
3001 IF(.NOT.STSRCH(M,LM,L4(II+1),4-II,IF)) GO TO 2991
IT=1
GO TO 5000
C
3002 IF (.NOT.STSRCH(C,LC,L4(II+1),4-II,IF)) GO TO 3012
IFN=II+IF
IF (.NOT.STSRCH(A,LA,L4(IFN+1),4-IFN,IF)) GO TO 2991
IFN=IFN+IF
IF (.NOT.STSRCH(L,LL,L4(IFN+1),4-IFN,IF)) GO TO 2991
IT=9
GO TO 5000
3012 IF (.NOT.STSRCH(J,LJ,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,LH,L4(II+1),4-II,IF)) GO TO 2991
IF (.NOT.STSRCH(Z,LZ,L4(II+IF+1),4-II-IF,IF)) GO TO 2991
IT=3
GO TO 5000
3004 IF(.NOT.STSRCH(H,LH,L4(II+1),4-II,IF)) GO TO 2991
IF (.NOT.STSRCH(Z,LZ,L4(II+IF+1),4-II-IF,IF)) GO TO 2991
IT=4
GO TO 5000
3005 IF (.NOT.STSRCH(V,LV,L4(II+1),4-II,IF)) GO TO 3015
IT=5
GO TO 5000
3015 IF (.NOT.STSRCH(R,LR,L4(II+1),4-II,IF)) GO TO 2991
IF (.NOT.STSRCH(G,LG,L4(II+IF+1),4-II-IF,IF)) GO TO 2991
IT=6
GO TO 5000
3006 IF (.NOT.STSRCH(U,LU,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(/' *** ECNVX. EUNITC INPUT = ',A4,' CANNOT BE PROCESSED.'
1 , ' ALLOWED TYPES ARE'/(10X,A8))
STOP
C
5000 IVAL=IT
WRITE(6,602) LTYP(IT),EUNITS
602 FORMAT(/' INPUT ENERGY VALUES CONVERTED FROM ',A8,/5X,'TO '
1 ,'INTERNAL WORKING UNITS OF 1/CM DUE TO ALPHAMERIC INPUT =',A4)
RETURN
END
FUNCTION EPSUM(R,N,E,EVEC,WKS)
C
C FUNCTION TO EVALUATE THE EIGENPHASE SUM FROM THE R-MATRIX.
C F02ABF DIAGONALISES THE N X N REAL SYMMETRIC R-MATRIX,
C RETURNING THE EIGENVALUES IN E.
C THE EIGENPHASE SUM IS THEN OBTAINED BY SUMMING ARCTANGENTS
C OF THE EIGENVALUES.
C THE RESULT IS RETURNED IN UNITS OF PI, AND IS SHIFTED TO BE
C AS CLOSE AS POSSIBLE TO THE PREVIOUS EIGENPHASE SUM CALCULATED
C (STORED IN SMLAST)
C SEE ASHTON, CHILD AND HUTSON, J. CHEM. PHYS. 78, 4025 (1983).
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE SMLAST
DIMENSION R(N,N), E(N), EVEC(N,N), WKS(N)
DATA PI/3.141592653589793238462643D0/
DATA SMLAST/10.D0/
C
IF(N.EQ.1) GOTO 200
IFAIL=0
CALL F02ABF(R,N,N,E,EVEC,N,WKS,IFAIL)
EPSUM=0.D0
DO 100 I=1,N
X=ATAN(E(I))
EPSUM=EPSUM+X
100 CONTINUE
GOTO 300
200 EPSUM=ATAN(R(1,1))
300 EPSUM=EPSUM/PI
DELTA=SMLAST-EPSUM+0.5D0
IF(DELTA.LE.0.D0) DELTA=DELTA-1.D0
IDEL=INT(DELTA)
EPSUM=EPSUM+DBLE(IDEL)
SMLAST=EPSUM
RETURN
END
FUNCTION ESYMTP(J1,K1,J2,K2,LM,MU)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA CON15/.282094791773878209D0/
Z(X)=2.D0*X+1.D0
ESYMTP=0.D0
XJ1=J1
XJ2=J2
XK1=K1
XK2=K2
XLM=LM
XMU=MU
E=THRJ(XJ1,XLM,XJ2,-XK1,-XMU,XK2)
IF (ABS(E).LE.1.D-8) RETURN
ESYMTP=E*PARITY3((IABS(J2-J1)+J2+J1)/2-MU-K1)*
& CON15*SQRT(SQRT(Z(XJ1)*Z(XJ2)))
RETURN
END
SUBROUTINE F02AAF(A, IA, N, R, E, IFAIL)
C
C SIMULATES NAG DIAGONALISER F02AAF WITH LAPACK CALLS
C JMH MAY 93
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DIMENSION A(IA,N), R(N), E(N)
DIMENSION V(1)
DATA IV/1/
DATA ZERO/0.D0/
C
IT1=IXNEXT
IT2=IT1+(5*N+1)/NIPR
IT3=IT2+(N+1)/NIPR
LWREQ=8*N
LWORK=MX-IT3+1
IF(LWORK.LT.LWREQ) THEN
WRITE(6,100) LWORK,N
100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE',
1 ' IN F02AAF.'/' LAPACK ROUTINE DSYEVX NEEDS AT LEAST 8*N,',
2 ' AND N =',I5,' ON THIS CALL.')
STOP
ENDIF
C
IXNEXT=IT3+LWREQ
NUSED=0
CALL CHKSTR(NUSED)
C
C SAVE DIAGONAL ELEMENTS IN E
C
CALL DCOPY(N,A,IA+1,E,1)
C
C CALL LAPACK DIAGONALISER: DESTROYS LOWER TRIANGLE OF A
C
CALL DSYEVX('N','A','L',N,A,IA,DUM,DUM,IDUM,IDUM,ZERO,M,R,V,IV,
1 X(IT3),LWORK,X(IT1),X(IT2),INFO)
C
IF (INFO .NE. 0) THEN
WRITE (6,120) INFO
120 FORMAT(' *** ERROR IN DSYEVX: INFO =',I3)
END IF
C
IFAIL=INFO
IXNEXT=IT1
C
C RESTORE LOWER TRIANGLE FROM UNCHANGED UPPER TRIANGLE
C AND DIAGONAL FROM E
C
CALL DSYFIL('L',N,A,IA)
CALL DCOPY(N,E,1,A,IA+1)
C
RETURN
END
SUBROUTINE F02ABF(A, IA, N, R, V, IV, E, IFAIL)
C
C SIMULATES NAG DIAGONALISER F02ABF WITH LAPACK CALLS
C JMH MAY 93
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DIMENSION A(IA,N), V(IV,N), R(N), E(N)
DATA ZERO/0.D0/
C
IT1=IXNEXT
IT2=IT1+(5*N+1)/NIPR
IT3=IT2+(N+1)/NIPR
LWREQ=8*N
LWORK=MX-IT3+1
IF(LWORK.LT.LWREQ) THEN
WRITE(6,100) LWORK,N
100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE',
1 ' IN F02ABF.'/' LAPACK ROUTINE DSYEVX NEEDS AT LEAST 8*N,',
2 ' AND N =',I5,' ON THIS CALL.')
STOP
ENDIF
C
IXNEXT=IT3+LWREQ
NUSED=0
CALL CHKSTR(NUSED)
C
C SAVE DIAGONAL ELEMENTS IN E
C
CALL DCOPY(N,A,IA+1,E,1)
C
C CALL LAPACK DIAGONALISER: DESTROYS LOWER TRIANGLE OF A
C
CALL DSYEVX('V','A','L',N,A,IA,DUM,DUM,IDUM,IDUM,ZERO,M,R,V,IV,
1 X(IT3),LWORK,X(IT1),X(IT2),INFO)
C
IF (INFO .NE. 0) THEN
WRITE (6,120) INFO
120 FORMAT(' *** ERROR IN DSYEVX: INFO =',I3)
END IF
C
IFAIL=INFO
IXNEXT=IT1
C
C RESTORE LOWER TRIANGLE FROM UNCHANGED UPPER TRIANGLE
C AND DIAGONAL FROM E
C
CALL DSYFIL('L',N,A,IA)
CALL DCOPY(N,E,1,A,IA+1)
C
RETURN
END
INTEGER FUNCTION FIND(I,J,IG,NG)
C
C FUNCTION TO FIND A PARTICULAR FOURIER COMPONENT IN A LIST
C OF COMPONENTS, AND RETURN THE POSITION OF THE REQUIRED
C COMPONENT.
C
DIMENSION IG(2,NG)
C
II=I
JJ=J
CALL ORDER(II,JJ)
FIND=0
DO 10 N=1,NG
IF(II.NE.IG(1,N) .OR. JJ.NE.IG(2,N)) GOTO 10
FIND=N
GOTO 20
10 CONTINUE
20 RETURN
END
SUBROUTINE FINDRM(W,N,RSTART,RTURN,IK,P,VL,IV,ERED,EINT,CENT,
1 RMLMDA,DIAG,DIAG2,XK,PHASE,MXLAM,NPOTL,IRMSET,ITYPE,IPRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION W(N,N),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N),DIAG(N),
1 DIAG2(N),XK(N),PHASE(N)
C
C SUBROUTINE TO FIND A SUITABLE STARTING POINT FOR INTEGRATION
C
C FIND CLASSICAL TURNING POINT OF DIAGONAL POTENTIAL
C IN LOWEST-LYING CHANNEL.
C START FROM A GUESS BASED ON THE CENTRIFUGAL POTENTIAL
C MOD 28 MAR 95 (SG) TO START AT 0.8*RMIN RATHER THAN 0.0
C IN CASE OF FAILURE
C
RMIN=RSTART
RTURN=1.D30
NOPEN=0
DO 80 I=1,N
DIF=ERED-EINT(I)
IF (DIF.LT.0.D0) GOTO 80
NOPEN=NOPEN+1
RCENT=SQRT(CENT(I)/DIF)
RCENT=MAX(RCENT,RMIN)
RTURN=MIN(RTURN,RCENT)
80 CONTINUE
C
C FOR SURFACE SCATTERING, OVERRIDE THE CENTRIFUGAL GUESS
C
IF (ITYPE.EQ.8) RTURN=RMIN
C
IF (NOPEN.LE.0) THEN
IF (IPRINT.GE.3) WRITE(6,*) ' *** FINDRM. NO OPEN CHANNELS'
GOTO 300
ENDIF
C
ITRY=0
90 RSTART=RTURN
IF (ITRY.GT.25) GOTO 140
CALL WAVMAT(W,N,RSTART,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
C
C FIND LOWEST CHANNEL
C
IK=1
V1=DIAG(1)
DO 100 I=1,N
IF (DIAG(I).GE.V1) GO TO 100
IK=I
V1=DIAG(I)
100 CONTINUE
C
RTURN=0.999D0*RSTART
DO 120 II=1,100
CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG2,
1 MXLAM,NPOTL)
C
C CHECK THAT CHANNEL IK IS STILL LOWEST, AND CALCULATE ALL
C THE DERIVATIVES FOR USE LATER
C
V2=DIAG2(IK)
DO 110 I=1,N
XK(I)=(DIAG2(I)-DIAG(I))/(RTURN-RSTART)
DIAG(I)=DIAG2(I)
IF (DIAG(I).LT.V2) THEN
ITRY=ITRY+1
GOTO 90
ENDIF
110 CONTINUE
DV1=XK(IK)
C
IF (IPRINT.GE.8) WRITE(6,602) RTURN,V2
602 FORMAT(' FINDRM: AT R =',F8.4,' SMALLEST V-E IS',F11.2)
C
C THERE MIGHT BE A WELL BEHIND THE BARRIER MAXIMUM.
C PROVIDED IT IS ABOVE THE SCATTERING ENERGY, JUMP OVER IT
C AND TRY AGAIN. ONLY DO THIS ONCE, THOUGH.
C
IF (DV1.GE.0.D0) THEN
IF (V2.GT.0.D0) THEN
ITRY=ITRY+10
IF (ITRY.LT.20) THEN
RTURN=2.D0*RTURN
GOTO 90
ELSE
GOTO 140
ENDIF
ELSE
ITRY=ITRY+5
RTURN=0.9D0*RTURN
GOTO 90
ENDIF
ENDIF
RSTART=RTURN
V1=V2
DR=-V1/DV1
IF (DR.LT.-0.3D0*RTURN .AND. ITYPE.NE.8) DR=-0.3D0*RTURN
RTURN=RTURN+DR
IF (ITRY.GT.25 .OR. DR.GT.1.D3) GO TO 140
IF (RTURN.LE.0.D0 .AND. ITYPE.NE.8) GO TO 140
IF (ABS(DR/RTURN).LE.1.D-3) GO TO 160
120 CONTINUE
C
C ARRIVE HERE IF DR BECOMES HUGE, RTURN BECOMES NEGATIVE,
C OR THERE IS NO CONVERGENCE IN 100 NEWTON-RAPHSON ITERATIONS.
C IF THIS HAPPENS, JUST USE THE INPUT VALUE OF RMIN
C
140 IF (IPRINT.GE.3) WRITE(6,*) ' *** FINDRM. ',
1 'UNABLE TO FIND CLASSICAL TURNING POINT'
GOTO 300
C
C ARRIVE HERE IF WE HAVE CONVERGED ON A CLASSICAL TURNING POINT
C DIAG ARRAY CONTAINS DIAGONAL ELEMENTS
C
160 IF (IPRINT.GE.3) WRITE(6,603) RTURN
603 FORMAT(' INNER CLASSICAL TURNING POINT AT R =',F8.4)
C
C SPECIAL CASE: CALLED TO FIND RTURN ONLY
C
IF (IRMSET.LE.0) THEN
RSTART=RMIN
RETURN
ENDIF
C
C FIND NEW RSTART BY INTEGRATING PHASE INTEGRALS INWARDS.
C WE WANT RSTART SUCH THAT
C INT(RSTART,RTURN) SQRT(E-V) DR = 2.303 * IRMSET
C TRY TO DO IT IN NSTEP ROUGHLY EQUAL STEPS
C
NSTEP=3+IRMSET/3
C
TARGET=2.303D0*DBLE(IRMSET)
DR=1.5D0*TARGET/SQRT(ABS(XK(IK)))/DBLE(NSTEP)
C
DO 210 I=1,N
PHASE(I)=0.D0
XK(I)=SQRT(ABS(DIAG(I)))
210 CONTINUE
C
220 CONTINUE
C
DO 240 ISTEP=1,NSTEP
RNEXT=RSTART-DR
IF (RNEXT.LT.0.D0 .AND. ITYPE.NE.8) THEN
RSTART=0.8*RMIN
IF (IPRINT.GE.1) THEN
WRITE(6,*) ' *** FINDRM. REACHED ORIGIN ',
1 'WHILE ACCUMULATING PHASE INTEGRAL. CHECK POTENTIAL'
WRITE(6,*) ' PROPAGATION WILL START AT 0.8*RMIN'
ENDIF
RETURN
ENDIF
C
CALL WAVMAT(W,N,RNEXT,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
DRNEXT=0.D0
DO 230 I=1,N
IF (DIAG(I).LE.0.D0) THEN
IF (IPRINT.GE.3)
1 WRITE(6,*) ' *** FINDRM. INNER CLASSICALLY ALLOWED REGION ',
1 'ENCOUNTERED WHILE INTEGRATING INWARDS FROM TURNING POINT.'
GOTO 260
ENDIF
V1=SQRT(DIAG(I))
V2=0.5D0*(V1+XK(I))
PHASE(I)=PHASE(I)+DR*V2
DRNEXT=MAX(DRNEXT,(TARGET-PHASE(I))/V1)
XK(I)=V1
230 CONTINUE
C
RSTART=RNEXT
IF (ISTEP.LT.NSTEP) DR=DRNEXT/DBLE(NSTEP-ISTEP)
C
IF (IPRINT.GE.8) WRITE(6,604) ISTEP,RNEXT,DR,DIAG(IK)
604 FORMAT(' FINDRM: STEP',I3,' AT R =',2F8.4,F11.2)
C
IF (DRNEXT.LE.0.D0) GOTO 250
C
C IF THE STEP SIZE SEEMS EXCESSIVE, TRY ACCUMULATING THE
C PHASE INTEGRAL MORE CAUTIOUSLY
C
IF (ISTEP.LT.NSTEP .AND. ITYPE.NE.8
1 .AND. DR.GT.0.5D0*RSTART .AND. DR.GT.0.5D0*RMIN) THEN
DR=0.02D0*RSTART
GOTO 220
ENDIF
C
240 CONTINUE
C
250 IF (IPRINT.GE.3) WRITE(6,606) RSTART
606 FORMAT(' RADIAL INTEGRATION WILL START AT R =',F8.4)
RETURN
C
C ARRIVE HERE IF THE INWARDS SEARCH ENTERED A CLASSICALLY ALLOWED
C REGION. TRY TO FIND A BETTER STARTING POINT AND LOOK FOR THE
C INNER TURNING POINT
C
260 DR=0.1D0*RNEXT
RTURN=RNEXT-DR
DO 290 II=1,9
CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
DO 270 I=1,N
IF (DIAG(I).LE.0.D0) GOTO 280
270 CONTINUE
ITRY=ITRY+10
GOTO 90
280 RTURN=RTURN-DR
290 CONTINUE
IF (IPRINT.GE.1) THEN
WRITE(6,*) ' *** FINDRM. UNABLE TO FIND',
1 ' INNER CLASSICAL TURNING POINT. CHECK POTENTIAL'
WRITE(6,*) ' PROPAGATION WILL START AT 0.8*RMIN'
ENDIF
RSTART=0.8*RMIN
RETURN
C
300 RSTART=RMIN
RTURN=2.D0*RMIN
IF (IPRINT.GE.3) WRITE(6,608)
608 FORMAT(14X,'RSTART SET TO RMIN'/14X,'RTURN SET TO 2*RMIN')
RETURN
C
END
SUBROUTINE FINDRX(ENERGY,EINT,CENT,NNRG,N,CINT,RMAX,RSTOP,
1 NOPMAX,IRXSET,IPRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C SUBROUTINE TO SCAN INPUT ENERGIES AND THRESHOLDS TO DETERMINE
C A SAFE RMAX WHICH IS OUTSIDE THE CENTRIFUGAL BARRIER FOR
C ALL COMBINATIONS. ALSO FIND THE LARGEST VALUE OF NOPEN
C TO SAFEGUARD AGAINST SHRINKING THE BASIS SET TOO FAR.
C
DIMENSION ENERGY(NNRG),EINT(N),CENT(N)
C
NOPMAX=0
RSTOP=RMAX
DO 200 J=1,NNRG
NOPEN=0
ERED=ENERGY(J)*CINT
DO 100 I=1,N
DIF=ERED-EINT(I)
IF(DIF.LT.0.D0) GOTO 100
NOPEN=NOPEN+1
IF(IRXSET.LE.0) GOTO 100
RCENT=SQRT(CENT(I)/DIF)
RSTOP=MAX(RSTOP,RCENT)
100 CONTINUE
200 NOPMAX=MAX0(NOPMAX,NOPEN)
IF(RSTOP.GT.RMAX .AND. IPRINT.GE.3) WRITE(6,601) RSTOP
601 FORMAT('0 RMAX INCREASED TO',F7.2,' FOR THIS PARITY CASE',
1 ' TO ENSURE THAT OPEN CHANNEL MATCHING'/' OCCURS BEYOND',
2 ' THE CENTRIFUGAL BARRIER FOR ALL ENERGIES')
RETURN
END
FUNCTION FSYMTP(J1,K1,L1,J2,K2,L2,JT,LAM,MU)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C CALCULATES MATRIX ELEMENT FOR SYMMETRIC TOP FUNCTIONS
C (J1 K1 L1, JTOT / Y(LAM,MU) / J2 K2 L2, JTOT).
C USES SUBROUTINES -
C THRJ(XJ1,XJ2,XJ3,XM1,XM2,XM3)
C THREEJ(J1,J2,J3) WHICH IS FOR M1=M2=M3=0
C SIXJ(J1,L1,J2,L2,JTOT,LAM)
C
DATA PI/3.14159265358979289D0/
C STATEMENT FUNCTION DEFINITION . . .
Z(Y) = 2.D0 * Y + 1.D0
C
IF (K1-K2+MU .NE. 0) GO TO 9000
F=THREEJ(L1,L2,LAM)
IF (F.EQ.0.D0) GO TO 9000
XJ1=J1
XJ2=J2
XK1=K1
XK2= - K2
XL1=L1
XL2=L2
XLAM=LAM
XMU=MU
F=F * THRJ(XJ1,XJ2,XLAM,XK1,XK2,XMU)
IF (F.EQ.0.D0) GO TO 9000
F=F * SIXJ(J1,L1,J2,L2,JT,LAM)
IF (F.EQ.0.D0) GO TO 9000
PH=PARITY3(J1+J2+K2-JT)
F=F*PH*SQRT(Z(XJ1)*Z(XJ2)*Z(XL1)*Z(XL2)*Z(XLAM)/(4.D0*PI))
FSYMTP=F
RETURN
9000 FSYMTP=0.D0
RETURN
END
SUBROUTINE GASLEG(N,Z,A)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C *** ROUTINE TO GENERATE GAUSS-LEGENDRE POINTS/WEIGHTS
C *** TAKEN FROM AD VAN DER AVOIRD'S N2-N2 CODE (SG 11/7/91)
C *** NEEDS FUNCTION ZBES
DIMENSION P(301),PD(301),Z(1),A(1)
DATA PI/3.14159 26535 89793 D0/
IF (N.LE.300) GO TO 20
WRITE (6,10)
10 FORMAT (/10X,31H***** GASLEG N TOO LARGE *****/)
STOP
20 NN=N+1
IFIN=0
IODD=0
C=2.0D0/PI
C=1.0D0-(C*C)
IF (MOD(N,2).EQ.0) GO TO 30
NKNT=(N-1)/2
IODD=1
GO TO 40
30 NKNT=N/2
40 K=1
CHA=0.0D0
CHB=0.0D0
P(1)=1.0D0
DN=N+0.50D0
DN2=DN*DN
DEN=SQRT(DN2+(C/4.0D0))
50 BES=ZBES(K)
X=COS(BES/DEN)
PDX=1.0D0/(1.0D0-X*X)
60 CONTINUE
P(2)=X
DO 70 I=3,NN
IN=I-1
IM=I-2
P(I)=((2.0D0*IN-1.0D0)*X*P(IN)-IM*P(IM))/IN
PD(I)=IN*PDX*(P(IN)-X*P(I))
70 CONTINUE
IF (IFIN.EQ.1) GO TO 100
IF (ABS(P(NN)).LT.1.0D-12) GO TO 80
X=X-(P(NN)/PD(NN))
PDX=1.0D0/(1.0D0-X*X)
GO TO 60
80 Z(K)=X
TA=N*P(N)
TA=TA*TA
A(K)=(2.0D0*(1.0D0-X*X))/TA
CHA=CHA+2.0D0*A(K)
Z2=Z(K)*Z(K)
CHB=CHB+2.0D0*A(K)*Z2
IF (K.EQ.NKNT) GO TO 90
K=K+1
GO TO 50
90 CONTINUE
IF (IODD.EQ.0) GO TO 110
X=0.0D0
K=NKNT+1
Z(K)=X
IFIN=1
GO TO 60
100 TA=N*P(N)
TA=TA*TA
A(K)=2.0D0/TA
CHA=CHA+A(K)
110 CONTINUE
RETURN
END
SUBROUTINE GAUSHP(NN,X,A)
C CALCULATES THE ZEROS, X(I), AND WEIGHTS, A(I), I=1,NN, FOR
C GAUSS-HERMITE QUADRATURE.
C Approximates the integral from -infinity to infinity f(x)*exp(-x**2)
C by the sum(i=1,nn) w(i)*f(x(i)).
C ADAPTED BY S. GREEN FROM STROUD AND SECREST GAUSSIAN QUADRATURE FORMULAS.
C VERSION OF 18 APRIL 94; FIXED NN=1 BUG 10 MAR 95 (SG)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (MXIT=15)
DIMENSION X(NN),A(NN)
DATA EPS/1.D-15/
C
GAM(Y)=(((((((.035868343D0*Y-.193527818D0)*Y+.482199394D0)*Y-
1 .756704078D0)*Y+.918206857D0)*Y-.897056937D0)*Y+
2 .988205891D0)*Y-.577191652D0)*Y+1.D0
C
IF (NN.LE.0) THEN
WRITE(6,*) ' *** GAUSHP CALLED FOR ILLEGAL NPT=',NN
STOP
ELSEIF (NN.EQ.1) THEN
WRITE(6,*) ' *** GAUSHP. WARNING, SINGLE POINT REQUESTED.'
X(1)=0.D0
A(1)=SQRT(ACOS(-1.D0))
RETURN
ELSE
FN=NN
N1=NN-1
N2=(NN+1)/2
C COMPUTE GAMMA FN BY HASTINGS APPROX; 0.LE.X.LE.70.
Z=FN
IF (Z.LE.0.D0 .OR. Z.GE.7.D1) THEN
WRITE(6,600) Z
600 FORMAT(' *** GAUSHP. CANNOT GET GAMMA FUNCTION FOR',F10.2)
STOP
ENDIF
IF (Z.EQ.1.D0) THEN
GAMMA=1.D0
GO TO 20
ELSEIF (Z.LT.1.D0) THEN
GAMMA=GAM(Z)/Z
GO TO 20
ELSE
ZA=1.D0
10 Z=Z-1.D0
IF (Z-1.D0) 13,11,12
11 GAMMA=ZA
GO TO 20
12 ZA=ZA*Z
GO TO 10
13 GAMMA=ZA*GAM(Z)
GO TO 20
ENDIF
20 CC=1.7724538509D0*GAMMA*(2.D0**(-N1))
S=(2.D0*FN+1.D0)**(1.D0/6.D0)
DO 100 I=1,N2
IF (I.EQ.1) THEN
C LARGEST ZERO
XT=S**3-1.85575D0/S
GO TO 50
ELSEIF (I.EQ.2) THEN
C SECOND ZERO
XT=XT-1.14D0*FN**.426D0/XT
GO TO 50
ELSEIF (I.EQ.3) THEN
C THIRD ZERO
XT=1.86D0*XT-0.86D0*X(1)
GO TO 50
ELSEIF (I.EQ.4) THEN
C FOURTH ZERO
XT=1.91D0*XT-0.91D0*X(2)
GO TO 50
ELSE
C ALL HIGHER ZERO'S
XT=2.D0*XT-X(I-2)
ENDIF
C
C IMPROVE THE APPROXIMATE ROOT XT AND OBTAIN
C DPN = DERIVATIVE OF H(N) AT XT; PN1 = VALUE OF H(N-1) AT XT
50 IT=0
60 IT=IT+1
IF (IT.GT.MXIT) THEN
WRITE(6,*) ' *** GAUSHP FAILED TO CONVERGE. ITERATIONS ='
1 ,MXIT
STOP
ENDIF
CALL HRECUR(P,DP,PN1,XT,NN)
D=P/DP
XT=XT-D
IF (ABS(D).GT.EPS) GO TO 60
DPN=DP
X(I)=XT
A(I)=CC/(DPN*PN1)
NI=NN-I+1
X(NI)=-XT
100 A(NI)=A(I)
ENDIF
RETURN
END
SUBROUTINE GAUSSP(A,B,NPT,XPT,WHT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION XPT(NPT),WHT(NPT)
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C THIS ROUTINE SETS UP ABSCISSAE AND WEIGHTS FOR NPT-POINT *
C GAUSS-LEGENDRE INTEGRATION IN THE INTERVAL (A,B). *
C *
C ON RETURN, THE FUNCTION TO BE INTEGRATED SHOULD BE EVALUATED *
C AT THE POINTS XPT(I). INTEGRAL = SUM(I=1,NPT) F(XPT(I))*WHT(I)*
C *
C THIS VERSION (SG 11/7/91) CALCULATES POINTS/WEIGHTS FROM *
C GASLEG/ZBES CODE OF AD VAN DER AVOIRD *
C DOES ANY NUMBER OF PTS FROM 1 TO MXPT, WHERE LIMIT IS FROM *
C DIMENSION STATEMENTS IN GASLEG (P,PD AT LEAST (MXPT+1) ) *
C AND HERE W,X DIMENSIONED AT LEAST ((MXPT+1)/2) *
C *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
DIMENSION X(128),W(128)
DATA MXPT/256/
C
T1=(B-A)/2.D0
T2=(B+A)/2
IF (NPT-1) 9999,9998,9997
9997 IF (NPT.LE.MXPT) GO TO 3100
WRITE(6,601) NPT,MXPT
601 FORMAT('0 * * * WARNING. GAUSS-LEGENDRE NPT =',I6,' REDUCED TO',
1 I4)
NPT=MXPT
3100 CALL GASLEG(NPT,X,W)
N2=(NPT+1)/2
I1=1
I2=NPT
IC=1
DO 2000 I=1,N2
XPT(I1)=-X(IC)*T1+T2
XPT(I2)=X(IC)*T1+T2
WHT(I1)=W(IC)*T1
WHT(I2)=WHT(I1)
I1=I1+1
I2=I2-1
2000 IC=IC+1
C N.B FOR NPT ODD, THE LAST (I.E. MIDDLE) TERM IS EVALUATED TWICE.
RETURN
9999 WRITE(6,610) NPT
610 FORMAT('0 * * * WARNING. GAUSS-LEGENDRE REQUESTED WITH NPT =',I6)
C REPLACE WITH SINGLE-POINT AT (A+B)/2 * (B-A)
NPT=1
9998 XPT(1)=T2
WHT(1)=2.D0*T1
RETURN
END
SUBROUTINE GCLOCK(XTIME)
DOUBLE PRECISION XTIME
REAL TIME,TTIME
DIMENSION TTIME(2)
C
C THIS ROUTINE IS MACHINE-DEPENDENT.
C IT SHOULD RETURN THE ELAPSED CPU TIME IN UNITS OF SECONDS.
C ONLY DIFFERENCES ARE USED, SO IT NEED NOT BE AN ABSOLUTE VALUE.
C
C DUMMY RESULT FOR VANILLA DISTRIBUTION
XTIME=0.D0
C
C CODE BELOW CALLS THE BSD UNIX TIMING ROUTINE.
C A C VERSION OF etime FOR MOST OTHER UNIX SYSTEMS IS AVAILABLE FROM JMH.
C TIME=etime(TTIME)
C XTIME=DBLE(TIME)
C
C CODE BELOW IS THE GISS ROUTINE
C CALL CLOCKS(ITIME)
C XTIME=-ITIME
C XTIME=XTIME*1.D-2
RETURN
END
SUBROUTINE GDATE(CDATE)
C
C THESE ROUTINES ARE MACHINE-DEPENDENT, AND MUST BE SIMULATED.
C THEY SHOULD RETURN STRINGS CONTAINING THE CURRENT DATE & TIME.
C
CHARACTER CDATE*11, CTIME*9
CDATE='UNKNOWN '
RETURN
ENTRY GTIME(CTIME)
CTIME='UNKNOWN '
RETURN
END
SUBROUTINE GET102(MXLVL,NLEVEL,JLEVEL,ELEVEL)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JLEVEL(2,MXLVL),ELEVEL(MXLVL)
WRITE(6,699)
699 FORMAT('0 GET102. DUMMY ROUTINE CALLED. TERMINAL ERROR.')
STOP
END
FUNCTION GSYMTP(J1,K1,J2,K2,MVAL,LM,MU)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA Z0/0.D0/, PIFCT/.282094791773878209D0/
C STATEMENT FUNCTION . . .
Z(X)=2.D0*X+1.D0
C
XJ1=J1
XK1=K1
XJ2=J2
XK2=K2
XM=MVAL
XLM=LM
XMU=MU
GSYMTP=0.D0
F=THRJ(XJ1,XLM,XJ2,XK1,XMU,-XK2)
IF (ABS(F) .LE. 1.D-8) RETURN
F=F*THRJ(XJ1,XLM,XJ2,-XM,Z0,XM)
IF (ABS(F) .LE. 1.D-8) RETURN
GSYMTP=F*PIFCT*SQRT(Z(XJ1)*Z(XJ2)*Z(XLM))*PARITY3(K1+MVAL)
RETURN
END
SUBROUTINE HEADER(W,WX,N,NSQ,P,VL,IV,EINT,CENT,DIAG,MXLAM,NPOTL,
1 ICODE,ISAV,EFIRST)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C ROUTINE TO WRITE/CHECK A HEADER LABEL ON UNIT ISCRU FOR USE
C WITH THE OPTION TO SAVE TRANSFORMATION MATRICES FOR A SUBSEQUENT
C RUN. THE LABEL CONSISTS OF ALL INTEGRATION TOLERANCES AND
C A SAMPLE POTENTIAL MATRIX.
C
C THE VARIOUS FLAGS ARE USED AS FOLLOWS:
C ICODE=1, ISAV=1: FIRST ENERGY, WRITE HEADER
C ICODE=1, ISAV=-1: FIRST ENERGY, CHECK HEADER
C ICODE=2: SUBSEQUENT ENERGY, SKIP HEADER
C
C
DIMENSION W(NSQ),WX(NSQ),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N),
1 DIAG(N),PAR(13),PARX(13)
C COMMON BLOCK FROM DRIVER AND RMTPRP
COMMON/DRIVE/STEST,STEPS,STAB,CONV,RMIN,RMAX,XEPS,DR,
1 DRMAX,RMID,TOLHI,RTURN,
2 VTOL,ESHIFT,ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP
EQUIVALENCE(PAR(1),STEST)
C
IF(ISCRU.EQ.0) RETURN
REWIND ISCRU
IF(ISAV.EQ.0) RETURN
IF(ICODE.EQ.1) GO TO 40
C
C SUBSEQUENT ENERGY CALC. - SKIP OVER ANY HEADER
C
READ(ISCRU)
READ(ISCRU)
RETURN
C
40 IF(ISAV.EQ.-1) GO TO 60
C
C WRITE OUT A HEADER
C
RX=2.D0*RMIN
CALL WAVMAT(W,N,RX,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,
1 NPOTL)
WRITE(ISCRU) N,EFIRST,RX,PAR
WRITE(ISCRU) W
RETURN
C
C READ AND VERIFY HEADER. SET NOPEN=-1 AS A FLAG THAT NO ACTUAL
C SCATTERING CALCULATION IS TO BE DONE FOR THIS ENERGY.
C SET ICODE=2 SO THAT A "SUBSEQUENT ENERGY" CALCULATION IS DONE
C
60 READ(ISCRU) NX,EFIRST,RX,PARX
IF(N.NE.NX) GO TO 999
DO 62 I=1,13
IF(PAR(I).NE.PARX(I)) GO TO 999
62 CONTINUE
CALL WAVMAT(W,N,RX,P,VL,IV,EFIRST,EINT,CENT,RMLMDA,DIAG,MXLAM,
1 NPOTL)
READ(ISCRU) WX
DO 64 I=1,NSQ
IF(W(I).NE.WX(I)) GO TO 998
64 CONTINUE
ICODE=2
WRITE(6,603) ISCRU
603 FORMAT('0 HEADER LABEL ON UNIT',I3,' SUCCESSFULLY VERIFIED.')
RETURN
C
C HEADER IS WRONG - RUN TERMINATED
C
998 WRITE(6,600) ISCRU
600 FORMAT('0****** ERROR - HEADER ON UNIT',I3,' DOES NOT AGREE',
1 ' WITH DATA FOR CURRENT RUN'/)
WRITE(6,601) (W(I),WX(I),I=1,NSQ)
601 FORMAT(2D24.15,10X,2D24.15)
999 WRITE(6,600) ISCRU
WRITE(6,602) N,NX,(PAR(I),PARX(I),I=1,13)
602 FORMAT(2I8/(2D24.15))
STOP
END
SUBROUTINE HERM(H,N,X)
C
C SUBROUTINE TO GENERATE HERMITE POLYNOMIALS
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION H(N)
P0=1.0D0
H(1)=P0
IF(N.LE.1) RETURN
X2=X+X
P1=X2
H(2)=P1
IF(N.LE.2) RETURN
DO 100 K=3,N
TEMP=X2*P1 - DBLE(K+K-4)*P0
P0=P1
P1=TEMP
H(K)=P1
100 CONTINUE
RETURN
END
SUBROUTINE HRECUR(PN,DPN,PN1,X,NN)
C SG: ADAPTED FROM STROUD AND SECREST, GAUSSIAN QUADRATURE FORMULAS GREEN.
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
P1=1.D0
P=X
DP1=0.D0
DP=1.D0
DO 1 J=2,NN
FJ=J
FJ2=(FJ-1.D0)/2.D0
Q=X*P-FJ2*P1
DQ=X*DP+P-FJ2*DP1
P1=P
P=Q
DP1=DP
1 DP=DQ
PN=P
DPN=DP
PN1=P1
RETURN
END
SUBROUTINE IDPART(ITYPE,IDENT,SPNUC,WT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION WT(2)
C
C THIS ROUTINE PROCESSES INPUT FOR IDENTICAL TARGET-PROJECTILE.
C IDENT.NE.0 IMPLIES TARGET AND PROJECTILE ARE IDENTICAL.
C OTHERWISE (IDENT.EQ.0) IEXCH=0 IN ALL CASES AND NO PROCESSING
C WITH IEXCH OR WT WILL OCCUR.
C
CHARACTER*8 NAME(2)
DATA NAME/' BOSE ',' FERMI '/
C
IF (IDENT.EQ.0) RETURN
WRITE(6,600)
600 FORMAT('0 IDENT PARAMETER SPECIFIES THAT TARGET AND PROJECTILE ARE
1 IDENTICAL. PROPERLY SYMMETRIZED FUNCTIONS WILL BE CONSTRUCTED.')
IF (ITYPE.EQ.3.OR.ITYPE.EQ.13.OR.ITYPE.EQ.23) GO TO 1000
WRITE(6,601) ITYPE
601 FORMAT('0 * * * ERROR. FOR ITYPE =',I4,' IDENT PROCESSING NOT SUP
1PORTED. REQUEST CANCELLED.')
IDENT=0
RETURN
1000 SPNUC=ABS(SPNUC)
IF (WT(1).EQ.0.D0 .AND. WT(2).EQ.0.D0) GO TO 2000
WRITE(6,603) WT
603 FORMAT(' STATISTICAL WEIGHTS SPECIFIED AS WT IN &BASIS DATA. SPN
1UC IGNORED.'/10X,'ANTI-SYMMETRIC, WT(1) =',F7.4,', SYMMETRIC, WT(
22) =',F7.4)
RETURN
2000 IST=INT(2.D0*SPNUC+0.0001D0)
IST=IST-2*(IST/2)
C IST=0 FOR BOSE STATISTICS, IST=1 FOR FERMI STATISTICS.
DN=2.D0*SPNUC+1.D0
WT(2-IST)=(SPNUC+1.D0)/DN
WT(IST+1)=SPNUC/DN
WRITE(6,602) SPNUC,NAME(IST+1),WT
602 FORMAT(' FOR NUCLEAR SPIN =', F6.2,',',A8,' STATISTICAL WEIGHTS A
1RE'/10X,'ANTI-SYMMETRIC, WT(1) =',F7.4,', SYMMETRIC, WT(2) =',
2 F7.4)
RETURN
END
SUBROUTINE IOSBIN(NVC,ITYPX,ATAU,MX,IASYMU,IPHIFX,IOSNG)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE
C
C *** MODIFIED FEB 92 TO CHANGE ITYPE=2 TO USE IV() INDEXING
C *** MODIFIED MAY 92 TO HANDLE ITYPE=103 (SG) ***
C *** MODIFIED JAN/FEB 92 TO GENERALIZE ITYPE=2 HANDLING
C *** MODIFIED FEB 88 TO CORRECT 'IHOMO' HANDLING OF ITYPE=5,6 CASES
C WHERE POTENTIAL IS SYMMETRIC ABOUT THETA=PI/2
C *** AUG 86 ADD LM,LMAX ARGUMENTS TO IXQLF
C *** UPDATED APR 86 TO MERGE BASIN-IOSBIN PROCESSING
C
C THIS IS IOS 'BASIS' ROUTINE FOR COMBINED MOLSCAT/IOS APR 86
C MODIFICATIONS MAY 1978 FOR ITYPE=5.
C MODIFICATIONS SEPT 1985 FOR ITYPE=6,
C INCLUDING ADDITION OF MMAX TO &INPUT.
C
C-----ENTRY IOSBIN READS &BASIS AND SETS UP BASIS DATA.
C PARAMETERS ARE NVC (NO. VIB. CHANNELS), ITYPX RETURNS ROTOR TYPE
C AND ATAU(MX) WHICH WILL HOLD ROTOR COEFF. FOR ITYPE=6
C
DIMENSION ATAU(MX)
C
C-----ENTRY IOSBGP GETS LAM(MXLAM) INFORMATION FROM &POTL.
C CAN THEN CHOOSE NGPT, LMAX, MMAX, AND SET UP GAUSS PTS/WTS
C SPECIFICATIONS FOR ENTRY IOSBGP . . .
DIMENSION LAM(MXLAM)
LOGICAL ODD
C
C-----ENTRY IOSB1, CALLED AFTER STORAGE IS ALLOCATED, SETS UP PWGHT, VLI
C ALSO IXQL AND LM.
C SPECIFICATIONS . . .
DIMENSION PWGHT(NGPT,LMAX), VLI(NGPT,MXXXXL)
DIMENSION IXQL(NIXQL,NQL),LM(3,LMAX)
C BELOW (TEMPORARY) TO CONTROL FLOW OF ALTERNATE ITYPE=3 CODE
LOGICAL LNEW
C
C-----ENTRY IOSB2 IS CALLED JUST BEFORE INTEGRATOR. SETS UP VL, ETC.
C SPECIFICATIONS FOR ENTRY IOSB2 . . .
DIMENSION CENT(NVC),EINT(NVC),WVEC(NVC),VL(2),IVIX(2)
DIMENSION LORB(NVC),JJJ(NVC),NB(NVC)
C COMMON TO PASS ANGLES TO VRTP FOR "UNEXPANDED" (MXLAM=0) POTL CASE
C N.B. 3RD ANGLE FOR ITYPE=3. IH0,IC0 TO SET IHOMO,ICNSYM IN VRTP
C FACTOR IS 1./(VALUE OF LOWEST ANGULAR TERM) - DEPENDS ON ITYPE
COMMON/ANGLES/COSANG(7),FACTOR,IH0,IC0,IH1,IC1
LOGICAL LVRTP
C
C-----ENTRY IXQLF RETURNS INDEX IN IXQL OF AN INPUT L,M1,M2,ICDE SYM.
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C TO CONTROL DEBUGGING OUTPUT OF COUPLING MATRIX
C LDEBUG=.TRUE. CAN GIVE QUITE A BIT OF OUTPUT !
LOGICAL LDEBUG
C
C SPECIFICATIONS FOR MOLSCAT(&BASIS) COMPATIBILITY. . .
DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2),
1 WEXE(2),WT(2),ELEVEL(1000)
INTEGER JMIN,JMAX,NLEVEL,JLEVEL(4000),J1MIN,J1MAX,J2MIN,J2MAX,
1 IDENT,JSTEP,J1STEP,J2STEP,ISYM(10),ISYM2(10)
EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)),
1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),
2 (JSTEP,J1STEP), (ROTI(7),WE(1)),(ROTI(9),WEXE(1))
C
COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL,
1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT,
2 MXJL,MXEL
C
C INTERNAL VERSION OF JLEVEL,ELEVEL IS ALSO USED; CF IOSOUT
DIMENSION LEVV(4000),EV(1000)
C
C COMMON BLOCK TO COMMUNICATE WITH IOSOUT . . .
COMMON /IOUTCM/ MAX,LEVV
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MXXX,IXNEXT,NIPR,IVLFL,X(1)
C
C IOS GAUSS POINT CONTROL
DIMENSION IOSNGP(3),IOSNG(3)
C
C ******************************************************************
C ** PROGRAM LIMITATION **
C ** DIMENSIONS FOR GAUSS POINTS **
C ** ------- ---------- **
C ** COULD USE /MEMORY/ FOR DYNAMIC STORAGE, BUT BELOW SHOULD **
C ** SUFFICE FOR MOST FEASIBLE CALCULATIONS. **
C ******************************************************************
PARAMETER(MXGPT=400)
DIMENSION COSA(MXGPT),GWT(MXGPT)
C FOR ITYPE=3 TO HOLD PLM(LI,M,) AND COS(M*PHI) -- LNEW=.TRUE. CODE
DIMENSION PL1(MXGPT),PL2(MXGPT),COSM(MXGPT)
C
C AND EQUIVALENT INTERNAL ARRAYS
DATA NVCMX/1000/
DATA IZ/0/
DATA LNEW/.TRUE./,LDEBUG/.FALSE./
C
C STATEMENT FUNCTION USED IN DETERMINING ITYPE=5,6 IHOMO SYMMETRY
ODD(I,J)=(I-J)-2*((I-J)/2) .NE. 0
C
C
C SPECIFICATIONS FOR LEGENDRE STATEMENT FUNCTION . . .
XLEG(I,TH)=SQRT(2.D0/DBLE(2*I+1))*PLM(I,0,TH)
C N.B. PLM(L,M,COSTH) RETURNS A **NORMALIZED** ASSOC. LEG. POLY.
C
C NB. THE FOLLOWING VARIABLES ARE USED AS LIMITS (SOME ITYPE=5 ONLY)
C MAX=HIGHEST J IN BASIS / MXK=HIGHEST K (SYM. TOP) IN BASIS.
C LMBDMX=HIGHEST LAMBDA IN POTL / MUMX=HIGHEST MU IN POTL
C LMMAX=HIGHEST 'L' IN SLLR,SLLI,QLT / MUMAX=HIGHEST 'M'
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
PI=ACOS(-1.D0)
WRITE(6,666)
666 FORMAT('0 PROCESSED BY IOSBIN ROUTINE (FEB 94).')
C
C SET LOCAL (AND HENCE KEPT) VALUES FROM ARGUMENTS
DO 1107 I=1,3
1107 IOSNGP(I)=IOSNG(I)
IPHIFL=IPHIFX
C INITIALIZE SIZE OF ATAU TO ZERO.
MXA=MX
MX=0
C SET DEFAULT IH0,IC0, IH1, IC1 WHICH MAY BE CHANGED IN VRTP
IH0=0
IC0=0
IH1=0
IC1=0
C
WRITE(6,620) ITYPX
620 FORMAT('0 INPUT ITYPE =',I4)
C
ITYP=ITYPX-10*(ITYPX/10)
ITYPX=100+ITYP
C SET IVLFL TO ZERO FOR MOST CASES; EXCEPTION IS ITYPE=102 (FEB 94)
IVLFL=0
IF (ITYP.EQ.1) GO TO 1000
IF (ITYP.EQ.2) GO TO 2000
IF (ITYP.EQ.3) GO TO 3000
IF (ITYP.EQ.5) GO TO 5000
IF (ITYP.EQ.6) GO TO 6000
WRITE(6,699) ITYP
699 FORMAT('0 * * * ERROR. MOD(ITYPE,10) =',I3,' NOT SUPPORTED.')
STOP
C
1000 NVC=1
ASSIGN 6100 TO IGOTP
EV(1)=0.D0
LEVV(1)=0
ILOFF=1
IF (NLEVEL.GT.0) GO TO 1200
WRITE(6,601) JMIN,JMAX,JSTEP
601 FORMAT('0 JLEVEL, NLEVEL CREATED FROM JMIN, JMAX, JSTEP =',
& 3I5)
JMIN=MAX0(JMIN,0)
JMAX=MAX0(JMIN,JMAX)
JSTEP=MAX0(JSTEP,1)
MAX=0
NLEVEL=0
DO 1100 I=JMIN,JMAX,JSTEP
IF (NLEVEL.GE.MXJL) GO TO 1109
NLEVEL=NLEVEL+1
JLEVEL(NLEVEL)=I
1100 MAX=MAX0(MAX,I)
GO TO 9000
1109 WRITE(6,698)
698 FORMAT('0 * * * WARNING. OUT OF SPACE IN JLEVEL. ',
1 'BASIS TRUNCATED.')
NLEVEL=MXJL
GO TO 9000
1200 WRITE(6,602) NLEVEL,(JLEVEL(I),I=1,NLEVEL)
602 FORMAT('0 BASIS TAKEN FROM NLEVEL, JLEVEL INPUT. NO. OF LEVELS ',
& '(NLEVEL) =',I4/(' ',20I5) )
MAX=0
DO 1300 I=1,NLEVEL
IF (I.GT.MXJL) GO TO 1109
1300 MAX=MAX0(MAX,JLEVEL(I))
GO TO 9000
C
C>>SG --------- CODE REWORKED FEB 92 (ANTICIPATING H2-H CALCULATIONS)
2000 ILOFF=3
C MODS FEB 94 TO USE IV() INDEXING FOR ITYPE=2 REQUIRE IVLFL=1
IVLFL=1
ASSIGN 6200 TO IGOTP
C
IF (NLEVEL.GT.0) GO TO 2100
C -------- GET 'VIBRATIONAL LEVELS' FROM SPECIAL SUBROUTINE -------
WRITE(6,697)
697 FORMAT('0 IOSBIN (FEB 92). NLEVEL.LT.0. AN APPROPRIATE',
1 ' SUBROUTINE MUST BE PROVIDED:'/
2 35X,'GET102(MXJL,NLEVEL,JLEVEL,ELEVEL)'/)
CALL GET102(MXJL,NLEVEL,JLEVEL,ELEVEL)
NVC=NLEVEL
MAX=0
DO 2190 I=1,NVC
EV(I)=ELEVEL(I)
LEVV(I)=JLEVEL(2*I)
2190 MAX=MAX0(MAX,JLEVEL(2*I-1))
C SKIP '2009' PRINT OUT OF LEVEL INFO/ DO IT IN GET102 IF DESIRED
GO TO 9000
C
C ----- GET 'VIBRATIONAL LEVELS' FROM JLEVEL -----
C CURRENT CODE DOES NOT ALLOW DUPLICATE VIB LEVELS.
2100 NVC=1
ITOP=2*NLEVEL
WRITE(6,602) NLEVEL,(JLEVEL(I),I=1,ITOP)
LEVV(1)=JLEVEL(2)
MAX=JLEVEL(1)
I=2
2102 IF (I.GT.NLEVEL) GO TO 2110
DO 2103 II=1,NVC
IF (LEVV(II).NE.JLEVEL(2*I)) GO TO 2103
WRITE(6,693) I,JLEVEL(2*I-1),JLEVEL(2*I)
693 FORMAT(' IOSBIN (FEB 92). LEVEL',I4,' V,J =',2I4,' DUPLICATES'
1 ,' AN EARLIER VIB LEVEL.'/
2 20X,'VIBRATIONAL VALUE IGNORED, HIGHER J-VALUE KEPT.')
JXX=MAX0(JLEVEL(2*II-1),JLEVEL(2*I-1))
JLEVEL(2*II-1)=JXX
MAX=MAX0(MAX,JXX)
IF (I.LT.NLEVEL) GO TO 2120
C I.EQ.NLEVEL ==> REDUCE NLEVEL AND GET OUT
NLEVEL=NLEVEL-1
GO TO 2110
C PULL DOWN LIST/ DECREASE NLEVEL/ GO BACK FOR NEW I-TH LEVEL
2120 DO 2121 J=I+1,NLEVEL
ELEVEL(J-1)=ELEVEL(J)
JLEVEL(2*J-3)=JLEVEL(2*J-1)
2121 JLEVEL(2*J-2)=JLEVEL(2*J)
NLEVEL=NLEVEL-1
GO TO 2102
2103 CONTINUE
C DUPLICATE VIB LEVEL NOT FOUND/ ADD THIS VIBRATIONAL LEVEL
IF (NVC.LT.NVCMX) GO TO 2104
WRITE(6,694) NVCMX
694 FORMAT('0 ISOBIN -- ERROR. VIBRATIONAL LEVELS IN NLEVEL/JLEVEL'
1 ,' EXCEED NVCMX =',I4)
STOP
2104 NVC=NVC+1
LEVV(NVC)=JLEVEL(2*I)
MAX=MAX0(MAX,JLEVEL(2*I-1))
I=I+1
GO TO 2102
C
2110 WRITE(6,692) NVC
692 FORMAT('0 IOSBIN (FEB 92). NUMBER OF VIB. CHANNELS (NVC) =',I4)
C
C ----- GET ENERGY LEVELS -----
DO 2111 I=1,NVC
IF (ELEVEL(I).EQ.0.) GO TO 2111
C IF ELEVEL() VALUES ARE SET (NON-ZERO), USE THEM
GO TO 2290
2111 CONTINUE
C IF WE REACH HERE, ALL ELEVEL ARE ZERO.
C IF THERE IS ONLY ONE LEVEL, AND ENERGY()=0, WE ARE STILL OKEY
IF (NVC.GT.1) GO TO 2280
C SET EV() FROM ELEVEL() AND WE ARE DONE.
2290 WRITE(6,691)
691 FORMAT('0 IOSBIN (FEB 92). VIBRATIONAL ENERGIES ',
1 'TAKEN FROM ELEVEL INPUT.')
DO 2291 I=1,NVC
2291 EV(I)=ELEVEL(I)
GO TO 2009
C OTHERWISE, SEE IF WE CAN CALCULATE ENERGIES FROM WE, WEXE
2280 IF (WE(1).GT.0.D0) GO TO 2200
WRITE(6,696) NVC,WE(1)
696 FORMAT('0 IOSBIN (FEB 92) CANNOT GET ENERGIES FROM ELEVEL ',
& 'OR WE. NVC, WE =',I6,D14.4)
STOP
2200 WRITE(6,603) WE(1)
603 FORMAT('0 TARGET ENERGY LEVELS (TAKING V = 0 AS ZERO ENERGY)',
1 ' COMPUTED FROM WE =',F10.4)
IF (WEXE(1).NE.0.D0) WRITE(6,604) WEXE(1)
604 FORMAT(67X,'CORRECTED FOR WEXE =',F10.6)
DO 2201 I=1,NVC
FV=LEVV(I)
EV(I)=WE(1)*FV-WEXE(1)*FV*(FV+1.D0)
C STORE BACK IN JLEVEL,ELEVEL FOR ISAVEU OUTPUT PURPOSES.
C>>SG JLEVEL(I)=LEVV(I) -->> THIS WAS USED FOR ISAVEU CAPABILITY IN
C>>SG -->> IOSDRV AND WILL NO LONGER WORK THERE
C ELEVEL() IS NEEDED IN IOSB2 TO GET EINT, ETC.
2201 ELEVEL(I)=EV(I)
NLEVEL=NVC
C ------ OUTPUT LEVV, EV ------
2009 DO 2019 I=1,NVC
2019 WRITE(6,613) I,LEVV(I),EV(I)
613 FORMAT(' LEVEL',I4,' LEVV =',I4,' EV =',F12.4)
GO TO 9000
C<<SG ------------------------------<< END OF MODIFICATIONS (2/4/91)
C
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 ----- END OF ITYPE=3 CODE ADDED 5/6/92 (SG)
C
5000 ILOFF=2
ASSIGN 6500 TO IGOTP
NVC=1
EV(1)=0.D0
LEVV(1)=0
IF (NLEVEL.GT.0) GO TO 5001
WRITE(6,687) ITYPX
687 FORMAT('0 * * * WARNING. CURRENT ITYPE =',I3,' REQUIRES NLEVEL/'
1 ,'JLEVEL INPUT. CROSS SECTIONS NOT COMPUTED.')
GO TO 9000
5001 ITOP=3*NLEVEL
WRITE(6,652) NLEVEL,(JLEVEL(I),I=1,ITOP)
652 FORMAT('0 BASIS IS TAKEN FROM NLEVEL =',I4,' AND JLEVEL INPUT'/
1 '0 J K PRTY'/ (' ',I3,2I4))
MAX=0
MXK=0
C BELOW IS A LESS-THAN-PERFECT CHECK ON DIMENSIONS FOR JLEVEL
NLEVEL=MIN0(NLEVEL,MXJL)
DO 5002 I=1,NLEVEL
MAX=MAX0(MAX,JLEVEL(3*I-2))
5002 MXK=MAX0(MXK,IABS(JLEVEL(3*I-1)))
GO TO 9000
C
6000 ILOFF=2
ASSIGN 6500 TO IGOTP
NVC=1
EV(1)=0.D0
LEVV(1)=0
CALL SET6I(JLEVEL,MXJL,NLEVEL,ATAU,MXA,IASYMU)
MX=MXA
C ***
C *** N.B JLEVEL(,1) = J, JLEVEL(,2) = TAU, JLEVEL(,3) = PARITY
C *** JLEVEL(,4)+1 = STARTING ADDRESS IN ATAU OF COEFFS (NK=2*J+1)
C ***
MAX=0
IF (NLEVEL.LE.0) GO TO 9000
DO 6001 I=1,NLEVEL
6001 MAX=MAX0(MAX,JLEVEL(4*I-3))
MXK=MAX
GO TO 9000
C
C COMMON RETURN POINT
9000 RETURN
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY IOSBGP(MXLAM,LAM,MXXXXL,NGPT,LMAX,MMAX,NQL,NIXQL)
C
C FIND HIGHEST LAMBDA VALUE AND CHECK FOR HOMONUCLEAR SYMMETRY.
C IHOMO =1( ALL LEGENDRE SYMMETRIES) OR 2 ( ONLY EVEN LEGENDRE SYMS)
C N.B. THIS WILL HAVE TO BE RESET FOR ITYPE=5,6, BUT WE NEED TO
C DETERMINE MXXXXL FOR VRTP; N.B. MXLAM=1 HAS BEEN SET BY POTENL.
MXXXXL=0
C
C
C SEPARATE CODE FOR ITYPE=3
IF (ITYP.EQ.3) GO TO 3330
C
C BELOW IS UNIFIED ITYPE=1,2,5,6 -- THEN SPLITS OFF FOR 5,6
IHOMO=2
IL=1
DO 3001 I=1,MXLAM
L=LAM(IL)
IF (L.GE.0) GO TO 3002
WRITE(6,695) I,L
695 FORMAT('0 * * * WARNING. LAM(I) NEGATIVE',2I5)
L=IABS(L)
LAM(IL)=L
3002 MXXXXL=MAX0(L,MXXXXL)
IF (L-2*(L/2).EQ.1) IHOMO=1
3001 IL=IL+ILOFF
C CHECK FOR 'MXSYM=0' CASE, I.E. UNEXPANDED POTENTIAL.
C N.B. IHOMO=1,2 ONLY SHOULD BE ALLOWED, NOT CHECKED BELOW.
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
LVRTP=MXXXXL.LE.0
IF (.NOT.LVRTP) GO TO 3003
IHOMO=1
IF (IH0.EQ.0) GO TO 3003
IHOMO=IH0
WRITE(6,617) IHOMO
617 FORMAT('0 * * * NOTE. IHOMO TAKEN FROM VRTP ROUTINE =',I4)
C
3003 IF (ITYP.EQ.5 .OR. ITYP.EQ.6) GO TO 3500
C *** BELOW FOR ITYPE=1,2 // SET MXXXXL, DETERMINE NGPT AND LMAX=NQL
THLO=-1.D0
THHI=1.D0
SFACT=1.D0
IF (IHOMO.EQ.1) GO TO 3200
THLO=0.D0
SFACT=SFACT*2.D0
WRITE(6,608)
608 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ',
& 'THAT POTENTIAL HAS ONLY EVEN LEGENDRE TERMS.')
C
3200 MXXXXL=MXXXXL/IHOMO+1
IF (IOSNGP(1).LE.0) GO TO 3101
NGL=IOSNGP(1)
WRITE(6,655) NGL,IOSNGP(1)
GO TO 3102
3101 I=MXXXXL*IHOMO
NGL=2*(MAX+I)
WRITE(6,656) NGL,MAX,I
3102 NGPT=NGL
IF (NGPT.LE.MXGPT) GO TO 3103
WRITE(6,607) NGPT,MXGPT
607 FORMAT('0 * * * WARNING. NGPT.GT.MXGPT -- REDUCED.')
NGPT=MXGPT
C SET UP FOR LINEAR MOLECULES / POINTS AND WEIGHTS.
3103 CALL GAUSSP(THLO,THHI,NGPT,COSA,GWT)
DO 3201 I=1,NGPT
3201 GWT(I)=GWT(I)*SFACT
WRITE(6,609) NGPT,(COSA(I),GWT(I),I=1,NGPT)
609 FORMAT('0 THETA INTEGRATION DONE BY ',I3,'-POINT GAUSSIAN ',
& 'QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6)))
C CHOOSE LMAX.
IF (LMAX.LE.0) GO TO 3301
WRITE(6,610) LMAX
610 FORMAT('0 LMAX TAKEN FROM &INPUT LMAX =',I5)
IF (LMAX.GT.NGPT*IHOMO) WRITE(6,611)
611 FORMAT('0 * * * WARNING. LMAX TOO LARGE FOR NGPT. ERRORS IN ',
& 'HIGHER Q(L) WILL RESULT.')
GO TO 3300
3301 LMAX=NGPT*IHOMO
WRITE(6,612) LMAX
612 FORMAT('0 * * * WARNING. INPUT LMAX.LE.0 (DEFAULT), WILL USE ',
& 'HIGHEST VALUE CONSISTENT WITH NGPT. LMAX =',I4)
3300 NQL=LMAX
NIXQL=2
C>>SG CHECK THAT MXXXXL IS GE TO 1 FOR FUTURE INDEXING PURPOSES
IF (MXXXXL.GE.1) RETURN
WRITE(6,990) MXXXXL
990 FORMAT('0 IOSBIN (FEB 92 CODE). MXXXXL RESET FROM',I4/
1 ' ****** WARNING. THIS IS PROBABLY AN ERROR CONDITION.')
MXXXXL=1
RETURN
C
C *** BELOW FOR ITYPE=5 AND 6 // SET MXXXXL, NGPT, LMAX, NQL
C FEB 88 CODE BELOW TO SET IHOMO FOR ITYPE=5,6.
C N.B V(PI-THETA)=V(PI) REQUIRES YLM EXIST ONLY FOR L-M EVEN
C WHICH DIFFERES FORM THE L EVEN FOR ITYPE=1,2 USED PREVIOUSLY
C>>SG 5/11/92
C>>SG 5/11/92 N.B. THIS SHOULD BE REDONE TO TAKE ADVANTAGE OF NEW GAUSSP
C>>SG 5/11/92
3500 IF (.NOT.LVRTP) GO TO 3540
IHOMO=1
IF (IH0.EQ.0) GO TO 3543
IHOMO=IH0
GO TO 3543
C ABOVE ALLOWS SETTING IN VRTP ROUTINE/ BELOW CHECKS INPUT L,M SYMS.
3540 IHOMO=2
DO 3542 L=1,MXLAM
IF (ODD(LAM(2*L),LAM(2*L-1))) IHOMO=1
3542 CONTINUE
3543 THLO=-1.D0
THHI=1.D0
SFACT=1.D0
IF (IHOMO.EQ.1) GO TO 3541
WRITE(6,618)
618 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ',
& 'THAT POTENTIAL IS SYMMETRIC ABOUT THETA=PI/2'/' * * * NOTE.')
THLO=0.D0
SFACT=2.D0
C NEXT GET ICNSYM (OLD CODE SHOULD ALWAYS STILL WORK OKEY)
3541 LMBDMX=MXXXXL
MUMX=0
DO 3501 L=1,MXLAM
3501 MUMX=MAX0(MUMX,IABS(LAM(2*L)))
C FIND ICNSYM WHICH IS PHI EQUIVALENT OF IHOMO
IF (MUMX.GT.1) GO TO 3502
C ALLOW SETTING OF ICNSYM FOR 'MXSYM=0' (UNEXPANDED POTL) CASE
ICNSYM=1
IF (.NOT.LVRTP .OR. IC0.EQ.0) GO TO 3503
ICNSYM=IC0
WRITE(6,654) ICNSYM
654 FORMAT('0 * * * NOTE. ICNSYM TAKEN FROM VRTP ROUTINE =',I4)
GO TO 3503
3502 ICNSYM=MUMX
3506 DO 3504 L=1,MXLAM
M=IABS(LAM(2*L))
IF (M-(M/ICNSYM)*ICNSYM .NE. 0) GO TO 3505
3504 CONTINUE
GO TO 3503
3505 ICNSYM=ICNSYM-1
IF (ICNSYM.GT.1) GO TO 3506
3503 PHILO=0.D0
PHIHI=PI/DBLE(ICNSYM)
SFACT=SFACT*DBLE(ICNSYM)*2.D0
C N.B. WE USE HERE FACT THAT POTENTIAL IS EVEN IN PHI SO INTEGRAL
C IS TWICE THAT FROM 0 TO PI. THIS IS REFLECTED IN HAVING ONLY
C COS (M*PHI) AND NOT SIN (M*PHI) IN PWGHT, ETC.
IF (ICNSYM.GT.1) WRITE(6,658) ICNSYM
658 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF',I4
& ,'-FOLD SYMMETRY ABOUT Z-AXIS.'/' * * * NOTE.')
C DETERMINE NO. OF LAMBDA, MU SYMMETRIES (MXXXXL)
MXXXXL=0
DO 3507 L=IZ,LMBDMX
MTOP=MIN0(MUMX,L)
DO 3507 M=IZ,MTOP,ICNSYM
IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 3507
MXXXXL=MXXXXL+1
3507 CONTINUE
C DETERMINE NO. OF GAUSSPOINTS FOR THETH(NGL) AND PHI (NGM)
C ** N.B. SOME MANEUVERING IS NECESSARY SINCE GAUSSP MAY REDUCE NPT.
WRITE(6,645) IPHIFL
645 FORMAT('0 * * * NOTE. IPHIFL (PHI INTEGRATION FLAG) =',I4)
IPASS=0
IF (IOSNGP(1).GT.0) GO TO 3510
NGL=2*(MAX+LMBDMX)
WRITE(6,656) NGL,MAX,LMBDMX
656 FORMAT('0 * * * NOTE. INPUT IOSNGP(1) .LE. 0 (DEFAULT). ',
& 'NGL =',I4,' COMPUTED FROM MAX, LMBDMX =',2I4)
GO TO 3531
3510 NGL=IOSNGP(1)
WRITE(6,655) NGL,IOSNGP(1)
655 FORMAT('0 * * * NOTE. NGL =',I4,' TAKEN FROM',
& ' &BASIS IOSNGP(1) =',I4)
3531 IF (IOSNGP(2).GT.0) GO TO 3532
NGM=MAX0(1,2*(MUMX+MXK))
WRITE(6,647) NGM,MXK,MUMX
647 FORMAT('0 * * * NOTE. INPUT IOSNGP(2) .LE. 0 (DEFAULT). NGM =',
& I4, ' COMPUTED FROM MXK, MUMX =',2I4)
GO TO 3511
3532 WRITE(6,646) IOSNGP(2)
646 FORMAT('0 * * * NOTE. NGM SET FROM &BASIS IOSNGP(2) =',I4)
NGM=MAX0(1,IOSNGP(2))
3511 CALL GAUSSP(THLO,THHI,NGL,COSA,GWT)
IF (MUMX.GT.0 .OR. IPASS.GT.0 .OR.LVRTP) GO TO 3512
NGM=1
WRITE(6,650)
650 FORMAT('0 * * * NOTE.'/' * * * NOTE. POTENTIAL HAS NO PHI ',
& 'DEPENDENCE. INTEGRAL DONE ANALYTICALLY.')
3512 IF (IPHIFL.NE.0)
&CALL GAUSSP(PHILO,PHIHI,NGM,COSA,GWT)
NGPT=NGM+NGL
IF (NGPT.LE.MXGPT) GO TO 3513
WRITE(6,607) NGPT,MXGPT
NGL=(DBLE(MXGPT)/DBLE(NGPT))*NGL
NGM=(DBLE(MXGPT)/DBLE(NGPT))*NGM
NGM=MAX0(NGM,1)
IPASS=1
GO TO 3511
3513 CALL GAUSSP(THLO,THHI,NGL,COSA,GWT)
WRITE(6,609) NGL,(COSA(I),GWT(I),I=1,NGL)
IF (IPHIFL.EQ.0) GO TO 3515
CALL GAUSSP(PHILO,PHIHI,NGM,COSA(NGL+1),GWT(NGL+1))
WRITE(6,644) NGM,(COSA(NGL+I),GWT(NGL+I),I=1,NGM)
644 FORMAT('0 PHI INTEGRATION DONE BY ',I3,'-POINT GAUSSIAN ',
& 'QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6)))
GO TO 3516
3515 IX=NGL
FACTL=(PHIHI-PHILO)/DBLE(NGM)
TH=-FACTL/2.D0
DO 3514 I=1,NGM
IX=IX+1
TH=TH+FACTL
GWT(IX)=FACTL
3514 COSA(IX)=TH
WRITE(6,651) NGM,(COSA(NGL+I),GWT(NGL+I),I=1,NGM)
651 FORMAT('0 PHI INTEGRATION DONE BY ',I3,'-POINT GAUSS-MEHLER ',
& 'CHEBYSCHEV) QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6)))
3516 WRITE(6,653) SFACT
653 FORMAT('0 ABOVE WEIGHTS MULTIPLIED BY SYMMETRY FACTOR =',D16.8)
NGPT=NGL*NGM
C NEXT CHOOSE LMAX (LMMAX,MUMAX)
IF (LMAX.LE.0) GO TO 3520
WRITE(6,610) LMAX
LMMAX=LMAX
GO TO 3523
3520 LMMAX=MIN0(NGL*IHOMO,2*MAX)
WRITE(6,612) LMMAX
C INPUT CAPABILITY ON MMAX ADDED IN VERSION 6.
3523 IF (MMAX.LE.0) GO TO 3525
MUMAX=MMAX
WRITE(6,630) MMAX
630 FORMAT('0 MMAX TAKEN FROM &INPUT MMAX =',I5)
GO TO 3524
3525 MUMAX=MIN0(NGM*ICNSYM,2*MXK,LMMAX)
WRITE(6,631) MUMAX
631 FORMAT('0 * * * WARNING. MMAX=0 (DEFAULT). WILL USE HIGHEST',
& ' VALUE CONSISTENT WITH IOSNGP(2), MMAX =',I4)
C RESET LMAX TO REFLECT *NUMBER* OF LAMBDA,MU VALUES.
C AND COUNT NQL (NUMBER OF QLT VALUES)
3524 LMAX=0
NQL=0
DO 3521 L=IZ,LMMAX
MTOP=MIN0(MUMAX,L)
DO 3521 M=IZ,MTOP,ICNSYM
IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 3521
LMAX=LMAX+1
DO 3522 I=IZ,M,ICNSYM
IF (IHOMO.EQ.2 .AND. ODD(L,I)) GO TO 3522
IX=2
IF (I.EQ.M) IX=1
NQL=NQL+IX
3522 CONTINUE
3521 CONTINUE
NIXQL=3
RETURN
C
C ITYPE=3 CODE ADDED 5/6/92 (SG)
C GET POTENL SYMS. (ITYPE=3 USES IHOMO,ICNSYM FOR IHOMO1,IHOMO2)
3330 L1MAX=0
L2MAX=0
LLMAX=0
IL=0
DO 3331 I=1,MXLAM
L1MAX=MAX0(L1MAX,LAM(IL+1))
L2MAX=MAX0(L2MAX,LAM(IL+2))
LLMAX=MAX0(LLMAX,LAM(IL+3))
3331 IL=IL+ILOFF
MXXXXL=MAX0(MXXXXL,L1MAX,L2MAX,LLMAX)
LVRTP=MXXXXL.LE.0
IF (.NOT.LVRTP) GO TO 3332
C ?? MXXXXL=1 THIS WILL BE TAKEN CARE OF IN 3336 LOOP
IHOMO=1
ICNSYM=1
IF (IH0.EQ.0) GO TO 3333
IHOMO=IH0
WRITE(6,637) IHOMO
637 FORMAT('0 * * * NOTE. IHOMO (MOL 1) TAKEN FROM VRTP ROUTINE =',I4)
3333 IF (IC0.EQ.0) GO TO 3334
ICNSYM=IC0
WRITE(6,638) ICNSYM
638 FORMAT('0 * * * NOTE. IHOMO (MOL 2) TAKEN FROM VRTP ROUTINE =',I4)
GO TO 3334
C FOR EXPANDED POTENTIAL (.NOT.LVRTP) GET IHOMO1,IHOMO2 FROM LAM
3332 IHOMO=2
ICNSYM=2
DO 3335 I=1,MXLAM
IF (ODD(LAM(3*I-2),0)) IHOMO=1
3335 IF (ODD(LAM(3*I-1),0)) ICNSYM=1
3334 IM=1
IF (IHOMO.EQ.2) WRITE(6,639) IM
639 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ',
& 'THAT POTENTIAL IS SYMMETRIC ABOUT PI/2 FOR MOLECULE',I3)
IM=2
IF (ICNSYM.EQ.2) WRITE(6,639) IM
C>>SG (5/18/92) STORE IHOMO,ICNSYM BACK IN IH0,IC0 FOR USE IN IOSOUT
IH0=IHOMO
IC0=ICNSYM
C COUNT L1,L2,LL SYMMETRIES (MXXXXL)
C FOR IDENT PARTICLES, L1,L2<->L2,L1 MUST BOTH BE IN POTL SYMS
MXXXXL=0
DO 3336 L1=IZ,L1MAX,IHOMO
L2TOP=L2MAX
IF (IDENT.GT.0) L2TOP=L1MAX
DO 3336 L2=IZ,L2TOP,ICNSYM
LLO=ABS(L1-L2)
LHI=L1+L2
DO 3336 LL=LLO,LHI
IF (ODD(L1+L2,LL)) GO TO 3336
MXXXXL=MXXXXL+1
3336 CONTINUE
C SET INTEGRATION LIMITS AND GET GAUSS POINTS
C CURRENT GAUSSP (5/6/92) DOES *ARBITRARY* NO PTS;
C IF REQUEST EXCEEDS DIMENSIONS (MXGPT) TERMINATE.
SFACT=1.D0
IF (IOSNGP(1)*IOSNGP(2)*IOSNGP(3).GT.0 .AND.
1 IOSNGP(1)+IOSNGP(2)+IOSNGP(3).LE.MXGPT) GO TO 3337
WRITE(6,636) IOSNGP,MXGPT
636 FORMAT('0 IOSBGP. ERROR. IOSNGP INPUT, ',3I5,' ILLEGAL OR ',
1 'EXCEEDS STORAGE (MXGPT) =',I5)
STOP
3337 NGP1=IOSNGP(1)
THLO=-1.D0
THHI=1.D0
IF (IHOMO.EQ.2) THEN
THLO=0.D0
SFACT=SFACT*2.D0
ENDIF
CALL GAUSSP(THLO,THHI,NGP1,COSA(1),GWT(1))
WRITE(6,609) NGP1,(COSA(I),GWT(I),I=1,NGP1)
NGP2=IOSNGP(2)
IST2=NGP1
THLO=-1.D0
IF (ICNSYM.EQ.2) THEN
THLO=0.D0
SFACT=SFACT*2.D0
ENDIF
CALL GAUSSP(THLO,THHI,NGP2,COSA(IST2+1),GWT(IST2+1))
WRITE(6,609) NGP2,(COSA(IST2+I),GWT(IST2+I),I=1,NGP2)
WRITE(6,645) IPHIFL
PHILO=0.D0
C CAN ALWAYS USE SYMMETRY V(-PHI)=V(PHI) TO REDUCE INTEGRAL
C FROM (0,2*PI) TO (0,PI) -- CORRECT SFACT ACCORDINGLY
PHIHI=PI
SFACT=SFACT*2.D0
IST3=IST2+NGP2
NGM=IOSNGP(3)
IF (IPHIFL.EQ.0) GO TO 3338
CALL GAUSSP(PHILO,PHIHI,NGM,COSA(IST3+1),GWT(IST3+1))
WRITE(6,644) NGM,(COSA(IST3+I),GWT(IST3+I),I=1,NGM)
GO TO 3339
3338 IX=IST3
FACTL=(PHIHI-PHILO)/DBLE(NGM)
TH=-FACTL/2.D0
DO 3342 I=1,NGM
IX=IX+1
TH=TH+FACTL
GWT(IX)=FACTL
3342 COSA(IX)=TH
WRITE(6,651) NGM,(COSA(IST3+I),GWT(IST3+I),I=1,NGM)
C SET NGPT AS PRODUCT OF THETA-1, THETA-2, PHI GRIDS
3339 NGPT=NGP1*NGP2*NGM
WRITE(6,653) SFACT
C RESET LMAX AND NQL=LMAX TO REFLECT NUMBER OF L1,L2,LL VALUES
C USE ITYP=5,6 VARIABLES: LMMAX FOR L1, MUMAX FOR L2
IF (LMAX.GT.0) GO TO 3340
LMMAX=(NGP1-1)*IHOMO
WRITE(6,640) LMAX,LMMAX,NGP1,IHOMO
640 FORMAT('0 &INPUT LMAX =',I4,' -- L1MAX =',I4,' CALCULATED FROM ',
1 ' NGP1 AND (SYMMETRY) IHOMO =',2I4)
GO TO 3344
3340 LMMAX=LMAX
WRITE(6,641) LMAX
641 FORMAT(' L1MAX TAKEN FROM &INPUT LMAX =',I4)
3344 IF (MMAX.GT.0) GO TO 3343
MUMAX=(NGP2-1)*ICNSYM
WRITE(6,642) MMAX,MUMAX,NGP2,ICNSYM
642 FORMAT('0 &INPUT MMAX =',I4,' -- L2MAX =',I4,' CALCULATED FROM ',
1 ' NGP2 AND (SYMMETRY) ICNSYM=',2I4)
GO TO 3345
3343 MUMAX=MMAX
WRITE(6,643) MMAX
643 FORMAT(' L2MAX TAKEN FROM &INPUT MMAX =',I4)
3345 LMAX=0
DO 3341 L1=IZ,LMMAX,IHOMO
L2TOP=MUMAX
C IDENTICAL PARTICLES KEEP ONLY L1.GE.L2 IN LM(,)
IF (IDENT.GT.0) L2TOP=L1
DO 3341 L2=IZ,L2TOP,ICNSYM
LLO=ABS(L1-L2)
LHI=L1+L2
DO 3341 LL=LLO,LHI
IF (ODD(L1+L2,LL)) GO TO 3341
LMAX=LMAX+1
3341 CONTINUE
NQL=LMAX
NIXQL=2
RETURN
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY IOSB1(PWGHT,VLI,IXQL,LM,NGPT,LMAX,MXXXXL,NIXQL,NQL)
C
IF (ITYP.EQ.3) GO TO 4300
IF (ITYP.EQ.5 .OR. ITYP.EQ.6) GO TO 4500
C
C N.B. FOR ITYPE=1,2 LMAX=NQL
C PWGHT MULTIPLY SL(COS(THETA)) TO GET LEGENDRE COEFFICIENTS
FACTL=-.5D0
DO 4100 L=1,LMAX
IXQL(1,L)=L
IXQL(2,L)=0
LM1=L-1
LM(1,L)=LM1
FACTL=FACTL+1.D0
DO 4101 NX=1,NGPT
C N.B. WE KEEP EVEN AND ODD L FOR HOMONUCLEARS, BUT SET TO 0. IF NEC
PWGHT(NX,L)=0.D0
IF (IHOMO.EQ.2 .AND. L-2*(L/2).EQ.0) GO TO 4101
PWGHT(NX,L)=FACTL*GWT(NX)*XLEG(L-1,COSA(NX))
4101 CONTINUE
4100 CONTINUE
C NEXT COMPUTE VLI
DO 4200 NX=1,NGPT
L=0
DO 4201 IL=1,MXXXXL
VLI(NX,IL)=XLEG(L,COSA(NX))
4201 L=L+IHOMO
4200 CONTINUE
RETURN
C
C ITYPE=3 -- SETUP VLI
4300 I=0
IF (LNEW) GO TO 4993
C>>SG 5/21/92 BELOW IS OLD CODE - BYPASSED FOR LNEW=.TRUE.
DO 4301 IX1=1,NGP1
DO 4301 IX2=1,NGP2
DO 4301 IX3=1,NGM
C I COUNTS GAUSS POINTS TO NGPT.
I=I+1
IL=0
DO 4301 L1=IZ,L1MAX,IHOMO
L2TOP=L2MAX
IF (IDENT.GT.0) L2TOP=L1MAX
DO 4301 L2=IZ,L2TOP,ICNSYM
LLO=ABS(L1-L2)
LHI=L1+L2
DO 4301 LL=LLO,LHI
IF (ODD(L1+L2,LL)) GO TO 4301
C IL COUNTS SYMMETRIES IN POTENTIAL TO L1MAX,L2MAX
IL=IL+1
VLI(I,IL)=YRR(L1,L2,LL,COSA(IX1),COSA(IST2+IX2),COSA(IST3+IX3))
4301 CONTINUE
PIFACT=2.D0*PI*SFACT
IL=0
DO 4302 L1=IZ,LMMAX,IHOMO
L2TOP=MUMAX
IF (IDENT.GT.0) L2TOP=L1
DO 4302 L2=IZ,L2TOP,ICNSYM
LLO=ABS(L1-L2)
LHI=L1+L2
DO 4302 LL=LLO,LHI
IF (ODD(L1+L2,LL)) GO TO 4302
XLFACT=1.D0/(2.D0*LL+1.D0)
IL=IL+1
IXQL(1,IL)=IL
IXQL(2,IL)=0
LM(1,IL)=L1
LM(2,IL)=L2
LM(3,IL)=LL
I=0
DO 4303 IX1=1,NGP1
DO 4303 IX2=1,NGP2
DO 4303 IX3=1,NGM
I=I+1
4303 PWGHT(I,IL)=GWT(IX1)*GWT(IST2+IX2)*GWT(IST3+IX3)*
1 YRR(L1,L2,LL,COSA(IX1),COSA(IST2+IX2),COSA(IST3+IX3))
2 *PIFACT*XLFACT
4302 CONTINUE
GO TO 4998
C>>SG 5/21/92 ------- END OF OLD CODE
C
C NEW CODE 5/21/92 MUCH MORE EFFICIENT. YRR() ASSEMBLED AS NEEDED
C AVOIDING RECALCULATION OF THRJ, PLM, ETC.
4993 DEN=SQRT(4.D0*PI)*2.D0*PI
DO 4310 IL=1,MXXXXL
DO 4310 IX=1,NGPT
4310 VLI(IX,IL)=0.D0
MTOP=MIN0(L1MAX,L2MAX)
DO 4311 M=IZ,MTOP
PTM=PARITY3(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=PARITY3(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=PARITY3(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=PARITY3(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=PARITY3(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=PARITY3(L2)
DO 4327 IX=1,NGP2
4327 PL2(IX)=PLM(L2,M,COSA(IST2+IX))*PTL2
4326 LLO=ABS(L1-L2)
LHI=L1+L2
DO 4323 LL=LLO,LHI
IF (ODD(L1+L2,LL)) GO TO 4323
IL=IL+1
C STORE IXQL, LM ONLY FOR M=0 PASS ONLY.
IF (M.GT.0) GO TO 4328
IXQL(1,IL)=IL
IXQL(2,IL)=0
LM(1,IL)=L1
LM(2,IL)=L2
LM(3,IL)=LL
4328 IF (L1.LT.M .OR. L2.LT.M) GO TO 4323
XL=LL
C TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*PIFACT/(2.D0*XL+1.D0)
C 2*L+1 FACTOR CANCELS THAT IN DEF OF YRR ???
TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*PIFACT
I=0
DO 4329 IX1=1,NGP1
DO 4329 IX2=1,NGP2
DO 4329 IX3=1,NGM
I=I+1
4329 PWGHT(I,IL)=PWGHT(I,IL)+PL1(IX1)*PL2(IX2)*COSM(IX3)*TJ
4323 CONTINUE
4321 CONTINUE
C END OF M-LOOP - PWGHT NOW CONTAINS YRR; NEED TO MULT BY GAUSS WTS
I=0
DO 4330 IX1=1,NGP1
DO 4330 IX2=1,NGP2
DO 4330 IX3=1,NGM
I=I+1
WTFACT=GWT(IX1)*GWT(IST2+IX2)*GWT(IST3+IX3)
DO 4330 IL=1,LMAX
4330 PWGHT(I,IL)=PWGHT(I,IL)*WTFACT
C
4998 WRITE(6,659) (I,LM(1,I),LM(2,I),LM(3,I),I=1,LMAX)
659 FORMAT('0 BI-SPHERICAL HARMONICS FOR EXPANDING S-MATRIX ARE ',
1'AS FOLLOWS'/'0 INDX L1 L2 LL'/(' ',4I4))
RETURN
C
C ITYPE=5,6 -- COMPUTE VLI
4500 I=0
DO 4501 NX=1,NGL
DO 4501 IX=1,NGM
I=I+1
IL=0
DO 4501 L=IZ,LMBDMX
MTOP=MIN0(MUMX,L)
DO 4501 M=IZ,MTOP,ICNSYM
IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 4501
IL=IL+1
VLI(I,IL)=PLM(L,M,COSA(NX))/SQRT(2.D0*PI)
IF (M.NE.0) VLI(I,IL)=VLI(I,IL)*2.D0*COS(DBLE(M)*COSA(NGL+IX))
4501 CONTINUE
C SETUP PWGHT
FACTL=1.D0/SQRT(2.D0*PI)
IL=0
DO 4502 L=IZ,LMMAX
MTOP=MIN0(L,MUMAX)
DO 4502 M=IZ,MTOP,ICNSYM
IF (IHOMO.EQ.2 .AND.ODD(L,M)) GO TO 4502
IL=IL+1
IV=0
DO 4503 IX=1,NGL
DO 4503 NX=1,NGM
IV=IV+1
4503 PWGHT(IV,IL)=GWT(IX)*GWT(NGL+NX)*PLM(L,M,COSA(IX))*
& COS(DBLE(M)*COSA(NGL+NX))*
2 (SFACT*FACTL)
4502 CONTINUE
I=0
IX=0
DO 4505 L=IZ,LMMAX
MTOP=MIN0(MUMAX,L)
DO 4505 M=IZ,MTOP,ICNSYM
IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 4505
I=I+1
LM(1,I)=L
LM(2,I)=M
DO 4504 IL=1,I
IF (LM(1,IL).NE.L) GO TO 4504
IX=IX+1
IXQL(1,IX)=I
IXQL(2,IX)=IL
IF (I.NE.IL) GO TO 4506
IXQL(3,IX)=0
GO TO 4504
4506 IXQL(3,IX)=1
IX=IX+1
IXQL(1,IX)=I
IXQL(2,IX)=IL
IXQL(3,IX)=2
4504 CONTINUE
4505 CONTINUE
WRITE(6,657) (I,LM(1,I),LM(2,I),I=1,LMAX)
657 FORMAT('0 SPHERICAL HARMONIC SYMMETRIES FOR EXPANDING S-MATRIX ',
1 'ARE AS FOLLOWS'/'0 INDX L M'/(' ',2I4,I3))
WRITE(6,649)
649 FORMAT('0 BELOW ARE INDICES TO SYMMETRIES IN QLT'/
&'0 IN QLT LM1 L M LM2 L M CODE')
DO 4507 I=1,NQL
IL=IXQL(1,I)
IX=IXQL(2,I)
4507 WRITE(6,648) I,IL,LM(1,IL),LM(2,IL),IX,LM(1,IX),LM(2,IX),IXQL(3,I)
648 FORMAT(' ',I7,I6,2I3,I6,2I3,I6)
RETURN
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY IOSB2(JTOT,LORB,JJJ,NB,CENT,EINT,CINT,WVEC,VL,IVIX,IP,
& NVC,ERED,NPOTL,MXLAM,LAM,VLI,NGPT,MXXXXL)
C
XJ=JTOT
XJ=XJ*(XJ+1.D0)
DO 6666 I=1,NVC
LORB(I)=JTOT
JJJ(I)=I
NB(I)=I
CENT(I)=XJ
EINT(I)=CINT*EV(I)
DIF=ERED-EINT(I)
WVEC(I)=SQRT(ABS(DIF))
IF (DIF.GE.0.D0) GO TO 6666
WVEC(I)=-WVEC(I)
6666 CONTINUE
C
GO TO IGOTP,(6100,6200,6300,6500)
C
C CHECK FOR CONSISTENT IVLFL
6100 IF (IVLFL.NE.0) GO TO 9999
DO 6101 I=1,MXLAM
IL=LAM(I)/IHOMO + 1
C IVIX(I)=I
6101 VL(I)=VLI(IP,IL)
C SET COSANG, FACTOR FOR MXLAM.LE.0 CASE
COSANG(1)=COSA(IP)
FACTOR=1.D0
GO TO 6900
C
C>>SG -------------- NEW CODE --------------------->>
C>>SG CHECK FOR NPOTL=1 (LVRTP) OR NPOTL=MXLAM (EXPANDED)
C>>SG LATTER CASE UNCHANGED FROM VERSION 10 CODE
C>>SG JAN 94: *ALL* ITYPE=2 NOW HAVE IVLFL=1; NPOTL.LE.MXLAM
6200 IF (IVLFL.LE.0) GO TO 9999
C ZERO IVIX,VL STORAGE
ITOP=NVC*(NVC+1)*NPOTL/2
DO 6202 IX=1,ITOP
IVIX(IX)=0
6202 VL(IX)=0.D0
IF (.NOT.LVRTP ) GO TO 6250
C
C UNEXPANDED 'LVRTP' POTENTIAL (BELOW HAS A LOT OF 'DEBUGGING' TEST)
IF (NPOTL.NE.1) THEN
WRITE(6,670) NPOTL,MXLAM
670 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LVRTP INCONSISTENT WITH',
1 ' NPOTL, MXLAM',2I6)
STOP
ENDIF
DO 6203 L=1,MXLAM
LLL=LAM(3*L-2)
IL=LLL/IHOMO+1
C N.B. WE SHOULD HAVE LLL=0 AND IL=1 *** DEBUGGING ONLY ***
IF (LLL.NE.0 .OR. IL.NE.1) WRITE(6,672) LLL,IL
672 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LLL.NE.0 .OR IL.NE.1',2I6)
IV=LAM(3*L-1)
IVP=LAM(3*L)
IVVP=0
DO 6204 IROW=1,NVC
NV=LEVV(IROW)
DO 6204 ICOL=1,IROW
NVP=LEVV(ICOL)
IVVP=IVVP+1
IF (.NOT.((NV.EQ.IV.AND.NVP.EQ.IVP).OR.(NV.EQ.IVP.AND.NVP.EQ.IV)))
1 GO TO 6204
C IF WE REACH BELOW, THIS ROW/COL CORRESPONDS TO CURRENT 'SYMMETRY'
IX=(IVVP-1)*NPOTL+LLL+1
C SINCE NPOTL=1 AND LLL=0, SHOULD HAVE IX=IVVP *** DEBUGGING ***
IF (IX.NE.IVVP) WRITE(6,673) IX,IVVP
673 FORMAT('0 IOSB2 (FEB 92) -- ERROR. IX.NE.IVVP FOR VL,IVIX',2I6)
IVIX(IX)=L
VL(IX)=VLI(IP,IL)
6204 CONTINUE
6203 CONTINUE
C SET COSANG, FACTOR FOR VRTP CASE, AND RETURN
COSANG(1)=COSA(IP)
FACTOR=1.D0
GO TO 6900
C
C CODE BELOW FOR POTENTIAL EXPANDED IN LEGENDRE POLY'S
C MODIFIED TO USE IV() INDEXING
C
6250 IF (MXXXXL.GT.NPOTL) THEN
WRITE(6,*) ' IOSB2. MXXXXL.GT.NPOTL NOT ALLOWED',MXXXXL,NPOTL
STOP
ENDIF
DO 6251 L=1,MXLAM
IL=LAM(3*L-2)/IHOMO + 1
C DEBUGGING ...
IF (IL.GT.MXXXXL) THEN
WRITE(6,*) ' IOSB2. IL.GT.MXXXXL SHOULD NOT OCCUR',IL,MXXXXL
ENDIF
LV1=LAM(3*L-1)
LV2=LAM(3*L)
IVVP=0
DO 6252 IV=1,NVC
DO 6252 IVP=1,IV
IVVP=IVVP+1
IF (LEVV(IV).EQ.LV1 .AND. LEVV(IVP).EQ.LV2) GO TO 6253
IF (LEVV(IV).EQ.LV2 .AND. LEVV(IVP).EQ.LV1) GO TO 6253
GO TO 6252
6253 IX=(IVVP-1)*NPOTL+IL
IVIX(IX)=L
VL(IX)=VLI(IP,IL)
6252 CONTINUE
6251 CONTINUE
GO TO 6900
C
C CHECK FOR CONSISTENT IVLFL
6300 IF (IVLFL.NE.0) GO TO 9999
IL=0
DO 6301 L1=IZ,L1MAX,IHOMO
L2TOP=L2MAX
IF (IDENT.GT.0) L2TOP=L1MAX
DO 6301 L2=IZ,L2TOP,ICNSYM
LLO=ABS(L1-L2)
LHI=L1+L2
DO 6301 LL=LLO,LHI
IF (ODD(L1+L2,LL)) GO TO 6301
IL=IL+1
DO 6302 I=1,MXLAM
IF (L1.NE.LAM(3*I-2)) GO TO 6302
IF (L2.NE.LAM(3*I-1)) GO TO 6302
IF (LL.NE.LAM(3*I )) GO TO 6302
C IVIX(I)=I
VL(I)=VLI(IP,IL)
IF (LDEBUG) WRITE(6,635) I,L1,L2,LL,IL
635 FORMAT(' IOSB2. DEBUG. I,L1,L2,LL,IL',5I5)
6302 CONTINUE
6301 CONTINUE
C FOR 'VRTP' CASE NEED TO SET COSANG(), FACTOR =(4*PI)**(3/2)
FACTOR=(4.D0*PI)*SQRT(4.D0*PI)
C CALCULATE IX1,IX2,IX3 FROM IP (# OF GAUSS POINT)
IX3=IP
IX1=(IX3-1)/(NGP2*NGM)+1
IX3=IX3-(IX1-1)*(NGP2*NGM)
IX2=(IX3-1)/NGM+1
IX3=IX3-(IX2-1)*NGM
COSANG(1)=COSA(IX1)
COSANG(2)=COSA(IST2+IX2)
COSANG(3)=COSA(IST3+IX3)
GO TO 6900
C<<SG --------------------------------------- END OF MODIFICATIONS
C
C CHECK FOR CONSISTENT IVLFL
6500 IF (IVLFL.NE.0) GO TO 9999
IL=0
DO 6501 L=IZ,LMBDMX
MTOP=MIN0(MUMX,L)
DO 6501 M=IZ,MTOP,ICNSYM
IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 6501
IL=IL+1
DO 6502 I=1,MXLAM
IF (L.NE.LAM(2*I-1) .OR. M.NE.LAM(2*I) ) GO TO 6502
C IVIX(I)=I
VL(I)=VLI(IP,IL)
6502 CONTINUE
6501 CONTINUE
C FOR MXLAM.LE.0 CASE, SET COSANG, FACTOR (SQRT(4*PI) FOR ITYPE=5,6)
IL=(IP-1)/NGM
IJ=IP-NGM*IL
IL=IL+1
COSANG(1)=COSA(IL)
COSANG(2)=COSA(NGL+IJ)
FACTOR=SQRT(4.D0*PI)
C FACTOR=3.544907703D0
GO TO 6900
C
C COMMON RETURN PT -- ALLOW FOR (DEBUGGING) OUTPUT OF COUPLING MATRIX
6900 IF (LDEBUG) CALL CPLOUT(IVIX,VL,NVC,NPOTL)
RETURN
C
9999 WRITE(6,690) IVLFL,ITYP
690 FORMAT(/' IOSBIN (JAN 93). IVLFL=',I5,
1 ' INCONSISTENT WITH ITYP=',I5)
STOP
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY IXQLF(LM,LMAX,LX,M1,M2,ICDE,INDX,IXQL,NIXQL,NQL)
C
C N.B. M1.GE.M2 AND M1,M2.GE.0 ARE **ASSUMED** HERE
C IT IS POSSIBLE TO IMPLEMENT A MORE GENERAL CODE
C N.B. THIS SHOULD ONLY BE CALLED FOR ITYPE=5,6 / NOT CHECKED HERE
C RETURN INDX=-1 IF L, M1, OR M2 ARE SYMMETRY FORBIDDEN.
IF (M1-ICNSYM*(M1/ICNSYM).NE.0) GO TO 7002
IF (M2-ICNSYM*(M2/ICNSYM).NE.0) GO TO 7002
C IF (LX-IHOMO*(LX/IHOMO).NE.0) GO TO 7002 <KILLED FEB 88>
IF (IHOMO.EQ.2 .AND. ODD(LX,M1)) GO TO 7002
IF (IHOMO.EQ.2 .AND. ODD(LX,M2)) GO TO 7002
ICODE=ICDE
IF (M1.EQ.M2) ICODE=0
INDX=0
DO 7001 I=1,NQL
IF (LX.NE.LM(1,IXQL(1,I))) GO TO 7001
IF (M1.NE.LM(2,IXQL(1,I))) GO TO 7001
IF (M2.NE.LM(2,IXQL(2,I))) GO TO 7001
IF (ICODE.NE.IXQL(3,I)) GO TO 7001
INDX=I
RETURN
7001 CONTINUE
RETURN
7002 INDX=-1
RETURN
C
END
SUBROUTINE IOSCLC(NNRG,ENERGY,JTOTL,JTOTU,JSTEP,INTFLG,PRINT,ISU,
1 ITYPX,RMIN,RMAX,DEEP,IRMSET,IRXSET,RVFAC,NUMDER,
2 NCAC,TEST,RM,EPSIL,NVC,LMAX,NGPT,NQL,NIXQL,
3 MXXXXL,LAMBDA,MXLAM,NPOTL,VLI,
4 PWGHT,SLR,SLI,QLT,QLS,
5 SLLR,SLLI,IXQL,SIGTH,SIGAV,IEC,LM,
6 IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT,
7 IXWV,IXJJJ,IXLORB,IXNB,WVEC,NB,
8 IFLS,MXLN,LINE,LTYPE)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C>>SG MODIFIED MAY 92 - ITYPE=3 / ADD JSTEP TO IOSOUT PARMS / ISAVEU
C>>SG MODIFIED FEB 92 FOR SOME CLOSED-CHANNEL HANDLING
C *** 14 JULY 86 FIX ISCRU BUG
INTEGER PRINT
LOGICAL NUMDER
DIMENSION ENERGY(NNRG),TEST(2),LAMBDA(MXLAM)
DIMENSION WVEC(NVC),NB(NVC)
DIMENSION PWGHT(NGPT,LMAX),SLR(NVC,NVC,NGPT),SLI(NVC,NVC,NGPT),
& QLS(NVC,NVC),QLT(NVC,NVC,NQL),SIGTH(NVC,NVC,NGPT),
& SIGAV(NVC,NVC),SLLR(NVC,NVC,LMAX),SLLI(NVC,NVC,LMAX),
& VLI(NGPT,MXXXXL)
DIMENSION IEC(NQL),IXQL(NIXQL,NQL),LM(3,LMAX)
DIMENSION LINE(2,MXLN),LTYPE(MXLN)
C
C N.B. SREAL,SIMAG ARE DIM (NVC,NVC), BUT SCATTERING ROUTINE
C REDUCES THIS TO (NOPEN,NOPEN). HANDLED HERE AS 1-D VECTOR.
C MOST OF 'SCATTERING' VARIABLES ARE PASSED HERE AS ADDR. IN X().
C BUT WVEC AND NB ARE ALSO PASSED AS VECTORS FOR CONVENIENCE.
C N.B. V IS CORRECTION FOR 'VOLUME' IN ANGULAR INTEGRAL
C FOR ITYPE=1,2 V=1.
C FOR ITYPE=3,5,6 V=1/(4*PI)
C CALCULATION OF QLS(0) AND SIGAV DEPENDS ON FACT THAT 1ST SYMMETRY
C IN PWGHT IS SPHERICAL, CORRECTED BY V.
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS
C *** IT APPEARS THAT ONLY 'NOPEN' IS NEEDED IN FOLLOWING BLOCK
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
CHARACTER*4 LEFT
DATA LEFT/'SIG('/
C
C INITIALIZE VARIOUS PARAMETERS
PI=ACOS(-1.D0)
NUSED=0
ITYPE=ITYPX-10*(ITYPX/10)
C NOPEN MUST BE SET INITIALLY TO HANDLE 'NVC' COUNTING
NOPEN=1
C SET ICX TO NEXT LOCATION (HAD BEEN ARGUMENT IC IN V11)
ICX=IXNEXT
C V IS A (NORMALIZATION) FACTOR FOR CALCULATING QLT() FROM S*S
C AVGFCT FOR SPHERICAL AVG IN TERMS OF LOWEST SYMMETRY PWGHT
C>>SG N.B. ITYPE=3 VALUES DIFFER FROM GOLDFLAM-KOURI AND AGG-CLARY
C ITYPE V AVGFCT
C 1,2 1. 1.
C 3 1/4*PI 1./SQRT(4*PI)
C 5,6 1/4*PI 1./SQRT(4*PI)
V=1.D0
IF (ITYPE.EQ.5.OR.ITYPE.EQ.6.OR.ITYPE.EQ.3) V=1.D0/(4.D0*PI)
AVGFCT=SQRT(V)
CINT=RMLMDA/EPSIL
C INITIALIZE RSTART, IN CASE IRMSET.LE.0 AND FINDRM NOT CALLED
RMINSV=RMIN
RSTART=RMIN
CALL GCLOCK (TITIME)
C
C PRINT LEVEL FOR SCATTERING CAN BE LESS THAN FOR IOS1
C
IOSPR=MAX0(0,PRINT-10)
C
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C LOOP OVER ENERGIES.
C
DO 2000 IE=1,NNRG
ICODE=1
IF(IE.GT.1 .AND. ISCRU.GT.0) ICODE=2
IF(ISCRU.GT.0) REWIND ISCRU
WRITE(6,622) IE,ENERGY(IE)
622 FORMAT('1 IOSCLC (MAY 92). ENERGY(',I3,') =',F12.4,' (1/CM).')
ERED=ENERGY(IE)*CINT
IF (IE.EQ.1) EFIRST=ERED
ESHIFT=ERED-EFIRST
C A MORE SOPHISTICATED WAY OF SAVING RTURN IS PROBABLY WANTED,
C BUT BELOW SHOULD WORK AS A TEMPORARY MEASURE
RTURN=RMINSV
C ZERO STORAGE
DO 2100 I=1,NQL
2100 IEC(I)=0
DO 2109 IV=1,NVC
DO 2109 IVP=1,NVC
QLS(IV,IVP)=0.D0
SIGAV(IV,IVP)=0.D0
DO 2101 I=1,NQL
2101 QLT(IV,IVP,I)=0.D0
DO 2102 I=1,NGPT
2102 SIGTH(IV,IVP,I)=0.D0
2109 CONTINUE
C
C LOOP OVER PARTIAL WAVES
C
DO 3000 JTOT=JTOTL,JTOTU,JSTEP
IF (PRINT.GT.1) WRITE(6,626) JTOT,IE,ENERGY(IE)
626 FORMAT('0 ***** PARTIAL WAVE =',I5,' FOR ENERGY(',I3,') = ',
& F12.4,' *****')
C
IF (JTOTU.LT.999999) GO TO 3001
C CHECK FOR CONVERGENCE
C ONLY CHECK FOR QLT WHERE IXQL(NIXQL,IL).EQ.0
DO 3002 IL=1,LMAX
IF (IXQL(NIXQL,IL).NE.0) GO TO 3002
IF (IEC(IL).LT.NCAC) GO TO 3001
3002 CONTINUE
CALL GCLOCK(TJTIME)
TIME=TJTIME-TITIME
TITIME=TJTIME
JTO=JTOT-JSTEP
WRITE(6,620) IE,ENERGY(IE),LMAX,NCAC,TEST,JTOTL,JSTEP,JTO
620 FORMAT('1 ***** ***** ***** CALCULATION AT ENERGY(',I3,') =',
1 F10.2,' (1/CM) ',
& ' TERMINATED DUE TO CONVERGENCE FOR',I4,' Q(L).'/
& 22X,'NCAC, TEST =',I4,2E12.4/
2 22X,'PARTIAL WAVES',I4,' (',I4,' ) ',I5)
WRITE(6,641) TIME
641 FORMAT('0 ***** ***** ***** TIME WAS',F9.2,' SEC.'/' ')
GO TO 3009
3001 FACTL=(2*JTOT+1)*PI
C
C GET ANGLE-DEPENDENT SCATTERING / LOOP OVER GAUSS POINTS.
DO 3100 IP=1,NGPT
C
C INITIALIZE SCAT VARIABLES VL, LORB, EINT, ETC.
CALL IOSB2(JTOT,X(IXLORB),X(IXJJJ),NB,X(IXCENT),X(IXEINT),CINT,
1 WVEC,X(IXVL),X(IXIV),IP,NVC,ERED,NPOTL,MXLAM,LAMBDA,VLI,
2 NGPT,MXXXXL)
C
CONV=0.D0
RTURN=RSTART
IF(ICODE.NE.1) GOTO 3005
CALL FINDRX(ENERGY(IE),X(IXEINT),X(IXCENT),1,NVC,CINT,RMAX,RSTOP,
1 NOPMAX,IRXSET,IOSPR)
C
IF(IRMSET.LE.0) GOTO 3005
C GET TEMPORARY STORAGE FOR FINDRM; MODIFED 23 AUG FOR NEW FINDRM (SG)
IT1=ICX
IT2=IT1+MXLAM
IT3=IT2+NVC
IT4=IT3+NVC
IXNEXT=IT4+NVC
CALL CHKSTR(NUSED)
CALL FINDRM(X(IXSR),NVC,RSTART,RTURN,IK,X(IT1),X(IXVL),X(IXIV),
1 ERED,X(IXEINT),X(IXCENT),RMLMDA,X(IXSI),X(IT2),X(IT3),X(IT4),
2 MXLAM,NPOTL,IRMSET,ITYPE,IOSPR)
C RELEASE TEMPORARY STORAGE
IXNEXT=IT1
IF(RVFAC.EQ.0.D0) GOTO 3005
RMID=RVFAC*RTURN
IF(IOSPR.GE.3) WRITE(6,3003) RMID,RVFAC
3003 FORMAT('0 RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3)
C
C NOW READY TO SOLVE 'COUPLED' EQUATIONS; DONE AS CALL TO STORAG.
C
3005 NV=NPOTL*NVC*(NVC+1)/2
CALL STORAG( INTFLG,NVC,MXLAM,NV,NPOTL,
1 IXJJJ,IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT,
2 IXWV,IXLORB,IXNB,
3 ESHIFT,NOPMAX,DEEP,IK,ICODE,IOSPR, NUMDER)
C
C INITIALIZE TO UNIT S-MATRIX TO CLEAR 'NON-CLASSICAL' CHANNELS.
C
4000 DO 4005 IV=1,NVC
DO 4005 IVC=1,NVC
DELVVP=0.D0
IF (IV.EQ.IVC) DELVVP=1.D0
SLR(IV,IVC,IP)=DELVVP
4005 SLI(IV,IVC,IP)=0.D0
IF (NOPEN.GT.0) GO TO 4009
WRITE(6,699) IP,NOPEN
699 FORMAT(' * * * NOTE. FOR ORIENTATION',I6,' NOPEN =',I3)
GO TO 3100
4009 IF (NOPEN.LE.NVC) GO TO 4008
WRITE(6,698) IP,NOPEN,NVC
698 FORMAT(' * * * ERROR. FOR ORIENTATION',I6,' NOPEN.GT.NVC',2I6)
GO TO 3100
4008 IF (CONV.GE.0.D0) GO TO 4007
WRITE(6,696) JTOT,IP
696 FORMAT('0 * * * WARNING. SLR,SLI,SIGTH NOT SET DUE TO LACK OF CON
&VERGENCE FOR PART. WAVE',I4,' ORIENTATION',I5)
GO TO 3100
C
4007 IF (PRINT.GE.15) WRITE(6,601)
601 FORMAT(' ')
NNP=0
DO 4200 N=1,NOPEN
IV=NB(N)
WV=RM/WVEC(IV)
C SET WVEC(IV) TO WAVENUMBER IN 1/ANGSTROMS FOR ISAVEU OUTPUT
WVEC(IV)=1.D0/WV
WV=WV*WV*FACTL
DO 4200 NP=1,NOPEN
IVP=NB(NP)
NNP=NNP+1
DELVVP=0.D0
IF (IV.EQ.IVP) DELVVP=1.D0
C BELOW CHANGED APR 86 SINCE ONLY INDICES FOR SREAL,SIMAG ARE HERE
SLR(IV,IVP,IP)=X(IXSR-1+NNP)
SLI(IV,IVP,IP)=X(IXSI-1+NNP)
C ACCUMULATE ANGLE-DEPENDENT TOTAL CROSS SECTION.
ADD=DELVVP-SLR(IV,IVP,IP)
ADD=(ADD*ADD+SLI(IV,IVP,IP)*SLI(IV,IVP,IP) )*WV
SIGTH(IV,IVP,IP)=SIGTH(IV,IVP,IP)+ADD
IF (PRINT.LT.15) GO TO 4200
WRITE(6,627) IP,IV,IVP,SLR(IV,IVP,IP),SLI(IV,IVP,IP),
& ADD,SIGTH(IV,IVP,IP)
627 FORMAT(' FOR ORIENTATION',I6,' VIB LEVEL =',I2,' TO',I2,
& ', SREAL, SIMAG =',2D14.6,' SIGTH ADD',D12.4,' = ',D12.4)
4200 CONTINUE
3100 CONTINUE
C END OF LOOP OVER ORIENTATIONS
C
C INTEGRATE OVER ORIENTATIONS TO GET SLLR/SLLI
C ** N.B. THESE ARE T-MATRIX COMPONENTS **
IF (PRINT.GE.20) WRITE(6,601)
DO 3218 IV=1,NVC
DO 3218 IVP=1,NVC
DELVVP=0.D0
IF (IV.EQ.IVP) DELVVP=1.D0
DO 3218 L=1,LMAX
SLLI(IV,IVP,L)=0.D0
SLLR(IV,IVP,L)=0.D0
DO 3208 NX=1,NGPT
SLLR(IV,IVP,L)=SLLR(IV,IVP,L)+(DELVVP-SLR(IV,IVP,NX))*PWGHT(NX,L)
3208 SLLI(IV,IVP,L)=SLLI(IV,IVP,L)-SLI(IV,IVP,NX)*PWGHT(NX,L)
IF (PRINT.GE.20)
& WRITE(6,648) IV,IVP,L,SLLR(IV,IVP,L),SLLI(IV,IVP,L)
648 FORMAT(5X,3I5, 2D16.8)
3218 CONTINUE
C
C ***
C>>SG MAY 92. CODE BELOW REPLACED BY CALL ISUTP AT STATEMENT NO. 3000
C SAVE SLLR/SLLI HRE / N.B. SLR/SLI MIGHT BE USEFUL LATER.
C IF (ISU.LE.0) GO TO 3230
C WRITE(ISU,3231) JTOT,IE,ENERGY(IE)
C3231 FORMAT(2I4,E16.8)
C WRITE(ISU,3232) NOPEN,(NB(I),JTOT,WVEC(NB(I)),I=1,NOPEN)
C3232 FORMAT(I4/(2I4,E16.8))
C WRITE(ISU,3233) (((SLLR(NB(IV),NB(IVP),L),IV=1,NOPEN),IVP=1,NOPEN)
C & ,L=1,LMAX)
C WRITE(ISU,3233) (((SLLI(NB(IV),NB(IVP),L),IV=1,NOPEN),IVP=1,NOPEN)
C & ,L=1,LMAX)
C3233 FORMAT(5E16.8)
C ***
C
C COMPUTE QLS (QLOLD PREVIOUSLY) FOR 1ST (TOTALLY SYMMETRIC) CASE
3230 IF (PRINT.GE.10) WRITE(6,601)
DO 3220 IV=1,NVC
C SET WVEC(IV) TO (2*L+1)*PI/K**2 FOR USE IN GETTING QL'S
C>>SG TRAP CLOSED CHANNELS (NEGATIVE WVEC) TO PREVENT ROUND-OFF PROBLEMS
IF (WVEC(IV).LE.0.) GO TO 3220
WVEC(IV)=FACTL/(WVEC(IV)*WVEC(IV))
DO 3219 IVP=1,NVC
DELVVP=0.D0
IF (IV.EQ.IVP) DELVVP=1.D0
SUMR=0.D0
SUMI=0.D0
DO 3209 NX=1,NGPT
SUMR=SUMR+PWGHT(NX,1)*SLR(IV,IVP,NX)
SUMI=SUMI+PWGHT(NX,1)*SLI(IV,IVP,NX)
3209 CONTINUE
C>>SG BELOW SUFFERS FROM ROUND-OFF ERROR FOR IV=IVP CLOSED
C>>SG TEST CASES GIVE V*(SUMR**2+SUMI**2)-DELVVP ABOUT 2.D-13
C>>SG BEST WAY TO FIX THIS IS PROBABLY TO TRAP *CLOSED* CHANNELS
SUM2=(V*(SUMR*SUMR+SUMI*SUMI)-DELVVP)*WVEC(IV)
QLS (IV,IVP)=QLS (IV,IVP)+SUM2
IF (PRINT.GE.10) WRITE(6,638) IV,IVP,SUM2, QLS(IV,IVP)
638 FORMAT(' FOR QLS( 0) VIB LEV =',I3,' TO',I3,15X,
& 'ADD',D12.4,' =',D12.4)
3219 CONTINUE
3220 CONTINUE
C
C *** IN ACCUMULATING QL DIVERGENT CODE FOR ITYPE=1,2 AND ITYPE=5,6
C
IF (ITYPE.EQ.1 .OR. ITYPE.EQ.2) GO TO 8881
IF (ITYPE.EQ.3) GO TO 8883
IF (ITYPE.EQ.5 .OR. ITYPE.EQ.6) GO TO 8885
STOP
C
C ACCUMULATE QL'S / TEST FOR CONVERGENCE
8881 BIGL=-1.D0
DO 3200 L=1,NQL
LMP=L-1
BIGL=BIGL+2.D0
ITEST=0
IF (PRINT.GE.10 .AND. NVC.GT.1) WRITE(6,601)
DO 3210 IV=1,NVC
DO 3210 IVP=1,NVC
TLLR=SLLR(IV,IVP,L)
TLLI=SLLI(IV,IVP,L)
TLLSQ=(TLLR*TLLR+TLLI*TLLI)*V*WVEC(IV)/BIGL
QLT(IV,IVP,L)=QLT(IV,IVP,L)+TLLSQ
XTEST=TEST(1)
IF (L.GT.1 .OR. IV.NE.IVP) XTEST=TEST(2)
IF (TLLSQ.GT.XTEST) ITEST=1
IF (PRINT.LT.10) GO TO 3210
WRITE(6,628) LMP,IV,IVP,TLLSQ,QLT(IV,IVP,L)
628 FORMAT(' FOR QLT(',I3,') VIB LEV =',I3,' TO',I3,
& ' IOS T-MATRIX ADD',D12.4,' =',D12.4)
3210 CONTINUE
C>>SG 5/12/92 STATEMENT BELOW SHOULD BE UNNECESSARY
IF (JTOTU.LT.999999) GO TO 3200
C SUPPRESS CONVERGENCE CHECK FOR LOW PARTIAL WAVES.
IF (JTOT.LE.3*JSTEP*NCAC) GO TO 3200
IF (IXQL(NIXQL,L).NE.0) GO TO 3200
IEC(L)=IEC(L)+1
IF (ITEST.GT.0) IEC(L)=0
3200 CONTINUE
GO TO 3000
C
8883 DO 8873 IL=1,NQL
BIGL=(2*LM(3,IL)+1)
C N.B. NVC=1 FOR ITYPE=3
TLLR=SLLR(1,1,IL)
TLLI=SLLI(1,1,IL)
TLLSQ=(TLLR*TLLR+TLLI*TLLI)*V*WVEC(1) * BIGL
QLT(1,1,IL)=QLT(1,1,IL)+TLLSQ
IF (PRINT.GE.10) WRITE(6,652) IL,LM(1,IL),LM(2,IL),LM(3,IL),
2 TLLSQ,QLT(1,1,IL)
652 FORMAT(' FOR QLT(',I3,'), L1,L2,L =',3I3,' ADD',
1 D12.4,' =',D12.4)
XTEST=TEST(MIN0(2,IL))
IF (JTOT.LE.3*JSTEP*NCAC) GO TO 8873
C IF (IXQL(NIXQL,IL).NE.0) GO TO 8875 --- SHOULD ALL = 0
IEC(IL)=IEC(IL)+1
IF (TLLSQ.GT.XTEST) IEC(IL)=0
8873 CONTINUE
GO TO 3000
C
8885 DO 8875 IL=1,NQL
C N.B. NVC=1 FOR ITYPE=5,6
TLLR=SLLR(1,1,IXQL(1,IL))
TLLI=SLLI(1,1,IXQL(1,IL))
TLLR1=SLLR(1,1,IXQL(2,IL))
TLLI1=SLLI(1,1,IXQL(2,IL))
IF (IXQL(3,IL).EQ.2) GO TO 8865
C BELOW FOR REAL PART / ALSO FOR DIAGONAL CASES
TLLSQ=(TLLR*TLLR1+TLLI*TLLI1)*V*WVEC(1)
GO TO 8855
C BELOW FOR IMAGINARY PART
8865 TLLSQ=(TLLI*TLLR1-TLLR*TLLI1)*V*WVEC(1)
8855 QLT(1,1,IL)=QLT(1,1,IL)+TLLSQ
IF (PRINT.GE.10) WRITE(6,651) IL,LM(1,IXQL(1,IL)),LM(2,IXQL(1,IL))
1 ,LM(2,IXQL(2,IL)),IXQL(3,IL),
2 TLLSQ,QLT(1,1,IL)
651 FORMAT(' FOR QLT(',I3,'), L,M,M1 =',3I4,', CODE =',I2,' ADD',
1 D12.4,' =',D12.4)
XTEST=TEST(MIN0(2,IL))
IF (JTOT.LE.3*JSTEP*NCAC) GO TO 8875
IF (IXQL(3,IL).NE.0) GO TO 8875
IEC(IL)=IEC(IL)+1
IF (TLLSQ.GT.XTEST) IEC(IL)=0
8875 CONTINUE
GO TO 3000
C
3000 CALL ISUTP(ISU,ENERGY(IE),JTOTL,JSTEP,JTOT,NVC,NQL,QLS,QLT)
C END OF LOOP OVER PARTIAL WAVES
C
CALL GCLOCK(TJTIME)
TIME=TJTIME-TITIME
TITIME=TJTIME
WRITE(6,631) ENERGY(IE),JTOTL,JSTEP,JTOTU
631 FORMAT('1 ***** ***** ***** END OF CALCULATION FOR ENERGY =',
1 F12.4,' (1/CM) ***** ***** *****'/
& 22X,'PARTIAL WAVES',I4,' (',I4,' ) ',I5)
WRITE(6,641) TIME
C
C END OF CALCULATION FOR THIS ENERGY / OUTPUT CROSS SECTIONS
C MAKE SURE WE HAVE NUSED BY CALLING CHKSTR
3009 CALL CHKSTR(NUSED)
WRITE(6,684) NUSED,MX
684 FORMAT('0',2(' *****'),' STORAGE SO FAR USED',I10,' OF THE',
1 I10,' AVAILABLE WORDS.')
C>>SG
C>>SG N.B. NVC SHOULD BE LOWERED TO NOUT=NOPEN (AS IN IOSOUT)
C>>SG
DO 3305 NX=1,NGPT
IV=1
WRITE(6,632) NX,(LEFT,IV,IVP,SIGTH(IV,IVP,NX),IVP=1,NVC)
632 FORMAT('0 FOR ORIENTATION',I6,3(5X,A4 ,I2,',',I2,') =',1PE12.4)
& /(23X,3(5X,A4,I2,',',I2,') =',1PE12.4)))
IF (NVC.LE.1) GO TO 3008
DO 3007 IV=2,NVC
3007 WRITE(6,642) (LEFT,IV,IVP,SIGTH(IV,IVP,NX),IVP=1,NVC)
C>>SG FORMAT CHANGED 2/6/92 TO ELIMINATE APPARENT COMPILER BUG
642 FORMAT(23X,3(5X, A4, I2,',',I2,') =',1PE12.4)/
1 (23X,3(5X, A4, I2,',',I2,') =',1PE12.4)))
3008 DO 3305 IV=1,NVC
DO 3305 IVP=1,NVC
3305 SIGAV(IV,IVP)=SIGAV(IV,IVP)+PWGHT(NX,1)*SIGTH(IV,IVP,NX)*AVGFCT
WRITE(6,643)
643 FORMAT('0 AVERAGE OVER ORIENTATIONS')
DO 3004 IV=1,NVC
3004 WRITE(6,642) (LEFT,IV,IVP,SIGAV(IV,IVP),IVP=1,NVC)
C
C CALL IOSOUT/IOSPB TO GET STATE TO STATE AND PR. BR. CROSS SECTIONS
C N.B. ATAU, NEEDED ONLY FOR SIG6, IS STORED IN X(1), I.E., JLEV.
C THIS IS PRETTY BAD CODING; BETTER PASSING OF ATAU TO SIG6 NEEDED
C
IATAU=1
CALL IOSOUT(ENERGY(IE),QLT,QLS,NVC,ITYPE,X(IATAU),LM,IXQL,
1 LMAX,NIXQL,NQL,JSTEP)
IF(IFLS.GT.0)
1CALL IOSPB(ENERGY(IE),QLT,QLS,IFLS,LINE,LTYPE,ITYPE,NVC,LM,IXQL,
1 LMAX,NIXQL,NQL)
C
2000 CONTINUE
C
C END OF LOOP OVER ENERGIES.
C
RETURN
END
SUBROUTINE IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC,
1 IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX,
2 IPROGM,URED,LABEL,NUMDER,
3 LAMBDA,MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC,
4 DEEP,PRINT,NVC, ISAVEU,TITIME,RM,EPSIL,RMIN,RMAX)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C INTEGRATED MOLSCAT/IOS IMPLEMENTED APR 86 CAMBRIDGE, ENGLAND.
C -- A GUTTED VERSION OF IOS1, INTERFACED TO CCP6 MOLSCAT.
C THIS IS A DRIVER FOR THE IOS CODE; MOLSCAT/DRIVER CALLS
C BASIN TO READ &BASIS, WHICH THEN CALLS IOSBIN.
C DRIVER THEN CALLS POTENL TO GET &POTL DATA,
C AND FINALLY CALLS IOSDRV TO SET UP AND PERFORM IOS CALCULATION.
C
INTEGER PRINT
DIMENSION ENERGY(NNRG),TEST(2),LINE(2,MXLN),LTYPE(MXLN),
1 LAMBDA(MXLAM)
LOGICAL NUMDER
CHARACTER*80 LABEL
C
C LAST CHANGED 1/19/93. NEW DYNAMIC MEMORY HANDLING
C ** VERSION 6 / OCT 85/ ADDS ITYPE=6 CAPABILITY
C / ALSO ALLOWS "UNEXPANDED" POTL, V(R,ANGLES)
C ** VERSION 5 / MAR 81/ ADDS INTFLG=4 (MOLSCAT V.8)
C / JUNE 82/ REPLACES PLM WITH R. T PACK VERSION.
C ** VERSION 4 / MAY. 78/ ADDS ITYPE=5 CODE.
C / SEP. 78/ **TEMPORARY** ISAVEU CPABILITY
C / APR. 79/ CHANGED FOR ISCRU (MOLSCAT V.7) COMPATABIL
C ** VERSION 3 / DEC. 77/ IS TOTALLY NEW ORGANIZATION TO ACCOMMODATE
C ITYPE=2 (VIBROTOR - ATOM)
C ** VERSION 2 / OCT. 77/ ADDS WKB (R.T PACK) CAPABILITY **
C ** VERSION 1 / SEP. 77/ INTERFACE HOUSTON PROGRAM W/MOLSCAT.
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY
C IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINTED W/ VL ARRAY.
C NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2.
C
C CMBASE MODIFIED TO MATCH CURRENT SPECS IN MOLSCAT/BASIS
C THIS IS USED ONLY TO GET LV,EV VALUES IN IOSBIN SO THEY CAN BE
C WRITTEN TO ISAVEU HERE.
DIMENSION EV(1000),LV(4000)
COMMON /CMBASE/ DUM(1016),IDUM(4031)
EQUIVALENCE (EV(1),DUM(13)),(LV(1),IDUM(2))
C
C MUST INITIALIZE NUSED NON-NEGATIVE BEFORE CALL CHKSTR
NUSED=0
WRITE(6,68)
68 FORMAT('0 IOSDRV ENTERED. SET-UP FOR INFINITE ORDER SUDDEN',
1 ' CALCULATION.')
C
C CONTINUE WITH SET-UP FOR IOS. PROCESS &POTL LAM(MXLAM) DATA
C SET NGPT, LMAX AND GAUSS PTS/WTS.
C N.B. LMAX/MMAX INITIALLY CONTAIN HIGHEST L,M VALUES
C DESIRED FOR QLM. LMAX IS RESET TO EQUAL THE *NUMBER* OF L,M
C VALUES IN LM,SLLR,SLLI,ETC.
CALL IOSBGP(MXLAM,LAMBDA,MXXXXL,NGPT,LMAX,MMAX,NQL,NIXQL)
C
C RESERVE STORAGE FOR VARIABLES. IC HAS NEXT AVAIL LOC IN X()
C STORAGE FOR SCATTERING VARIABLES . . .
C SREAL(NVC,NVC),SIMAG(NVC,NVC),WVEC(NVC),EINT(NVC),CENT(NVC),
C VL(NVC*(NVC+1)/2,MXLAM),JJJ(NVC),LORB(NVC),NB(NVC)
C --ADDED APR 86-- KMAT(NVC,NVC),IV(NVC*(NVC+1)/2,MXLAM)
C
C V11 CODE EXPECTED IC TO BE STORAGE USED SO FAR
ISVMEM=IXNEXT
IC=IXNEXT-1
IXSR=IC+1
IXSR=IXNEXT
IXSI=IXSR+NVC*NVC
IXKMAT=IXSI+NVC*NVC
IXWV=IXKMAT+NVC*NVC
IXEINT=IXWV+NVC
IXCENT=IXEINT+NVC
IXVL=IXCENT+NVC
NV=NVC*(NVC+1)*NPOTL/2
IXJJJ=IXVL+NV
IXLORB=IXJJJ+NVC
IXNB=IXLORB+NVC
IXIV=IXNB+NVC
IC=IXIV
IF (IVLFL.GT.0) IC=IXIV+(NV+NIPR-1)/NIPR
C
C IOS VARIABLES
C VLI(NGPT,MXXXXL),PWGHT(NGPT,LMAX),SLR(NVC,NVC,NGPT),
C SLI(NVC,NVC,NGPT),SIGTH(NVC,NVC,NGPT),SIGAV(NVC,NVC),
C QLS(NVC,NVC),QLT(NVC,NVC,NQL),IEC(NQL ),IXQL(NIXQL,NQL)
C SLLR(NVC,NVC,LMAX),SLLI(NVC,NVC,LMAX),LM(3,LMAX)
C
IXVLI=IC
IXPW=IXVLI+MXXXXL*NGPT
IXSLR=IXPW+NGPT*LMAX
IXSLI=IXSLR+NVC*NVC*NGPT
IXSGTH=IXSLI+NVC*NVC*NGPT
IXSGAV=IXSGTH+NVC*NVC*NGPT
IXQLS=IXSGAV+NVC*NVC
IXQLT=IXQLS+NVC*NVC
IXSLLR=IXQLT+NVC*NVC*NQL
IXSLLI=IXSLLR+NVC*NVC*LMAX
IXIEC=IXSLLI+NVC*NVC*LMAX
IXQL=IXIEC+(NQL+NIPR-1)/NIPR
IXLM=IXQL+(NIXQL*NQL+NIPR-1)/NIPR
IC=IXLM+(3*LMAX+1)/NIPR
WRITE(6,681) NVC,NGPT,LMAX,MXXXXL,NQL,NIXQL,IC
681 FORMAT('0 STORAGE ALLOCATED FOR NVC (NO. VIB. CHANNELS) =',T60,
1 I4/25X,'NGPT (NO. GAUSS PTS.) =',T58,I6/
2 25X,'LMAX (NO. LEGENDRE COEFFS.) =',T60,I4/
3 25X,'MXXXXL (NO. SYMMETRIES IN POTL) =',T60,I4/
4 25X,'NQL (NO. QLT) =',T60,I4/
5 25X,'NIXQL (NO. INDICES IN IXQL) =',T60,I4/
6 25X,'NEXT LOCATION =',T54,I10)
C IC IS NOW 'NEXT STORAGE LOCATION'
IXNEXT=IC
CALL CHKSTR(NUSED)
C
C SET UP PWGHT, VLI TABLES - ALSO IXQL TABLE
C
CALL IOSB1(X(IXPW),X(IXVLI),X(IXQL),X(IXLM),NGPT,LMAX,MXXXXL,
1 NIXQL,NQL)
C
IF (ISAVEU.LE.0) GO TO 3000
C
C *** ISAVEU OUTPUT -- MAY 92 VERSION
C
WRITE(6,3600) ISAVEU
3600 FORMAT('0'/'0 QLS/QLT SAVED (MAY 92 FORMAT) ON UNIT ISAVEU =',I3)
IPOUT=100+IPROGM
ITOUT=100+ITYPE-100*(ITYPE/100)
WRITE(ISAVEU,3601) LABEL,ITOUT,NVC,NQL,URED,IPOUT
3601 FORMAT(A80/3I4,F8.4,I4)
C WRITE(ISAVEU,3602) (LV(I),I=1,NVC)
3602 FORMAT(20I4)
C WRITE(ISAVEU,3603) NVC,(EV(I),I=1,NVC)
3603 FORMAT(I4/(5E16.8))
C WRITE(ISAVEU,3603) NNRG,(ENERGY(I),I=1,NNRG)
C
3000 CALL GCLOCK(TJTIME)
TIME=TJTIME-TITIME
WRITE(6,640) TIME
640 FORMAT('0 TIME TO SET UP CALCULATION WAS',F8.2,
1 ' SECONDS. EXIT IOSDRV')
WRITE(6,69)
69 FORMAT('0',30('===='))
C
C PASS CONTROL TO IOSCLC TO DO CALCULATION.
C
CALL IOSCLC(NNRG,ENERGY,JTOTL,JTOTU,JSTEP,INTFLG,PRINT,ISAVEU,
1 ITYPE,RMIN,RMAX,DEEP,IRMSET,IRXSET,RVFAC,NUMDER,
2 NCAC,TEST,RM,EPSIL,NVC,LMAX,NGPT,NQL,NIXQL,
3 MXXXXL,LAMBDA,MXLAM,NPOTL,X(IXVLI),
4 X(IXPW),X(IXSLR),X(IXSLI),X(IXQLT),X(IXQLS),
5 X(IXSLLR),X(IXSLLI),X(IXQL),
6 X(IXSGTH),X(IXSGAV),X(IXIEC),X(IXLM),
7 IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT,IXWV,
8 IXJJJ,IXLORB,IXNB,X(IXWV),X(IXNB),
9 IFLS,MXLN,LINE,LTYPE)
C
C RELEAST STORAGE USED BY IOSDRV/IOSCLC/STORAG
IXNEXT=ISVMEM
RETURN
END
SUBROUTINE IOSOUT(ENERGY,QL,QLOLD,NVC,ITYPE,ATAU,LM,IXQL,
1 LMAX,NIXQL,NQL,JSTEP)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C>>SG MODIFIED MAY 92 - ITYPE=3 / ADD JSTEP TO PARAMETER LIST.
C>>SG MODIFIED FEB 92
C>>SG TO CORRECT APPARENT COMPILER BUG, IN FORMATS 615,616
C>>SG TO ALLOW FOR OUTPUT OF NOUT.LT.NVC VIB LEVELS IF SOME CLOSED
C
C AUG 86 IXQLF ADD LM,LMAX ARGUMENTS
C *** TO CONTROL OPTIONAL 'DEBUGGING' OUTPUT ***
LOGICAL PRNT
C ALLOW FOR MXSIG OUTPUT LEVELS
PARAMETER (MXSIG=200)
CHARACTER*1 S(MXSIG),BLANK,STAR
CHARACTER*4 LCODE(3),LQLT,LQLS
DIMENSION QL(NVC,NVC,NQL),QLOLD(NVC,NVC)
DIMENSION LM(3,LMAX),IXQL(NIXQL,NQL)
DIMENSION ATAU(2)
C STORAGE RESERVED FOR MAXIMUM OF MXSIG LEVELS
DIMENSION SIG(MXSIG),SIG3(MXSIG)
C
C COMMON BLOCKS TO COMMUNICATE WITH IOSBIN(BASIS SET) ROUTINES
COMMON /CMBASE/DUM(1016),IDUM(4031)
DIMENSION JLEV(4000)
EQUIVALENCE (NLEV,IDUM(1)), (JLEV(1),IDUM(2)), (IDENT,IDUM(4029))
COMMON /IOUTCM/ JMAX,LEVV(4000)
C COMMON TO GET SYMMETRY INFORMATION (IHOMO1,IHOMO2) FOR ITYPE=3
COMMON/ANGLES/COSANG(7),FACTOR,IH1,IH2,IH3,IH4
C
DATA IZERO/0/, ZTOL/1.D-8/
DATA BLANK/' '/, STAR/'*'/
DATA LCODE/' ','REAL','IMAG'/, LQLT/' QLT'/, LQLS/' QLS'/
DATA PRNT/.FALSE./
C
C STATEMENT FUNCTION FOR NORMALIZATION XNORM . . .
XNORM(EPSI)=1.D0/(1.D0+ABS(EPSI))
FUNC(I)=2.D0*DBLE(I)+1.D0
C
WRITE(6,601) ENERGY
601 FORMAT('1 STATE-TO-STATE CROSS SECTIONS (IN ANG**2) FOR KINETIC ',
& 'ENERGY =',F12.4,' (1/CM).'/'0 PROCESSED BY IOSOUT (FEB 92).')
C
XJSTEP=JSTEP
IF(JSTEP.GT.1) WRITE(6,690) JSTEP
690 FORMAT('0 CROSS SECTIONS (BUT NOT QL) MULTIPLIED BY JSTEP ='
1 ,I3)
IF (ITYPE.EQ.5 .OR.ITYPE.EQ.6) GO TO 5000
IF (ITYPE.EQ.3) GO TO 3000
C
C CODE BELOW IS ITYPE=1,2 FROM VERSION 3. IT SHOULD STILL WORK
C SINCE ALL QL (NOW QLT) ARE IN ORDER.
WRITE(6,610) NVC,(LEVV(I),I=1,NVC)
610 FORMAT('0 NO. OF VIBRATIONAL LEVELS =',I4,'. LEVELS ARE'/
& (' ',13I10) )
IF (JMAX.LT.MXSIG) GO TO 2200
WRITE(6,692) JMAX,MXSIG
692 FORMAT('0 JMAX =',I6,' REDUCED BECAUSE OF MXSIG =',I5)
JMAX=MXSIG-1
2200 WRITE(6,602) JMAX
602 FORMAT('0 MAXIMUM J-VALUE REQUESTED IS',I4)
C>>SG ------------------------- >> CODE BELOW ADDED FEB 92
C>> DETERMINE IF ALL CHANNELS ARE OPEN. SINCE WE DON'T HAVE ACCESS
C TO NOPEN HERE, SIMPLY FIND THE HIGHEST 'CHANNEL' FOR WHICH WE
C HAVE NONZERO QL() OR QLOLD()
NOUT=0
DO 2300 IV=1,NVC
C FIRST CHECK QLOLD
DO 2301 IVP=1,NVC
IF (QLOLD(IV,IVP).NE.0.) GO TO 2390
2301 CONTINUE
C THEN CHECK QL()
DO 2302 IVP=1,NVC
DO 2302 IL=1,NQL
IF (QL(IV,IVP,IL).NE.0.) GO TO 2390
2302 CONTINUE
GO TO 2300
2390 NOUT=IV
2300 CONTINUE
IF (NOUT.NE.NVC) WRITE(6,620) NOUT
620 FORMAT('0 IOSOUT (FEB 92). ALL QL,QLOLD ZERO FOR SOME CHANNELS'
1 ,', PRESUMABLY CLOSED ENERGETICALLY.'/
2 '0 OUTPUT LIMITED TO NOUT =',I3)
C
C<<SG -<< END OF ADDITIONAL CODE FEB 92. NB NVC CHANGED TO NOUT BELOW
IV=1
WRITE(6,606)(IV,IVP,QLOLD(IV,IVP),IVP=1,NOUT)
606 FORMAT('0 QLOLD(0) ',4(2X,I3,' TO',I3,' =',1PE12.4) /
& (12X,4(2X,I3,' TO',I3,' =',1PE12.4)))
IF (NOUT.LE.1) GO TO 2001
DO 2101 IV=2,NOUT
2101 WRITE(6,616) (IV,IVP,QLOLD(IV,IVP),IVP=1,NOUT)
616 FORMAT(12X,4(2X,I3,' TO',I3,' =',1PE12.4)/
1 (12X,4(2X,I3,' TO',I3,' =',1PE12.4)))
2001 DO 1300 L=1,NQL
LM1=L-1
C IF (LM1.NE.LM(1,IXQL(1,L))) WRITE(6,698) L,LM1,LM(1,IXQL(1,L))
698 FORMAT('0 * * * ERROR. L-1.NE.LM(1,L) ',3I6)
IV=1
WRITE(6,605) LM1,(IV,IVP,QL(IV,IVP,L),IVP=1,NOUT)
605 FORMAT('0 Q(',I3,' ) ',4(2X,I3,' TO',I3,' =',1PE12.4) /
& (12X,4(2X,I3,' TO',I3,' =',1PE12.4)))
IF (NOUT.LE.1) GO TO 1300
DO 1301 IV=2,NOUT
1301 WRITE(6,615) (IV,IVP,QL(IV,IVP,L),IVP=1,NOUT)
615 FORMAT(12X,4(2X,I3,' TO',I3,' =',1PE12.4)/
1 (12X,4(2X,I3,' TO',I3,' =',1PE12.4)))
1300 CONTINUE
C
DO 4000 IV=1,NOUT
DO 4000 IVP=1,NOUT
WRITE(6,640) IV,IVP
640 FORMAT('0 ***** ***** ***** BELOW FOR VIB LEVEL',I3,' TO',I3)
IMSG=0
DO 1000 JI=IZERO,JMAX
WRITE(6,603) JI
603 FORMAT('0 FOR INITIAL LEVEL J =',I4,' CROSS SECTIONS (ANG**2) ',
& 'TO FINAL LEVELS ARE')
DO 1100 JF=IZERO,JMAX
IF=JF+1
S(IF)=BLANK
LLOW=IABS(JF-JI)
LTOP=JF+JI
IF (LTOP.LE.LMAX-1) GO TO 1101
S(IF)=STAR
IMSG=1
LTOP=LMAX-1
1101 SIG(IF)=0.D0
IF (LLOW.GT.LTOP) GO TO 1100
DO 1200 L=LLOW,LTOP
TJ=THREEJ(JI,L,JF)
1200 SIG(IF)=SIG(IF)+TJ*TJ*QL(IV,IVP,L+1)
1100 SIG(IF)=FUNC(JF)*SIG(IF) * XJSTEP
1000 WRITE(6,604) (JF,SIG(JF+1),S(JF+1),JF=IZERO,JMAX)
604 FORMAT(6(4X,I3,1PE12.4,A1))
IF (IMSG.GT.0) WRITE(6,699)
699 FORMAT( '0 ***** NOTE. FOR CROSS SECTIONS MARKED WITH A ',
1 'STAR, SOME CONTRIBUTING Q(L) ARE NOT AVAILABLE.')
4000 CONTINUE
RETURN
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=PARITY3(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=PARITY3(JLEV(3*IF))
IF (KF.EQ.0) EPSF=0.D0
XNF=XNORM(EPSF)
LLO=IABS(JI-JF)
LHI=JI+JF
PJK=PARITY3(JI+JF+KI+KF)
MPLS=KI+KF
MMIN=IABS(KI-KF)
P2=1.D0
IF (KI-KF.LT.0) P2=PARITY3(MMIN)
SIG(IF)=0.D0
S(IF)=BLANK
TMAX=0.D0
DO 5102 L=LLO,LHI
XL=L
PL=PJK*PARITY3(L)
C -----------------------TERM 1 -------------------
PP=1.D0+EPSI*EPSF*PL
PP=PP*PP
IF (PP.LE.ZTOL) GO TO 5200
TJ=THRJ(XJF,XL,XJI,XKF,XKI-XKF,-XKI)
TJ=TJ*TJ
IF (TJ.LE.ZTOL) GO TO 5200
CALL IXQLF(LM,LMAX,L,MMIN,MMIN,0,INDEX,IXQL,NIXQL,NQL)
IF (INDEX.GT.0) GO TO 5110
IF (INDEX.EQ.-1) GO TO 5200
IMSG=1
S(IF)=STAR
C IF ('PRINT'.GT.25) WRITE(6, ) MSG
GO TO 5200
5110 TT=PP*TJ*QL(1,1,INDEX)
TMAX=MAX(ABS(TT),TMAX)
SIG(IF)=SIG(IF)+TT * XJSTEP
C -----------------------TERM 2 -------------------
5200 PP=(1.D0+EPSI*EPSF*PL)*(EPSF+EPSI*PL)
IF (ABS(PP).LE.ZTOL) GO TO 5300
TJ=THRJ(XJF,XL,XJI,XKF,XKI-XKF,-XKI)*
& THRJ(XJF,XL,XJI,-XKF,XKF+XKI,-XKI)
IF (ABS(TJ).LE.ZTOL) GO TO 5300
CALL IXQLF(LM,LMAX,L,MPLS,MMIN,1,INDEX,IXQL,NIXQL,NQL)
IF (INDEX.GT.0) GO TO 5210
IF (INDEX.EQ.-1) GO TO 5300
IMSG=1
S(IF)=STAR
C ON HIGH PRNTLV WRITE MSG
GO TO 5300
5210 TT=2.D0*P2*PP*TJ*QL(1,1,INDEX)
TMAX=MAX(TMAX,ABS(TT))
SIG(IF)=SIG(IF)+TT * XJSTEP
C -----------------------TERM 3 -------------------
5300 PP=EPSF+EPSI*PL
PP=PP*PP
IF (PP.LE.ZTOL) GO TO 5102
TJ=THRJ(XJF,XL,XJI,-XKF,XKF+XKI,-XKI)
TJ=TJ*TJ
IF (TJ.LE.ZTOL) GO TO 5102
CALL IXQLF(LM,LMAX,L,MPLS,MPLS,0,INDEX,IXQL,NIXQL,NQL)
IF (INDEX.GT.0) GO TO 5310
IF (INDEX.EQ.-1) GO TO 5102
S(IF)=STAR
IMSG=1
C ON 'PRNTLV' WRITEN MSG
GO TO 5102
5310 TT=PP*TJ*QL(1,1,INDEX)
TMAX=MAX(ABS(TT),TMAX)
SIG(IF)=SIG(IF)+TT * XJSTEP
5102 CONTINUE
IF (ABS(SIG(IF)).GE.ZTOL*TMAX) GO TO 5101
IF (SIG(IF).EQ.0.D0) GO TO 5101
IF (PRNT) WRITE(6,697) IF,SIG(IF),TMAX
697 FORMAT(' * * * NOTE. ROUND-OFF ERROR FOR LEV(F) =',I3,
& ', SIG(IF),TMAX =',2D12.4)
SIG(IF)=0.D0
5101 SIG(IF)=SIG(IF)*XNI*XNF*FUNC(JF)
5100 WRITE(6,604) (IF,SIG(IF),S(IF),IF=1,NLEV)
IF (IMSG.GT.0) WRITE(6,699)
RETURN
C
C BELOW FOR ITYPE=6
6000 DO 6100 I=1,NLEV
WRITE(6,664) I,JLEV(4*I-3),JLEV(4*I-2),JLEV(4*I-1)
664 FORMAT('0 INITIAL LEVEL =',I4,' J, TAU, PARITY =',3I4)
DO 6101 IF=1,NLEV
SIG(IF)=0.D0
S(IF)=BLANK
6101 CALL SIG6(NLEV,JLEV,ATAU,I,IF,SIG(IF),S(IF),IMSG,QL,IXQL,NIXQL,
1 NQL,LM,LMAX)
6100 WRITE(6,604) (IF,SIG(IF)*XJSTEP,S(IF),IF=1,NLEV)
IF (IMSG.GT.0) WRITE(6,699)
RETURN
C
END
SUBROUTINE IOSPB(ENERGY,QL,QLOLD,NL,LINE,LTYPE,ITYPE,
1 NVC,LM,IXQL,LMAX,NIXQL,NQL)
C ***
C *** MODIFIED DEC 86 FOR COMPATBILITY WITH OFF-DIAGONAL PRBR CODE
C ***
C ** N.B. DIMENSIONS ON QL,QLOLD SHOULD HAVE NVC REMOVED.
C ALSO, LM APPEARS NOT TO BE USED IN THIS ROUTINE
C AUG 86 IXQLF ADD LM,LMAX ARGUMENTS
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
LOGICAL EXISTS
C TO CONTROL PRINTING OF 'OPTIONAL' OUTPUT
LOGICAL LPRT
C FOR UPWARD COMPATIBILITY WITH OLD (DIAG ONLY) INPUT
LOGICAL LDIAG
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C DEC 86 LINE() CHANGED TO 1-DIMENSIONAL ARRAY CONTROLED BY NPL
DIMENSION QL(NVC,NVC,NQL),QLOLD(NVC,NVC),LINE(2),LTYPE(NL)
DIMENSION LM(3,LMAX),IXQL(NIXQL,NQL)
C QLOLD IS QL(0) IN THE NOTATION OF IOS PAPER 1.
C
C COMMON TO COMMUNICATE WITH IOSBIN ROUTINE
DIMENSION JLEV(4000)
COMMON /CMBASE/DUM(1016),IDUM(4031)
EQUIVALENCE (JLEV(1),IDUM(2)), (NLEV,IDUM(1))
C
DATA IZERO/0/, IONE/1/, TOL/1.D-5/
DATA LPRT/.FALSE./
DATA LDIAG/.FALSE./
C
C STATEMENT FUNCTION DEFINITIONS. . .
XNORM(EPSA)=1.D0/(1.D0+ABS(EPSA))
FUNC(JA)=DBLE(2*JA+1)
EXISTS(I)= I.GT.0 .AND. I.LE.NLEV
C
IF (NL.LE.0) RETURN
C NPL IS NO. OF INDICES IN LINE PER CROSS SECTION
NPL=4
IF (LDIAG) NPL=2
WRITE(6,600) NL,ENERGY
600 FORMAT('0'/'0 PRESSURE BROADENING CROSS SECTIONS REQUESTED FOR',
& I4,' SPECTRAL LINES.'/'0 ENERGY =',F12.4,' (1/CM).')
IF (ITYPE.EQ.1 .AND. NVC.EQ.1) GO TO 1111
IF (ITYPE.EQ.5 .AND. NVC.EQ.1) GO TO 5000
WRITE(6,695) ITYPE,NVC
695 FORMAT('0 * * * NOTE. IOSPB NOT SUPPORTED FOR ITYPE, NVC =',2I6)
NL=0
RETURN
1111 QTOT=0D0
IF (LMAX.LT.2) GO TO 1001
DO 1000 IL=2,LMAX
1000 QTOT=QTOT+QL(1,1,IL)
1001 LM1=LMAX-1
WRITE(6,651) LM1,QTOT,QLOLD(1,1)
651 FORMAT('0 SUM OVER Q(L), L = 1,',I3,' =',F12.4,' QLOLD(0) =',
& F12.4)
C ***
C *** SAVE QL(1,1,1) AND REPLACE WITH QLOLD(1,1)
Q0SAVE=QL(1,1,1)
QL(1,1,1)=QLOLD(1,1)
C *** LOOP OVER LINES
DO 2000 LN=1,NL
LVA=LINE((LN-1)*NPL+1)
LVB=LINE((LN-1)*NPL+2)
IF (.NOT.LDIAG) GO TO 1091
LVA1=LVA
LVB1=LVB
GO TO 1092
1091 LVA1=LINE((LN-1)*NPL+3)
LVB1=LINE((LN-1)*NPL+4)
1092 IF (EXISTS(LVA).AND.EXISTS(LVB).AND.EXISTS(LVA1).AND.EXISTS(LVB1))
1 GO TO 2001
WRITE(6,691) LN,LVA,LVB,LVA1,LVB1
691 FORMAT('0 * * * ERROR. FOR LINE',I3,' LEVEL A OR B .GT. NLEV -
& CANNOT PROCESS',4I6)
GO TO 2000
2001 JA=JLEV(LVA)
JB=JLEV(LVB)
JA1=JLEV(LVA1)
JB1=JLEV(LVB1)
K=LTYPE(LN)
IF (K.LE.0) K=IABS(JA-JB)
WRITE(6,601) LN,JA,JB,JA1,JB1,K
601 FORMAT('0 LINE',I3,' FOR JA, JB; JA1, JB1 = ',2I4,4X,2I4,
& ' PROCESSED FOR',I4,'-POLE RADIATION.')
LTOP=MIN0(JA+JA1,JB+JB1)
IF (LTOP.LE.LM1) GO TO 2002
WRITE(6,692) LTOP,LM1
692 FORMAT('0 * * * WARNING. POSSIBLE ERROR LTOP.GT.LMAX',2I6)
LTOP=LM1
2002 LMIN=MAX0(IABS(JA-JA1),IABS(JB-JB1))
QTOT2=0.
DO 2100 L=LMIN,LTOP
C FC=FCOEF(JA,JB,JA,JB,K,L)
FC=PARITY3(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=PARITY3(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=PARITY3(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)*PARITY3(K+KA+KB)*FUNC(JA)*FUNC(JB)
DO 5100 L=IZERO,LTOP,2
SFACT=SIXJ(JA,JB,JA,JB,K,L)
IF (ABS(SFACT).LT.TOL) GO TO 5100
XL=L
C TERM 1 . . .
PF=(1.D0+EPSA*EPSA)*(1.D0+EPSB*EPSB)
TF=THRJ(XJA,XL,XJA,XKA,0D0,-XKA)*THRJ(XJB,XL,XJB,XKB,0D0,-XKB)
C HANDLE Q(0,0,0) -- I.E. QLOLD -- SEPARATELY.
IF (L.EQ.0) GO TO 5101
CALL IXQLF(LM,LMAX,L,IZERO,IZERO,IZERO,IX,IXQL,NIXQL,NQL)
IF (IX.EQ.0) WRITE(6,659) L,IZERO,IZERO,IZERO
659 FORMAT(' REQUESTED MISSING Q. L, MA, MB, CODE =',4I4)
IF (IX.LE.0) GO TO 5200
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QL(1,1,IX)
QTOT2=QTOT2+ADDR
ADDI=0.D0
IF(LPRT)WRITE(6,657)L,IZERO,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI
657 FORMAT(' L, MA, MB =',3I3,' *', F12.5 ,' ADD(R/I) =',2F12.5,
& ' = ',2F12.5)
GO TO 5200
5101 ADDI=0.D0
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QLOLD(1,1)
QTOT2=QTOT2+ADDR
IF(LPRT)WRITE(6,657)L,IZERO,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI
C TERM 2 . . .
5200 IF (EPSA.EQ.0.D0 .OR. KA2.GT.L) GO TO 5300
PF=2.D0*EPSA*(1.D0+EPSB*EPSB)
TF=THRJ(XJA,XL,XJA,-XKA,2.D0*XKA,-XKA)*
& THRJ(XJB,XL,XJB,XKB,0D0,-XKB)
CALL IXQLF(LM,LMAX,L,KA2,IZERO,IONE,IX,IXQL,NIXQL,NQL)
IF (IX.EQ.0) WRITE(6,659) L,KA2,IZERO,IONE
IF (IX.LE.0) GO TO 5300
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QL(1,1,IX)
ADDI=XXX*QL(1,1,IX+1)
QTOT2=QTOT2+ADDR
QTOTI=QTOTI+ADDI
IF (LPRT)WRITE(6,657)L,KA2,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI
C TERM 3 . . .
5300 IF (EPSB.EQ.0.D0 .OR. KB2.GT.L) GO TO 5400
PF=2.D0*EPSB*(1.D0+EPSA*EPSA)
TF=THRJ(XJA,XL,XJA,XKA,0D0,-XKA)*
& THRJ(XJB,XL,XJB,-XKB,2.D0*XKB,-XKB)
CALL IXQLF(LM,LMAX,L,KB2,IZERO,IONE,IX,IXQL,NIXQL,NQL)
IF (IX.EQ.0) WRITE(6,659) L,IZERO,KB2,IONE
IF (IX.LE.0) GO TO 5400
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QL(1,1,IX)
ADDI=-XXX*QL(1,1,IX+1)
QTOT2=QTOT2+ADDR
QTOTI=QTOTI+ADDI
IF(LPRT) WRITE(6,657) L,IZERO,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI
C TERM 4 . . .
5400 IF (EPSA*EPSB.EQ.0.D0 .OR. KA2.GT.L .OR. KB2.GT.L) GO TO 5100
PF=4.D0*EPSA*EPSB
TF=THRJ(XJA,XL,XJA,-XKA,2.D0*XKA,-XKA)*
& THRJ(XJB,XL,XJB,-XKB,2.D0*XKB,-XKB)
IF (KA2-KB2) 5401,5402,5403
5401 CALL IXQLF(LM,LMAX,L,KA2,KB2,IONE,IX,IXQL,NIXQL,NQL)
IF (IX.EQ.0) WRITE(6,659) L,KA2,KB2,IONE
IF (IX.LE.0) GO TO 5100
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QL(1,1,IX)
ADDI=XXX*QL(1,1,IX+1)
QTOT2=QTOT2+ADDR
QTOTI=QTOTI+ADDI
IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI
GO TO 5100
5402 CALL IXQLF(LM,LMAX,L,KA2,KB2,IZERO,IX,IXQL,NIXQL,NQL)
IF (IX.EQ.0) WRITE(6,659) L,KA2,KB2,IZERO
IF (IX.LE.0) GO TO 5100
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QL(1,1,IX)
QTOT2=QTOT2+ADDR
ADDI=0.D0
IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI
GO TO 5100
5403 CALL IXQLF(LM,LMAX,L,KB2,KA2,IONE,IX,IXQL,NIXQL,NQL)
IF (IX.EQ.0) WRITE(6,659) L,KB2,KA2,IONE
IF (IX.LE.0) GO TO 5100
XXX=FACT*SFACT*PF*TF
ADDR=XXX*QL(1,1,IX)
ADDI=-XXX*QL(1,1,IX+1)
QTOT2=QTOT2+ADDR
QTOTI=QTOTI+ADDI
IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI
5100 CONTINUE
WRITE(6,658) QTOT2,QTOTI
658 FORMAT(11X,'***** CROSS SECTION (A**2), REAL PART =',F12.4,5X,
& 'IMAG. PART =',F12.4)
5001 CONTINUE
C
RETURN
END
FUNCTION IPASYM(JI,NK,A)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C ROUTINE TO SET PARITY CODE FOR ASYMMETRIC TOP FUNCTIONS.
C
C IPASYM K-PAR +/- PAR
C 0 EVEN +
C 1 EVEN -
C 2 ODD +
C 3 ODD -
C
DIMENSION A(NK)
DATA EPS/1.D-4/
C
IPAR=-1
KPAR=-1
IF (NK.EQ.2*JI+1) GO TO 1000
1999 WRITE(6,699) JI,NK,(A(I),I=1,NK)
699 FORMAT('0 * * * ERROR. FOLLOWING SET OF ASYMMETRIC TOP COEFFICIEN
&TS ARE INVALID (PARITY).',2I6/(10X,6F12.8))
IPASYM=-1
RETURN
C NORMALIZE IF NECESSARY . . .
1000 XN=0.D0
DO 1100 I=1,NK
1100 XN=XN+A(I)*A(I)
IF (ABS(XN).GE.EPS) GO TO 1200
WRITE(6,602)
602 FORMAT('0 * * * ERROR. COEFFICIENTS CANNOT BE NORMALIZED.')
GO TO 1999
1200 XN=1.D0/SQRT(XN)
IF (ABS(XN-1.D0).LE.EPS) GO TO 2000
WRITE(6,601) XN
601 FORMAT(10X,'COEFFICIENTS NORMALIZED WITH FACTOR',D14.6)
2000 DO 2100 I=1,NK
2100 A(I)=A(I)*XN
C
NMID=JI+1
C DETERMINE EVEN/ODD K
LP=0
IF (ABS(A(NMID)).LE.EPS) GO TO 3100
KPAR=0
3100 IF (JI.LE.0) GO TO 4000
DO 3200 I=1,JI
LP=IABS(LP-1)
IF (ABS(A(NMID+I)).LE.EPS .AND. ABS(A(NMID-I)).LE.EPS)
& GO TO 3200
IF (KPAR.GE.0) GO TO 3300
KPAR=LP
GO TO 3200
3300 IF (KPAR.EQ.LP) GO TO 3200
KPAR=-1
GO TO 1999
3200 CONTINUE
C
C NOW DO +/- KPARITY . . .
4000 IF (ABS(A(NMID)).LE.EPS) GO TO 4100
IPAR=0
4100 IF (JI.LE.0) GO TO 5000
DO 4200 I=1,JI
IF (ABS(A(NMID-I)).GT.EPS) GO TO 4300
IF (ABS(A(NMID+I)).LE.EPS) GO TO 4200
IPAR=-1
GO TO 1999
4300 RATIO=A(NMID+I)/A(NMID-I)
IF (ABS(RATIO-1.D0).LE.EPS) GO TO 4400
IF (ABS(RATIO+1.D0).LE.EPS) GO TO 4500
IPAR=-1
GO TO 1999
4500 IF (IPAR) 4501,4502,4200
4501 IPAR=1
GO TO 4200
4502 IPAR=-1
GO TO 1999
4400 IF (IPAR) 4401,4200,4402
4401 IPAR=0
GO TO 4200
4402 IPAR=-1
GO TO 1999
4200 CONTINUE
C
5000 IF (KPAR.LT.0 .OR. IPAR.LT.0) GO TO 1999
IPASYM=2*KPAR+IPAR
RETURN
END
SUBROUTINE ISUTP(ISU,EN,JTL,JST,JT,NVC,NQL,QLS,QLT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION QLS(NVC,NVC),QLT(NVC,NVC,NQL)
IF (ISU.LE.0) RETURN
WRITE(ISU,3232) EN,JTL,JST,JT
3232 FORMAT(' ENERGY',F10.3,' JTOT',3I6)
WRITE(ISU,3233) ((QLS(IV,IVP),IV=1,NVC),IVP=1,NVC)
3233 FORMAT(1P,5D16.8)
WRITE(ISU,3233) (((QLT(IV,IVP,L),IV=1,NVC),IVP=1,NVC),L=1,NQL)
RETURN
END
SUBROUTINE IVCHK(IVLFL,IPRINT,ITYPE,NLABV,MXLAM,NPOTL,LAM)
DIMENSION LAM(1),NLABV(9)
C
C THIS ROUTINE CHECKS LAMBDA (MOLSCAT POTENTIAL SYMMETRY INDICES)
C TO ASCERTAIN WHETHER IV() INDEXING SCHEME ('NON-TRIVIAL' CASES)
C WILL WORK. IMPLEMENTATION BEGINNING V9 WILL **NOT** WORK
C PROPERLY IF TWO OF THE 'SYMMETRIES' ARE IDENTICAL.
C
C SINCE WE HAVE ACCESS TO ITYPE/NPOTL, WE COULD ALSO CHECK WHETHER
C NPOTL IS BIG ENOUGH; NOT DONE IN CURRENT CODE.
C
LOGICAL OKEY,LTEST
C
C CALLED FROM DRIVER AFTER BASIN(IOSBIN)/POTENL(INITIZATION)
C
IF (IVLFL.LE.0) THEN
IF (IPRINT.GE.3)
1 WRITE(6,*) ' IVCHK. IV() INDEXING IS NOT REQUESTED.'
RETURN
ENDIF
IF (MXLAM.LE.1) THEN
IF (IPRINT.GE.3) WRITE(6,*) ' IVCHK. NOT NEEDED, MXLAM.LE.1 '
RETURN
ENDIF
C
ITP=ITYPE-10*(ITYPE/10)
IF (ITP.EQ.0) THEN
WRITE(6,*) ' *** IVCHK. ILLEGAL ITYPE',ITYPE
STOP
ENDIF
NQ=NLABV(ITP)
OKEY=.TRUE.
DO 1000 I1=2,MXLAM
ITOP=I1-1
DO 1000 I2=1,ITOP
C LTEST IS TRUE IF LAM(,I1) IDENTICAL TO LAM(,I2)
C FALSE IF ANY INDICES DIFFER
LTEST=.TRUE.
DO 1100 N=1,NQ
1100 LTEST=LTEST.AND.LAM((I2-1)*NQ+N).EQ.LAM((I1-1)*NQ+N)
IF (.NOT.LTEST) GO TO 1000
C IF WE REACH CODE BELOW,TWO SETS OF INDICES ARE IDENTICAL
IF (OKEY) WRITE(6,600)
OKEY=.FALSE.
WRITE(6,601) I1,(LAM((I1-1)*NQ+N),N=1,NQ)
WRITE(6,601) I2,(LAM((I2-1)*NQ+N),N=1,NQ)
600 FORMAT('0 *** IVCHK. IV() INDEXING WILL NOT WORK. TERMINATING'/
1 ' *** IDENTICAL INDICES FOR TWO SYMMETRIES IN LAMBDA()'/
2 ' *** SYMMETRY/ INDICES')
601 FORMAT(9X,I5,10I6)
1000 CONTINUE
IF (OKEY) THEN
IF (IPRINT.GE.3) WRITE(6,*) ' IVCHK. COMPLETED SUCCESSFULLY.'
RETURN
ENDIF
STOP
END
SUBROUTINE J3J000(J2,J3,IVAL,W3J,J1MIN)
IMPLICIT DOUBLE PRECISION (A-H,J-M,O-Z)
DIMENSION W3J(1)
C
A(J1)=SQRT((J1*J1-DJ23S)*(J23P1S-J1*J1))
C
DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/,HALF/0.5D0/,ONPO/1.1D0/,
$ MZERO/1.0D-34/,TENTH/0.1D0/
C
C THIS SUBROUTINE CALCULATES A SEQUENCE OF 3-J SYMBOLS FOR FIXED J2,
C J3, M2=M3=0 FOR J1MIN.LE.J1.LE.J1MAX USING THE RECURSIVE METHOD OF
C K. SCHULTEN AND R. G. GORDON, J. MATH. PHYS., VOL. 10, P. 1971,
C (1975). PROGRAMMED BY D. E. FITZ, 9/16/79.
C
C NOT TESTED FOR HALF-INTEGER QUANTUM NUMBERS.
C
JJ2P1=J2*(J2+ONE)
JJ3P1=J3*(J3+ONE)
DJ23S=(J2-J3)**2
J23P1S=(J2+J3+ONE)**2
J1MIN=ABS(J2-J3)
J1MAX=J2+J3
SGNV=J2-J3
SGN=ONE
IF(SGNV.LT.ZERO) SGN=-ONE
ISGN=INT(SGNV+SGN*TENTH)
SGN=ONE
IF(MOD(ISGN,2).NE.0) SGN=-ONE
IVAL=INT(J1MAX-J1MIN+TENTH)/2+1
C
C RIGHT RECURSION.
C
20 NMID=IVAL/2+1
W3J(1)=HALF
IF(IVAL.EQ.1) GO TO 40
J1=J1MIN
DO 21 IM2=2,NMID
J1=J1+TWO
21 W3J(IM2)=-A(J1-ONE)*W3J(IM2-1)/A(J1)
IF(IVAL.EQ.2) GO TO 40
SCALE=W3J(NMID)
C
C LEFT RECURSION.
C
30 W3J(IVAL)=HALF
J1=J1MAX
IEND=IVAL-NMID
DO 32 IM2=1,IEND
W3J(IVAL-IM2)=-A(J1)*W3J(IVAL-IM2+1)/A(J1-ONE)
32 J1=J1-TWO
C
C MATCH LEFT AND RIGHT RECURSIVE RESULTS BY SCALING.
C
31 SCALE=SCALE/W3J(NMID)
DO 33 IM2=NMID,IVAL
33 W3J(IM2)=SCALE*W3J(IM2)
C
C NORMALIZE RESULTS AND SET PHASE.
C
40 SUM=ZERO
DO 41 IM2=1,IVAL
J1=J1MIN+TWO*DBLE(IM2-1)
41 SUM=SUM+(TWO*J1+ONE)*W3J(IM2)**2
RNORM=ONE/SQRT(SUM)
IF((SGN*W3J(IVAL)).LT.ZERO) RNORM=-RNORM
DO 42 IM2=1,IVAL
42 W3J(IM2)=W3J(IM2)*RNORM
RETURN
END
SUBROUTINE J6J(J2,J3,L1,L2,L3,IVAL,J1MIN,D6J)
IMPLICIT DOUBLE PRECISION (A-H,J-Z)
DIMENSION D6J(2)
DATA ZERO/0.D0/,TENTH/0.1D0/,HALF/0.5D0/,ONE/1.D0/,TWO/2.D0/,
$ CONST/1.0D-12/
E(J1S)=SQRT((J1S-MJ23S)*(J23P1S-J1S)*(J1S-ML23S)*(L23P1S-J1S))
F(J1,JJP1)=(TWO*J1+ONE)*(JJP1*(FACT-JJP1-TWO*LLP1)+FACT2)
C
C THIS ROUTINE CALCULATES THE 6-J COEFFICIENTS FOR ALL PERMISSIBLE
C VALUES OF J1 FOR FIXED VALUES OF J2, J3, L1, L2, AND L3 USING THE
C RECURSIVE ALGORITHM OF K. SCHULTEN AND R. G. GORDON, J. MATH. PHYS.
C VOL. 16, P. 1961, (1975).
C PROGRAMMED BY D. E. FITZ, 10/22/79
C MODIFIED BY S. GREEN 20 AUG 93 TO TEST DIMENSION ON D6J
C
MXDIM=IVAL
JJP2=J2*(J2+ONE)
JJP3=J3*(J3+ONE)
LLP1=L1*(L1+ONE)
LLP2=L2*(L2+ONE)
LLP3=L3*(L3+ONE)
MJ23S=(J2-J3)**2
ML23S=(L2-L3)**2
J23P1S=(J2+J3+ONE)**2
L23P1S=(L2+L3+ONE)**2
FACT2=(LLP2-LLP3)*(JJP2-JJP3)
FACT=JJP2+JJP3+LLP2+LLP3
J1MIN=MAX(ABS(J2-J3),ABS(L2-L3))
J1MAX=MIN(J2+J3,L2+L3)
IVAL=INT(J1MAX-J1MIN+ONE+TENTH)
IF (IVAL.GT.MXDIM) THEN
WRITE(6,*) 'J6J: ARRAY D6J TOO SMALL. NEEDS ',IVAL,' BUT ONLY ',
1 MXDIM,' SUPPLIED'
STOP
ENDIF
C
C TEST FOR OTHER TRIANGULAR INEQUALITES.
C
IL1=INT(TWO*L1+TENTH)
IL2=INT(TWO*L2+TENTH)
IL3=INT(TWO*L3+TENTH)
IJ2=INT(TWO*J2+TENTH)
IJ3=INT(TWO*J3+TENTH)
IF((IJ2.LE.IL1+IL3.AND.IJ2.GE.IABS(IL1-IL3)).AND.
$ (IJ3.LE.IL1+IL2.AND.IJ3.GE.IABS(IL1-IL2))) GO TO 11
DO 12 I=1,IVAL
12 D6J(I)=ZERO
RETURN
C
11 INMID=(IVAL+3)/2
SGNV=J2+J3+L2+L3
SGN=ONE
ISIGN=INT(SGNV+TENTH)
IF(MOD(ISIGN,2).NE.0) SGN=-ONE
D6J(1)=HALF
C
C UPWARD RECURSION.
C
IF(IVAL.EQ.1) GO TO 40
JJP1=J1MIN*(J1MIN+ONE)
F1=F(J1MIN,JJP1)
J1=J1MIN+ONE
J1S=J1*J1
E2=E(J1S)
IF(J1MIN.LT.TENTH) GO TO 15
D6J(2)=-F1*D6J(1)/(E2*J1MIN)
GO TO 16
15 D6J(2)=-HALF*(LLP2+JJP2-LLP1)*D6J(1)/SQRT(JJP2*LLP2)
16 SCALE=D6J(2)
IF(IVAL.EQ.2) GO TO 40
DO 21 IJ2=3,INMID
JJP1=J1*(J1+ONE)
F1=F(J1,JJP1)
J1=J1+ONE
E1=E2
J1S=J1*J1
E2=E(J1S)
21 D6J(IJ2)=-(F1*D6J(IJ2-1)+J1*E1*D6J(IJ2-2))/(E2*(J1-ONE))
SCALE=D6J(INMID)
IEXC=5
IF(ABS(SCALE).GT.CONST) GO TO 18
INMID=INMID-1
SCALE=D6J(INMID)
IEXC=3
GO TO 30
18 IF(IVAL.EQ.3) GO TO 40
C
C DOWNWARD RECURSION.
C
30 D6J(IVAL)=HALF
J1=J1MAX
J1S=J1*J1
JJP1=J1*(J1+ONE)
F1=F(J1,JJP1)
E1=E(J1S)
D6J(IVAL-1)=-F1*D6J(IVAL)/(E1*(J1+ONE))
IEND=IVAL-INMID
IF(IVAL.LE.IEXC) GO TO 31
DO 32 IJ2=2,IEND
J1=J1-ONE
E2=E1
J1S=J1*J1
JJP1=J1*(J1+ONE)
E1=E(J1S)
F1=F(J1,JJP1)
32 D6J(IVAL-IJ2)=-(J1*E2*D6J(IVAL-IJ2+2)+F1*D6J(IVAL-IJ2+1))/
$ (E1*(J1+ONE))
C
C MATCH UPWARD AND DOWNWARD RECURSIVE RESULTS BY SCALING.
C
31 SCALE=SCALE/D6J(INMID)
DO 33 IJ2=INMID,IVAL
33 D6J(IJ2)=SCALE*D6J(IJ2)
C
C NORMALIZE RESULTS AND SET PHASE.
C
40 SUM=ZERO
DO 41 IJ2=1,IVAL
J1=J1MIN+DBLE(IJ2-1)
41 SUM=SUM+(TWO*J1+ONE)*D6J(IJ2)**2
RNORM=ONE/SQRT(SUM*(TWO*L1+ONE))
IF((SGN*D6J(IVAL)).LT.ZERO) RNORM=-RNORM
DO 42 IJ2=1,IVAL
42 D6J(IJ2)=D6J(IJ2)*RNORM
RETURN
END
SUBROUTINE J6TO4(NLEV,JLEV,ATAU,JLNW,NAVAIL,ELEVNW,JLEVNW)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JLEV(1),ATAU(1),JLNW(NAVAIL),ELEVNW(MXEL),JLEVNW(MXJL)
C CMBASE FOR VERSION 14 (AUG 94)
DIMENSION BE(2),ALPHAE(2),DE(2)
EQUIVALENCE (BE(1),AAE(1)), (ALPHAE(1),BBE(1)), (DE(1),CCE(1))
COMMON /CMBASE/ AAE(2),BBE(2),CCE(2),ROTI(6),ELEVEL(1000),EMAX,
1 WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10),
2 J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL
C
C WE MUST BE ABLE TO GET J2 FROM J2MIN,J2MAX,J2STEP
C AND CALCULATE LINEAR ROTOR ENERGY FROM BE(2)
WRITE(6,641) J2MIN,J2MAX,J2STEP
641 FORMAT(/' *** J6TO4. COMBINING ASYMMETRIC ROTOR AND LINEAR ROTOR'
1 /' LINEAR ROTOR LEVELS FROM J2MIN =',I3,
2 ', J2MAX =',I3,', J2STEP =',I2)
J2MIN=MAX0(J2MIN,0)
J2MAX=MAX0(J2MAX,J2MIN)
J2STEP=MAX0(J2STEP,1)
IF (BE(2).LE.0.D0) THEN
IF (J2MAX.EQ.0) THEN
C SET ARBITRARY BE(2) SINCE ENERGY WILL ALWAYS BE ZERO
BE(2)=1.D0
ELSE
WRITE(6,*) ' *** SET4/J6TO4. CANNOT OBTAIN LINEAR ROTOR',
1 ' ENERGY FROM BE(2)'
STOP
ENDIF
ENDIF
WRITE(6,644) BE(2)
644 FORMAT(/' LINEAR ROTOR ENERGY LEVELS COMPUTED FROM B(E) =',F12.6)
IF (ALPHAE(2).NE.0.D0) WRITE(6,645) ALPHAE(2)
645 FORMAT(27X,'CORRECTED FOR ALPHA(E) = ',F12.8)
IF (DE(2).NE.0.D0) WRITE(6,646) DE(2)
646 FORMAT(27X,'CORRECTED FOR D(E) = ',F12.8)
IF (EMAX.GT.0.D0) WRITE(6,648) EMAX
648 FORMAT(/' ENERGY CAP ON BASIS FUNCTIONS IS EMAX =',F14.4)
C
C NLNW COUNTS NEW 'NLEVEL'; INEW COUNTS NEW 'NLEV'
MINA=9999999
MAXA=0
INEW=0
NLNW=0
ITOP=0
NKVAL=0
MXNEW=NAVAIL/8
C LOOP OVER ITYPE=6 FORMAT IN JLEV(NLEV,6)
JMIN=9999999
JMAX=0
DO 1000 IOLD=1,NLEV
J1=JLEV(IOLD)
ITAU=JLEV(NLEV+IOLD)
IPAR=JLEV(2*NLEV+IOLD)
ISTA=JLEV(3*NLEV+IOLD)
NK=JLEV(4*NLEV+IOLD)
MINA=MIN(MINA,ISTA+1)
MAXA=MAX(MAXA,ISTA+NK)
NKVAL=NKVAL+NK
INDX=JLEV(5*NLEV+IOLD)
IF (INDX.NE.IOLD) WRITE(6,690) INDX,IOLD
690 FORMAT(' *** J6TO4. PROBABLY ERROR. INDX.NE.I',2I6)
C EXPAND ON J2
DO 2000 J2=J2MIN,J2MAX,J2STEP
FJ=DBLE(J2)
FJ=FJ*(FJ+1.D0)
E2=(BE(2)-ALPHAE(2)*0.5D0)*FJ - DE(2)*FJ*FJ
EN=ELEVEL(INDX) + E2
IF (EMAX.GT.0.D0 .AND. EN.GT.EMAX) GO TO 2000
NLNW=NLNW+1
IF (NLNW.GT.MXEL) THEN
WRITE(6,*) ' *** J6TO4. NUMBER LEVELS EXCEEDS MXEL',MXEL
STOP
ENDIF
ELEVNW(NLNW)=EN
JLEVNW(3*NLNW-2)=J1
JLEVNW(3*NLNW-1)=ITAU
JLEVNW(3*NLNW)=J2
IF (JLEVEL(2*INDX-1).NE.J1 .OR. JLEVEL(2*INDX).NE.ITAU) THEN
WRITE(6,*) ' *** J6TO4. INCOMPATIBLE JLEVEL(), JLEV() FOR'
WRITE(6,*) ' LEVEL',INDX
ENDIF
C EXPAND J1+J2 TO J12; NEED TO SET JMIN,JMAX TO MIN/MAX OF J12
C FOR USE IN PICKING ORBITAL MOMENTA FOR A GIVEN JTOT
DO 3000 J12=ABS(J1-J2),J1+J2
INEW=INEW+1
IF (INEW.GT.MXNEW) THEN
WRITE(6,*) ' *** J6TO4. SCRATCH SPACE EXCEEDED FOR BASIS NO.'
1 ,INEW
STOP
ENDIF
JLNW(ITOP+1)=J12
JLNW(ITOP+2)=J2
JLNW(ITOP+3)=J1
JLNW(ITOP+4)=ITAU
JLNW(ITOP+5)=IPAR
JLNW(ITOP+6)=ISTA
JLNW(ITOP+7)=NK
JLNW(ITOP+8)=NLNW
JMIN=MIN(JMIN,J12)
JMAX=MAX(JMAX,J12)
3000 ITOP=ITOP+8
2000 CONTINUE
1000 CONTINUE
C
C COPY JLEVNW,ELEVNW BACK TO JLEVEL,ELEVEL
DO 4000 I=1,NLNW
ELEVEL(I)=ELEVNW(I)
JLEVEL(3*I-2)=JLEVNW(3*I-2)
JLEVEL(3*I-1)=JLEVNW(3*I-1)
4000 JLEVEL(3*I)=JLEVNW(3*I)
C SHIFT ATAU UP TO REFLECT START AT 6*NLEV+1 TO 8*INEW+1
IF (NKVAL.NE.MAXA-MINA+1)
1 WRITE(6,*) ' POSSIBLE ERROR. MINA,MAXA,NKVAL',MINA,MAXA,NKVAL
MOVE=8*INEW-6*NLEV
DO 4500 I=1,NKVAL
4500 ATAU(8*INEW+NKVAL+1-I)=ATAU(6*NLEV+NKVAL+1-I)
C SHIFT ISTA (JLNW(6,I)) TO REFLECT MOVED ATAU
IX=6
DO 4600 I=1,INEW
JLNW(IX)=JLNW(IX)+MOVE
4600 IX=IX+8
C RESET NLEV; COPY JLNW TO JLEV, CORRECTING ORDER
NLEV=INEW
ITOP=0
DO 5000 I=1,NLEV
IX=I
DO 5100 II=1,8
ITOP=ITOP+1
JLEV(IX)=JLNW(ITOP)
5100 IX=IX+NLEV
5000 CONTINUE
RETURN
END
SUBROUTINE J9J(J1,J2,J4,J5,J6,J7,J8,J9,IVAL,J3MIN,D9J)
IMPLICIT DOUBLE PRECISION (A-H,J-Z)
DIMENSION D9J(1),D6J3(200),D6J5(200),D6J7(200)
DATA MXDIM6/200/
DATA ZERO/0.D0/,TENTH/0.1D0/,HALF/0.5D0/,ONE/1.D0/,TWO/2.D0/
C
C THIS ROUTINE CALCULATES THE 9-J SYMBOLS BY SUMMATION OVER 6-J
C SYMBOLS WHICH IN TURN ARE CALCULATED BY THE RECURSIVE METHOD
C OF SCHULTEN AND GORDON.
C PROGRAMMED BY D. E. FITZ, 22 OCT 79.
C
C MODIFIED BY M. L. DUBERNET, 15 SEP 93 AND J. M. HUTSON, 3 OCT 93
C TO ALLOW HALF-INTEGER ANGULAR MOMENTA
C MODIFIED BY J. M. HUTSON, 3 OCT 93 TO CHECK D9J DIMENSION
C
MXDIM9=IVAL
J3MIN=MAX(ABS(J1-J2),ABS(J6-J9))
J3MAX=MIN(J1+J2,J6+J9)
IJ3N=INT(TWO*J3MIN+TENTH)
IJ3X=INT(TWO*J3MAX+TENTH)
IVAL=1+(IJ3X-IJ3N)/2
IF(IVAL.GT.MXDIM9) THEN
WRITE(6,*) 'J9J: ARRAY D9J TOO SMALL. NEEDS ',IVAL,' BUT ONLY ',
1 MXDIM9,' SUPPLIED'
STOP
ENDIF
C
C TEST FOR TRIANGULAR INEQUALITIES.
C
D9J(1)=ZERO
IF (IVAL.LE.0) RETURN
IJ1=INT(TWO*J1+TENTH)
IJ2=INT(TWO*J2+TENTH)
IJ4=INT(TWO*J4+TENTH)
IJ5=INT(TWO*J5+TENTH)
IJ6=INT(TWO*J6+TENTH)
IJ7=INT(TWO*J7+TENTH)
IJ8=INT(TWO*J8+TENTH)
IJ9=INT(TWO*J9+TENTH)
DO 15 IJL=1,IVAL
15 D9J(IJL)=ZERO
IF((IJ4-IABS(IJ7-IJ1))*(IJ7+IJ1-IJ4).LT.0) RETURN
IF((IJ5-IABS(IJ8-IJ2))*(IJ8+IJ2-IJ5).LT.0) RETURN
IF((IJ5-IABS(IJ6-IJ4))*(IJ6+IJ4-IJ5).LT.0) RETURN
IF((IJ8-IABS(IJ9-IJ7))*(IJ9+IJ7-IJ8).LT.0) RETURN
C
IVAL7=MXDIM6
CALL J6J(J1,J9,J7,J8,J4,IVAL7,JMIN7,D6J7)
C
IVAL5=MXDIM6
CALL J6J(J6,J2,J5,J8,J4,IVAL5,JMIN5,D6J5)
C
JMIN=MAX(JMIN5,JMIN7)
JMAX=MIN(J1+J9,J2+J6,J4+J8)
IEND=INT(JMAX-JMIN+TENTH+ONE)
I5=INT(JMIN-JMIN5+TENTH)
I7=INT(JMIN-JMIN7+TENTH)
C
C LOOP RUNS OVER TWICE J3 TO ALLOW HALF-INTEGER VALUES
C
ITAB=0
DO 20 IJ3=IJ3N,IJ3X,2
ITAB=ITAB+1
J3=HALF*DBLE(IJ3)
C
IVAL3=MXDIM6
CALL J6J(J1,J9,J3,J6,J2,IVAL3,JMIN3,D6J3)
I3=INT(JMIN-JMIN3+TENTH)
SUM=ZERO
C
DO 10 I=1,IEND
J=DBLE(I-1)+JMIN
SGN=ONE
ISIGN=INT(TWO*J+TENTH)
IF(MOD(ISIGN,2).NE.0) SGN=-ONE
SUM=SUM+(TWO*J+ONE)*SGN*D6J3(I+I3)*D6J5(I+I5)*D6J7(I+I7)
10 CONTINUE
D9J(ITAB)=SUM
20 CONTINUE
RETURN
END
SUBROUTINE KSYM(AK,N)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION AK(N,N)
DO 10 I=1,N
DO 10 J=1,I
TMP=0.5D0*(AK(I,J)+AK(J,I))
AK(I,J)=TMP
AK(J,I)=TMP
10 CONTINUE
RETURN
END
SUBROUTINE KTOS(R,SR,SI,NOP)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION R(1),SR(1),SI(1)
C
C ROUTINE TO OBTAIN THE S MATRIX FROM THE REACTANCE (K) MATRIX
C ALTHOUGH THIS ROUTINE USES SYMMETRIC MATRIX MULTIPLICATION,
C THE WHOLE OF R MUST BE SUPPLIED AND THE WHOLE OF SR AND
C SI ARE RETURNED.
C
C I + R*R IS POSITIVE DEFINITE, SO SYMINV CANNOT FAIL
C
NOPP1=NOP+1
NOPSQ=NOP*NOP
CALL DSYMM('L','L',NOP,NOP,0.5D0,R,NOP,R,NOP,0.D0,SR,NOP)
DO 10 II=1,NOPSQ,NOPP1
10 SR(II)=SR(II)+0.5D0
CALL SYMINV(SR,NOP,NOP,IFAIL)
CALL DSYFIL('U',NOP,SR,NOP)
CALL DSYMM('L','L',NOP,NOP,1.D0,SR,NOP,R,NOP,0.D0,SI,NOP)
DO 30 II=1,NOPSQ,NOPP1
30 SR(II)=SR(II)-1.D0
RETURN
END
SUBROUTINE LDPROP(U,Z,N,RBEGIN,REND,NSTEP,
X ESHIFT,IREAD,IWRITE,ISCRU,
X P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL,ISTART,NODES)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
LOGICAL IREAD,IWRITE
DIMENSION U(N,N),Z(N,N),P(MXLAM),VL(2),IV(2),EINT(N),CENT(N),DG(N)
C
H = (REND-RBEGIN)/DBLE(2*NSTEP)
D1 = H*H/3.D0
D2 = 2.D0*D1
D4 = -D1/16.D0
R = RBEGIN
NODES=0
IF( .NOT. IREAD) GO TO 100
READ(ISCRU) U
DO 90 I = 1,N
90 U(I,I)=U(I,I)-ESHIFT
GO TO 110
100 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL)
IF(IWRITE) WRITE(ISCRU) U
C
110 IF(ISTART.EQ.1) GO TO 135
SGN=1.D0
IF(REND.LT.RBEGIN) SGN=-1.D0
DO 130 J = 1,N
DO 120 I = J,N
120 Z(I,J) = 0.D0
Z(J,J) = SGN*1.D30
130 IF(U(J,J).GT.0.D0) Z(J,J) = SGN*SQRT(U(J,J))
135 CONTINUE
C
DO 150 J = 1,N
DO 140 I = J,N
140 Z(I,J) = H*Z(I,J)+D1*U(I,J)
150 Z(J,J) = 1.D0+Z(J,J)
C
DO 260 ISTEP = 1,NSTEP
R = R+H
IF( .NOT. IREAD) GO TO 160
READ(ISCRU) U
ESH=-D4*ESHIFT
DO 155 I=1,N
155 U(I,I)=U(I,I)+ESH
GO TO 190
160 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL)
DO 180 J = 1,N
DO 170 I = J,N
170 U(I,J) = D4*U(I,J)
180 U(J,J) = 0.125D0+U(J,J)
IF(IWRITE) WRITE(ISCRU) U
190 CALL SYMINV(U,N,N,NCU)
IF(NCU.GT.N) GO TO 900
CALL SYMINV(Z,N,N,NCZ)
IF(NCZ.GT.N) GO TO 900
NODES=NODES+NCZ
DO 210 J = 1,N
DO 200 I = J,N
200 Z(I,J) = U(I,J)-Z(I,J)
210 Z(J,J) = Z(J,J)-6.D0
CALL SYMINV(Z,N,N,NCZ)
IF(NCZ.GT.N) GO TO 900
NODES=NODES+NCZ-NCU
R = R+H
IF(ISTEP.EQ.NSTEP) D2=D1
IF( .NOT. IREAD) GO TO 220
READ(ISCRU) U
ESH=-D2*ESHIFT
DO 215 I=1,N
215 U(I,I)=U(I,I)+ESH
GO TO 245
220 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL)
DO 240 I=1,N
DO 230 J=1,I
230 U(I,J)=D2*U(I,J)
240 U(I,I)=U(I,I)+2.D0
IF(IWRITE) WRITE(ISCRU) U
245 DO 250 J = 1,N
DO 250 I = J,N
250 Z(I,J) = U(I,J)-Z(I,J)
260 CONTINUE
C
HI = 1.D0/H
DO 280 J = 1,N
DO 270 I = J,N
Z(I,J) = HI*Z(I,J)
270 Z(J,I) = Z(I,J)
280 Z(J,J) = Z(J,J)-HI
RETURN
C
900 WRITE(6,901)
901 FORMAT('0 *** ERROR IN SYMINV CALLED FROM LDPROP - TERMINATING')
STOP
END
SUBROUTINE LDVIVS(N,NSQ,MXLAM,NPOTL,
1 SR,SI,W,VL,IVL,EINT,CENT,WV,L,NB,
2 P,A1,A1P,B1,B1P,
3 WKS,G1,G1P,G2,G2P,COSX,SINX,SINE,DIAG,XK,XSQ,
4 TSTORE,W0,W1,W2,EYE11,EYE12,EYE22,VEC,
5 ICODE,IPRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C ***
C *** INTERFACE TO VIVAS/LDPROP
C *** -------------------------------------------------------------
C *** ADAPTED FROM PROGRAMS OF G.A. PARKER, J.V. LILL, & J.C. LIGHT
C *** REF.: N.R.C.C. SOFTWARE CATALOG, VOL. 1, PROG. NO. KQ04, 1980.
C *** -------------------------------------------------------------
C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGY.
C ***
DIMENSION SR(NSQ),SI(NSQ),W(NSQ),VL(2),IVL(2),
1 EINT(N),CENT(N),WV(N),L(N),NB(N),
2 P(MXLAM),A1(N),A1P(N),B1(N),B1P(N),
3 WKS(N),G1(N),G1P(N),G2(N),G2P(N),
4 COSX(N),SINX(N),SINE(N),DIAG(N),XK(N),XSQ(N),
5 TSTORE(NSQ),W0(NSQ),W1(NSQ),W2(NSQ),
6 EYE11(NSQ),EYE12(NSQ),EYE22(NSQ),VEC(NSQ)
C
COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR,
1 DRMAX,RVIVAS,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA,
2 NOPEN,JKEEP,ISCRU,MAXSTP
C
LOGICAL IALFP,IV,IVP,IVPP,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE
COMMON /LDVVCM/ XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,
1 NUMDER,IVPP,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE
C
C LOGICAL VARIABLES
LOGICAL LLD,LVIVS
C
C-----------------------------------------------------------------
C SET UP TO USE UNIT (ISCRU)
IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0
IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0
C-------------------------------------------------------------------
IF(IWRITE) WRITE(ISCRU) RMIN,RVIVAS,RMAX
IF(IREAD) READ (ISCRU) RMIN,RVIVAS,RMAX
C
C DECIDE WHICH CALCULATIONS (LDPROP/VIVAS) ARE DESIRED
C
LLD= RMIN.LT.RVIVAS
LVIVS= RMAX.GT.RVIVAS
IF (LLD.OR.LVIVS) GO TO 130
WRITE(6,699) RMIN,RVIVAS,RMAX
699 FORMAT('0 * * * ERROR. NULL CALCULATION REQUESTED.'/
& ' RMIN, RVIVAS, RMAX =',3E14.4)
STOP
C
130 RMID=MIN(RMAX,RVIVAS)
RMID=MAX(RMIN,RMID)
C
C CALCULATE WAVEVECTORS, AND STEP SIZE FOR LDPROP
C
BIG=0.D0
NOPEN=0
DO 190 I=1,N
DIF=ERED-EINT(I)
WV(I)=SIGN(SQRT(ABS(DIF)),DIF)
BIG=MAX(BIG,WV(I))
NB(I)=I
190 IF(DIF.GT.0.D0) NOPEN=NOPEN+1
IF(NOPEN.LE.0) RETURN
IF(IREAD) THEN
READ(ISCRU) NSTEP
ELSE
NSTEP=BIG*STEPS*(RMID-RMIN)/ACOS(-1.D0)
IF(IWRITE) WRITE(ISCRU) NSTEP
ENDIF
LLD = LLD .AND. NSTEP.GT.0
C-------------------------------------------------------------------
C PROPAGATE THE LOG-DERIVATIVE MATRIX THROUGH THE SCATTERING REGION
IF (.NOT.LLD) GO TO 200
CALL LDPROP(W,SR,N,RMIN,RMID,NSTEP,
& ESHIFT,IREAD,IWRITE,ISCRU,
& P,VL,IVL,ERED,EINT,CENT,RMLMDA,A1,MXLAM,NPOTL,0,NODES)
IF(IPRINT.GE.3) WRITE(6,195) RMIN,RMID,NSTEP
195 FORMAT('0 LDPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ',
& F12.4,' TO ',F12.4,' IN ',I6,' STEPS.')
200 IF (.NOT.LVIVS) GO TO 210
C GET R-MATRIX BY INVERTING LOGD OR BY DIRECT INITIALIZATION
IF (LLD) THEN
CALL SYMINV(SR,N,N,IFAIL)
CALL DSYFIL('U',N,SR,N)
ELSE
N1=N+1
DO 170 I=1,NSQ
170 SR(I)=0.D0
DO 180 I=1,NSQ,N1
180 SR(I)=1.D30
ENDIF
DRNOW=DR
C SET TLDIAG/TOFF FROM TOLHI. C.F. NRCC DEFAULTS OF .064
TLDIAG=.064D0*SQRT(TOLHI/.001D0)
TOFF=TLDIAG
CALL VIVAS(N,NSQ,DRNOW,RMID,RMAX,DRMAX,TLDIAG,TOFF,ESHIFT,
& SR,EYE11,EYE12,EYE22,W,W0,W1,W2,TSTORE,VEC,SI,
& G1,G1P,G2,G2P,A1,A1P,B1,B1P,XSQ,XK,COSX,
& SINX,SINE,DIAG,NOPEN,IPRINT,ISCRU,
& P,VL,IVL,ERED,EINT,CENT,RMLMDA,MXLAM,WKS,NPOTL)
C AND CONVERT R-MATRIX BACK TO LOGD MATRIX
CALL SYMINV(SR,N,N,IFAIL)
C------------------------------------------------------------------
C SORT CHANNELS BY ASYMPTOTIC ENERGY
C
210 IF(N.LE.1) GOTO 230
NM1=N-1
DO 220 I=1,NM1
IP1=I+1
DO 220 J=IP1,N
IF(EINT(NB(I)).LE.EINT(NB(J))) GOTO 220
IT=NB(I)
NB(I)=NB(J)
NB(J)=IT
220 CONTINUE
C-------------------------------------------------------------
C CALCULATE K AND S MATRICES
230 CALL YTOK(NB,WV,L,N,NOPEN,A1,A1P,B1,B1P,SR,SI,W,RMAX)
CALL KTOS(W,SR,SI,NOPEN)
RETURN
END
SUBROUTINE MASK
RETURN
END
* ----------------------------------------------------------------------
SUBROUTINE MAXMGV (A, NA, C, NC, N)
* SUBROUTINE TO SCAN A VECTOR FOR ITS MAXIMUM MAGNITUDE (ABSOLUTE VAL
* ELEMENT
* CURRENT REVISION DATE: 24-SEPT-87
* -------------------------------------------------------------------
* VARIABLES IN CALL LIST:
* A: FLOATING POINT INPUT VECTOR
* NA: INTEGER ELEMENT STEP FOR A
* C: FLOATING POINT OUTPUT SCALAR: ON RETURN CONTAINS VALUE OF
* MAXIMUM MAGNITUDE (ABSOLUTE VALUE) ELEMENT
* NC: INTEGER INDEX OF MAXIMUM MAGNITUDE ELEMENT
* N: INTEGER ELEMENT COUNT
* SUBROUTINES CALLED:
* IDAMAX: BLAS ROUTINE TO FIND INDEX OF MAXIMUM MAGNITUDE (ABSOLUTE V
* ELEMENT
* -------------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER IDAMAX, N, NA, NC
DIMENSION A(1)
NC = ( IDAMAX (N, A, NA) - 1) * NA + 1
C = ABS( A(NC) )
RETURN
END
SUBROUTINE MCGCPL(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,MVALUE,ITYPE,
1 IEX,VL,IV,PRINT)
C MODIFIED FOR ITYPE=4 BY SG 29 JUN 94
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE LFIRST
INTEGER PRINT
INTEGER LAM(2),JLEV(NLEV,3),J(2),L(2),IV(1)
DIMENSION VL(2)
LOGICAL LFIRST
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DATA SQRTHF/.70710678118654753D0/, Z0/0.D0/
C STATEMENT FUNCTION DEFINITION . . .
Z(I)=DBLE(I+I+1)
C
IF (ITYPE.EQ.21) GO TO 1000
IF (ITYPE.EQ.22) GO TO 2000
IF (ITYPE.EQ.23) GO TO 3000
IF (ITYPE.EQ.24) GO TO 4000
IF (ITYPE.EQ.25) GO TO 5000
IF (ITYPE.EQ.26) GO TO 6000
IF (ITYPE.EQ.27) GO TO 7000
STOP
C
1000 IF (IVLFL.NE.0) GO TO 9999
CALL CPL21(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST)
RETURN
C
2000 IF (IVLFL.LE.0) GO TO 9999
CALL CPL22(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,MVALUE,
1 IV,VL,PRINT,LFIRST)
RETURN
C
3000 IF (IVLFL.NE.0) GO TO 9999
CALL CPL23(N,MXLAM,LAM,NLEV,JLEV,J,L,MVALUE,IEX,VL,PRINT,LFIRST)
RETURN
C
CTRP>> JUN94 (SG)
4000 CALL CPL24(N,MXLAM,LAM,NLEV,JLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST)
RETURN
C<<TRP
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)
NZERO=NPOTL*N*(N+1)/2
DO 1547 I=1,NZERO
IV(I)=0
1547 VL(I)=0.D0
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)=PARITY3(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
IF (VL(I).NE.0.D0) 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.GT.0.AND.PRINT.LT.14)
1 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
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.NE.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.NE.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
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
* ----------------------------------------------------------------------
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 OUTPUT( JTOT, NBASIS, J, L, WVEC, SREAL, SIMAG,
1 AKMAT, CONV, NOPEN, M, MXPAR, WT, IEXCH, INRG, RM, PRNT, TTIME,
2 ENERGY, SIG, JLEV, ISST, IECONV, MINJT, MAXJT,
3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT,N)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE INVERR,NSTOR,ITYPE,NLEVEL,LOUT,JSTEP
C
C FOR MOLSCAT VERSION 14, JUL 1994
C WITH RESTART (IRSTRT) CAPABILITIES
C
C ENTRY OUTPUT - PROCESSES S MATRICES TO X-SECTIONS OUTPUTS THEM.
C ENTRY OUTSIG - (10/92) SEPARATE ENTRY TO UPDATE UNIT(ISIGU)
C TO FIX BUG W/ NO BASIS FNS FOR PARITY M=MXPAR
C ENTRY OUTINT - INITIALIZATION ENTRY FROM DRIVER.
C ENTRY OUTPCH - PUNCHES FINAL CROSS SECTIONS.
C ENTRY OUTERR - SETS ERROR FLAG, CALLED ONLY FROM DVSCAT.
C
C MODIFICATIONS AUG. 74 - - -
C NLEVEL IS DIFFERENT FROM NLEV. FORMER FOR ELEVEL,JLEVEL,
C AND LATTER FOR JLEV(NLEV,NQN).
C TSIG IS NOW FIRST NLEVEL*NLEVEL=NSTOR ELEMENTS OF SIG.
C DEGENERACY IS IN 2ND NSTOR ELEMENTS OF SIG.
C MODIFIED NOV 91 - - - MULTIPLIES CROSS SECTIONS BY JSTEP
C MODIFIED JUN 92 TO GIVE UNFORMATTED ISAVEU OUTPUT W/ ONLY
C NONREDUNDANT S(I,J). OLDER (FORMATTED) CODE IS SAVED AS
C COMMENTS TO PROVIDE COMPATIBILITY W/ VERSION 10 AND EARLIER.
C N.B FORMATS 800,801,802 ALSO USED FOR IPARTU OUTPUT.
C SREAL,SIMAG ARE WRITTEN USING A SUBROUTINE SWRITE.
C 21 JAN 93 -- NEW DYNAMIC MEMORY HANDLING
C APR 94 -- MODIFED CALLING SEQUENCES, OUTPUT FORMATS
C ACCOMMODATE NEGATIVE SIG-INDEX, JLEV((NQN-1)*NLEV+I)
C AUG 95 ADDED N TO PARAMETER LIST AND WRITE(6,642)
C
DIMENSION NBASIS(1),J(1),L(1),WVEC(1),SREAL(1),SIMAG(1)
DIMENSION AKMAT(NOPEN,NOPEN)
INTEGER ISST(2),MAXJT(2),MINJT(2),IECONV(2)
INTEGER PRINT,PRNT
INTEGER NLEV,JLEV(1)
DIMENSION SIG(1),ENERGY(1)
LOGICAL OKEY,LOUT,ACCUM,OPENED,LWARN
C INTEGER CTIME(2),CDATE(4)
CHARACTER CTIME*9,CDATE*11
CHARACTER*4 LABEL(20)
CHARACTER*1 STAR,BLANK
C
COMMON /CMBASE/ ROTI(12),ELEVEL(1004),IDUM(4031)
EQUIVALENCE (JHALF,IDUM(4028))
C
C COMMON BLOCK TO DRIVER FOR RESONANCE SEARCHES
C
COMMON/EIGSUM/EPSM(5)
C
EQUIVALENCE (NLVL,IDUM(1))
C
DATA STAR/'*'/, BLANK/' '/
DATA EPS/1.D-12/
DATA IPUNCH/7/
C
PI=ACOS(-1.D0)
PI2=2.D0*PI
C
PRINT=PRNT
C>>SG IEXCH=1
IRET=0
C
C SET LOGICAL VARIABLES
OKEY=CONV.GE.0.D0 .AND. IECONV(INRG).GE.0
ACCUM=OKEY .AND. INVERR.LE.0 .AND. ITYPE.NE.8
C
C BOOKEEPING FOR MINJT AND MAXJT
IF (MINJT(INRG).LT.0) MINJT(INRG)=JTOT
IF (OKEY .AND. JTOT.GT.MAXJT(INRG) .AND. MAXJT(INRG).GE.0)
& MAXJT(INRG)=JTOT
C
C PRINT OUT OPEN-CHANNEL BASIS FUNCTIONS AND WAVEVECTORS IN 1/A.
IF (PRINT.GE.11) WRITE(6,601)
601 FORMAT('0 CHANNEL NO. TARGET LEVEL ORBITAL L WVEC(1/ANG.)')
C CONVERT WVEC TO INVERSE ANGSTROMS
DO 1000 I=1,NOPEN
NB=NBASIS(I)
WVEC(NB)=WVEC(NB)/RM
IF (PRINT.GE.11) WRITE(6,602) I,J(NB),L(NB),WVEC(NB)
602 FORMAT(3I12,E18.8)
1000 CONTINUE
C
C
C PROCESS S-MATRIX. ACCUMULATE X-SECTIONS IN TSIG. PRINT.
C J(NBASIS(I)) IS LEVEL NUMBER OF ITH BASIS FN. IN ASYMPTOTIC AREA.
C CLEAR TSIG.
DO 1400 I=1,NSTOR
1400 SIG(I)=0.D0
IF (PRINT.GT.10) WRITE(6,606)
606 FORMAT('0 ROW COL',10X,'S**2',15X,'PHASE/2PI',12X,'RE (S)',14X,
1 'IM (S)' )
C
IJ=0
NTOP=(NQN-1)*NLEV
C CALCULATE GLOBAL MULTIPLICATIVE FACTOR FOR X-SECTIONS.
XJ=DBLE((2/JHALF)*JTOT+1)*PI
C>>SG CALCULATE (OR GET FROM PARM LIST) IEXCH -- FOR USE W/ISAVEU
C IF (IEXCH.NE.0) XJ=XJ*WT
IF (WT.GT.0.D0) XJ=XJ*WT
DO 2000 ICOL=1,NOPEN
LEVC=J(NBASIS(ICOL))
LCOL=JLEV(NTOP+LEVC)
IF (LCOL.GT.0) THEN
CS1=1.D0
ELSE
CS1=-1.D0
LCOL=-LCOL
ENDIF
DO 2000 IROW=1,NOPEN
DD=WVEC(NBASIS(IROW))
DD=DD*DD
LEVR=J(NBASIS(IROW))
C IJ IS INDEX OF SREAL,SIMAG(IROW,ICOL)
IJ=IJ+1
SMAG=( SREAL(IJ)*SREAL(IJ)+SIMAG(IJ)*SIMAG(IJ) )
IF (PRINT.LE.10 .OR. SMAG.LE.EPS) GO TO 2300
PHASE=ATAN2(SIMAG(IJ),SREAL(IJ)) / PI2
IF(ITYPE.NE.8) GO TO 2100
C SPECIAL CASE FOR SURFACE SCATTERING: WRITE OUT ONE COLUMN ONLY,
C LABELLED BY G VECTORS RATHER THAN CHANNEL NUMBERS
XJ=1.D0
IF(JLEV(LEVC).NE.0 .OR. JLEV(NLEV+LEVC).NE.0) GOTO 2400
WRITE(6,607) JLEV(LEVR),JLEV(NLEV+LEVR),
1 SMAG,PHASE,SREAL(IJ),SIMAG(IJ)
GOTO 2400
C ALL OTHER CASES
2100 WRITE(6,607) IROW,ICOL,SMAG,PHASE,SREAL(IJ),SIMAG(IJ)
607 FORMAT(2I5,4E20.6)
2300 IF (IROW.NE.ICOL) GO TO 2400
C FOR IROW = ICOL, CALCULATE T = 1 - S.
SMAG=1.D0-SREAL(IJ)
SMAG=SMAG*SMAG + SIMAG(IJ)*SIMAG(IJ)
2400 CONTINUE
C N.B. LCOL (LROW) < 0 IMPLIES JI (JF) .GT. JZCSMX
C IF BOTH NEGATIVE, INDICATE BY NEGATIVE SIGMA
LROW=JLEV(NTOP+LEVR)
CSF=1.D0
IF (LROW.LT.0) THEN
LROW=-LROW
IF (CS1.LT.0.D0) CSF=-1.D0
ENDIF
IF (LROW.GT.NLEVEL .OR. LCOL.GT.NLEVEL) GO TO 2000
C II IS INDEX OF SIG(ICOL,IROW). N.B. JLEV(LEV,NQN) HAS POINTER
C TO 'SERIAL' NUMBER OF 'LEVEL'.
II=(LROW-1)*NLEVEL+LCOL
C ACCOUNT FOR K(J,J), DEGEN. LATTER IN SIG(NSTOR+II).
SIG(II) = SIG(II) + CSF * SMAG*XJ/(SIG(NSTOR+II)*DD)
2000 CONTINUE
C
C ACCUMULATE X-SECTIONS. SET IJ TO START OF INRG-TH ENERGY IN SIG
4100 IJ=(INRG+1)*NSTOR
II=0
XII=0.D0
XIJ=0.D0
DO 3000 JI=1,NLEVEL
DO 3000 I=1,NLEVEL
II=II+1
IJ=IJ+1
IF ( ACCUM ) SIG(IJ)=SIG(IJ)+SIG(II)
IF (JI.EQ.I) GO TO 3100
XIJ=MAX(XIJ,ABS( SIG(II)))
GO TO 3000
3100 XII=MAX(XII,ABS( SIG(II)))
3000 CONTINUE
C
IF (ACCUM) GO TO 5101
C CODE BELOW IS REACHED IF SIGMA NOT ACCUMULATED. . .
IF (ITYPE.EQ.8) GO TO 6500
IF (OKEY) GO TO 9100
WRITE(6,9600)
9600 FORMAT(' ****** SIGMA NOT ACCUMULATED DUE TO LACK OF CONVERGENCE',
1 ' IN THIS OR PREVIOUS CALCULATION.')
IF(ISAVEU.GT.0) WRITE(6,9632)
9632 FORMAT(' ****** SCATTERING MATRIX NOT SAVED')
MAXJT(INRG)=-IABS(MAXJT(INRG))
IECONV(INRG)=MIN0(IECONV(INRG)-1,-1)
GO TO 6500
C
9100 WRITE(6,9611) INVERR
9611 FORMAT(' ****** SIGMA NOT ACCUMULATED BECAUSE OF MATRIX ',
1 'INVERSION ERROR',I4)
IF(ISAVEU.GT.0) WRITE(6,9632)
GO TO 6500
C
C BELOW REACHED IF SIGMA ACCUMULATED. OUTPUT, SAVE ON TAPE, DISK.
C
5101 IF(PRINT.EQ.1) THEN
WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ,N,NOPEN
ELSEIF(PRINT.GT.1) THEN
WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ,N,NOPEN,TTIME
642 FORMAT(' JTOT=',I4,'.',I2,' E(',I3,
1 ')=',F10.3,', MAX D/O-D=',1P,2D9.1,' N/NOP=',2I5,
2 2X,'TIME=',0P,F8.2)
ENDIF
C
IF(ISIGPR.LE.0) GO TO 5100
IF (PRINT.LE.4) GO TO 5100
WRITE(6,9601)
9601 FORMAT('0',8(' * '),'PARTIAL CROSS SECTIONS',8(' * '))
DO 5200 I=1,NLEVEL
C5200 WRITE(6,631) (ABS(SIG((II-1)*NLEVEL+I)),I,II, II=1,NLEVEL)
C BELOW INCORPORATES JMH V12 UPDATE AND SG V13X UPDATE
IF (ENERGY(INRG).GT.ELEVEL(I))
1WRITE(6,631) (ABS(SIG((II-1)*NLEVEL+I)),I,II, II=1,NLEVEL)
5200 CONTINUE
631 FORMAT('0',4(1P,D10.2,' FOR SIG(',2I3,')' )/
1 ( ' ',4(1P,D10.2,' FOR SIG(',2I3,')' )))
IF (PRINT.LE.10) GO TO 5100
WRITE(6,9602) MINJT(INRG),JTOT
9602 FORMAT('0',6(' * '),'CROSS SECTIONS ACCUMULATED FROM JTOT=',
1 I4,' TO',I4,6(' * '))
ISTART=(INRG+1)*NSTOR
XJS=DBLE(JSTEP)/DBLE(JHALF)
IF (JSTEP.NE.1) WRITE(6,9630) XJS
9630 FORMAT(31X,'MULTIPLIED BY',F5.1,' TO ACCOUNT FOR JSTEP.')
DO 5299 I=1,NLEVEL
5299 WRITE(6,631)
1 (ABS(SIG((II-1)*NLEVEL+I+ISTART))*XJS,I,II,II=1,NLEVEL)
5100 IF (XII.LE.DTOL .AND. XIJ.LE.OTOL) GO TO 5102
IECONV(INRG)=MIN0(IECONV(INRG),0)
GO TO 5103
5102 IECONV(INRG)=IECONV(INRG)+1
5103 IF(KSAVE.GT.0) GO TO 6320
C
C SAVE S MATRICES ON TAPE (ISAVEU) . . .
IF (IRSTRT.GT.0) GO TO 6500
IF (ISAVEU.LE.0) GO TO 6500
C BEGINNING IN VERSION 14 NOPEN IS WITH THE 'HEADER' RECORD
WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M,NOPEN
C WRITE(ISAVEU,803) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M
C 803 FORMAT(2I4,E16.8,I4,E16.8,I4)
WRITE(ISAVEU)
1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN)
C WRITE(ISAVEU,804) NOPEN,
C 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN)
C 804 FORMAT(I4/(2I4,E16.8))
CALL SWRITE(ISAVEU,NOPEN,SREAL)
CALL SWRITE(ISAVEU,NOPEN,SIMAG)
C NSQ=NOPEN*NOPEN
C WRITE(ISAVEU,805) (SREAL(I),I=1,NSQ)
C WRITE(ISAVEU,805) (SIMAG(I),I=1,NSQ)
C 805 FORMAT(5E16.8)
GO TO 6500
C
6320 IF(ISAVEU.LE.0) GO TO 6322
C 'KSAVE' OUTPUT FORMAT *NOT* CHANGED
WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M
6324 FORMAT(2I4,D22.15,I4,D22.15,I4)
WRITE(ISAVEU) NOPEN,
1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN)
6326 FORMAT(I4/(2I4,D22.15))
NPL1=NOPEN+1
NSQ=NOPEN*NOPEN
WRITE(ISAVEU) (SREAL(I),SIMAG(I),I=1,NSQ,NPL1)
WRITE(ISAVEU) ((AKMAT(I,JJ),I=1,JJ),JJ=1,NOPEN)
6328 FORMAT(4(D20.13))
6322 ESUM=EPSUM(AKMAT,NOPEN,SREAL,SIMAG,SREAL(NOPEN+1))
IF(ISAVEU.GT.0) WRITE(ISAVEU) ESUM
WRITE(6,6342) ESUM
6342 FORMAT('0 S-MATRIX EIGENPHASE SUM, EPSUM/PI =',F9.5)
IS=INRG-5*((INRG-1)/5)
EPSM(IS)=ESUM
C
WRITE(KSAVE,6330) JTOT,M,NOPEN,INRG,ENERGY(INRG),ESUM
6330 FORMAT(1X,I3,2I4,I5,F18.10,F21.15)
C
C ENTRY TO ALLOW UPDATING OF SIG() ON UNIT ISIGU
C IN CASE THERE ARE NO BASIS FNS FOR SYMMETRY BLOCK M=MXPAR.
GO TO 6500
ENTRY OUTSIG(ISIGU,M,MXPAR,INRG,ENERGY,MINJT,MAXJT,SIG)
IRET=1
C
C UPDATE DISK (ISIGU) RECORD IF THIS IS THE LAST PARITY CASE
6500 IF (.NOT.LOUT .OR. M.NE.MXPAR) GO TO 7200
XJS=JSTEP
IJ=(INRG+1)*NSTOR
I10=ISST(INRG)
DO 7100 I=1,NLEVEL
DO 7100 II=1,NLEVEL
IJ=IJ+1
C I10 IS INCREMENTED BY ASSOCIATED VARIABLE HERE.
IF (SIG(IJ).GE.0.D0) THEN
WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG),
1 MINJT(INRG),JSTEP,MAXJT(INRG),II,I,SIG(IJ)*XJS,BLANK
ELSE
WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG),
1 MINJT(INRG),JSTEP,MAXJT(INRG),II,I,ABS(SIG(IJ))*XJS,STAR
ENDIF
I10=I10+1
101 FORMAT(A1,F19.6,I5,2I7,5X,2I5,1P,D20.6,1X,A1)
7100 CONTINUE
IF (PRINT.GT.1) WRITE(6,690) ISIGU,INRG,ENERGY(INRG),JTOT,M
690 FORMAT(' OUTSIG: DA FILE (',I2,') UPDATED WITH SIGMA FOR ENERGY('
1 ,I3,') =',F10.2,' JTOT =',I4,'.',I2)
C
C>>SG(10/92)
C7200 CONTINUE
7200 IF (IRET.EQ.1) RETURN
C<<SG
C
IF(IPARTU.LE.0) GOTO 7250
WRITE(IPARTU,7205) JTOT,M,INRG,ENERGY(INRG)
7205 FORMAT(3I5,F20.5)
DO 7210 I=1,NLEVEL
7210 WRITE(IPARTU,7211) (SIG((II-1)*NLEVEL+I),II=1,NLEVEL)
7211 FORMAT(5F14.6)
7250 CONTINUE
C
INVERR=0
C RESTORE WVEC TO UNITS OF 1./RM
DO 7259 I=1,NOPEN
7259 WVEC(NBASIS(I))=WVEC(NBASIS(I))*RM
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C INITIALIZATION ENTRY.
C
ENTRY OUTINT(LABEL,ENERGY,NNRG,NLEV,NQN,JLEV,SIG,IC, IECONV,
1 URED,ITYP,KSAVE,ISST,MINJT,MAXJT,ISIGU,IPARTU,ISAVEU,IPROGM,
2 MXSIG,ISIGPR,JST,IRSTRT)
C
JSTEP=JST
ITYPE=ITYP
INVERR=0
C FIND NLEVEL AS MAX. INDEX FROM JLEV(I,NQN); ALLOW FOR NEG SIG IND
IJ=(NQN-1)*NLEV
NLEVEL=0
DO 6196 II=1,NLEV
IJ=IJ+1
6196 NLEVEL=MAX0(NLEVEL,IABS(JLEV(IJ)))
IF (NLEVEL.GT.0) GO TO 6195
WRITE(6,603)
603 FORMAT('0 * * * ERROR. NO LEVELS IN SIG. MATRICES.')
STOP
6195 IF (MXSIG.GT.0) THEN
NLEVEL=MIN0(MXSIG,NLEVEL)
WRITE(6,604) MXSIG
604 FORMAT('0 NOTE. MAXIMUM LEVEL FOR WHICH CROSS SECTIONS ARE'
1 ,' ACCUMULATED MAY BE LIMITED BY MXSIG =',I4)
ENDIF
NSTOR=NLEVEL*NLEVEL
C
C CALCULATE REQUIRED STORAGE AND INITIALIZE IT. NSTOR LOCATIONS
C FOR TSIG; NSTOR FOR DEGEN; NNRG*NSTOR FOR SIG.
IJ=NSTOR*(NNRG+2)
IC=IC+IJ
C IC INCREMENTED TO REFLECT ADDITIONAL STORAGE TAKEN UP BY SIG.
C THIS CODE RELIES ON THE FACT THAT IXNEXT IS PASSED IN ARG. IC
C AND THAT IT IS REFERENCED BY LOCATION SO THAT THE VALUE
C IN COMMON IS UPDATED BY THE ASSIGNMENT IC= ...
C SO THAT THE VALUE IN /MEMORY/ ..,IXNEXT,.. IS SET FOR CHKSTR
C
C N.B NUSED MUST BE INITIALIZED NON-NEGATIVE BEFORE CHKSTR
NUSED=0
CALL CHKSTR(NUSED)
C INITIALIZE SIG TO ZERO
II=2*NSTOR+1
DO 6200 I=II,IJ
6200 SIG(I)=0.D0
C DEGENERACY INFORMATION IN SIG(NSTOR+(LROW-1)*NLEVEL+LCOL)
II=NSTOR
DO 6194 LROW=1,NLEVEL
DO 6194 LCOL=1,NLEVEL
II=II+1
6194 CALL DEGENF(LCOL,LROW,SIG(II))
C
C PREPARE FOR STORAGE OF SIG ON DA (ISIGU).
MXREC=NSTOR*NNRG+2
LOUT=.TRUE.
IF (ISIGU.LE.0) GO TO 6197
OPEN(ISIGU,STATUS='UNKNOWN',ACCESS='DIRECT',
1 FORM='FORMATTED',RECL=80,ERR=6197)
GO TO 6199
6197 LOUT=.FALSE.
WRITE(6,651)
651 FORMAT('0 STATE-TO-STATE INTEGRAL CROSS-SECTIONS WILL BE ',
1 'COMPUTED BUT NOT STORED ON DISK')
GO TO 6198
6199 WRITE(6,652) ISIGU
652 FORMAT('0 STATE-TO-STATE INTEGRAL CROSS SECTIONS ',
1 'WILL BE STORED IN A D.A. FILE ON UNIT',I3)
6198 CONTINUE
IF (.NOT. LOUT) GO TO 6208
C INITIALIZE DATA SET ON ISIGU. . .
I10=1
WRITE(ISIGU,100,REC=I10) LABEL
100 FORMAT(20A4)
I10=I10+1
DO 6201 II=1,NNRG
ISST(II)=I10
DO 6201 I=1,NSTOR
WRITE(ISIGU,199,REC=I10)
199 FORMAT('.',79X)
6201 I10=I10+1
WRITE(ISIGU,102,REC=I10)
102 FORMAT('$',79X)
I10=I10+1
C
C PROCESS IRSTRT POSSIBILITIES NEXT.
6208 IF (IRSTRT.NE.0) THEN
WRITE(6,*) ' *** '
IF (IRSTRT.GT.3) THEN
WRITE(6,*) ' *** IRSTRT REDUCED TO MAX ALLOWED VALUE = 3'
IRSTRT=3
ENDIF
WRITE(6,655) ISAVEU,IRSTRT
655 FORMAT(' *** OUTINT. RESTART FROM UNIT(',I3,'). IRSTRT =',I4)
WRITE(6,*) ' *** '
IF (KSAVE.NE.0) THEN
WRITE(6,*) ' *** INCOMPATIBLE WITH KSAVE.NE.0',KSAVE
WRITE(6,*) ' *** CHANGE INPUT DECK AND RESUBMIT ***'
STOP
ENDIF
IF (ISAVEU.LE.0) THEN
WRITE(6,*) ' *** INCOMPATIBLE WITH ISAVEU.LE.0',ISAVEU
WRITE(6,*) ' *** CHANGE INPUT DECK AND RESUBMIT ***'
STOP
ELSE
C***** GISS VERSION FOLLOWS
OPEN(ISAVEU,STATUS='OLD',FORM='UNFORMATTED')
ENDIF
C IF WE ARE DOING A RESTART, SKIP 'NORMAL' KSAVE, ISAVEU PROCESSING.
GO TO 6209
ENDIF
C
IF(KSAVE.GT.0) GO TO 6300
C
C PREPARE TO SAVE S MATRICES ON (ISAVEU).
C
IF (ISAVEU.LE.0) GO TO 6209
WRITE(6,660) ISAVEU,IPROGM
660 FORMAT(/' COMPUTED S-MATRICES WILL BE SAVED ON UNIT',I3/
1 ' N.B. THESE ARE *** UNFORMATTED *** IN MOLSCAT VERSION',I3)
INQUIRE(ISAVEU,OPENED=OPENED)
IF(.NOT.OPENED) OPEN(ISAVEU,STATUS='UNKNOWN',FORM='UNFORMATTED')
WRITE(ISAVEU) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
C WRITE(ISAVEU,800) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
800 FORMAT(20A4/3I4,F8.4,I4)
NSQ=NQN*NLEV
WRITE(ISAVEU) (JLEV(I),I=1,NSQ)
C WRITE(ISAVEU,801) (JLEV(I),I=1,NSQ)
801 FORMAT(20I4)
WRITE(ISAVEU) NLVL,(ELEVEL(I),I=1,NLVL)
C IF (IPROGM.GE.3) WRITE(ISAVEU,802) NLVL,(ELEVEL(I),I=1,NLVL)
WRITE(ISAVEU) NNRG,(ENERGY(I),I=1,NNRG)
C WRITE(ISAVEU,802) NNRG,(ENERGY(I),I=1,NNRG)
802 FORMAT(I4/(5E16.8))
GO TO 6209
C
6300 NSQ=NQN*NLEV
IF(ISAVEU.LE.0) GO TO 6301
WRITE(6,6306) ISAVEU
6306 FORMAT('0 COMPUTED K-MATRICES WILL BE SAVED ON UNIT',I3)
INQUIRE(ISAVEU,OPENED=OPENED)
IF(.NOT.OPENED) OPEN(ISAVEU,STATUS='UNKNOWN',FORM='UNFORMATTED')
REWIND ISAVEU
WRITE(ISAVEU) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
WRITE(ISAVEU) (JLEV(I),I=1,NSQ)
WRITE(ISAVEU) NLVL,(ELEVEL(I),I=1,NLVL)
WRITE(ISAVEU) NNRG,(ENERGY(I),I=1,NNRG)
6304 FORMAT(I4/4(D20.13))
6301 WRITE(6,6307) KSAVE
6307 FORMAT('0 EIGENPHASE SUMMARY WILL BE WRITTEN TO UNIT',I3)
CALL GDATE(CDATE)
CALL GTIME(CTIME)
INQUIRE(KSAVE,OPENED=OPENED)
IF(.NOT.OPENED) OPEN(KSAVE,STATUS='UNKNOWN',FORM='FORMATTED')
WRITE(KSAVE,6308) (LABEL(I),I=1,19),
1 CDATE,CTIME,NLEV,NQN,NNRG,(JLEV(I),I=1,NSQ)
6308 FORMAT(1X,19A4/1X,A11,A9,4X,8X,'NLEV =',
1 I3,' NQN =',I3,' NNRG =',I4/(1X,'JLEV ',15I4))
WRITE(KSAVE,6309)
6309 FORMAT(1X/' JTOT M NOP I',6X,'ENERGY(I)',7X,'EPSUM/PI')
C
6209 IF(IPARTU.LE.0) GOTO 6321
WRITE(6,6311) IPARTU
6311 FORMAT('0 PARTIAL CROSS SECTIONS WILL BE WRITTEN TO UNIT',I3)
REWIND IPARTU
WRITE(IPARTU,800) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
NSQ=NQN*NLEV
WRITE(IPARTU,801) (JLEV(I),I=1,NSQ)
WRITE(IPARTU,802) NLVL,(ELEVEL(I),I=1,NLVL)
WRITE(IPARTU,802) NNRG,(ENERGY(I),I=1,NNRG)
C
C SET UP 'BOOKKEEPING' VARIABLES.
6321 DO 6100 I=1,NNRG
MINJT(I)=-1
IECONV(I)=0
6100 MAXJT(I)=0
C
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
ENTRY OUTPCH(SIG,ENERGY,NNRG,MINJT,MAXJT,ISIGPR,LABEL,ISIGU,LWARN)
C ARGUMENT 'JSTEP' ADDED AUG 86; MOVED TO 'OUTPUT' APR 94 - SG
C ARGUMENT 'ISIGU' ADDED JUL 92 - JMH
C PRINT 'INCOMPLETE COUPLED STATES VALUES' ONLY IF ISIGPR.GE.2
C NEVER PUNCH THESE VALUES (INDICATED BY NEGATIVE SIGMA) HOWEVER.
IF(ISIGPR.GT.0) GO TO 9000
WRITE(6,9603) IPUNCH
9603 FORMAT('0 SIGMA NOT PRINTED BECAUSE ISIGPR = 0'/
1 ' SIGMA WILL BE WRITTEN TO UNIT IPUNCH =',I4)
GO TO 9001
9000 WRITE(6,9678) LABEL
9678 FORMAT('1',20A4/)
IF (LWARN) THEN
WRITE(6,*)
WRITE(6,*) ' **************************************************'
WRITE(6,*) ' **************************************************'
WRITE(6,*) ' ** WARNING. SOME SIGMA MAY BE INCOMPLETE **'
WRITE(6,*) ' ** OWING TO IFEGEN .GT. 1 **'
WRITE(6,*) ' **************************************************'
WRITE(6,*) ' **************************************************'
ENDIF
C ***
C *** AUG 86. FORCE PUNCH FROM INTERNAL SIG MATRIX. BY SETTING LOUT
LOUT=.FALSE.
C ***
WRITE(6,9679)
9679 FORMAT(/12X,'ENERGY JTOTL JSTEP JTOTU',9X,
1 'F I',10X,'SIG(F,I)'/)
IF (LOUT) GO TO 9500
C OUTPUT FROM STORAGE IN SIG.
9001 IJ=2*NSTOR
XJSTEP=DBLE(JSTEP)/DBLE(JHALF)
IF(JSTEP.NE.1) WRITE(6,9604) XJSTEP
9604 FORMAT(' *** N.B. CROSS SECTIONS HAVE BEEN MULTIPLIED BY',F5.1,
1 ' TO ACCOUNT FOR JSTEP')
DO 9900 K=1,NNRG
MN=MINJT(K)
MXJ=MAXJT(K)
EK=ENERGY(K)
DO 9900 I=1,NLEVEL
DO 9900 II=1,NLEVEL
IJ=IJ+1
SIJ=SIG(IJ)*XJSTEP
IF (ISIGPR.LE.0) GO TO 9909
IF (SIJ.GE.EPS) THEN
WRITE(6,101) BLANK,EK,MN,JSTEP,MXJ,II,I,SIJ,BLANK
ELSEIF (ABS(SIJ).GE.EPS.AND.ISIGPR.GE.2) THEN
WRITE(6,101) BLANK,EK,MN,JSTEP,MXJ,II,I,ABS(SIJ),STAR
ENDIF
C DO NOT PUNCH DIAGONALS, VERY SMALL, OR 'INCOMPLETE CS VALUES'
9909 IF (II.EQ.I .OR. SIJ.LE.EPS) GO TO 9900
WRITE(IPUNCH,101) STAR,EK,MN,JSTEP,MXJ,II,I,SIJ
9900 CONTINUE
RETURN
C BELOW PUNCHES FROM DISK(ISIGU ) STORAGE.
9500 CALL RDPCH(ISIGU)
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
ENTRY OUTERR(INVER)
INVERR=INVER
RETURN
END
FUNCTION PARITY3(I)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARITY3=1.D0
IF((I/2)*2-I.NE.0) PARITY3=-1.D0
RETURN
END
SUBROUTINE PERT1(N,CX,SX,XSQ,X,H,V0,V1,V2,
X EYE11,EYE12,EYE22,A1,A2,A1P,A2P)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C-------------------------------------------------------------------
C THIS ROUTINE CALCULATES AND STORES THE PERTURBATION
C INTEGRALS IN EYE11, EYE12 AND EYE22 FOR THE INTERVAL.
C ALSO ON RETURN V0, V1 AND V2 CONTAIN THE PERTURBATION
C INTEGRALS FOR THE CURRENT STEP WHICH ARE USED FOR
C THE STEP SIZE DETERMINATION ONLY.
C-------------------------------------------------------------------
LOGICAL IFIRST
DIMENSION CX(1),SX(1),XSQ(1),X(1)
DIMENSION V0(N,N),V1(N,N),V2(N,N)
DIMENSION EYE11(N,N),EYE22(N,N)
DIMENSION EYE12(N,N),A1(N),A1P(N),A2(N),A2P(N)
DATA TOL/1.D-3/
DATA IFIRST/.FALSE./
C-------------------------------------------------------------------
C STORE CONSTANTS ON THE FIRST CALL.
C-------------------------------------------------------------------
IF (IFIRST) GO TO 100
CON1 = 1.D0/24.D0
CON2 = 1.D0/3.D0
CON3 = 1.D0/120.D0
CON4 = 1.D0/12.D0
CON5 = 0.2D0
CON6 = 1.D0/5040.D0
CON7 = 1.D0/30240.D0
CON8 = 1.D0/15.D0
CON9 = 1.D0/840.D0
CON11 = 1.D0/180.D0
CON12 = 1.D0/6.D0
CON13 = 1.D0/560.D0
CON10 = 1.D0/20160.D0
CON14 = 1.D0/42.D0
CON15 = 1.D0/8.D0
CON16 = 1.D0/48.D0
CON17 = 1.D0/168.D0
CON18 = 1.D0/112.D0
CON19 = 1.D0/40.D0
CON20 = 1.D0/36.D0
CON21 = 1.D0/216.D0
IFIRST = .TRUE.
100 HSQ = H*H
HINV = 1.D0/H
HSQINV = 1.D0/HSQ
HF = H**3
C-------------------------------------------------------------------
C THIS IS REACHED ONLY WHEN CORRECTIONS TO THE SECOND
C DERIVATIVE OF THE POTENTIAL ARE NOT DESIRED.
C-------------------------------------------------------------------
DO 200 I = 1,N
XI = X(I)
SXI = SX(I)
CXI = CX(I)
XSXI = XI*SXI
XSQI = XSQ(I)
G1 = XSXI/XSQI
G2 = 8.D0*XSQI
G3 = XSQI*XSQI
G4 = 4.D0*XSQI
G5 = 2.D0*XSQI
G6 = 0.5D0*G1
G7 = G3*XSQI
DO 200 J = I,N
XSQJ = XSQ(J)
IF (I .EQ. J) GO TO 160
XJ = X(J)
SXJ = SX(J)
CXJ = CX(J)
XSXJ = XJ*SXJ
F5 = XSQI*XSQJ
F6 = XSXI*XSXJ
F7 = CXI*CXJ
SD = XSQI-XSQJ
SUM = XSQI+XSQJ
COEF = HF/(2.D0*F6)
HC = H*COEF*V1(I,J)
COEF = COEF*V0(I,J)
D = XI-XJ
IF (ABS(D) .GT. TOL) GO TO 130
IF (ABS(SUM) .LT. TOL) GO TO 150
S = XI+XJ
SSQ = S*S
DSQ = D*D
SHALF = S*0.5D0
IF (XSQI .LT. 0.D0 .AND. XSQJ .LT. 0.D0) GO TO 110
IF (F5 .LT. 0.D0) GO TO 130
C2 = COS(SHALF)
S2 = SIN(SHALF)
GO TO 120
110 C2 = COSH(SHALF)
S2 = -SINH(SHALF)
SSQ = -SSQ
DSQ = -DSQ
120 SS2 = S*S2
GO TO 140
C-------------------------------------------------------------------
C GENERAL FORMULAS
C-------------------------------------------------------------------
130 F25 = 1.D0/SD
F8 = XSXJ*CXI
F9 = XSXI*CXJ
F12 = 2.D0*COEF*F25
F13 = HC*F25
F18 = 2.D0*SUM
R1V0 = F12*(F9-F8)
R2V0 = F12*(XSXI-XSXJ)
R1V1 = F13*((F18*(F7-1.D0)+4.D0*F6)*F25+F9-F8)
R2V1 = F13*(F18*(CXI-CXJ)*F25+XSXI+XSXJ)
GO TO 170
C-------------------------------------------------------------------
C THE FOLLOWING FORMULAS ARE VALID WHEN THE DIFFERENCE BETWEEN
C THE WAVEVECTORS TIMES THE STEP SIZE IS SMALL.
C-------------------------------------------------------------------
140 F14 = SS2/SSQ
F16 = DSQ*CON1
F17 = DSQ/80.D0
F15 = SS2*C2
F36 = DSQ*CON17
F37 = DSQ*CON18
F38 = DSQ*CON19
F39 = 1.D0-DSQ*CON15*(1.D0-DSQ*CON16*(1.D0-DSQ*CON3))
F40 = 1.D0/SSQ
R1V0 = COEF*(1.D0-DSQ*CON12*(1.D0-DSQ/20.D0*(1.D0-DSQ*CON14))+
X2.D0*F15*F40)
R2V0 = COEF*(F14*(F39)+0.5D0*C2*(1.D0-F16*(1.D0-F17*(1.D0-F36)))
X)*2.D0
R1V1 = HC*((-2.D0*SS2*F14+F15)*F40-F16*(1.D0-DSQ*CON8*(1.D0-3.D0*
XF37)))
R2V1 = HC*(-S2*CON4*(1.D0-F38*(1.D0-F37))+(0.5D0*C2-F14)/S*(1.D0-
XF16*(1.D0-F17)))*D
GO TO 170
C-------------------------------------------------------------------
C THE FOLLOWING FORMULAS ARE VALID WHEN BOTH OF THE WAVEVECTORS
C TIMES THE STEP SIZE ARE SMALL.
C-------------------------------------------------------------------
150 F20 = SUM*SUM
F22 = G4*XSQJ
F23 = XSQJ*XSQJ
F29 = SUM*CON12
F28 = 14.D0*F5
F30 = COEF*2.D0
R1V0 = F30*(1.D0-F29+(F20+F22)*CON3-(SUM*(G3+F28+F23))*CON6)
R2V0 = F30*(1.D0-F29+(XSQI*SUM+F23)*CON3-(G3+F23)*SUM*CON6)
R1V1 = -HC*CON4*(SUM-(F20+F22)*CON8+(SUM*(G3+F28+F23))*CON13)
R2V1 = HC*(CON4+SUM*CON11-(3.D0*F20-G5*XSQJ)*CON10)*SD
GO TO 170
C-------------------------------------------------------------------
C FORMULAS VALID FOR DIAGONAL ELEMENTS ONLY.
C THESE DIAGONAL ELEMENTS ALSO CONTAINS CONTRIBUTIONS TO THE
C SECOND DERIVATIVE OF THE POTENTIAL.
C-------------------------------------------------------------------
160 F6 = XSXI*XSXI
CXJ = CXI
XSXJ = XSXI
F7 = CXI*CXI
COEF = HF/(2.D0*F6)
HHC = HSQ*COEF*V2(I,J)
HC = H*COEF*V1(I,J)
COEF = COEF*V0(I,J)
R1V0 = COEF*(1.D0+CXI*G1)
R2V0 = COEF*(G1+CXI)
R1V1 = HC*(CXI-G1)*G6
R2V1 = 0.D0
R1V2 = HHC*(CXI*(CXI+(XSQI-2.D0)*G6)/XSQI*0.25D0+CON1)
R2V2 = HHC*((6.D0+XSQI)*CXI*CON2+(XSQI-2.D0)*G1)/G2
TERM1 = -CXJ*(R1V0+R1V1+R1V2)
CCIJ = F6*(R1V0+R1V1+R1V2)*HSQINV
CSIJ = XSXI*(R2V0+R2V1+R2V2+TERM1)*HINV
SSIJ = (R1V0-R1V1+R1V2-CXJ*(R2V0-R2V1+R2V2)-CXI*(R2V0+R2V1+R2V2)+
XF7*(R1V0+R1V1+R1V2))
CCJI = CCIJ
CSJI = XSXJ*(R2V0-R2V1+R2V2-CXI*(R1V0+R1V1+R1V2))*HINV
SSJI = SSIJ
GO TO 180
C-------------------------------------------------------------------
C CC- COSINE-COSINE INTEGRALS
C CS- COSINE-SINE INTEGRALS
C SS- SINE-SINE INTEGRALS
C-------------------------------------------------------------------
170 TERM1 = -CXJ*(R1V0+R1V1)
CCIJ = F6*(R1V0+R1V1)*HSQINV
CSIJ = XSXI*(R2V0+R2V1+TERM1)*HINV
SSIJ = R1V0-R1V1-CXJ*(R2V0-R2V1)-CXI*(R2V0+R2V1)+F7*(R1V0+R1V1)
CCJI = CCIJ
CSJI = XSXJ*(R2V0-R2V1-CXI*(R1V0+R1V1))*HINV
SSJI = SSIJ
180 V0(I,J) = CCIJ
V0(J,I) = CCJI
V1(I,J) = CSIJ
V1(J,I) = CSJI
V2(I,J) = SSIJ
V2(J,I) = SSJI
TERM1 = A1P(J)*SSIJ+A1(J)*CSJI
TERM2 = A1P(J)*CSIJ+A1(J)*CCIJ
TERM3 = A2P(J)*SSIJ+A2(J)*CSJI
TERM4 = A2P(J)*CSIJ+A2(J)*CCIJ
EYE11(I,J) = A1P(I)*TERM1+A1(I)*TERM2+EYE11(I,J)
EYE11(J,I) = EYE11(I,J)
EYE22(I,J) = A2P(I)*TERM3+A2(I)*TERM4+EYE22(I,J)
EYE22(J,I) = EYE22(I,J)
EYE12(I,J) = A1P(I)*TERM3+A1(I)*TERM4+EYE12(I,J)
IF (I .EQ. J) GO TO 200
EYE12(J,I) = A2P(I)*TERM1+A2(I)*TERM2+EYE12(J,I)
200 CONTINUE
RETURN
C----------------***END-PERT1***-------------------------------------
END
SUBROUTINE PERT2(N,CX,SX,XSQ,X,H,V0,V1,V2,
X EYE11,EYE12,EYE22,A1,A2,A1P,A2P)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C-------------------------------------------------------------------
C THIS ROUTINE CALCULATES AND STORES THE PERTURBATION
C INTEGRALS IN EYE11, EYE12 AND EYE22 FOR THE INTERVAL.
C ALSO ON RETURN V0, V1 AND V2 CONTAIN THE PERTURBATION
C INTEGRALS FOR THE CURRENT STEP WHICH ARE USED FOR
C THE STEP SIZE DETERMINATION ONLY.
C-------------------------------------------------------------------
LOGICAL IFIRST
DIMENSION CX(1),SX(1),XSQ(1),X(1)
DIMENSION V0(N,N),V1(N,N),V2(N,N)
DIMENSION EYE11(N,N),EYE22(N,N)
DIMENSION EYE12(N,N),A1(N),A1P(N),A2(N),A2P(N)
DATA TOL/1.D-3/
DATA IFIRST/.FALSE./
C-------------------------------------------------------------------
C STORE CONSTANTS ON THE FIRST CALL.
C-------------------------------------------------------------------
IF (IFIRST) GO TO 100
CON1 = 1.D0/24.D0
CON2 = 1.D0/3.D0
CON3 = 1.D0/120.D0
CON4 = 1.D0/12.D0
CON5 = 0.2D0
CON6 = 1.D0/5040.D0
CON7 = 1.D0/30240.D0
CON8 = 1.D0/15.D0
CON9 = 1.D0/840.D0
CON11 = 1.D0/180.D0
CON12 = 1.D0/6.D0
CON13 = 1.D0/560.D0
CON10 = 1.D0/20160.D0
CON14 = 1.D0/42.D0
CON15 = 1.D0/8.D0
CON16 = 1.D0/48.D0
CON17 = 1.D0/168.D0
CON18 = 1.D0/112.D0
CON19 = 1.D0/40.D0
CON20 = 1.D0/36.D0
CON21 = 1.D0/216.D0
IFIRST = .TRUE.
100 HSQ = H*H
HINV = 1.D0/H
HSQINV = 1.D0/HSQ
HF = H**3
C-------------------------------------------------------------------
C THE FOLLOWING IS USED WHEN CORRECTIONS TO THE SECOND
C DERIVATIVE OF THE POTENTIAL ARE DESIRED.
C-------------------------------------------------------------------
DO 190 I = 1,N
XI = X(I)
SXI = SX(I)
CXI = CX(I)
XSXI = XI*SXI
XSQI = XSQ(I)
G1 = XSXI/XSQI
G2 = 8.D0*XSQI
G3 = XSQI*XSQI
G4 = 4.D0*XSQI
G5 = 2.D0*XSQI
G6 = 0.5D0*G1
G7 = G3*XSQI
DO 190 J = I,N
XSQJ = XSQ(J)
IF (I .EQ. J) GO TO 160
XJ = X(J)
SXJ = SX(J)
CXJ = CX(J)
XSXJ = XJ*SXJ
F5 = XSQI*XSQJ
F6 = XSXI*XSXJ
F7 = CXI*CXJ
SD = XSQI-XSQJ
SUM = XSQI+XSQJ
COEF = HF/(2.D0*F6)
HHC = HSQ*COEF*V2(I,J)
HC = H*COEF*V1(I,J)
COEF = COEF*V0(I,J)
D = XI-XJ
IF (ABS(D) .GT. TOL) GO TO 130
IF (ABS(SUM) .LT. TOL) GO TO 150
S = XI+XJ
SSQ = S*S
DSQ = D*D
SHALF = S*0.5D0
IF (XSQI .LT. 0.D0 .AND. XSQJ .LT. 0.D0) GO TO 110
IF (F5 .LT. 0.D0) GO TO 130
C2 = COS(SHALF)
S2 = SIN(SHALF)
GO TO 120
110 C2 = COSH(SHALF)
S2 = -SINH(SHALF)
SSQ = -SSQ
DSQ = -DSQ
120 SS2 = S*S2
GO TO 140
C-------------------------------------------------------------------
C GENERAL FORMULAS
C-------------------------------------------------------------------
130 F25 = 1.D0/SD
F8 = XSXJ*CXI
F9 = XSXI*CXJ
F10 = SD*SD
F11 = 2.D0*XSQJ
F12 = 2.D0*COEF*F25
F13 = HC*F25
F18 = 2.D0*SUM
F19 = 0.25D0*F25
F24 = -8.D0*(SUM+F11)
F26 = -8.D0*(SUM+G5)
F27 = 1.D0/F10
F31 = HHC*F27
R1V0 = F12*(F9-F8)
R2V0 = F12*(XSXI-XSXJ)
R1V1 = F13*((F18*(F7-1.D0)+4.D0*F6)*F25+F9-F8)
R2V1 = F13*(F18*(CXI-CXJ)*F25+XSXI+XSXJ)
R1V2 = F31*((((F10+F24)*F9-(F10+F26)*F8)*F19+SUM*(F7+1.D0)+2.D0*
XF6))
R2V2 = F31*(((F10+F24)*XSXI-(F10+F26)*XSXJ)*F19+SUM*(CXI+CXJ))
GO TO 170
C-------------------------------------------------------------------
C THE FOLLOWING FORMULAS ARE VALID WHEN THE DIFFERENCE BETWEEN
C THE WAVEVECTORS TIMES THE STEP SIZE IS SMALL.
C-------------------------------------------------------------------
140 F14 = SS2/SSQ
F16 = DSQ*CON1
F17 = DSQ/80.D0
F15 = SS2*C2
F36 = DSQ*CON17
F37 = DSQ*CON18
F38 = DSQ*CON19
F39 = 1.D0-DSQ*CON15*(1.D0-DSQ*CON16*(1.D0-DSQ*CON3))
F40 = 1.D0/SSQ
F41 = (SSQ-8.D0)*0.5D0*F14
R1V0 = COEF*(1.D0-DSQ*CON12*(1.D0-DSQ/20.D0*(1.D0-DSQ*CON14))+
X2.D0*F15*F40)
R2V0 = COEF*(F14*(F39)+0.5D0*C2*(1.D0-F16*(1.D0-F17*(1.D0-F36)))
X)*2.D0
R1V1 = HC*((-2.D0*SS2*F14+F15)*F40-F16*(1.D0-DSQ*CON8*(1.D0-3.D0*
XF37)))
R2V1 = HC*(-S2*CON4*(1.D0-F38*(1.D0-F37))+(0.5D0*C2-F14)/S*(1.D0-
XF16*(1.D0-F17)))*D
R1V2 = HHC*(C2*(2.D0*C2+F41)*F40+(1.D0-DSQ*CON5*(1.D0-11.D0*F36*
X(1.D0-DSQ*CON20)))*CON4)*0.5D0
R2V2 = HHC*((F39)*(C2+F41*0.5D0)*F40+(1.D0-F38*(3.D0-F37*(5.D0-
X7.D0*DSQ*CON21)))*C2*CON1)
GO TO 170
C-------------------------------------------------------------------
C THE FOLLOWING FORMULAS ARE VALID WHEN BOTH OF THE WAVEVECTORS
C TIMES THE STEP SIZE ARE SMALL.
C-------------------------------------------------------------------
150 F20 = SUM*SUM
F21 = SUM*CON5
F22 = G4*XSQJ
F23 = XSQJ*XSQJ
F29 = SUM*CON12
F28 = 14.D0*F5
F30 = COEF*2.D0
R1V0 = F30*(1.D0-F29+(F20+F22)*CON3-(SUM*(G3+F28+F23))*CON6)
R2V0 = F30*(1.D0-F29+(XSQI*SUM+F23)*CON3-(G3+F23)*SUM*CON6)
R1V1 = -HC*CON4*(SUM-(F20+F22)*CON8+(SUM*(G3+F28+F23))*CON13)
R2V1 = HC*(CON4+SUM*CON11-(3.D0*F20-G5*XSQJ)*CON10)*SD
R1V2 = HHC*(1.D0-F21+11.D0*(F20+F22)*CON9-11.D0*(SUM*(G3+F28+F23))
X*CON7)*CON4
R2V2 = HHC*(1.D0-F21+(11.D0*F20-19.D0*F5)*CON9-(11.D0*(G7+F23*
XXSQJ)+3.D0*F5*SUM)*CON7)*CON4
GO TO 170
C-------------------------------------------------------------------
C FORMULAS VALID FOR DIAGONAL ELEMENTS ONLY.
C-------------------------------------------------------------------
160 F6 = XSXI*XSXI
CXJ = CXI
XSXJ = XSXI
F7 = CXI*CXI
COEF = HF/(2.D0*F6)
HHC = HSQ*COEF*V2(I,J)
HC = H*COEF*V1(I,J)
COEF = COEF*V0(I,J)
R1V0 = COEF*(1.D0+CXI*G1)
R2V0 = COEF*(G1+CXI)
R1V1 = HC*(CXI-G1)*G6
R2V1 = 0.D0
R1V2 = HHC*(CXI*(CXI+(XSQI-2.D0)*G6)/XSQI*0.25D0+CON1)
R2V2 = HHC*((6.D0+XSQI)*CXI*CON2+(XSQI-2.D0)*G1)/G2
C-------------------------------------------------------------------
C CC- COSINE-COSINE INTEGRALS
C CS- COSINE-SINE INTEGRALS
C SS- SINE-SINE INTEGRALS
C-------------------------------------------------------------------
170 TERM1 = -CXJ*(R1V0+R1V1+R1V2)
CCIJ = F6*(R1V0+R1V1+R1V2)*HSQINV
CSIJ = XSXI*(R2V0+R2V1+R2V2+TERM1)*HINV
SSIJ = (R1V0-R1V1+R1V2-CXJ*(R2V0-R2V1+R2V2)-CXI*(R2V0+R2V1+R2V2)+
XF7*(R1V0+R1V1+R1V2))
CCJI = CCIJ
CSJI = XSXJ*(R2V0-R2V1+R2V2-CXI*(R1V0+R1V1+R1V2))*HINV
SSJI = SSIJ
V0(I,J) = CCIJ
V0(J,I) = CCJI
V1(I,J) = CSIJ
V1(J,I) = CSJI
V2(I,J) = SSIJ
V2(J,I) = SSJI
TERM1 = A1P(J)*SSIJ+A1(J)*CSJI
TERM2 = A1P(J)*CSIJ+A1(J)*CCIJ
TERM3 = A2P(J)*SSIJ+A2(J)*CSJI
TERM4 = A2P(J)*CSIJ+A2(J)*CCIJ
EYE11(I,J) = A1P(I)*TERM1+A1(I)*TERM2+EYE11(I,J)
EYE11(J,I) = EYE11(I,J)
EYE22(I,J) = A2P(I)*TERM3+A2(I)*TERM4+EYE22(I,J)
EYE22(J,I) = EYE22(I,J)
EYE12(I,J) = A1P(I)*TERM3+A1(I)*TERM4+EYE12(I,J)
IF (I .EQ. J) GO TO 190
EYE12(J,I) = A2P(I)*TERM1+A2(I)*TERM2+EYE12(J,I)
190 CONTINUE
RETURN
C----------------***END-PERT2***-------------------------------------
END
FUNCTION PLM(LIN,MIN,COSTH)
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 THIS ROUTINE ALWAYS RETURNS THE VALUE FOR ABS(MIN); NOTE THAT
C FOR MIN.LT.0 THIS VALUE SHOULD BE MULTIPLIED BY PARITY3(MIN)
C
C FUNCTION PM1(LIN,MIN,COSTH)
C This routine appears to be much more stable for large l, m than
C the routine from Nerf/ modified according to R.T Pack
C It was obtained:
C From: Marie-Lise Dubernet <mld@ipp-garching.mpg.de>
C Date: Mon, 19 Jun 1995 12:48:11 +0200 (MET DST)
C Some mods 27-28 June 95 by SG for speed and to accord w/ MOLSCAT
C Bugs fixed 21 Sept 95 (SG)
C
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C CHECK FOR ABS(COSTH).LE.1.D0 ...
IF (ABS(COSTH).GT.1.D0) THEN
WRITE(6,*) ' *** ILLEGAL ARGUMENT TO PLM. X =',COSTH
STOP
ENDIF
C SAVE ARGUMENTS IN LOCAL VARIABLES
L=LIN
M=ABS(MIN)
X=COSTH
C
C IF M>L PLM=0 !
IF(M.GT.L) THEN
PLM=0.D0
RETURN
ENDIF
LMAX=L
C
IF (M.GT.0) GO TO 5
C HERE FOR REGULAR LEGENDRE POLYNOMIALS
PLM=1.D0
PM2=0.D0
XL=0.D0
DO 2 L=1,LMAX
XL=XL+1.D0
PP=((2.D0*XL-1.D0)*X*PLM-(XL-1.D0)*PM2)/XL
PM2=PLM
2 PLM=PP
GO TO 9000
C
C HERE FOR ALEXANDER-LEGENDRE POLYNOMIALS
C
5 IMAX=2*M
RAT=1.D0
AI=0.D0
DO 6 I=2,IMAX,2
AI=AI+2.D0
6 RAT=RAT*((AI-1.D0)/AI)
C Y=SIN(THETA)
Y=SQRT(1.D0-X*X)
PLM=SQRT(RAT)*(Y**M)
PM2=0.D0
LOW=M+1
XL=LOW-1
DO 10 L=LOW,LMAX
XL=XL+1.D0
AL=DBLE((L+M)*(L-M))
AL=1.D0/AL
AL2=(DBLE((L+M-1)*(L-M-1)))*AL
AL=SQRT(AL)
AL2=SQRT(AL2)
PP=(2.D0*XL-1.D0)*X*PLM*AL-PM2*AL2
PM2=PLM
10 PLM=PP
PLM=PLM*PARITY3(MIN)
C
C CONVERT TO MOLSCAT'S IDIOSYNCRATIC NORMALIZATION
9000 PLM=PLM*SQRT(XL+0.5D0)
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 POTIN9(ITYPE,LAM,MXLAM,NPTS,NDIM,XPT,XWT,MXPT,X,MX,
1 IXFAC)
DIMENSION XPT(MXPT,NDIM),XWT(MXPT,NDIM),NPTS(NDIM),
1 LAM(MXLAM),X(MX)
WRITE(6,*) ' *** POTIN9 CALLED WITHOUT A SUITABLE USER-SUPPLIED',
1 ' ROUTINE'
STOP
END
SUBROUTINE PRBR(JTOT,M,N,INRG,RM,
1 NBASIS,LEV,L,WVEC,SREAL,SIMAG,IC,IL,IC1,IL1,
2 JLEV,MXPAR,WGHT,PRINT,ILSU)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE
C
C *** AUG 76 NEW COUPLED STATES TREATMENT (KOURI ET AL.)
C *** JUL 86 (CCP6 VERSION 9) MOD 26 AUG 86 TO GET MXREC PROPERLY.
C *** AND MOD 21 OCT 86 : EDIFMX
C *** OCT 86 VERSION FOR 'OFF-DIAGONAL' CROSS SECTIONS
C *** JAN 87 CHANGES TO GET MPLMIN HANDLING CORRECT FOR ITYPE=25,26
C *** AND ADD JSTEP TO ENTRY PRBOUT (REQUIRES CHANGE IN DRIVER)
C *** MAR 87 CORRECTIONS FOR ITYPE=26
C *** DEC 88 INCLUDE ITYPE=7 AND Q=0
C *** MAR 89 HAS 'IN-CORE' D.A. SIMULATION
C *** (NEED SUBROUTINE DASIZE/ENTRIES DARD1,DARD2,DAWR1,DAWR2)
C *** JUL 92 REMOVES ALL REFERENCES TO LCSOLD (OLD, INCORRECT,
C *** FORMULATION FOR COUPLED STATES: SEE, E.G.,
C *** GREEN, ET AL. JCP, 66, 1409 (1977))
C *** CALLS TO ENTRIES (IN PRBR3) ALSO HAVE BEEN TRAPPED THERE.
C *** JUN 93 FIXES BUG IN PRBR3 AND USES /MEMORY/ TO ELIMINATE LIMITS.
C *** AUG 94 V14: ENTRY PRBCNT ADDED AND COMMON CMBASE CHANGED
C
C CALCULATES SIGMA(JA1,JB1;JA,JB;K)
C WHERE A/B INDICATE INITIAL/FINAL SPECTRAL LINES,
C A1/B1 ARE AFTER COLLISION, AND K IS TENSOR ORDER
C SEE, E.G., SHAFER AND GORDON, JCP 58, 5422 (1973).
C
C SUPPOSED TO BE UPWARD COMPATIBLE IF LDIAG=.TRUE.:
C LDIAG=.TRUE. TAKES *OLD* INPUT LINE=LEVA,LEVB, LEVA,LEVB, ... ,
C AND SETS LEVA1=LEVA, LEVB1=LEVB FOR ALL LINES.
C LDIAG=.FALSE. INPUT IS LINE=LEVA,LEVB,LEVA1,LEVB1,
C LEVA,LEVB,LEVA1,LEVB1, ...
C N.B. LDIAG FORCED TO TRUE FOR ITYPE=3 CALCULATIONS.
C
C ENTRY PRBRIN ACCEPTS &INPUT DATA AND SETS UP PRES. BROAD. CALC.
C ENTRY PRBOUT PRINTS OUT ACCUMULATED SIGR, SIGI.
C ENTRY PRBCNT FINDS WHETHER AN S-MATRIX WILL BE USED FOR PB CALC
C
C PRBR SPECIFICATIONS --------------------------------------
C
DIMENSION NBASIS(1),LEV(1),L(1),IC(1),IL(1),IC1(1),IL1(1),
1 JLEV(NLEV,NQN)
DIMENSION WVEC(1),SREAL(1),SIMAG(1)
C
C JTOT IS TOTAL ANGULAR MOMENTUM
C M = 0 FOR LAST PARITY STEP AT THIS JTOT.
C N IS NUMBER OF OPEN CHANNELS, DETERMINES DIMENSION OF VECTORS.
C INRG IS INDEX FOR ENERGY VALUES
C RM IS SCALING FACTOR FOR RADIAL WAVEFUNCTION.
C NBASIS (I) POINTS TO LEV,L VALUES FOR ITH OPEN CHANNEL.
C LEV IS VECTOR OF BASIS SET LEVELS
C L IS VECTOR OF BASIS ORBITAL ANGULAR MOMENTA.
C WVEC IS VECTOR OF WAVEVECTORS
C SREAL(N,N) IS REAL PART OF S MATRIX.
C SIMAG(N,N) IS IMAGINARY PART OF S MATRIX.
C
LOGICAL ITYPE3,EPM,LCSNEW,MPLMIN,LCSSYM
INTEGER JT(2)
C
C PRBRIN SPECIFICATIONS ------------------------------------
C
INTEGER NLPRBR,MXLN,LINE(MXLN),ILSU,NNRG,PRINT,MXNRG,IFEGEN
INTEGER T(MXLN)
DIMENSION ENERGY(NNRG)
C
C NLPRBR =0 FOR NO LINE SHAPE CALC.
C =N (GT.0) GIVES NO. OF LINES FOR WHICH TO COMPUTE L.S.
C LINE(4*I-3),... ,I=1,NLPRBR IS LEVEL DATA FOR LINES.
C ILSU (NOW REDUNDANT) WAS DIRECT ACCESS FILE FOR WORKING STORAGE
C ENERGY(NNRG) ARE ENERGIES AT WHICH S MATRIX IS CALCULATED.
C MXNRG IS MAXIMUM DIMENSION OF ENERGY ARRAY
C IFEGEN .GT. 0 REQUESTS GENERATION OF ADDITIONAL ENERGY VALUES.
C PRINT IS INTEGER PRINT CONTROL.
C
LOGICAL NOCALC,PF,NDEBUG
LOGICAL LDIAG,EXISTS,LDIAGX
CHARACTER*8 PTP(3)
C STORAGE DIMENSIONED FOR NO. OF LINES = MAXLN.
DIMENSION LN(400,9)
DIMENSION EREL(400),SIGR(400),SIGI(400)
DIMENSION P(2),PRTY(4)
C
C INFORMATION ORIGINALLY PASSED AS ENTRY PRBRBS, NOW IN COMMON
C
COMMON /CMBASE/ ROTI(12),ELEVEL(1000),EMAX,WT(2),SPNUC,
1 NLEVEL,JLEVEL(4000),MISC(26),JHALF,IDENT,MXJL,MXEL
COMMON /PRBASE/ ITYPE,NQN,NLEV,MVALUE,IEXCH,MPLMIN
COMMON /ASSVAR/ IDA
C
C NLEV AND NLEVEL ARE NO. OF LEVELS IN BASIS SET.
C JLEV AND JLEVEL ARE QUANTUM NUMBERS FOR THESE LEVELS.
C ELEVEL ARE ENERGIES OF THESE LEVELS.
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C --- DATA INITIALIZATIONS ---
C
DATA PTP/' Q = 0 ',' DIPOLE ',' RAMAN '/
DATA P/1.D0,-1.D0/, PRTY/1.D0,-1.D0,-1.D0,1.D0/
C *** BELOW REPLACES JMH'S CRITERION OF 1.D-10 FOR ENERGY DIFFERENCE
C *** SMALLER VALUE MAY BE NEEDED FOR RESONANCE CALCULATIONS.
DATA EDIFMX/5.D-6/
C FOR COMPATBILITY WITH OLD INPUT, SET LDIAG=.TRUE.
DATA LDIAGX/.FALSE./
C IF NDEBUG .EQ. .FALSE. CHECK FOR 'IMPOSSIBLE' NUMBERS OF MATCHES.
DATA NDEBUG/.FALSE./
C DIMENSION LIMITATION ...
DATA MAXLN/400/
C FOR CHECKING OVER-WRITE OF "DA FILE"
DATA JCHKSV/-1/
C
C STATEMENT FUNCTION (LOGICAL)
EXISTS(I) = I.GT.0 .AND. I.LE.NLEVEL
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
IF (NOCALC) RETURN
IF (JCHKSV.EQ.-1) JCHKSV=JTOT
DO 3000 IA=1,2
C IA=1 CHECKS FOR USE OF THIS JTOT,INRG WITH J(ALPHA).
C IA=2 FOR J(BETA).
IB=3-IA
C FIND LINES, I, WHICH USE THIS INRG, JTOT S MATRIX.
IKEEP=0
DO 3100 I=1,NLINE
IF (LN(I,IA+3).NE.INRG) GO TO 3100
K=LN(I,3)
JDIFMX=K
IF (LCSNEW) JDIFMX=0
JDM=MAX(JDM,JDIFMX)
IF (ITYPE3) GO TO 3211
C FOR ITYPE=1,2,5 GET J-VALUE FROM 1ST COL OF JLEV.
JA=JLEV(LN(I,1),1)
JB=JLEV(LN(I,2),1)
JA1=JLEV(LN(I,8),1)
JB1=JLEV(LN(I,9),1)
C PARITY FACTOR FOR CS WITH MPLMIN; THIS IS NORMALLY +1.
F3PJ=PARITY3(JA+JA1+JB+JB1)
C FIND BASIS FNS. CORRESPONDING TO JA/JA1 (JB/JB1) AND GET L VALUES.
C ROWS=>JA1,IC1,IL1 COLS=>JA,IC,IL
C FOR DIAG CASE (JA=JA1), IC/IC1 AND IL/IL1 HAVE SAME VALUES.
NLVAL=0
NLVAL1=0
DO 3200 II=1,N
JJ=NBASIS(II)
IF (LEV(JJ).NE.LN(I,IA)) GO TO 3201
NLVAL=NLVAL+1
IC(NLVAL)=II
IL(NLVAL)=L(JJ)
3201 IF (LEV(JJ).NE.LN(I,IA+7)) GO TO 3200
NLVAL1=NLVAL1+1
IC1(NLVAL1)=II
IL1(NLVAL1)=L(JJ)
3200 CONTINUE
GO TO 3212
C
C FOR ITYPE=3 GET J-VALUE FROM JLEVEL. RECALL J1,J2 PACKED IN ORDER
C
3211 JA=JLEVEL(2*LN(I,1)-1)
JB=JLEVEL(2*LN(I,2)-1)
C BELOW MAY BE NEEDED FOR COMPATIBILITY IN OFF-DIAG CODE
JA1=JA
JB1=JB
C ALLOCATE TEMPORARY STORAGE FOR SR,SI,TR,JBAR,ISTB,NBLK,LVAL
NSQ=N*N
NINT=(N+NIPR-1)/NIPR
IT1=IXNEXT
IT2=IT1+NSQ
IT3=IT2+NSQ
IT4=IT3+NSQ
IT5=IT4+NINT
IT6=IT5+NINT
IT7=IT6+NINT
IXNEXT=IT7+NINT
C WRITE(6,*) ' IT1-IT7,IXNEXT',IT1,IT2,IT3,IT4,IT5,IT6,IT7,IXNEXT
NUSED=0
CALL CHKSTR(NUSED)
CALL PRBR3(N,SREAL,SIMAG,JTOT,NLEV,NQN,JLEV,NBASIS,LEV,L,NPACK,
1 LN(I,IA),NLVAL,IC,IL,
2 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7))
C N.B. ONLY SR,SI NEED TO BE KEPT, IXNEXT COULD BE REDUCED HERE ...
C IXNEXT=IT3
C>>SG 1 JUN 93: NLVAL1,IL1,IC1 MUST BE ALSO BE SET (CF. DIAGONAL CASE).
NLVAL1=NLVAL
DO 3311 II=1,NLVAL
IL1(II)=IL(II)
3311 IC1(II)=IC(II)
C<<SG 1 JUN 93
C
3212 IF (NLVAL.LE.0 .OR. NLVAL1.LE.0) GO TO 3100
C GET WAVE NUMBER POINTED TO BY IPWVEC (SHOULD BE SAME FOR ALL IC'S)
IPWVEC=NBASIS(IC(1))
FK=WVEC(IPWVEC)
FK=FK/RM
FK=PI/(FK*FK)
C
C CHECK FOR AVAILABILITY OF J(BETA) MATRICES WITH WHICH TO CALC.
IPTR=LN(I,IB+5)
3400 IF (IPTR.LE.0) GO TO 5000
C
C PROCESS CURRENT S MATRIX WITH PREVIOUSLY STORED MATRICES.
4000 IDA=IPTR
C READ(ILSU,REC=IDA) IPTIND,IIN,IAIN,JTIN,IPTBK,NNTRY
CALL DARD1(IPTIND,IIN,IAIN,JTIN,IPTBK,NNTRY)
IDA=IDA+1
JT(IA)=JTIN
JT(IB)=JTOT
IF (LCSNEW) GO TO 4981
MVALIN=1
IF (IPTIND.EQ.-1) GO TO 4001
WRITE(6,402) IPTR,IPTIND
402 FORMAT(/' * * * ERROR. FOR IPTR =',I6,', ILLEGAL IPTIND =',I6)
4003 IPTR=IPTBK
GO TO 3400
C 'LCSNEW' CODE CAN USE JLEV(I,1) AS J-VALUE FOR ITYPE=1,2,5,6
4981 MVALIN = IPTIND+1000
IF (IABS(MVALIN).LE.JLEV(LN(I,IB),1)) GO TO 4001
WRITE(6,405) IPTIND,JA,JB,IA
405 FORMAT(' * * * ERROR. MVALUE LARGER THAN J-VALUE IN CS(NEW)',
1 4I12)
GO TO 4003
4001 IF (IIN.EQ.I .AND. IAIN.EQ.IB) GO TO 4002
WRITE(6,403) IIN,I,IAIN,IA
403 FORMAT(/' * * * ERROR. IIN, I, IAIN, IA =',4I12)
GO TO 4003
4002 JDIF=JTOT-JTIN
IF (JDIF.GE.0) GO TO 4004
WRITE(6,404) JTOT,JTIN
404 FORMAT(/' * * * ERROR. JTOT.LT.JTIN =',2I6)
GO TO 4003
4004 IF (JDIF.GT.JDIFMX) GO TO 5000
C
4005 ONE=1.D0
C N.B. FOR ITYPE=1,2,5,6, JLEV(LEV,NQN)=LEV
IF (.NOT.LCSNEW) GO TO 4006
C SET UP FOR NEW COUPLED STATES CODE
XJA=DBLE(JLEV(LN(I,IA),1))
XJB=DBLE(JLEV(LN(I,IB),1))
XJA1=DBLE(JLEV(LN(I,IA+7),1))
XJB1=DBLE(JLEV(LN(I,IB+7),1))
XN=DBLE(LN(I,3))
XMA=DBLE(MVALUE)
XMB=DBLE(MVALIN)
C FACTORS BELOW FOR ITYPE=25,26 MPLMIN=.TRUE.
TJ2P=1.D0
F3P=F3PJ
IF (.NOT.LCSSYM) GO TO 4006
IXA=LN(I,IA)
IXA1=LN(I,IA+7)
IXB=LN(I,IB)
IXB1=LN(I,IB+7)
IF (ITYPE.EQ.26) GO TO 4016
TJ2P=PARITY3(JLEV(IXB,2)+JLEV(IXB,3)+JLEV(IXB1,2)+JLEV(IXB1,3))
F3P=F3P*TJ2P*
1 PARITY3(JLEV(IXA,2)+JLEV(IXA,3)+JLEV(IXA1,2)+JLEV(IXA1,3))
GO TO 4006
4016 TJ2P=PRTY(JLEV(IXB,3)+1)*PRTY(JLEV(IXB1,3)+1)
F3P=F3P*TJ2P*PRTY(JLEV(IXA,3)+1)*PRTY(JLEV(IXA1,3)+1)
C FOR OLD CS CODE, ADD 1 TO SREAL ONLY FOR M=MP=0.
4006 DO 3600 ID=1,NNTRY
C READ(ILSU,REC=IDA) L1,L2,SR,SI
CALL DARD2(L1,L2,SR,SI)
IDA=IDA+1
NMATCH=0
C
C II LOOPS FOR L1 => INITIAL (UNPRIMED) I.E. JA:IL,IC (COLS)
C JJ LOOPS FOR L2 => FINAL (PRIMED) I.E. JA1:IL1,IC1 (ROWS)
DO 3700 II=1,NLVAL
IF (L1.NE.IL(II)) GO TO 3700
DO 3800 JJ=1,NLVAL1
IF (L2.NE.IL1(JJ)) GO TO 3800
NMATCH=NMATCH+1
IX=(IC(II)-1)*N+IC1(JJ)
C *** N.B. ABOVE HAS REVERSED ROWS/COLS FROM OLD CODE,
C *** BUT NOTE SYMMETRY OF S-MATRIX
SRNOW=SREAL(IX)
SINOW=SIMAG(IX)
C THERE SHOULD ONLY BE 1 MATCH. IF NDEBUG.EQ..FALSE. CHECK THIS.
IF (NDEBUG) GO TO 4099
3800 CONTINUE
3700 CONTINUE
C
3999 IF (NMATCH-1) 3600,4099,4098
C
4098 WRITE(6,409) NMATCH,IPTIND,IIN,IAIN,JTIN,IPTBK,NNTRY,L1,L2
409 FORMAT(/' * * * WARNING. NMATCH.GT.1 =',I3,' FOR IPTIND,IIN,',
1 'IAIN,JTIN,IPTBK,NNTRY,L1,L2 =',8I6)
GO TO 3600
C
4099 CONTINUE
IF (EPM) GO TO 3630
IF (LCSNEW) GO TO 3640
C BELOW IS CLOSE COUPLING CODE . . .
DJA1=JA1+JA1+1
DJA=JA+JA+1
F1=DBLE((2*JTOT+1)*(2*JTIN+1)) * SQRT(DJA1/DJA)
C FOR ITYPE=3 2 INDICES PACKED INTO L1,L2 - REMOVE 2ND.
L1N=L1-NPACK*(L1/NPACK)
L2N=L2-NPACK*(L2/NPACK)
C *** JA,JA1 ADDED TO PARITY FACTOR OCT 86 FOR OFF-DIAGONAL CASE.
C *** C.F. GREEN, C.P.L. 47, 119 (1977); COREY, MCCOURT, AND LIU,
C *** J. PHYS. CHEM. 88, 2031 (1984).
PARIT=PARITY3(JA-JA1+L1N-L2N)
F2=SIXJ(JA,K,L1N,JT(1),JB,JT(2))
C N.B. DELTA FUNCTION CONTAINS ALL QUANTUM NUMBERS.
C FOR SOME CASES CODE BELOW RECALCULATES SIXJ
IF (L1.EQ.L2 .AND.
1 LN(I,1).EQ.LN(I,8) .AND. LN(I,2).EQ.LN(I,9)) GO TO 3610
F3=SIXJ(JA1,K,L2N,JT(1),JB1,JT(2))
FR=0.D0
GO TO 3620
C
3610 F3=F2
FR=ONE
GO TO 3620
C
C BELOW FOR EFFECTIVE POTENTIAL METHOD
3630 F1=2*JTOT+1
F2=1.D0
F3=1.D0
FR=1.D0
PARIT=1.D0
GO TO 3620
C
C BELOW FOR COUPLED STATES (LCSNEW) CASE
3640 DJA1=JA1+JA1+1
DJA=JA+JA+1
F1=DBLE(2*JTOT+1) * SQRT(DJA1/DJA)
FR=1.D0
IF (LN(I,1).NE.LN(I,8) .OR. LN(I,2).NE.LN(I,9)) FR=0.D0
PARIT=PARITY3(JB+JB1)
C *** ACCOUNT FOR PLUS/MINUS MVALUE COUNTING. . .
C *** AFTER OCT 76, THIS IS CONTROLLED BY MPLMIN PASSED FROM BASE.
TJ1=THRJ(XJA,XJB,XN,XMA,-XMB,XMB-XMA)
1 *THRJ(XJA1,XJB1,XN,XMA,-XMB,XMB-XMA)
F2=TJ1
F3=1.D0
IF (.NOT.MPLMIN) GO TO 3620
TJ2=THRJ(XJA,XJB,XN,XMA,XMB,-XMB-XMA)
1 *THRJ(XJA1,XJB1,XN,XMA,XMB,-XMB-XMA)
F2=F2 + TJ2 * TJ2P
F3=1.D0 + F3P
IF (MVALUE.EQ.0) F3=F3/2.D0
IF (MVALIN.EQ.0) F3=F3/2.D0
GO TO 3620
C
3620 FCT=F1*F2*F3*FK*PARIT
FR=(FR-(SR*SRNOW+SI*SINOW))*FCT
FI=P(IA)*(SI*SRNOW-SR*SINOW)*FCT
SIGR(I)=SIGR(I)+FR
SIGI(I)=SIGI(I)+FI
IF (I.NE.IKEEP .AND. PRINT.GE.4) WRITE(6,602)
602 FORMAT(1X)
IKEEP=I
IF (PRINT.GE.4) WRITE(6,408) I,JT(IA),JT(IB),FR,SIGR(I),FI,SIGI(I)
408 FORMAT(' LINE',I3,' BETWEEN JTOT =',I3,' AND',I3,E14.6,
1 ' ADDED TO SIGR =',E14.6,8X,E14.6,' ADDED TO SIGI =',E14.6)
3600 CONTINUE
C THIS COMPLETES CALC. FOR ALL SAVED S MATRIX ELEMENTS IN THIS SET.
C FOLLOW POINTERS BACKWARDS TO FIND OTHER S MATRICES.
IPTR=IPTBK
GO TO 3400
C
C NO MORE STORED S MATRICES TO PROCESS.
C STORE CURRENT MATRIX VALUES FOR FUTURE USE.
C
5000 NNTRY=NLVAL*NLVAL1
IF (NEXTDA+NNTRY.LT.MXREC) GO TO 4200
WRITE(6,401) MXREC
401 FORMAT(/' *** PRBR. WARNING: TEMPORARY STORAGE OF',I8,
1 ' WORDS EXCEEDED.'/
2 ' *** WRAP-AROUND FEATURE WILL BE USED')
IF (JTOT-JCHKSV.LE.JDM+1) THEN
WRITE(6,491)
491 FORMAT(' *** PRBR. POSSIBLE ERROR')
WRITE(6,492) JCHKSV,JTOT,JDM
492 FORMAT(11X,'INITIAL, FINAL JTOT WERE',2I5,'.',
1 ' NEED DELTA-JTOT =',I3)
C ONE MIGHT WANT TO TERMINATE CALCULATION HERE.
ELSE
WRITE(6,493)
493 FORMAT(' *** PRBR. PROBABLY OK.')
WRITE(6,492) JCHKSV,JTOT,JDM
ENDIF
JCHKSV=JTOT
NEXTDA=1
C
4200 IPTIND=-1
IF (LCSNEW) IPTIND=MVALUE-1000
IPTBK=LN(I,IA+5)
C
C IDA IS ASSOCIATED VARIABLE, SET TO NEXT AVAILABLE RECORD AFTER
C READ/WRITE.
IDA=NEXTDA
C WRITE(ILSU,REC=IDA) IPTIND,I,IA,JTOT,IPTBK,NNTRY
CALL DAWR1(IPTIND,I,IA,JTOT,IPTBK,NNTRY)
IDA=IDA+1
DO 4100 II=1,NLVAL
DO 4100 JJ=1,NLVAL1
C IX IS INDEX TO SREAL, SIMAG. CHANGED FOR OFF-DIAG CODE TO
C CORRESPOND WITH CHOICE IN DO 3700 LOOP ABOVE
IX=(IC(II)-1)*N+IC1(JJ)
L1=IL(II)
L2=IL1(JJ)
C WRITE(ILSU,REC=IDA) L1,L2,SREAL(IX),SIMAG(IX)
CALL DAWR2(L1,L2,SREAL(IX),SIMAG(IX))
4100 IDA=IDA+1
C
LN(I,IA+5)=NEXTDA
NEXTDA=IDA
C THIS FINISHES PROCESSING LINE=I FOR IA.
C FOR ITYPE3 RESTORE SREAL,SIMAG AND RELEASE TEMP STORAGE
IF (ITYPE3) THEN
C WRITE(6,*) ' IT1,IT2,IXNEXT',IT1,IT2,IXNEXT
CALL PRBR3R(N,SREAL,SIMAG,X(IT1),X(IT2))
C RELEASE TEMPORARY STORAGE
IXNEXT=IT1
ENDIF
C
3100 CONTINUE
C THIS ENDS LOOP OVER I = 1,NLINE
3000 CONTINUE
C THIS ENDS LOOP OVER IA = ALPHA, BETA.
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
ENTRY PRBRIN(NLPRBR,LINE,T,MXLN,ILSU,NNRG,ENERGY,MXNRG,IFEGEN,
1 JLEV,PRINT)
C
LDIAG=LDIAGX
NEXTDA=1
JDM=0
C NPACK IS USED TO PACK TWO INDICES (J1,J2) INTO ONE INTEGER VAR.
NPACK=2**16
PI=ACOS(-1.D0)
IF (NLPRBR.GT.0) GO TO 1000
NOCALC=.TRUE.
RETURN
1000 WRITE(6,111)
111 FORMAT(//' REVIEW OF REQUESTED PRESSURE BROADENING CALCULATION.')
WRITE(6,610)
610 FORMAT(/' ****** THIS IS OFF-DIAGONAL VERSION (DEC 88) ******')
IF (LDIAG) WRITE(6,609)
609 FORMAT(9X,'LDIAG = TRUE OPTION TO HANDLE OLD INPUT')
C COUPLED STATES (ITYPE=25,26 ADDED OCT 76) / 'OLD' CS CODE REMOVED
LCSNEW=ITYPE.EQ.21 .OR. ITYPE.EQ.22
LCSSYM=ITYPE.EQ.25 .OR. ITYPE.EQ.26
LCSNEW=LCSNEW .OR. LCSSYM
EPM=ITYPE.EQ.11 .OR. ITYPE.EQ.12 .OR. ITYPE.EQ.15 .OR. ITYPE.EQ.16
ITYPE3=ITYPE.EQ.3
C TRAP TYPES INCONSISTENT W/LDIAG=.FALSE.
IF (LDIAG. OR. .NOT.(ITYPE3.OR.EPM)) GO TO 1992
IF (ITYPE3) THEN
LDIAG=.TRUE.
WRITE(6,*) ' *** FOR ITYPE=3 LDIAG HAS BEEN FORCED TO TRUE.'
WRITE(6,*) ' *** CHECK THAT &INPUT LINE DATA IS COMPATIBLE.'
ELSE
WRITE(6,197) ITYPE
197 FORMAT(/' *** LDIAG=.TRUE. INCOMPATIBLE WITH ITYPE =',I4,';',
1 ' REQUEST CANCELED.')
NOCALC=.TRUE.
RETURN
ENDIF
1992 IF (ITYPE.EQ.1 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.5) GO TO 1990
IF (ITYPE.EQ.6) GO TO 1990
IF (ITYPE.EQ.7) GO TO 1990
IF (ITYPE.EQ.31) GO TO 1990
IF (ITYPE3 .AND. IDENT.EQ.0) GO TO 1991
IF (LCSNEW) GO TO 1990
IF (EPM) GO TO 1990
WRITE(6,199) ITYPE
199 FORMAT(/' * * * WARNING. REQUESTED PRESSURE BROADENING ',
1 'CALCULATION NOT SUPPORTED FOR ITYPE =',I4,'.'/
2 18X,'REQUEST CANCELLED.')
NOCALC=.TRUE.
RETURN
1991 WRITE(6,198)
198 FORMAT(/' * * * WARNING. LIMITED IMPLEMENTATION FOR PRESSURE ',
1 'BROADENING WITH ITYPE = 3 .AND. IDENT = 0')
1990 NOCALC=.FALSE.
C NPL IS NUMBER OF INDICES PER LINE
NPL=4
IF (LDIAG) NPL=2
WRITE(6,100) NLPRBR
100 FORMAT(/' PRESSURE-BROADENING LINE-SHAPE CALCULATION REQUESTED'
1 ,' FOR',I4,' LINES.')
C N.B. DIMENSION ON LINE PASSED FROM DRIVER IS 2*MXLN
IF ((NPL*NLPRBR)/2.LE.MXLN) GO TO 1100
I=(2*MXLN)/NPL
WRITE(6,101) NLPRBR,I
101 FORMAT(/' * * * WARNING. ',I5,' LINES REQUESTED, REDUCED TO MAX',
1 ' OF',I3)
NLPRBR=I
1100 WRITE(6,110)
110 FORMAT(/5X,' LINE LEV(A) LEV(B) LEV(A1) LEV(B1)')
DO 1103 I=1,NLPRBR
IST=NPL*(I-1)
1103 WRITE(6,112) I,(LINE(IST+II),II=1,NPL)
112 FORMAT(5X,I4,I8,I6,I9,I7)
NLINE=0
NEWE=NNRG
DO 1200 I=1,NLPRBR
PF=.FALSE.
L1=LINE((NPL*(I-1))+1)
L2=LINE((NPL*(I-1))+2)
IF (LDIAG) GO TO 1104
L3=LINE((NPL*(I-1))+3)
L4=LINE((NPL*(I-1))+4)
GO TO 1105
1104 L3=L1
L4=L2
1105 IF (EXISTS(L1).AND.EXISTS(L2).AND.EXISTS(L3).AND.EXISTS(L4))
1 GO TO 1150
WRITE(6,108) L1,L2,L3,L4
108 FORMAT(/' * * * WARNING. REQUESTED LINE FOR LEVELS',4I4,
1 ' CANNOT BE PROCESSED - OUTSIDE NLEV RANGE.')
GO TO 1200
1150 IF (ITYPE3) GO TO 1151
C FOR ITYPE=1,2,5 TAKE J-VALUE FROM JLEV(LEV,1)
JA=JLEV(L1,1)
JB=JLEV(L2,1)
JA1=JLEV(L3,1)
JB1=JLEV(L4,1)
GO TO 1152
C FOR ITYPE=3 TAKE J-VALUES FROM JLEVEL. RECALL J1,J2 PACKED.
1151 JA=JLEVEL(2*L1-1)
JB=JLEVEL(2*L2-1)
JA1=JA
JB1=JB
1152 K=T(I)
K1=K
IF (K.GE.0) GO TO 1106
C IF 'LTYPE' NOT INPUT, CALCULATE FROM J-VALUES
K=IABS(JA-JB)
K1=IABS(JA1-JB1)
C OTHER THAN DIPOLE AND RAMAN (Q=0,2) TRANSITIONS NOT IMPLEMENTED.
C ALSO, MUST HAVE SAME 'K' FOR JA/JB AND JA1/JB1
1106 IF ((K.EQ.0.OR.K.EQ.1.OR.K.EQ.2).AND.(K.EQ.K1)) GO TO 1300
WRITE(6,102) JA,JB,JA1,JB1,I
102 FORMAT(/' * * * * ONLY DIPOLE AND RAMAN TRANSITIONS IMPLEMENTED'
1 ,'. CANNOT PROCESS JA,JB,JA1,JB1=',4I4/
2 10X,'SPECIFY LTYPE(',I3,' ) = 0, 1 OR 2 IN &INPUT.')
GO TO 1200
1300 NEPL=0
IF (IFEGEN.LE.0) GO TO 1301
C GENERATE ENERGY VALUES IF NECESSARY TO LINE AT REQUESTED E'S.
DO 1401 II=1,NNRG
EA=ENERGY(II)+ELEVEL(L1)
DO 1501 JJ=1,NEWE
ED=(ENERGY(JJ)-EA)/ENERGY(JJ)
IF (ABS(ED).GT.EDIFMX) GO TO 1501
JL=JJ
GO TO 1502
1501 CONTINUE
NEWE=NEWE+1
IF (NEWE.LT.MXNRG) GO TO 1201
1202 WRITE(6,611) I,II
611 FORMAT(/' * * * WARNING. CANNOT ADD ENERGY VALUE FOR LINE',I4,
1 ' RELATIVE ENRGY NO.',I4)
NEWE=NEWE-1
GO TO 1401
1201 ENERGY(NEWE)=EA
JL=NEWE
1502 EB=ENERGY(II)+ELEVEL(L2)
DO 1101 JJ=1,NEWE
ED=(ENERGY(JJ)-EB)/ENERGY(JJ)
IF (ABS(ED).GT.EDIFMX) GO TO 1101
JK=JJ
GO TO 1102
1101 CONTINUE
NEWE=NEWE+1
IF (NEWE.GE.MXNRG) GO TO 1202
ENERGY(NEWE)=EB
JK=NEWE
1102 NEPL=NEPL+1
IF (NLINE.LT.MAXLN) GO TO 1108
WRITE(6,109) L1,L2,L3,L4,JL,JK
GO TO 1200
1108 NLINE=NLINE+1
LN(NLINE,1)=L1
LN(NLINE,2)=L2
LN(NLINE,3)=K
LN(NLINE,4)=JL
LN(NLINE,5)=JK
LN(NLINE,6)=0
LN(NLINE,7)=0
LN(NLINE,8)=L3
LN(NLINE,9)=L4
SIGR(NLINE)=0.D0
SIGI(NLINE)=0.D0
EREL(NLINE)=ENERGY(II)
IF (PF) GO TO 1601
WRITE(6,103) L1,JA,L2,JB,L3,JA1,L4,JB1,PTP(K+1)
PF=.TRUE.
1601 WRITE(6,104) EREL(NLINE),JL,JK
1401 CONTINUE
GO TO 1403
C
C CHECK FOR AVAILABLE PAIRS OF ENERGIES WITH SAME INITIAL REL KE
C
1301 DO 1400 II=1,NNRG
EA=ENERGY(II)-ELEVEL(L1)
C *** 2 SEPT. 86 TO PREVENT CHOOSING NEGATIVE ENERGIES
IF (EA.LE.0.D0) GO TO 1400
DO 1500 JJ=1,NNRG
EB=ENERGY(JJ)-ELEVEL(L2)
ED=(EA-EB)/MAX(EA,EB,1.D0)
IF (ABS(ED).GT.EDIFMX) GO TO 1500
NEPL=NEPL+1
IF (NLINE.LT.MAXLN) GO TO 1109
WRITE(6,109) L1,L2,L3,L4,II,JJ
109 FORMAT(/' * * * WARNING. NO MORE TABLE SPACE FOR LEVELS =',4I3,
1 ', AND ENERGIES=',2I4,'; WILL BE SKIPPED.')
GO TO 1200
1109 NLINE=NLINE+1
LN(NLINE,1)=L1
LN(NLINE,2)=L2
LN(NLINE,3)=K
LN(NLINE,4)=II
LN(NLINE,5)=JJ
LN(NLINE,6)=0
LN(NLINE,7)=0
LN(NLINE,8)=L3
LN(NLINE,9)=L4
SIGR(NLINE)=0.D0
SIGI(NLINE)=0.D0
EREL(NLINE)=(EA+EB)/2.D0
IF (PF) GO TO 1600
WRITE(6,103) L1,JA,L2,JB,L3,JA1,L4,JB1,PTP(K+1)
103 FORMAT(/' LEVELS',I3,' (JA =',I3,' ), ',I3,' (JB =',I3,' )',
1 ' **TO** LEVELS',I3,' (JA1 =',I3,' ),',I3,' (JB1 =',I3,' )',
2 ' WILL BE PROCESSED FOR',A8,'RADIATION.')
PF=.TRUE.
1600 WRITE(6,104) EREL(NLINE),LN(NLINE,4),LN(NLINE,5)
104 FORMAT(12X,'AT RELATIVE K.E. =',F18.9,' (1/CM) WITH',I4,
1 '-TH AND',I4,'-TH ENERGY VALUES RESPECTIVELY.')
1500 CONTINUE
1400 CONTINUE
1403 IF (NEPL.GT.0) GO TO 1200
WRITE(6,105) L1,L2
105 FORMAT(/' * * * WARNING. NO RELEVANT PAIRS OF ENERGY VALUES ',
1 'FOR REQUESTED LEVELS =',2I4)
1200 CONTINUE
C
IF (IFEGEN.LE.0) GO TO 1701
C
C REMOVE ENERGIES THAT ARE NOT NEEDED FOR PRESSURE-BROADENING
NNRG=NEWE
II=1
1609 IF (II.GT.NNRG) GO TO 1615
DO 1610 I=1,NLINE
IF (LN(I,4).EQ.II .OR. LN(I,5).EQ.II) THEN
C WE ARE USING THIS ENERGY. CHECK THE NEXT
II=II+1
GO TO 1609
ENDIF
1610 CONTINUE
C REACH HERE IF IT IS NOT USED. COMPRESS LIST & REVISE INDEXES
NNRG=NNRG-1
DO 1611 JJ=II,NNRG
ENERGY(JJ)=ENERGY(JJ+1)
1611 CONTINUE
DO 1612 I=1,NLINE
IF (LN(I,4).GT.II) LN(I,4)=LN(I,4)-1
1612 IF (LN(I,5).GT.II) LN(I,5)=LN(I,5)-1
GO TO 1609
C
C SORT ENERGIES INTO DESCENDING ORDER, RENUMBER LN(,4) AND LN(,5)
C
1615 DO 1809 JJ=1,NNRG
II=0
ETOP=0.D0
DO 1805 I=JJ,NNRG
IF (ETOP.GE.ENERGY(I)) GO TO 1805
ETOP=ENERGY(I)
II=I
1805 CONTINUE
ENERGY(II)=ENERGY(JJ)
ENERGY(JJ)=ETOP
DO 1808 I=1,NLINE
KK=LN(I,4)
IF (KK.EQ.JJ) LN(I,4)=II
IF (KK.EQ.II) LN(I,4)=JJ
KK=LN(I,5)
IF (KK.EQ.JJ) LN(I,5)=II
1808 IF (KK.EQ.II) LN(I,5)=JJ
1809 CONTINUE
WRITE(6,612) NNRG,(I,ENERGY(I),I=1,NNRG)
612 FORMAT(//' MODIFIED ENERGY LIST NOW CONTAINS',I4,' VALUES,'
1 /(15X,'ENERGY(',I3,') =',F18.9))
WRITE(6,921)
921 FORMAT(/' LINE-SHAPE TABLES HAVE BEEN MODIFIED ACCORDINGLY.')
1701 IF (NLINE.GT.0) GO TO 1700
WRITE(6,106)
106 FORMAT(/' * * * WARNING. NONE OF REQUESTED LINES CAN BE ',
1 'PROCESSED. REQUEST CANCELLED.')
NOCALC=.TRUE.
RETURN
C CODE FOR IN-CORE ROUTINES REPLACES OLDER CODE BELOW
1700 CALL DAOPEN
CALL DASIZE(ILSU,MXREC)
RETURN
C1700 IF (ILSU.LE.0) GO TO 1900
C
C OLD CODE FOR OPENING PRESSURE BROADENING SCRATCH FILE.
C THIS IS NOW REPLACED BY IN-CORE STORAGE (JUN 92).
C THE APPROPRIATE RECORD LENGTH IS MACHINE-DEPENDENT, AND
C MUST BE SUFFICIENT TO STORE 6 INTEGERS. FOR EXAMPLE:
C
C IBM: LREC = 24 (BYTES)
C VAX: LREC = 6 (LONGWORDS)
C CRAY: LREC = 48 (BYTES)
C
C LREC=24
C OPEN(ILSU,STATUS='SCRATCH',ACCESS='DIRECT',FORM='UNFORMATTED',
C 1 RECL=LREC,ERR=1900)
C
C1900 WRITE(6,107) ILSU
C 107 FORMAT(/' * * * WARNING. UNABLE TO OPEN DIRECT ACCESS FILE ON ',
C 1 'CHANNEL',I3,'. REQUESTED LINE-SHAPE CALCULATION CANCELLED.')
C NOCALC=.TRUE.
C RETURN
C IF (ILSU.LE.100) WRITE(6,200) ILSU
C 200 FORMAT(/' LINE SHAPE CALCULATION USES DIRECT ACCESS FILE ON ',
C 1 'CHANNEL',I4,' FOR TEMPORARY STORAGE')
C RETURN
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY PRBCNT(INRG,LEV,N,IUSE)
C
C SEE WHETHER THIS S-MATRIX WILL CONTRIBUTE TO ANY OF THE LINES
C REQUESTED: IUSE=1 MEANS THAT IT WILL.
C
C THIS CODE MAY NOT WORK FOR DIATOM-DIATOM: BE CAUTIOUS FOR NOW
IF (ITYPE3) GO TO 5920
C
DO 5910 I=1,NLINE
DO 5910 IA=1,2
IF (LN(I,IA+3).NE.INRG) GO TO 5910
DO 5908 II=1,N
L1=LEV(II)
IF (L1.EQ.LN(I,IA) .OR. L1.EQ.LN(I,IA+7)) GO TO 5920
5908 CONTINUE
5910 CONTINUE
IUSE=0
RETURN
C
5920 IUSE=1
RETURN
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY PRBOUT(JSTEP)
IF (NOCALC) RETURN
WRITE(6,671)
671 FORMAT(/' ACCUMULATED PRESSURE-BROADENING CROSS SECTIONS',
1 ' (IN ANG**2)')
FACTJ=1.D0
IF (JSTEP.GT.1) THEN
FACTJ=DBLE(JSTEP)/DBLE(JHALF)
WRITE(6,672) FACTJ
672 FORMAT(/' *** NOTE *** CROSS SECTIONS MULTIPLIED BY',F5.1,
1 ' TO ACCOUNT FOR JSTEP')
ENDIF
WRITE(6,673)
673 FORMAT(/' LINE LEV(A) LEV(B) LEV(A1) LEV(B1) TYPE',8X,
1 'EREL(1/CM)',11X,'RE(S)',12X,'IM(S)')
C
DO 6996 I=1,NLINE
SIGRJS=SIGR(I)*FACTJ
SIGIJS=SIGI(I)*FACTJ
6996 WRITE(6,601) I,LN(I,1),LN(I,2),
1 LN(I,8),LN(I,9),PTP(LN(I,3)+1),EREL(I),SIGRJS,SIGIJS
601 FORMAT(2I5,2I7,I8,3X,A8,F18.9,2D17.6)
RETURN
END
SUBROUTINE PRBR3(N,SREAL,SIMAG,JTOT,NLEV,NQN,JLEV,NBASIS,LEV,L,
& NPACK,LINE,NLVAL,IC,IL,SR,SI,TR,JBAR,ISTB,NBLK,LVAL)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION SREAL(N,N),SIMAG(N,N)
DIMENSION SR(N,N),SI(N,N),TR(N,N),JBAR(N),ISTB(N),NBLK(N),LVAL(N)
INTEGER JLEV(NLEV,NQN),NBASIS(N),LEV(N),L(N),IC(N),IL(N)
C
C PRBR3 IS AN INTERFACE ROUTINE WHICH TRANSFORMS ITYPE=3 S-MATRICES
C INTO FORMAT NECESSARY FOR PRESSURE BROADENING CALC..
C THIS NECESSITATES TRANSFORM FROM J1,J2(J12)L,JTOT TO
C J1(J2,L)JBAR,JTOT REPRESENTATION. IC, IL MADE COMPATIBLE.
C
C SREAL, SIMAG ARE STORED TEMPORARILY IN SR, SI WHICH MUST BE
C RESTORED (VIA ENTRY PRBR3R) BEFORE RETURNING CONTROL FROM PRBR.
C 4 JUN 93: REMOVE LIMITS ON INTERNALLY DEFINED WORKING STORAGE
C
C ENTRIES PRBRCS, PBCSSM, AND PBCSDA, WHICH HAD BEEN USED IN
C 'OLD' CS TRANSORMATION (SHOWN TO BE INCORRECT) ARE NOW
C TRAPPED WITH ERROR MSG (7/92). THEY SHOULD NOT BE CALLED.
C
DATA ZERO/0.D0/
C
C STATEMENT FUNCTION DEFINITION.
Z(I)=I+I+1
C
C SAVE SREAL, SIMAG IN SR, SI AND CLEAR SREAL, SIMAG.
1000 DO 1100 I1=1,N
DO 1100 I2=1,N
SR(I1,I2)=SREAL(I1,I2)
SREAL(I1,I2)=0.D0
SI(I1,I2)=SIMAG(I1,I2)
1100 SIMAG(I1,I2)=0.D0
C
C PICK OUT ROWS OF S WHICH CORRESPOND TO 'LINE' AND GROUP INTO
C BLOCKS WITH SAME L-VALUE.
C NB IS NO. OF BLOCKS, IC IS TABLE OF ALL
C (NLVAL) ROWS, IL HAS J12 VALUES, ISTB HAS (START-1) IN IC OF
C EACH BLOCK, NBLK HAS NO. IN EACH BLOCK.
NB=0
NLVAL=0
DO 2000 II=1,N
JJ=NBASIS(II)
IF (JLEV(LEV(JJ),NQN).NE.LINE) GO TO 2000
C CHECK TO SEE THAT THIS ISN'T ALREADY IN IC. . .
IM=NLVAL
2100 IF (IM.LE.0) GO TO 2200
IF (II.EQ.IC(IM)) GO TO 2000
IM=IM-1
GO TO 2100
C IF NOT, START A NEW BLOCK. . .
2200 NB=NB+1
ISTB(NB)=NLVAL
NBLK(NB)=1
LVAL(NB)=L(JJ)
NLVAL=NLVAL+1
IC(NLVAL)=II
IL(NLVAL)=JLEV(LEV(JJ),3)
C PROCESS REMAINING TO FIND OTHER WITH SAME L-VALUE. . .
II1=II+1
IF (II1.GT.N) GO TO 2000
DO 2500 II2=II1,N
JJ=NBASIS(II2)
IF (JLEV(LEV(JJ),NQN).NE.LINE) GO TO 2500
IF (L(JJ).NE.LVAL(NB)) GO TO 2500
NBLK(NB)=NBLK(NB)+1
NLVAL=NLVAL+1
IC(NLVAL)=II2
IL(NLVAL)=JLEV(LEV(JJ),3)
2500 CONTINUE
2000 CONTINUE
IF (NLVAL.LE.0) RETURN
C
C DO BOOKEEPING FOR TRANSFORMATION AND GET JBAR VALUES.
C GET JA, J2 FROM 1ST MEMBER - SHOULD BE SAME FOR ALL.
JJ=LEV(NBASIS(IC(1)))
JA=JLEV(JJ,1)
J2=JLEV(JJ,2)
JLOW=IABS(JTOT-JA)
JTOP=JTOT+JA
DO 3000 II=1,NB
LLL=LVAL(II)
NJB=0
JMIN=IABS(J2-LLL)
JMAX=J2+LLL
DO 3100 II2=JLOW,JTOP
IF (II2.LT.JMIN) GO TO 3100
IF (II2.GT.JMAX) GO TO 3100
C ALL TRIANGLE INEQUALITIES SATISFIED. INCLUDE JBAR
NJB=NJB+1
JBAR(ISTB(II)+NJB)=II2
3100 CONTINUE
C NO.(JBAR) SHOULD EQUAL NO.(J12) FOR EVERY BLOCK.
IF (NJB.EQ.NBLK(II) ) GO TO 3000
WRITE(6,601) NJB,NBLK(II),II
601 FORMAT('0 * * * ERROR. NO.(JBAR) .NE. NO.(J12)',2I6,
1 ' FOR BLOCK =',I4)
STOP
3000 CONTINUE
C
C SET UP TRANFORM MATRIX TR(JBAR,J12)
DO 3500 II1=1,NLVAL
DO 3500 II2=1,NLVAL
3500 TR(II1,II2)=0.D0
DO 3600 II=1,NB
LLL=LVAL(II)
NTOP=NBLK(II)
DO 3600 II1=1,NTOP
JB=JBAR(ISTB(II)+II1)
DO 3600 II2=1,NTOP
J12=IL(ISTB(II)+II2)
3600 TR(ISTB(II)+II1,ISTB(II)+II2)=SQRT(Z(JB)*Z(J12))
1 * SIXJ(JA,J2,JTOT,LLL,J12,JB)
C
C TRANSFORM SR,SI TO SREAL, SIMAG
C LOOP OVER L
DO 3700 II1=1,NB
NTOP1=NBLK(II1)
IST1=ISTB(II1)
C LOOP OVER L-PRIME
DO 3700 II2=1,NB
NTOP2=NBLK(II2)
IST2=ISTB(II2)
C LOOP OVER JBAR
DO 3700 JB=1,NTOP1
IRNEW=IC(IST1+JB)
C LOOP OVER JBAR-PRIME
DO 3700 JBP=1,NTOP2
ICNEW=IC(IST2+JBP)
C LOOP OVER J12
DO 3700 J12=1,NTOP1
IROLD=IC(IST1+J12)
C LOOP OVER J12-PRIME
DO 3700 J12P=1,NTOP2
ICOLD=IC(IST2+J12P)
FACTOR = TR(IST1+JB,IST1+J12) * TR(IST2+JBP,IST2+J12P)
SREAL(IRNEW,ICNEW)=SREAL(IRNEW,ICNEW)+FACTOR*SR(IROLD,ICOLD)
SIMAG(IRNEW,ICNEW)=SIMAG(IRNEW,ICNEW)+FACTOR*SI(IROLD,ICOLD)
3700 CONTINUE
C
C PACK L,JBAR INDICES INTO IL()
II2=0
DO 4000 II=1,NB
NTOP=NBLK(II)
LLL=LVAL(II)
DO 4000 II1=1,NTOP
II2=II2+1
4000 IL(II2)=LLL*NPACK+JBAR(II2)
C SREAL, SIMAG, IC, AND IL ARE NOW IN FORMAT EXPECTED BY PRBR
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
ENTRY PRBR3R(N,SREAL,SIMAG,SR,SI)
C RESTORE SIMAG,SREAL IN CASE THEY ARE NEEDED FOR FURTHER PROCESSING
DO 5000 II1=1,N
DO 5000 II2=1,N
SREAL(II1,II2)=SR(II1,II2)
5000 SIMAG(II1,II2)=SI(II1,II2)
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C ENTRIES BELOW PROVIDED INTERFACE TO OLD (INCORRECT) CS CODE
C ----- DUMMIED 7/92 -----
C ENTRY PRBRCS TRANSFORMS BODY-FIXED TO SPACE-FIXED S-MATRICES.
C ENTRY PBCSSM RETURNS MATRIX ELEMENTS STORED INTERNALLY HERE.
C ENTRY PBCSDA OUTPUTS STORED S-MATRICES ON DISK.
C
ENTRY PRBRCS
C ENTRY PRBRCS(N,SREAL,SIMAG,JTOT,MVALUE,IEXCH,WGHT,IPWVEC,
C & NLEV,NQN,JLEV,NBASIS,LEV,L,LINE,NLVAL,ITYPE)
ENTRY PBCSSM
C ENTRY PBCSSM(L1,L2,NDEBUG,NMATCH,SROUT,SIOUT)
ENTRY PBCSDA
C ENTRY PBCSDA(ILSU)
WRITE(6,7300)
7300 FORMAT(' *** ERROR. PBBRCS, PBCSSM, OR PBCSDA CALLED.'/
1 ' *** THIS (INCORRECT) CS TRANSFORM NO LONGER',
2 ' SUPPORTED.')
STOP
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 QASCAT(N, NSQ, MXLAM, NPOTL,
1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB,
2 P, Y, W, EIVAL, Y1, Y2, Y3, Y4, DIAG,
3 ICODE, IPRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C ***
C *** ---------------------------------------------------------------
C *** ROUTINE TO PERFORM A SCATTERING CALCULATION USING QAPROP.
C *** SR AND SI CONTAIN THE S MATRIX ON EXIT.
C *** BOTH ARE USED INTERNALLY TO ECONOMISE ON WORKSPACE.
C *** ---------------------------------------------------------------
C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGIES.
C ***
C DIMENSION STATEMENTS FOR ARGUMENT LIST
DIMENSION U(NSQ),W(NSQ),Y(NSQ),
& EIVAL(N),Y1(N),Y2(N),Y3(N),Y4(N),DIAG(N)
DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ),
& EINT(N),CENT(N),WVEC(N)
INTEGER 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 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
C
C PROPAGATE LOG DERIVATIVE MATRIX THROUGH THE SCATTERING REGION
C ---------------------------------------------------------------
ISTART=0
CALL QAPROP(SR, SI, 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)
C ---------------------------------------------------------------
IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,REND,NSTEPS
1000 FORMAT('0 QAPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ',
& F12.4,' TO ',F12.4,' IN ',I6,' STEPS.')
C
C SORT CHANNELS BY ASYMPTOTIC ENERGY
C
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,Y,W,U,REND)
CALL KTOS(U,SR,SI,NOPEN)
RETURN
END
FUNCTION QSYMTP(J1,K1,J1P,K1P,J2,J2P,LL,LLP,JJ,JJP,JT,P1,Q1,P2,PP)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER P1,Q1,P2,PP
C
C CALCULATES MATRIX ELEMENT FOR LINEAR ROTOR/ASSYMETRIC TOP
C USES SUBROUTINES -
C THRJ( )
C THREEJ( ) WHICH IS FOR M1=M2=M3=0
C SIXJ(LL,LLP,JJ,JJP,PP,JT)
C NOTE THAT ORDER OF ARGUMENTS IS (J1,J2,J5,J4,J3,J6)
C XNINEJ( )
C
DATA PI/3.14159265358979289D0/
C STATEMENT FUNCTION DEFINITION . . .
Z(Y) = 2.D0 * Y + 1.D0
C
IF (K1P-K1+Q1 .NE. 0) GO TO 9000
F=THREEJ(LL,LLP,PP)
1 IF (F.EQ.0.D0) GO TO 9000
XJ1 = J1
XJ1P = J1P
XK1 = -K1
XK1P = K1P
XQ1 = Q1
XP1 = P1
F=F * THRJ(XJ1,XP1,XJ1P,XK1,XQ1,XK1P)
F = F*THREEJ(J2,P2,J2P)
2 IF (F.EQ.0.D0) GO TO 9000
F=F * SIXJ(LL,LLP,JJ,JJP,PP,JT)
3 IF (F. EQ. 0.0D0) GO TO 9000
F = F*XNINEJ(JJP,JJ,PP,J1P,J1,P1,J2P,J2,P2)
4 IF (F.EQ.0.D0) GO TO 9000
XLLP = LLP
XLL = LL
XJ2 = J2
XJ2P = J2P
XJJ = JJ
XJJP = JJP
XPP = PP
XP2 = P2
PH=PARITY3(-J1P+J2P-PP+K1-JJ-JT)
F=F*PH*SQRT(Z(XLLP)*Z(XLL)*Z(XJ2)*Z(XJ2P)*Z(XJJ)*Z(XJJP)
1 *Z(XPP)*Z(XP2)*Z(XJ1)*Z(XJ1P))/4.0/PI
5 QSYMTP=F
RETURN
9000 QSYMTP=0.D0
RETURN
END
SUBROUTINE RBES(N,Z,ZJN,ZJNP,ZYN,ZYNP)
C CALCULATES RICCATI-BESSEL FUNCTIONS OF NON-NEGATIVE INTEGER ORDER N,
C AND POSITIVE ARGUMENT Z, AND THEIR DERIVATIVES WITH RESPECT TO Z.
C THE DEFINITIONS AND NORMALIZATIONS ARE AS IN THE NBS HANDBOOK, P. 445
C THE METHODS USED ARE
C 1. IF Z.LE.N ( CLASSICALLY FORBIDDEN REGION), USE
C ASCENDING POWER SERIES FOR THE REGULAR SOLUTION ZJN AND
C ITS DERIVATIVE ZJNP. FOREWARD RECURRENCE IS USED FOR
C THE IRREGULAR SOLUTION ZYN AND ITS DERIVATIVE ZYNP.
C 2. IF Z.GT.N ( CLASSICALLY ALLOWED REGION), FOREWARD
C RECURRENCE IS USED FOR BOTH FUNCTIONS.
C LIBRARY FUNCTIONS REQUIRED SIN(Z) AND COS(Z)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DATA ONE /1.D0/
DATA HALF /0.5D0/
DATA TWO /2.D0/
DATA ZERO /0.D0/
DATA THREE/3.D0/
C
C EVALUATE TRIGONOMETRIC FUNCTIONS NEEDED
SINZ=SIN(Z)
COSZ=COS(Z)
ZINV=ONE/Z
AJ=SINZ
BJ=SINZ*ZINV-COSZ
AY=-COSZ
BY=-SINZ-COSZ*ZINV
IF(N-1)1,2,3
C FUNCTIONS OF ORDER ZERO
1 ZJN=AJ
ZJNP=COSZ
ZYN=AY
ZYNP=SINZ
RETURN
C FUNCTIONS OF ORDER ONE
2 ZJN=BJ
ZJNP=AJ-ZINV*BJ
ZYN=BY
ZYNP=AY-ZINV*BY
RETURN
C
C CASES FOR ORDER GREATER THAN 1
3 XN=N
DELF=ZINV+ZINV
FACTOR=DELF+ZINV
C TEST TO SEE IF RECURRENCE CAN BE USED FOR ALL FUNCTIONS
IF(Z.GT.XN) GO TO 100
C
C THIS CASE FOR NON-CLASSICAL REGION.
C USE POWER SERIES FOR REGULAR SOLUTION AND RECURSION FOR IRREGULAR
C COMPUTE COEFFIENT (C) IN FRONT OF POWER SERIES, AT SAME TIME AS
C FOREWARD RECURRENCE.
ZSQ=Z**2
TOP=XN+XN
XJ=THREE
C=ZSQ/THREE
25 ZYN=BY*FACTOR-AY
AY=BY
BY=ZYN
FACTOR=FACTOR+DELF
XJ=XJ+TWO
C=C*(Z/XJ)
IF(XJ.LT.TOP) GO TO 25
C FORM DERIVATIVE OF IRREGULAR SOLUTION
ZYNP=AY-ZINV*BY*XN
C USE POWER SERIES FOR REGULAR SOLUTION
C INITIALIZE
FACTOR=-HALF*ZSQ
U=ONE
TERM=ONE
DU=ONE
DTERM=ONE
D2NP3=TOP+THREE
DEN=D2NP3
DFACT=ZERO
C INCREMENT FACTORIAL FACTOR
35 DFACT=DFACT+ONE
TERM=TERM*(FACTOR/(DFACT*DEN))
C SUM SERIES
U=U+TERM
C INCREMENT DENOMINATOR
DEN=DEN+TWO
DTERM=DTERM*(FACTOR/(DFACT*DEN))
C SUM DERIVATIVE SERIES
DU=DU+DTERM
C TEST FOR CONVERGENCE TO SINGLE PRECISION ACCURACY
IF(ABS(TERM).GT.1.0D-09) GO TO 35
C CONVERGENCE. COMPUTE REGULAR FUNCTION.
ZJN=U*C
C COMPUTE DERIVATIVE
ZJNP=(XN+ONE)*ZJN*ZINV-(Z*DU/D2NP3)*C
RETURN
C
C CLASSICAL CASE. USE FOREWARD RECURSION.
100 CONST=ZINV*XN
TOP=CONST+CONST
200 AJ=FACTOR*BJ-AJ
AY=FACTOR*BY-AY
C INCREMENT FACTOR
FACTOR=FACTOR+DELF
C TEST FOR COMPLETION
IF(FACTOR.GT.TOP) GO TO 250
BJ=FACTOR*AJ-BJ
BY=FACTOR*AY-BY
FACTOR=FACTOR+DELF
C TEST FOR COMPLETION
IF(FACTOR.LT.TOP) GO TO 200
ZJN=BJ
ZYN=BY
C FORM DERIVATIVES
ZJNP=AJ-CONST*BJ
ZYNP=AY-CONST*BY
RETURN
250 ZJN=AJ
ZYN=AY
C FORM DERIVATIVES
ZJNP=BJ-CONST*AJ
ZYNP=BY-CONST*AY
RETURN
END
SUBROUTINE RDPCH(ISIGU)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C THIS ROUTINE LISTS/PUNCHES THE 'SAVED' CROSS SECTIONS FROM (ISIGU)
C FORMAT MADE COMPATBLE W/CURRENT VERSION APR 94 (SG)
C NOTE: BY-PASSED IN CURRENT VERSION OF MOLSCAT
C THE SEEMINGLY COMPLICATED METHOD USED IS TO ASSURE ABILITY TO
C RETRIEVE CROSS SECTIONS INDEPENDENTLY OF A SUCCESSFULLY TERMINATED
C SCATTERING RUN BY SAVING ON (ISIGU) AS WELL AS IN MATRIX SIG().
C
CHARACTER*1 A1(80),S,B,ST,EOF,CS
DATA B/' '/, ST/'*'/, EOF/'$'/
C
WRITE(6,601)
601 FORMAT('1')
I10=0
C
1000 I10=I10+1
READ(ISIGU,100,ERR=900,REC=I10) A1
100 FORMAT(80A1)
IF (A1(1).EQ.EOF) RETURN
IF (A1(1).NE.ST) GO TO 1000
READ(ISIGU,101,REC=I10) S,E,I1,I2,I3,I4,I5,SIG,CS
101 FORMAT(A1,F19.6,I5,2I7,5X,2I5,D20.6,1X,A1)
WRITE(6,600) B,E,I1,I2,I3,I4,I5,SIG,CS
600 FORMAT(A1,F19.6,I5,2I7,5X,2I5,1P,D20.6,1X,A1)
C PUNCH CHANNEL COMMENTED OUT IN THIS VERSION
C IF (SIG.GT.0. .AND. I4.NE.I5)
C 1 WRITE(7,600) S,E,I1,I2,I3,I4,I5,SIG,CS
GO TO 1000
900 WRITE(6,*) ' *** RDPCH. ERROR READING FILE',ISIGU
RETURN
END
SUBROUTINE RESTRT(IRSTRT,ISAVEU, JTOTL,JSTEP,MXPAR,MSET,MHI,
1 LABELX,ITYPEX,NLEVX,NQNX,UREDX,IPX,
2 JLEVX,NNRGX,ENERGX,MXNRG,
3 SIG,ISST,IECONV,MINJT,MAXJT,ISIGU,IPARTU,KSAVE,
4 OTOL,DTOL, IXX,RXX, MRSTRT,IERST,MXP,PRNTLV)
C
C MODIFICATIONS FOR VERSION 14, JUL 94
C RESTART MOLSCAT CALCULATION FROM SAVED TAPE ON UNIT(ISAVEU):
C IRSTRT= 1 RESTART AFTER A COMPLETED JTOT SET
C =-1 SAME AS 1, BUT BEGINNING AT &INPUT JTOTL
C = 2 RESTART AFTER A COMPLETED SYMMETRY BLOCK
C = 3 RESTART AFTER LAST GOOD JTOT,M,INRG SET
C
C A RESTART RUN SHOULD HAVE SAME INPUT DECK AS ORIGINAL RUN
C EXCEPT THAT IRSTRT PARAMETER MUST BE SET.
C FOR IRSTRT=-1, JTOTL MUST BE RESET TO DESIRED RESTART VALUE
C SOME OTHER PARMS (E.G., INTEGRATION PARMS *MAY* BE CHANGED)
C
C RECREATES ACCUM CROSS SECTIONS (OUTPUT/PRBR) FROM SAVED S-MATRICES
C
C JTSV(IRSTRT),MSV(IRSTRT),INSV(IRSTRT)
C CONTAIN VALUES FOR LAST *COMPLETED* SET FOR EACH IRSTRT OPTION.
C RETURNS JTOTL,MRSTRT,IERST -- VALUES AT WHICH TO RECOMMENCE
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JLEVX(1)
DIMENSION ENERGX(MXNRG)
DIMENSION MINJT(MXNRG),MAXJT(MXNRG),ISST(MXNRG),IECONV(MXNRG)
DIMENSION SIG(1), IXX(1),RXX(1)
DIMENSION JTSV(3),MSV(3),INSV(3)
INTEGER PRNTLV
CHARACTER*80 LABEL,LABELX
LOGICAL CONSIS,MPLMIN,LCS,LCS3
C BIG VALUE TO INITIALIZE JSTOP
DATA IBIG/1000000/
C
C DYNAMIC STORAGE COMMON BLOCK ...
C USAGE IN RESTRT DOES *NOT* CONFORM W/ USUAL MOLSCAT PHILOSOPHY:
C X() IS ACCESSED DIRECTLY, VIA IXX() AND RXX()
C LIMIT CHECKED DIRECTLY AGAINST MX, I.E., CHKSTR IS NOT USED.
C ON ENTRY IXX(1), RXX(1) ARE EQUIVALENCED TO X(IXNEXT)
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C 'BASIS' COMMON BLOCK -- NEED NLEVEL,ELEVEL,JLEVEL (V14, JUL 94)
DIMENSION ELEVEL(1000),ELVL(1000),JLEVEL(4000)
COMMON /CMBASE/ DUM(1016),IDUM(4031)
EQUIVALENCE (NLVL,IDUM(1)),(ELVL(1),DUM(13)),(JLEVEL(1),IDUM(2))
1 ,(IDENT,IDUM(4029))
C
C COMMON TO COMMUNICATION WITH PRBR; EXCEPT FOR MVALUE THESE HAVE
C BEEN SET IN PRIOR CALL TO BASIN.
COMMON /PRBASE/ ITYPE,NQN,NLEV,MVALUE,IEXX,MPLMIN
C
C --------------------------------------------------------
IF (IRSTRT.EQ.0.OR.IRSTRT.LT.-1) RETURN
CALL GCLOCK(TSTART)
C
C FIRST MXPAR LOCATIONS IN IXX USED TO STORE HIGHEST ENERGY/M
C (PERHAPS WE SHOULD KEEP HIGHEST ENERGY IN *LAST* JTOT CYCLE)
IXI=MXPAR
IXR=(MXPAR+NIPR-1)/NIPR
IF (IXNEXT+IXR-1.GT.MX) THEN
WRITE(6,*) ' *** TERMINAL ERROR. SCRATCH STORAGE EXCEEDED.'
STOP
ELSE
DO 1000 I=1,MXPAR
1000 IXX(I)=-1
ENDIF
C
JSTOP=IBIG
IF (IRSTRT.EQ.-1) THEN
WRITE(6,*) ' *** RESTRT. REQUEST TO RESTART AT JTOT =',JTOTL
JSTOP=JTOTL-JSTEP
IRSTRT=1
ENDIF
IT=ISAVEU
C CHECK HEADER INFO ON TAPE FOR AGREEMENT WITH CURRENT RUN PARAMS.
READ(IT,END=9001) LABEL,ITYPE,NLEV,NQN,URED,IP
WRITE(6,600) IT,LABEL,LABELX
600 FORMAT(' ***'/' *** RESTRT. DATA FROM UNIT ISAVEU =',I4/
2 ' *** LABEL ON ISAVEU =',A80/
3 ' *** CURRENT RUN LABEL =',A80/' ***')
IF (ITYPE.EQ.ITYPEX .AND. NLEVX.EQ.NLEV .AND. NQNX.EQ.NQN
1 .AND. URED.EQ.UREDX) THEN
WRITE(6,601) ITYPE,NLEV,NQN,URED,IP
601 FORMAT(/' *** CURRENT PARAMETERS AGREE WITH SAVED VALUES'/
1 6X,'ITYPE =',I3/6X,'NLEV, NQN =',2I4/6X,'URED =',F8.4/
2 6X,'IPROGM =',I3)
ELSE
WRITE(6,602) ITYPEX,ITYPE,NLEVX,NLEV,NQNX,NQN,UREDX,URED
602 FORMAT(' *** ERROR. CURRENT/SAVED PARAMTERS DO NOT MATCH'/
1 14X,'ITYPE',2I6/14X,'NLEV',2I6/14X,'NQN ',2I6/
2 14X,'URED',2F12.4/' *** TERMINATING.')
STOP
ENDIF
IF (IPX.NE.IP) WRITE(6,603) IPX
603 FORMAT(' *** RESTRT. WARNING: CURRENT RUN IS VERSION',I3,
1 '; DIFFERS FROM SAVE TAPE VERSION')
IF (IP.LE.13) THEN
WRITE(6,*) ' *** RESTRT. CURRENT VERSION CANNOT PROCESS',
1 ' SAVE TAPES IN IPROGM.LE.13 FORMAT'
STOP
ENDIF
C
NSQ=NLEV*NQN
NUSED=(IXI+NSQ+NIPR-1)/NIPR
IF (IXNEXT+NUSED-1.GT.MX) THEN
WRITE(6,*) ' *** TERMINAL ERROR. NOT ENOUGH STORAGE FOR JLEV'
STOP
ELSE
READ(IT,END=9001) (IXX(IXI+I),I=1,NSQ)
DO 1001 I=1,NSQ
IF (IXX(IXI+I).EQ.(JLEVX(I))) GO TO 1001
WRITE(6,604) (JLEVX(II),IXX(IXI+II),II=1,NSQ)
604 FORMAT(' *** TERMINAL ERROR. CURRENT/SAVED JLEV MISMATCH'/
1 (8(2X,2I4)))
STOP
1001 CONTINUE
WRITE(6,*) ' *** CURRENT/SAVED JLEV MATCH'
ENDIF
C
READ(IT,END=9001) NLEVEL,(ELEVEL(I),I=1,NLEVEL)
IF (NLVL.NE.NLEVEL) THEN
WRITE(6,605) NLVL,NLEVEL
605 FORMAT(' *** TERMINAL ERROR. CURRENT/SAVED NLEVEL',2I6)
STOP
ENDIF
DO 1002 I=1,NLEVEL
IF (ELVL(I).EQ.ELEVEL(I)) GO TO 1002
WRITE(6,606) I,ELVL(I),ELEVEL(I)
606 FORMAT(' *** TERMINAL ERROR. CURRENT/SAVED ELEVEL(',I3,')=',
1 2D12.4)
STOP
1002 CONTINUE
WRITE(6,*) ' *** CURRENT/SAVED NLEVEL,ELEVEL MATCH.'
C
IF (IXNEXT+IXR+MXNRG-1.GT.MX) THEN
WRITE(6,*) ' *** TERMINAL ERROR. NOT ENOUGH STORAGE FOR MXNRG'
STOP
ELSE
READ(IT,END=9001) NNRG,(RXX(IXR+I),I=1,NNRG)
ENDIF
IF (NNRG.NE.NNRGX) THEN
WRITE(6,607) NNRG,NNRGX
607 FORMAT(' *** TERMINAL ERROR. CURRENT/SAVED NNRG',2I6)
STOP
ENDIF
DO 1003 I=1,NNRG
IF (RXX(IXR+I).EQ.ENERGX(I)) GO TO 1003
WRITE(6,608) I,RXX(IXR+I),ENERGX(I)
608 FORMAT(' *** TERMINAL ERROR. CURRENT/SAVED ENERGY(',I3,')=',
1 2D12.4)
STOP
1003 CONTINUE
WRITE(6,*) ' *** CURRENT/SAVED NNRG,ENERGY MATCH.'
C
C CHECKING SPECIFIC TO SOME ITYPES ...
LCS=ITYPE.EQ.21.OR.ITYPE.EQ.22.OR.ITYPE.EQ.25.OR.ITYPE.EQ.26
1 .OR.ITYPE.EQ.27
LCS3=ITYPE.EQ.23
C MPLMIN IS AVAILABLE FROM CURRENT RUN IN /PRBASE/, BUT SAVE TAPE
C CANNOT BE CHECKED FOR ORIGINAL VALUE. ASSUME IT IS SAME.
C THIS SHOULD ONLY MATTER FOR PRESSURE BROADENING W/ COUPLED STATES
IF (LCS.OR.LCS3) THEN
IF (MPLMIN) THEN
WRITE(6,*) ' *** CURRENT COUPLED STATES APPROXIMATION ',
1 'HAS IDENTICAL +/- PROJECTIONS'
ELSE
WRITE(6,*) ' *** CURRENT COUPLED STATES APPROX HAS ',
1 'BOTH +/- PROJECTIONS'
ENDIF
WRITE(6,*) ' WILL ATTEMPT TO VERIFY CONSISTENCY WITH '
1 ,'SAVE TAPE'
ENDIF
C FOR ITYPE='3' CHECK JLEVEL/JLEV ARE CONSISTENT
IF (ITYPE-10*(ITYPE/10).EQ.3) THEN
CONSIS=.TRUE.
NLV=0
IXT=(NQNX-1)*NLEVX
DO 4002 I=1,NLEVX
IL=JLEVX(IXT+I)
NLV=MAX(NLV,IL)
CONSIS=CONSIS.AND.JLEVEL(2*IL-1).EQ.JLEVX(I)
4002 CONSIS=CONSIS.AND.JLEVEL(2*IL).EQ.JLEVX(NLEVX+I)
IF (NLV.EQ.NLVL.AND.CONSIS) THEN
WRITE(6,*) ' *** ITYPE=3+10*N: JLEVEL/JLEV ARE CONSISTENT'
ELSE
WRITE(6,*) ' *** ERROR. ITYPE=3+10*N: INCONSISTENT JLEVEL/',
1 'JLEV. SHOULD AFFECT ONLY PRBR CALCULATION'
ENDIF
ENDIF
C
C READ THROUGH JTOT/S-MATRICES FIRST TIME, TO SEE WHAT'S THERE
NOPMX=0
MAXMIN=0
JTOLD=-1
MSOLD=-1
C
2000 READ(IT,END=9002) JTOT,INRG,ECHK,IEXCH,WT,M,NOPEN
IF (JTOT.GT.JSTOP) GO TO 9004
C
C SEE IF M-VALUE IS CONSISTENT W/ MHI,MSET AND MXPAR
IF (M.GT.MXPAR.OR.M.LE.0) THEN
WRITE(6,*) ' *** TERMINAL ERROR. ILLEGAL M-VALUE',M
WRITE(6,*) ' *** TERMINAL ERROR. NOTE. MXPAR =',MXPAR
STOP
ELSE
IXX(M)=MAX(IXX(M),INRG)
ENDIF
IF (MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) THEN
WRITE(6,612) M,MSET,MHI
612 FORMAT(' *** RESTRT. WARNING. M =',I4,
1 ' INCONSISTENT WITH CURRENT MSET,MHI =',2I4)
ENDIF
C CHECK CONSISTENCY OF INRG,ECHK
IF (ABS(ECHK-ENERGX(INRG)).GT.1.D-8)
1WRITE(6,611) JTOT,M,INRG,ECHK
611 FORMAT('0 *** WARNING. FOR JTOT,M=',I4,'.',I2,' ENERGY('
1 ,I4,'), BAD ECHK =',D16.8)
C
IF (JTOT.EQ.JTOLD .OR. JTOLD.EQ.-1) GO TO 2011
C NEW JTOT. SAVE IRSTRT=1 VALUES; CHECK JSTEP CONSISTENCY
JTSV(1)=JTSV(3)
MSV(1)=MSV(3)
INSV(1)=INSV(3)
JSTEPX=JTOT-JTOLD
IF (JSTEP.EQ.JSTEPX) GO TO 2011
WRITE(6,609) JSTEP,JSTEPX
609 FORMAT(' *** RSTRT. TERMINAL ERROR. CURRENT/SAVED JSTEP =',2I6)
STOP
2011 JTOLD=JTOT
C
IF (M.EQ.MSOLD.OR.MSOLD.EQ.-1) GO TO 2021
C NEW PARITY (SYMMETRY) BLOCK; SAVE IRSTRT=2 VALUES, AND
C REVISE IXX(LAST-M) TO REFLECT HIGHEST INRG IN LAST SET
IXX(MSV(3))=INSV(3)
JTSV(2)=JTSV(3)
MSV(2)=MSV(3)
INSV(2)=INSV(3)
2021 MSOLD=M
C
2002 READ(IT,END=9003) (JX,LX,WVX,I=1,NOPEN)
C
IF (IXNEXT+IXR+NOPEN*NOPEN-1.LE.MX) THEN
CALL SREAD(IT,NOPEN,RXX(IXR+1),IEND)
IF (IEND.GT.0) GO TO 9003
CALL SREAD(IT,NOPEN,RXX(IXR+1),IEND)
IF (IEND.GT.0) GO TO 9003
ELSE
WRITE(6,*) ' *** RESTRT. TERMINAL ERROR. INADEQUATE SCRATCH '
1 ,'STORAGE FOR SREAL/SIMAG. NOPEN =',NOPEN
STOP
ENDIF
C COMPLETE JTOT,M,INRG SET. UPDATE NOPMX; SAVE IRSTRT=3 VALUES
NOPMX=MAX(NOPMX,NOPEN)
MAXMIN=MAX(MAXMIN,M)
JTSV(3)=JTOT
MSV(3)=M
INSV(3)=INRG
C
C GO BACK FOR MORE JTOT, INRG SETS . . .
GO TO 2000
C
C END OF FILE CONDITIONS
C
9001 WRITE(6,*) ' *** TERMINAL ERROR. PREMATURE EOF READING ISAVEU.'
STOP
C
C NORMAL END OF FILE AFTER A COMPLETED SET.
C DETERMINE IF LAST INPUT COMPLETED 1) M-SET, 2) JTOT
C AND MODIFY JTSV,MSV,INSV ACCORDINGLY
9002 WRITE(6,699) ISAVEU
699 FORMAT('0 *** NOTE. NORMAL EOF REACHED ON UNIT (',I3,')')
IF (INSV(3).EQ.IXX(MSV(3))) THEN
WRITE(6,*)' LAST INPUT APPEARS TO COMPLETE AN M-SET'
JTSV(2)=JTSV(3)
MSV(2)=MSV(3)
INSV(2)=INSV(3)
IF (MSV(3).EQ.MAXMIN) THEN
WRITE(6,*) ' IT ALSO APPEARS TO COMPLETE A JTOT'
JTSV(1)=JTSV(3)
MSV(1)=MSV(3)
INSV(1)=INSV(3)
ENDIF
ENDIF
C IRSTRT=-1 CASES: TRY TO ASCERTAIN COMPLETENESS THROUGH JSTOP.
IF (JSTOP.GE.IBIG) GO TO 3000
IF (JTOT.NE.JSTOP) THEN
WRITE(6,*) ' *** LAST COMPLETE JTOT,M,INRG=',
1 JTSV(3),MSV(3),INSV(3)
WRITE(6,*) ' *** ERROR. LAST JTOT.NE.JSTOP',JTOT,JSTOP
STOP
ENDIF
IF (JTSV(1).NE.JTOT) THEN
WRITE(6,*) ' *** POSSIBLE ERROR.'
WRITE(6,*) ' IT IS NOT CLEAR THAT FINAL JTOT SET IS',
1 ' COMPLETE. ASSUME IT IS.'
WRITE(6,*) ' *** LAST COMPLETE JTOT,M,INRG=',
1 JTSV(3),MSV(3),INSV(3)
JTSV(1)=JTSV(3)
MSV(1)=MSV(3)
INSV(1)=INSV(3)
ENDIF
GO TO 3000
C
C EOF WHILE READING S-MATRICES; ALL JTSV,MSV,INSV SHOULD BE CORRECT.
9003 WRITE(6,698) ISAVEU
698 FORMAT('0 *** NOTE. ABNORMAL EOF REACHED ON UNIT (',I3,')'/
1 ' INCOMPLETE (JTOT,INRG,M)-SET')
IF (JSTOP.LT.IBIG) THEN
WRITE(6,*) ' *** ERROR. ISAVEU DOES NOT HAVE ALL S-MATRICES',
1 ' PRIOR TO REQUESTED RESTART AT JTOTL =',JTOTL
WRITE(6,*) ' *** LAST COMPLETE JTOT,M,INRG=',
1 JTSV(3),MSV(3),INSV(3)
STOP
ENDIF
GO TO 3000
C BELOW REACHED IF JSTOP EXCEEDED BEFORE EOF
C FORCE JTSV(IRSTRT=1) VALUES TO LAST COMPLETED SET
9004 WRITE(6,*) ' *** ISAVEU INPUT TERMINATED BY IRSTRT=-1, JSTOP ='
1 ,JSTOP
JTSV(1)=JTSV(3)
MSV(1)=MSV(3)
INSV(1)=INSV(3)
C
3000 WRITE(6,630) JTSV(3),MSV(3),INSV(3)
630 FORMAT(/' ***',6X,' LAST COMPLETED (JTOT,M,INRG)-SET ---',3I5)
IF (IRSTRT.NE.3)
1 WRITE(6,631) IRSTRT,JTSV(IRSTRT),MSV(IRSTRT),INSV(IRSTRT)
631 FORMAT(' *** FOR REQUESTED IRSTRT =',I2/
1 ' ***',6X,' LAST COMPLETED (JTOT,M,INRG)-SET ---',3I5)
WRITE(6,632)
632 FORMAT(' ***',6X,' THESE S-MATRICES WILL BE REREAD/REPROCESSED')
C
C ----------------------------------------------------------------
C READ THROUGH TAPE AGAIN, ONLY THROUGH APPROPRIATE LAST SET
C AND PROCESS S-MATRICES THROUGH OUTPUT/PRBR
C
C ALLOCATE STORAGE FOR NB,J,L,WV,SR,SI; AND PRBR TEMPORARIES
C PLACE THE REAL VARIABLES FIRST
IXWV=1
IXSR=IXWV+NOPMX
IXSI=IXSR+NOPMX*NOPMX
NREAL=IXSI+NOPMX*NOPMX
C SPACE THE INTEGER VARIABLES BY NIPR
IXNB=NREAL*NIPR+1
IXJ=IXNB+NOPMX
IXL=IXJ+NOPMX
IT1=IXL+NOPMX
IT2=IT1+NOPMX
IT3=IT2+NOPMX
IT4=IT3+NOPMX
C NINT IS THE NUMBER OF REAL SPACES TAKEN BY THE INTEGERS
NINT=(7*NOPMX+NIPR-1)/NIPR
NUSED=NREAL+NINT
NAVAIL=MX-IXNEXT+1
IF (NUSED.GT.NAVAIL) THEN
WRITE(6,*) ' *** RESTRT. INADEQUATE SCRATCH STORAGE',
1 ' TO PROCESS SAVED S-MATRICES.'
STOP
ENDIF
C
C SET VALUES REQUIRED FOR OUTPUT/PRBR
DO 4001 I=1,NOPMX
4001 IXX(IXNB-1+I)=I
RM=1.D0
TTIME=0.D0
ISIGPR=0
CONV=0.D0
ILSU=0
C REQUEST MINIMAL OUTPUT FROM OUTPUT/PRBR ...
IPRINT=MIN(1,PRNTLV)
C
REWIND ISAVEU
READ(IT,END=9999) LABEL,ITYPE,NLEV,NQN,URED,IP
NSQ=NLEV*NQN
READ(IT,END=9999) (JLEVX(I),I=1,NSQ)
READ(IT,END=9999) NLEVEL,(ELEVEL(I),I=1,NLEVEL)
READ(IT,END=9999) NNRGX,(ENERGX(I),I=1,NNRGX)
C READ THROUGH JTOT/S-MATRICES FIRST TIME, TO SEE WHAT'S THERE
4000 READ(IT,END=9999) JTOT,INRG,ECHK,IEXCH,WT,M,NOPEN
MXP=MAX(MXP,M)
READ(IT,END=9999) (IXX(IXJ-1+I),IXX(IXL-1+I),RXX(IXWV-1+I),
1 I=1,NOPEN)
CALL SREAD(IT,NOPEN,RXX(IXSR),IEND)
IF (IEND.GT.0) GO TO 9999
CALL SREAD(IT,NOPEN,RXX(IXSI),IEND)
IF (IEND.GT.0) GO TO 9999
C
C SET NCHN TO -1 FOR REVISED (AUG 95) OUTPUT
NCHN=-1
CALL OUTPUT(JTOT,IXX(IXNB),IXX(IXJ),IXX(IXL),
1 RXX(IXWV),RXX(IXSR),RXX(IXSI),AKDUM,
2 CONV,NOPEN,M,MXPAR,WT,IEXCH,INRG,RM,IPRINT,TTIME,
3 ENERGX,SIG, JLEVX, ISST,IECONV,MINJT,MAXJT,
4 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT,
5 NCHN)
C
C BELOW DUPLICATES DRIVER (SG: I DON'T THINK IT IS USED ANYMORE.)
MOLD=-M
IF (M.EQ.MXPAR) MOLD=0
C
C COUPLED STATES PRBR NEEDS MVALUE; CALC FROM M (NB IEXX NOT USED)
C BELOW TRIES TO BE CONSISTENT WITH MOLSCAT; SHOULD BE MOOT AS IT
C ONLY AFFECTS PRBR AND ITYPE=23/IDENT.NE.0 IS NOT SUPPORTED.
C N.B. ORDER OF ITYPE=23 WAS CHANGED IN VERSION 13
IF (LCS.OR.(LCS3.AND.IP.LE.12)) THEN
IF (LCS3.AND.IDENT.NE.0) THEN
IF (M.LE.MXPAR/2) THEN
IEXX=1
MVALUE=M-1
ELSE
IEXX=2
MVALUE=M-(MXPAR/2)-1
ENDIF
ELSE
MVALUE=M-1
ENDIF
C CHECK CONSISTENCY OF MPLMIN/MVALUE,WT
IF ((MPLMIN.AND.(.NOT.((MVALUE.EQ.0.AND.WT.EQ.1.D0).OR.
1 (MVALUE.GT.0.AND.WT.EQ.2.D0))) .OR.
2 .NOT.MPLMIN.AND.MVALUE.NE.1.D0) .AND. IDENT.EQ.0)
3 WRITE(6,*) ' *** INCONSISTENT MVALUE/WT'
ELSE IF (LCS3.AND.IP.GE.13) THEN
C CODE FOR ORDER STARTING WITH VERSION 13X ...
IEXX=IEXCH
IF (IDENT.EQ.0) THEN
MVALUE=M-1
ELSE
IEXX=2-MOD(M,2)
IF (IEXX.NE.IEXCH) WRITE(6,*)
1 ' *** INCONSISTENT: IEXCH FROM M .NE. IEXCH ON TAPE'
MVALUE=(M+1)/2-1
ENDIF
ENDIF
CALL PRBR(JTOT,MOLD,NOPEN,INRG,RM,
1 IXX(IXNB),IXX(IXJ),IXX(IXL),RXX(IXWV),
2 RXX(IXSR),RXX(IXSI),IXX(IT1),IXX(IT2),IXX(IT3),IXX(IT4),
3 JLEVX,MXPAR,WT,IPRINT,ILSU)
C
C UNTIL WE HIT 'FINAL' SET, GO BACK FOR MORE JTOT,M,INRG ...
IF (JTOT.NE.JTSV(IRSTRT).OR.M.NE.MSV(IRSTRT).OR.
1 INRG.NE.INSV(IRSTRT)) GO TO 4000
C
C WE HAVE NOW FINISHED REPROCESSING THE 'SAVED' S-MATRICES
C
CALL GCLOCK(TEND)
TUSED=TEND-TSTART
WRITE(6,634) NUSED,NAVAIL,TUSED
634 FORMAT(' *** RESTRT. REPROCESSING COMPLETED. IT REQUIRED'/
1 5X,I9,' OF THE',I12,
2 ' CURRENTLY AVAILABLE WORDS OF STORAGE'/
3 9X,'AND',F8.2,' CPU SECONDS.')
C
C CHOOSE 'NEXT' JTOTL,MRSTRT,IERST AND PUT IN CALLING ARGUMENTS
IF (IRSTRT.EQ.3) THEN
JTOTL=JTSV(3)
MRSTRT=MSV(3)
IERST=INSV(3)+1
IF (IERST.GT.NNRG.OR.IERST.GT.IXX(MRSTRT)) THEN
IERST=1
MRSTRT=MRSTRT+1
IF (MRSTRT.GT.MXPAR.OR.MRSTRT.GT.MAXMIN) THEN
MRSTRT=1
JTOTL=JTOTL+JSTEP
ENDIF
ENDIF
ELSEIF (IRSTRT.EQ.2) THEN
JTOTL=JTSV(2)
MRSTRT=MSV(2)+1
IERST=1
IF (MRSTRT.GT.MXPAR.OR.MRSTRT.GT.MAXMIN) THEN
MRSTRT=1
JTOTL=JTOTL+JSTEP
ENDIF
ELSEIF (IRSTRT.EQ.1) THEN
MRSTRT=1
IERST=1
JTOTL=JTSV(1)+JSTEP
ENDIF
WRITE(6,635) JTOTL,MRSTRT,IERST
635 FORMAT(' *** RESTRT. CALCULATION WILL BE RESTARTED AT'/
1 15X,'JTOT =',I4,', M =',I3,', ENERGY(',I4,')')
C
RETURN
C
9999 WRITE(6,*) ' *** RESTRT. ERROR: UNEXPECTED EOF REREADING ISAVEU'
STOP
END
SUBROUTINE RMSBF(N,Z,RATIO)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C RETURNS RATIO OF DERIVATIVE TO FUNCTION VALUE FOR
C MODIFIED SPHERICAL BESSEL FUNCTIONS OF THE THIRD KIND,
C USING RECURSION BASED ON ABRAMOWITZ AND STEGUN 10.2.18.
C THE FUNCTION INVOLVED IS (-)**(N+1)*(2*Z/PI)*F(Z)*EXP(Z)
C IN THE NOTATION OF A&S.
C
F1=1.D0
IF(N.EQ.0) GO TO 20
DO 10 I=1,N
F3 = F1+DBLE(I+I-1)/Z
F1 = 1.D0/F3
10 CONTINUE
20 F3 = F1+DBLE(N+N+1)/Z
RATIO=1.D0/Z-(DBLE(N)*F1+DBLE(N+1)*F3)/DBLE(N+N+1)
RETURN
END
SUBROUTINE RMTPRP(NBAS,NSQBAS,MXLAM,NPOTL,
1 SR,SI,Q,VL,IV,EINT,CENT,WVEC,JJ,L,NB,
2 P,W,R,EIGOLD,EIGNOW,DIAG,R1,R2,R3,R4,CLOSE,
3 NOPMAX,DEEP,IK,ICODE,PRINT,NV,ISTART)
C-- BELOW IS FROM JMH JAN 93 W/ NEW MATRIX ROUTINES (--.V11X.LKED)
C-- MODIFIED BY SG (1/27/93) TO USE /MEMORY/ ..,IVLFL,
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
LOGICAL IREAD,IWRITE,CNTRCT,GOTTP
INTEGER PRINT
DIMENSION SR(NSQBAS),SI(NSQBAS),Q(NSQBAS),VL(NV),IV(NV),
1 EINT(NBAS),CENT(NBAS),WVEC(NBAS),JJ(NBAS),L(NBAS),NB(NBAS),
2 P(MXLAM),W(NSQBAS),R(NSQBAS),EIGOLD(NBAS),EIGNOW(NBAS),
3 DIAG(NBAS),R1(NBAS),R2(NBAS),R3(NBAS),R4(NBAS),CLOSE(NBAS)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C COMMON BLOCK FROM DRIVER
COMMON/DRIVE/DUMMY(4),RMIN,RMAX,XEPS,DR,DRMAX,RMID,FACT,
1 RTURN,VTOL,ESHIFT,ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP
C
C 14 JULY 86 VERSION FROM JMH
C THIS ROUTINE SOLVES THE COUPLED EQUATIONS USING THE R-MATRIX
C PROPAGATOR METHOD. (SEE LIGHT ET AL. J. CHEM. PHYS. 69 3518 1978)
C THIS VERSION USES A CONSTANT STEP SIZE DR FOR R < RMID, AND
C DR*R/RMID FOR R > RMID. THE CONSTANT-STEP METHOD IS RECOMMENDED BY
C ANDERSON, J.CHEM.PHYS. 77,4431(1982).
C VTOL IS A TOLERANCE PARAMETER FOR THE LARGEST OFF-DIAGONAL
C ELEMENT OF THE TRANSFORMATION MATRIX, USED TO DECIDE WHEN TO
C STOP INTEGRATING.
C FACT AND DRMAX ARE NOT USED IN THIS VERSION.
C
C ISTART IS 0 IF THE R-MATRIX IS TO BE INITIALISED
C 1 IF THE R-MATRIX (FROM L2 CALC) IS ALREADY IN R
C
C ----------------------------------------------------------------
C SET UP TO USE UNIT (ISCRU)
IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0
IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0
C ---------------------------------------------------------------
C
N=NBAS
NSQ=NSQBAS
GOTTP=.FALSE.
IF(XEPS.LE.0.D0 .OR. ISCRU.LE.0) GOTO 100
IF (IVLFL.NE.0) THEN
IF(IWRITE) WRITE(ISCRU) JJ,L,EINT,CENT,VL,IV
IF(IREAD) READ (ISCRU) JJ,L,EINT,CENT,VL,IV
ELSE
IF(IWRITE) WRITE(ISCRU) JJ,L,EINT,CENT,VL
IF(IREAD) READ (ISCRU) JJ,L,EINT,CENT,VL
ENDIF
C
C COUNT NUMBER OF OPEN CHANNELS AND SET UP WVEC ARRAY.
C
100 NOPEN=0
DO 110 I=1,N
DIF=ERED-EINT(I)
WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF)
IF(DIF.LE.0.D0) GOTO 110
NOPEN=NOPEN+1
110 CONTINUE
C
C IF THERE ARE NO OPEN CHANNELS RETURN
C
IF(NOPEN.EQ.0) RETURN
NOPSQ=NOPEN*NOPEN
C
C SORT CHANNELS BY ASYMPTOTIC ENERGY
C
DO 120 I=1,N
CLOSE(I)=0.D0
120 NB(I)=I
IF(N.LE.1) GOTO 140
NM1=N-1
DO 130 I=1,NM1
IP1=I+1
DO 130 J=IP1,N
IF(EINT(NB(I)).LE.EINT(NB(J))) GOTO 130
IT=NB(I)
NB(I)=NB(J)
NB(J)=IT
130 CONTINUE
140 CONTINUE
C
C ICODE=1/2 MEANS PROPAGATION ISN'T/IS TO BE DONE WITH STORED DATA
C
IF(ICODE.EQ.1 .AND. PRINT.GE.2) WRITE(6,150) RMIN
150 FORMAT('0 START R-MATRIX PROPAGATOR AT RMIN =',F8.5)
IF(PRINT.GE.15 .AND. ICODE.EQ.1) WRITE(6,160)
160 FORMAT('0 KSTEP RNOW EIGVAL(1) EIGVAL(N)'/)
C
C CALCULATE R-MATRIX AT FIRST STEP.
C
IF(IREAD) GOTO 170
RNOW=RMIN
IF(ISTART.EQ.0) RNOW=RNOW+0.5D0*DR
DRNOW=DR
DRNEW=DRNOW
KSTP=1
CALL WAVMAT(W,NBAS,RNOW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
IFAIL=0
CALL F02ABF(W,NBAS,NBAS,EIGOLD,SI,NBAS,R1,IFAIL)
IF(ISCRU.LE.0) GOTO 190
WRITE(ISCRU) RNOW,DRNOW
WRITE(ISCRU) KSTP,EIGOLD
WRITE(ISCRU) DRNEW
GOTO 190
C
170 READ(ISCRU) RNOW,DRNOW
READ(ISCRU) KSTP,EIGOLD
READ(ISCRU) DRNEW
DO 180 I=1,N
EIGOLD(I)=EIGOLD(I)-ESHIFT
180 CONTINUE
C
190 IF(ISTART.NE.0) GOTO 220
C
C NO INITIAL R-MATRIX SUPPLIED. INITIALISE IT.
C
DO 200 I=1,NSQ
200 R(I)=0.D0
IND=-N
DO 210 I=1,N
IND=IND+N+1
R(IND)=1.D0/SQRT(ABS(EIGOLD(I)))
210 CONTINUE
GOTO 230
C
C TRANSFORM SUPPLIED R-MATRIX TO LOCAL BASIS
C
220 CALL TRNSFM(SI,R,Q,N,.FALSE.,.TRUE.)
C
230 ITRY=-1
DLAST=1.D36
C
C PROPAGATE R-MATRIX
C
DO 430 KSTEP=2,MAXSTP
NOLD=N
ROLD=RNOW
RNOW=RNOW+0.5D0*(DRNOW+DRNEW)
DRNOW=DRNEW
IF(.NOT.IREAD) GOTO 250
C
C IF ICODE = 2 READ EIGNOW AND Q MATRIX FROM DISK
C
READ(ISCRU) KSTP,EIGNOW,Q
DO 240 I=1,N
EIGNOW(I)=EIGNOW(I)-ESHIFT
240 CONTINUE
GOTO 290
C
C IF ICODE = 1 CALCULATE EIGNOW AND Q MATRIX
C
250 CALL WAVMAT(W,N,RNOW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
IF(XEPS.LE.0.D0 .OR. GOTTP) GOTO 270
C
C LOOK FOR TURNING POINT OR POTENTIAL MINIMUM IN LOWEST-LYING
C CHANNEL (WHICHEVER OCCURS AT SMALLEST R).
C SAVE INFORMATION FOR USE IN NEXT CALL TO RMSET.
C
IF(DIAG(IK).GT.0.D0.AND.DIAG(IK).LT.DLAST) GOTO 260
GOTTP=.TRUE.
RTURN=RNOW
260 DLAST=DIAG(IK)
C
270 IFAIL=0
CALL F02ABF(W,N,N,EIGNOW,SR,N,R1,IFAIL)
CALL SGNCHK(SI,SR,N)
CALL DGEMUL(SI,N,'T',SR,N,'N',Q,N,N,N,N)
IF(ISCRU.GT.0) WRITE(ISCRU) KSTEP,EIGNOW,Q
DO 280 I=1,NSQ
280 SI(I)=SR(I)
290 CONTINUE
C
C IF(KSTEP.GT.2) GOTO 213
C
C CALCULATE PROPAGATOR FOR R-MATRIX.
C
NOPLOC=0
DO 320 I=1,N
EIG=EIGNOW(I)
FLAM=SQRT(ABS(EIG))
IF(EIG.GE.0.D0) GOTO 300
R1(I) = -1.D0/(FLAM*TAN(DRNEW*FLAM))
R2(I) = -1.D0/(FLAM*SIN(DRNEW*FLAM))
NOPLOC=NOPLOC+1
GOTO 310
300 R1(I) = 1.D0/(FLAM*TANH(DRNEW*FLAM))
R2(I) = 1.D0/(FLAM*SINH(DRNEW*FLAM))
IF(RNOW.GT.1.5D0*RTURN) CLOSE(I)=CLOSE(I)+DRNEW*FLAM
310 R3(I) = R2(I)
R4(I) = R1(I)
320 CONTINUE
C
CALL TRNSFM(Q,R,SR,N,.FALSE.,.TRUE.)
C
IND=-N
DO 330 I=1,N
IND=IND+N+1
R(IND)=R(IND)+R1(I)
330 CONTINUE
CALL SYMINV(R,N,N,IFAIL)
IF(IFAIL.GT.N) GOTO 480
CALL DSYFIL('U',N,R,N)
IND=0
DO 340 IC=1,N
DO 340 IR=1,N
IND=IND+1
R(IND)=-R3(IR)*R(IND)*R2(IC)
340 CONTINUE
IND=-N
DO 350 I=1,N
IND=IND+N+1
R(IND)=R(IND)+R4(I)
350 CONTINUE
IF(IREAD) GOTO 400
C
C IF ICODE=1 COMPUTE NEW STEP SIZE AND TEST FOR END OF PROPAGATION.
C
DRNEW=DR*RNOW/RMID
IF(DRNEW.LT.DR) DRNEW=DR
C
DO 360 I=1,N
EIGOLD(I)=EIGNOW(I)
360 CONTINUE
C
C SEE IF OFF-DIAG ELEMENTS OF SI ARE SMALL ENOUGH.
C
CALL COLIM(SI,R1,R2,VTOL,N)
CALL STRY(R1,R2,N,ITRY,EIGOLD)
IF(ITRY.NE.1) GOTO 380
RUP=RNOW+DRNOW/2.D0
IF(RUP.GE.RMAX .AND. NOPLOC.GE.NOPEN) GOTO 370
ITRY=0
GOTO 380
370 IF(ISCRU.LE.0) GOTO 450
DRNEW=-9999.D0
WRITE(ISCRU) DRNEW
WRITE(ISCRU) SI
GOTO 450
380 IF(ISCRU.GT.0) WRITE(ISCRU) DRNEW
EIG1=(ERED+EIGOLD(1))/RMLMDA
EIGN=(ERED+EIGOLD(N))/RMLMDA
IF(PRINT.GE.15) WRITE(6,390) KSTEP,RNOW,EIG1,EIGN
390 FORMAT(1X,I7,F11.5,2(1PD16.6))
GOTO 410
C
C IF ICODE=2 READ NEW STEP SIZE FROM DISK
C
400 READ(ISCRU) DRNEW
IF(DRNEW.NE.-9999.D0) GOTO 410
READ(ISCRU) SI
GOTO 450
C
410 CNTRCT=XEPS.GT.0.D0 .AND. N.GT.NOPMAX .AND. CLOSE(N).GT.DEEP
IF(IWRITE) WRITE(ISCRU) CLOSE,CNTRCT
IF(IREAD) READ (ISCRU) CLOSE,CNTRCT
IF (CNTRCT)
1 CALL SHRINK(ICODE,RNOW,W,N,VL,IV,NB,JJ,L,EINT,CENT,WVEC,
2 CLOSE,SI,EIGOLD,R,SR,DEEP,NSQ,NPOTL,ISCRU,NOPMAX,PRINT)
430 CONTINUE
C
C END OF R-MATRIX PROPAGATION LOOP
C
WRITE(6,440)
440 FORMAT('0***** ERROR IN RMTPRP - LIMIT OF',I7,'STEPS REACHED.',
1 ' RUN HALTED.')
STOP
C
C REACH HERE WHEN ASYMPTOTIC REGION IS REACHED
C
450 CALL TRNSP(SI,N)
CALL TRNSFM(SI,R,SR,N,.FALSE.,.TRUE.)
C
RUP=RNOW+DRNOW/2.D0
IF(ICODE.EQ.1 .AND. PRINT.GE.2)
1 WRITE(6,460) RUP,KSTEP
460 FORMAT(' FINISHED AT RUP =',F10.5,' AFTER',I7,' STEPS')
IF(ICODE.NE.1 .AND. PRINT.GE.5) WRITE(6,470)
470 FORMAT('0 R-MATRIX PROPAGATION COMPLETED USING STORED DATA')
C
CALL SYMINV(R,N,N,IFAIL)
IF(IFAIL.GT.N) GOTO 480
CALL YTOK(NB,WVEC,L,N,NOPEN,R1,R2,R3,R4,R,SR,Q,RUP)
CALL KTOS(Q,SR,SI,NOPEN)
RETURN
C
480 WRITE(6,490)
490 FORMAT('0***** ERROR IN SYMINV CALLED FROM RMTPRP.',
1 ' RUN HALTED.')
STOP
END
SUBROUTINE RSYM(NN,R,STEST,PRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER PRINT
DIMENSION R(NN,NN)
IF (NN.LE.1) RETURN
NERR=0
XX=0.D0
TEST=MAX(STEST,5.D-7)
DO 1200 I=2,NN
IM1=I-1
DO 1200 J=1,IM1
SUM=R(I,J)+R(J,I)
ASUM=ABS(SUM)
ADIF=ABS(R(I,J)-R(J,I))
IF (ASUM.LE.TEST) GO TO 1100
RAT=ADIF
IF (ASUM.GE.2.D0) RAT=RAT/ASUM
IF (RAT.LE.TEST) GO TO 1100
XX=MAX(XX,RAT)
NERR=NERR+1
1100 SUM=.5D0*SUM
R(I,J)=SUM
1200 R(J,I)=SUM
IF (NERR.LE.0) RETURN
NO=NN*(NN-1)/2
IF(PRINT.GE.4) WRITE(6,601) NERR,NO,TEST,XX
601 FORMAT(I6,' OF',I4,' OFF-DIAGONAL ELEMENTS OF ',
& 'K-MATRIX NOT SYMMETRIC WITH RESPECT TO TEST =',2D12.4)
RETURN
END
FUNCTION RSYMTP(J1,K1,J2,J1P,K1P,J2P,JJ,JJP,MU,P1,Q1,P2,PP)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER P1,Q1,P2,PP
DATA Z0/0.D0/, PI/3.14159265358979289D0/
C STATEMENT FUNCTION . . .
Z(X)=2.D0*X+1.D0
C
XJ1 = J1
XK1 = K1
XJ2 = J2
XJ1P = J1P
XK1P = K1P
XJ2P = J2P
XJJ = JJ
XJJP = JJP
XMU = MU
XQ1 = Q1
XP1 = P1
XP2 = P2
XPP = PP
RSYMTP=0.D0
F=THRJ(XJ1,XP1,XJ1P,-XK1,XQ1,XK1P)
IF (ABS(F) .LE. 1.D-8) RETURN
F=F*THRJ(XJJ,XPP,XJJP,XMU,Z0,-XMU)
IF (ABS(F) .LE. 1.D-8) RETURN
F = F*THREEJ(J2,P2,J2P)
IF(ABS(F) .LE. 1.D-8) RETURN
F = F*XNINEJ(JJ,PP,JJP,J1,P1,J1P,J2,P2,J2P)
IF(ABS(F) .LE. 1.D-8) RETURN
RSYMTP=F*SQRT(Z(XJ1)*Z(XJ1P)*Z(XJ2)*Z(XJ2P)*Z(XPP)*Z(XP2)
1 *Z(XJJ)*Z(XJJP))*PARITY3(J1P+J2P+JJ+MU-K1)/(4.0D0*PI)
RETURN
END
* ----------------------------------------------------------------------
SUBROUTINE SCAIRY (Z, SCAI, SCBI, SCAIP, SCBIP, ZETA)
* SCALED AIRY FUNCTIONS AND DERIVATIVES
* THIS PROGRAM WRITTEN BY D.E. MANOLOPOULOS (SEPT. 1986)
* CURRENT REVISION DATE: SEPT-1986
* ----------------------------------------------------------------
* FOR Z .LT. (-5.0D0)
* AI(Z) = SCAI*COS(ZETA) + SCBI*SIN(ZETA)
* BI(Z) = SCBI*COS(ZETA) - SCAI*SIN(ZETA)
* AI'(Z) = SCAIP*COS(ZETA) + SCBIP*SIN(ZETA)
* BI'(Z) = SCBIP*COS(ZETA) - SCAIP*SIN(ZETA)
* WHERE ZETA = (2/3)*(-Z)**(3/2) + PI/4
* FOR (-5.0D0) .LE. Z .LE. (+0.0D0)
* AI(Z) = SCAI
* BI(Z) = SCBI
* AI'(Z) = SCAIP
* BI'(Z) = SCBIP
* AND ZETA = 0
* FOR (+0.0D0) .LT. Z
* AI(Z) = SCAI*EXP(-ZETA)
* BI(Z) = SCBI*EXP(+ZETA)
* AI'(Z) = SCAIP*EXP(-ZETA)
* BI'(Z) = SCBIP*EXP(+ZETA)
* WHERE ZETA = (2/3)*(+Z)**(3/2)
* ----------------------------------------------------------------
* EVALUATION OF THE FUNCTIONS IS BASED ON A NUMBER OF
* CHEBYSHEV EXPANSIONS
*
* THIS VERSION IS SUITABLE FOR MACHINES WITH FULL WORD PRECISION
* ----------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DOUBLE PRECISION A, B, C, C1, C2, DF, DG, EX, EXP1Z, EXP2Z, F,
: G, PIB4, ROOT4Z, ROOTZ, RT3, SCAI, SCAIP, SCBI,
: SCBIP, T, T2, XEPS, Y, Z, ZCUBE, ZETA, ZSQ
DATA C1 / 3.55028053887817239D-01 /
DATA C2 / 2.58819403792806798D-01 /
DATA RT3 / 1.73205080756887729D+00 /
DATA PIB4 / 7.85398163397448310D-01 /
ZETA = 0.0D0
XEPS = 0.0D0
* ----------------------------------------------------------------------
* HERE IF NEAR ENOUGH ORIGIN TO USE 3 TERM POWER SERIES
IF ( ABS(Z) .LE. 0.025D0) THEN
ZSQ = Z * Z
ZCUBE = ZSQ * Z
* EVALUATE POWER SERIES ( THREE TERMS IS SUFFICIENT FOR ABS(X) < 0.025)
DF = 1.D0 + ZCUBE / 6.D0 + ZCUBE * ZCUBE / 180.D0
DG = Z * (1.D0 + ZCUBE / 12.D0 + ZCUBE * ZCUBE / 504.D0)
SCAI = C1 * DF - C2 * DG
SCBI = RT3 * (C1 * DF + C2 * DG)
* NOW FOR DERIVATIVES
DF = ZSQ / 2.D0 + ZSQ * ZCUBE / 30.D0
DG = 1.D0 + ZCUBE / 3.D0 + ZCUBE * ZCUBE / 72.D0
SCAIP = C1 * DF - C2 * DG
SCBIP = RT3 * (C1 * DF + C2 * DG)
* SCALE THE FUNCTIONS BY EXP(ZETA) IF Z .GT. 0
IF (Z .GT. 0.D0) THEN
ROOTZ = SQRT(Z)
ZETA = 2.0D0 * Z * ROOTZ / 3.0D0
EX = EXP(ZETA)
SCAI = SCAI * EX
SCAIP = SCAIP * EX
SCBI = SCBI / EX
SCBIP = SCBIP / EX
END IF
RETURN
END IF
IF (Z.LT.(+9.0D0)) GO TO 10
ROOTZ = SQRT(Z)
ROOT4Z = SQRT(ROOTZ)
ZETA = 2.0D0*Z*ROOTZ/3.0D0
T = 36.0D0/ZETA - 1.0D0
Y = ((((((((( +1.16537795324979200D-15*T
* -1.16414171455572480D-14)*T +1.25420655508401920D-13)*T
* -1.55860414100340659D-12)*T +2.21045776110011276D-11)*T
* -3.67472827517194031D-10)*T +7.44830865396606612D-09)*T
* -1.95743559326380581D-07)*T +7.44672431969805149D-06)*T
* -5.28651881409929932D-04)*T +2.81558489585006298D-01
SCAI = Y/ROOT4Z
Y = ((((((((((( +4.50165999254528000D-15*T
* +1.56232018374502400D-14)*T +5.26240712559918080D-14)*T
* +2.97814898856618752D-13)*T +1.97577620975625677D-12)*T
* +1.53678944110742706D-11)*T +1.45409933537455235D-10)*T
* +1.71547326972380087D-09)*T +2.61898617129147064D-08)*T
* +5.49497993491833009D-07)*T +1.76719804365109334D-05)*T
* +1.12212109935874117D-03)*T +5.65294557558522063D-01
SCBI = Y/ROOT4Z
Y = ((((((((( +1.20954638924697600D-15*T
* -1.21281218539020800D-14)*T +1.31303723724964224D-13)*T
* -1.64152781754533677D-12)*T +2.34672185025709461D-11)*T
* -3.94507329122119338D-10)*T +8.13125005420910243D-09)*T
* -2.19736365932356533D-07)*T +8.83993515227257822D-06)*T
* -7.43456339972080231D-04)*T -2.82847316336379200D-01
SCAIP = Y*ROOT4Z
Y = ((((((((((( -4.59170437029478400D-15*T
* -1.59840960512122880D-14)*T -5.41258863340784640D-14)*T
* -3.07414589507261184D-13)*T -2.04866616770522650D-12)*T
* -1.60321415915690897D-11)*T -1.52922073861488292D-10)*T
* -1.82445639488695332D-09)*T -2.83250890588806503D-08)*T
* -6.11130377639012647D-07)*T -2.07842147963678572D-05)*T
* -1.56350017663858255D-03)*T +5.62646283094843014D-01
SCBIP = Y*ROOT4Z
RETURN
10 IF (Z.LT.(+4.5D0)) GO TO 20
ROOTZ = SQRT(Z)
ZETA = 2.0D0*Z*ROOTZ/3.0D0
EXP1Z = EXP(ZETA-2.5D0*Z)
EXP2Z = EXP(ZETA-2.625D0*Z)
T = 4.0D0*Z/9.0D0 - 3.0D0
Y = ((((((((((((((((((((( +9.69081960415394529D-11*T
* +3.24436136050920784D-10)*T -3.57419513430644674D-09)*T
* -3.84461320827974687D-09)*T +8.88116699085949212D-08)*T
* -6.26105174374717557D-08)*T -1.69051051004298110D-06)*T
* +3.80731416363041759D-06)*T +2.43840529113057777D-05)*T
* -9.74379632673654766D-05)*T -2.45324254437931970D-04)*T
* +1.69517926953312785D-03)*T +1.19638433540225211D-03)*T
* -2.15255594590357451D-02)*T +9.33777073522844198D-03)*T
* +1.98716159257796883D-01)*T -2.54001858882057718D-01)*T
* -1.27148775197878180D+00)*T +2.52046376168394778D+00)*T
* +5.04987271423387057D+00)*T -1.33120978544419281D+01)*T
* -9.34903846550381088D+00)*T +3.10330812950257837D+01
SCAI = Y*EXP1Z
Y = (((((((((((((((((((((((( +3.79210935744593920D-14*T
* -4.16346635040194560D-14)*T -3.63110681886588928D-13)*T
* +1.38932592029414195D-12)*T -4.00489068810888806D-12)*T
* +1.39019501834951721D-11)*T -4.50877182237241508D-11)*T
* +1.38942309844733264D-10)*T -3.92503498108710093D-10)*T
* +1.20125005161756928D-09)*T -3.14234550677825531D-09)*T
* +1.03100587323694771D-08)*T -2.35240060783126760D-08)*T
* +8.98525670958611253D-08)*T -1.57273011181242048D-07)*T
* +7.77696763289738864D-07)*T -8.40211181188135235D-07)*T
* +6.34887361301864569D-06)*T -2.73464023289055762D-06)*T
* +4.54606729925166230D-05)*T +2.20459155042947089D-06)*T
* +2.58823388957588056D-04)*T +7.31023768389466446D-05)*T
* +1.01013806904596356D-03)*T +2.64794416332118755D-04)*T
* +1.97499785553709145D-03
SCBI = Y/EXP1Z
Y = ((((((((((((((((((((( -4.40679918437492851D-10*T
* +1.30954945449348301D-10)*T +1.30052079376596751D-08)*T
* -2.21315827945437064D-08)*T -2.56850909380644963D-07)*T
* +8.66960855365698346D-07)*T +3.75622307499741911D-06)*T
* -2.15396233361107222D-05)*T -3.55804094667597110D-05)*T
* +3.95317852914037711D-04)*T +5.03369361986934094D-05)*T
* -5.54634417403436820D-03)*T +5.29658186908372832D-03)*T
* +5.91311623537658225D-02)*T -1.09446664596286554D-01)*T
* -4.63589435529194219D-01)*T +1.25323269822030972D+00)*T
* +2.50138108959469254D+00)*T -9.12668774193995449D+00)*T
* -8.14385732036876466D+00)*T +4.00134082550833019D+01)*T
* +1.15396202931444799D+01)*T -8.17378314444550419D+01
SCAIP = Y*EXP1Z
Y = (((((((((((((((((((((((( -1.12976379481423872D-13*T
* +2.84163275199873024D-13)*T +9.21367859618119680D-14)*T
* -6.47465116933029888D-13)*T +5.66210442158931968D-13)*T
* -3.03158042458901709D-12)*T +1.32640217809876419D-11)*T
* -3.03558223041639219D-11)*T +5.32290407073565901D-11)*T
* +1.67561690905544950D-11)*T -3.35234276365918044D-10)*T
* +2.92807773020050397D-09)*T -8.76900994127464369D-09)*T
* +4.69138029321003869D-08)*T -1.00929917942876779D-07)*T
* +5.40401934648687824D-07)*T -8.19977129258456927D-07)*T
* +5.13367651438974580D-06)*T -4.77800617725922708D-06)*T
* +4.02415391117897098D-05)*T -1.74571192912274417D-05)*T
* +2.45332091645215217D-04)*T -2.22916383050374016D-05)*T
* +1.02535993549737948D-03)*T +5.94033287658300975D-05)*T
* +2.17420627539345627D-03
SCBIP = Y/EXP2Z
RETURN
20 IF (Z.LE.(+0.0D0)) GO TO 40
ROOTZ = SQRT(Z)
ZETA = 2.0D0*Z*ROOTZ/3.0D0
EXP1Z = EXP(ZETA-1.5D0*Z)
EXP2Z = EXP(ZETA-1.375D0*Z)
T = 4.0D0*Z/9.0D0 - 1.0D0
IF (Z.LT.(+XEPS)) GO TO 30
Y = ((((((((((((((((((((((( +4.97635854909020570D-12*T
* -3.25024150273916928D-11)*T -5.15773946723072737D-11)*T
* +8.66802872160017711D-10)*T -9.51292671519803048D-10)*T
* -1.33268133924677102D-08)*T +4.37061406144179625D-08)*T
* +1.18943714086308365D-07)*T -8.66980482244589319D-07)*T
* -2.46768077494905499D-08)*T +1.10610939830483627D-05)*T
* -1.80475663535516462D-05)*T -9.22213518989192294D-05)*T
* +3.15767712665407001D-04)*T +4.08626419412850994D-04)*T
* -3.12704269924340764D-03)*T +6.27899244118607949D-04)*T
* +1.99062142478229001D-02)*T -2.27427058211322122D-02)*T
* -7.94869698136278246D-02)*T +1.54261999158247445D-01)*T
* +1.75618463128730757D-01)*T -5.05223670654169859D-01)*T
* -1.49695902416050331D-01)*T +6.91290454439828966D-01
SCAI = Y*EXP1Z
Y = (((((((((((((((((((((((((((-8.01144609907912212D-11*T
* +2.67566208080291037D-10)*T +1.74416971406971503D-10)*T
* -3.12642164666800066D-09)*T +1.22114569059570056D-08)*T
* -2.93647730218878800D-08)*T +1.76951994785830839D-08)*T
* +2.13143266932123830D-07)*T -1.15569603602267288D-06)*T
* +3.34394065752949896D-06)*T -5.20143492253259528D-06)*T
* -3.21937890029830155D-06)*T +5.00360593064643409D-05)*T
* -1.77449408434194908D-04)*T +3.86357389967150628D-04)*T
* -4.53337922165622921D-04)*T -2.60866378774883161D-04)*T
* +3.01355585350049504D-03)*T -8.39047077309199055D-03)*T
* +1.63240267627966090D-02)*T -1.90830727084112485D-02)*T
* +1.65592661387959142D-02)*T +1.76101803014184860D-02)*T
* -3.36652019472526494D-02)*T +1.23831258886916327D-01)*T
* -6.48342330363017516D-02)*T +2.20310550882807725D-01)*T
* -1.03883014957365224D-02)*T +2.06857611342460346D-01
SCBI = Y/EXP2Z
30 Y = ((((((((((((((((((((((( -2.31635825886515692D-11*T
* +8.43840142802870600D-11)*T +3.68028065271203758D-10)*T
* -2.61043232825754937D-09)*T -4.65110871930215858D-10)*T
* +4.46164842334855713D-08)*T -9.24599436690579710D-08)*T
* -4.55809882095931368D-07)*T +2.21024501804834447D-06)*T
* +1.50251398952558802D-06)*T -2.91830008657289876D-05)*T
* +3.51391100964982453D-05)*T +2.37966767002002741D-04)*T
* -7.00969870295148024D-04)*T -9.84923358717942729D-04)*T
* +6.68935321740601810D-03)*T -1.66398286740112083D-03)*T
* -3.83618654865390504D-02)*T +4.80463615092658847D-02)*T
* +1.28359791076466449D-01)*T -2.80267155846714091D-01)*T
* -2.06049815358004057D-01)*T +7.63522843530878467D-01)*T
* +6.47699892977822355D-02)*T -8.32940737409625965D-01
SCAIP = Y*EXP2Z
Y = (((((((((((((((((((((((((((+2.69330665471830131D-10*T
* -1.25313111217921013D-09)*T +1.45057587508619405D-09)*T
* +5.82827351134571594D-09)*T -3.96093412314305685D-08)*T
* +1.37346521367521144D-07)*T -2.78927594518121271D-07)*T
* +2.96531845420687661D-08)*T +2.27734981888044076D-06)*T
* -1.02295902888535994D-05)*T +2.65515218319523965D-05)*T
* -3.86457370206378782D-05)*T -1.52212232476268640D-05)*T
* +2.84765225803690646D-04)*T -9.65798046252914453D-04)*T
* +2.04618065580453522D-03)*T -2.68702422147972510D-03)*T
* +8.36839039610090712D-04)*T +6.87131161447866570D-03)*T
* -2.10563741100004648D-02)*T +4.13290131622517073D-02)*T
* -5.03310394511775398D-02)*T +5.95467795825179773D-02)*T
* -1.64213101223235839D-02)*T +5.02536006477020710D-02)*T
* +5.75601787687195966D-02)*T +1.33220031651076020D-01)*T
* +7.76356357899154668D-02)*T +2.11213324176049168D-01
SCBIP = Y/EXP1Z
RETURN
40 IF (Z.LT.(-5.0D0)) GO TO 60
T = Z/5.0D0
T = -T*T*T
T = 2.0D0*T - 1.0D0
T2 = 2.0D0*T
IF (Z.GT.(-XEPS)) GO TO 50
A = +1.63586492025000000D-18
B = T2*A -1.14937368283025000D-16
C = T2*B-A +7.06090635856696000D-15
A = T2*C-B -3.75504581033290114D-13
B = T2*A-C +1.70874975807662448D-11
C = T2*B-A -6.56273599013291800D-10
A = T2*C-B +2.09250023300659871D-08
B = T2*A-C -5.42780372893997236D-07
C = T2*B-A +1.11655763472468469D-05
A = T2*C-B -1.76193215080912647D-04
B = T2*A-C +2.03792657403144947D-03
C = T2*B-A -1.61616260941907957D-02
A = T2*C-B +7.87369695059018748D-02
B = T2*A-C -1.88090320218915726D-01
C = T2*B-A +8.83593328666433903D-02
A = T2*C-B +9.46330439565858235D-02
F = T*A-C +7.60869994141726643D-02
A = +1.23340698467000000D-19
B = T2*A -9.05440546731800000D-18
C = T2*B-A +5.83052348377146000D-16
A = T2*C-B -3.26253073273305810D-14
B = T2*A-C +1.56911825099665634D-12
C = T2*B-A -6.40386375393414830D-11
A = T2*C-B +2.18414557202733054D-09
B = T2*A-C -6.11127835033401880D-08
C = T2*B-A +1.37095478225289560D-06
A = T2*C-B -2.39464595313812449D-05
B = T2*A-C +3.13306256975299299D-04
C = T2*B-A -2.90953380590207648D-03
A = T2*C-B +1.76972907074092250D-02
B = T2*A-C -6.17055677164122241D-02
C = T2*B-A +9.52472833367213949D-02
A = T2*C-B -4.32381694223484894D-02
G = T*A-C +3.76828717701544063D-02
SCAI = F - G*Z
SCBI = RT3*(F + G*Z)
50 A = -2.51308436743000000D-18
B = T2*A +1.65543326242034000D-16
C = T2*B-A -9.49237123028142500D-15
A = T2*C-B +4.68795260455788096D-13
B = T2*A-C -1.96942895842729954D-11
C = T2*B-A +6.93493715818491929D-10
A = T2*C-B -2.01076965264476206D-08
B = T2*A-C +4.69655735896232104D-07
C = T2*B-A -8.59527033121202608D-06
A = T2*C-B +1.18871496270269531D-04
B = T2*A-C -1.18244097697332692D-03
C = T2*B-A +7.87645202148185146D-03
A = T2*C-B -3.14174372672396468D-02
B = T2*A-C +6.20464642445295805D-02
C = T2*B-A -4.83824291776351778D-02
F = T*C-B +2.64808460123486707D-02
A = +5.89382778069400000D-18
B = T2*A -4.04811810887971000D-16
C = T2*B-A +2.42680453287673090D-14
A = T2*C-B -1.25683910148099294D-12
B = T2*A-C +5.55607745069567295D-11
C = T2*B-A -2.06683376304577072D-09
A = T2*C-B +6.35924425685425485D-08
B = T2*A-C -1.58422527393619013D-06
C = T2*B-A +3.11007119112993551D-05
A = T2*C-B -4.64189437787271433D-04
B = T2*A-C +5.00970025411579034D-03
C = T2*B-A -3.62166342717373453D-02
A = T2*C-B +1.53114671641953510D-01
B = T2*A-C -2.69270807740667256D-01
C = T2*B-A -9.61843661149152853D-02
A = T2*C-B +2.07099372879297732D-01
G = T*A-C +9.79943887874547828D-02
SCAIP = Z*Z*F - G
SCBIP = RT3*(Z*Z*F + G)
RETURN
60 ROOTZ = SQRT(-Z)
ROOT4Z = -SQRT(ROOTZ)
ZETA = 2.0D0*(-Z)*ROOTZ/3.0D0
T = -250.0D0/(Z*Z*Z) - 1.0D0
A = ((((((((((((( -4.50071772808806400D-15*T
* +1.11777933477806080D-14)*T -1.39959545848483840D-14)*T
* +4.93110187870320640D-14)*T -2.02193307034590720D-13)*T
* +7.53585452663569920D-13)*T -3.14632365928501299D-12)*T
* +1.52351450024952975D-11)*T -8.75801572233507014D-11)*T
* +6.27349413509555121D-10)*T -6.02183526555303242D-09)*T
* +8.70043536788235270D-08)*T -2.32935044050984079D-06)*T
* +1.83605337367638430D-04)*T -5.64003555099413391D-01
SCBI = A/ROOT4Z
B = (((((((((((((((( -4.12972759036723200D-15*T
* +8.36512465551360000D-15)*T -2.05945081774080000D-16)*T
* +6.23733840790323200D-15)*T -5.81333983959859200D-14)*T
* +1.52893566095288320D-13)*T -4.11064788026333184D-13)*T
* +1.33820884559538637D-12)*T -4.74293914921785574D-12)*T
* +1.84868021228605050D-11)*T -8.15686769476673166D-11)*T
* +4.19373390376196942D-10)*T -2.61584084406303574D-09)*T
* +2.10021454539364698D-08)*T -2.37847770210509358D-07)*T
* +4.43114636962516363D-06)*T -1.83241371436579068D-04)*T
* +3.89918976811026487D-02
SCAI = (B/ZETA)/ROOT4Z
A = ((((((((((((( -4.58484390222233600D-15*T
* +1.13969221615738880D-14)*T -1.43160328250060800D-14)*T
* +5.04734978526300160D-14)*T -2.07055957015081472D-13)*T
* +7.73043520694004480D-13)*T -3.23454581960357018D-12)*T
* +1.57043540332660220D-11)*T -9.06023827679991573D-11)*T
* +6.52303613917050367D-10)*T -6.30993998756281944D-09)*T
* +9.23711460831703303D-08)*T -2.54030284953639173D-06)*T
* +2.17448385781448409D-04)*T +5.64409671680379110D-01
SCAIP = A*ROOT4Z
B = (((((((((((((((( +4.19612197958451200D-15*T
* -8.50454708509081600D-15)*T +2.31421341122560000D-16)*T
* -6.39683104557465600D-15)*T +5.92509321833062400D-14)*T
* -1.56008660983891968D-13)*T +4.20106807813331968D-13)*T
* -1.36926896339755520D-12)*T +4.86000800286762854D-12)*T
* -1.89780061819570625D-11)*T +8.39314701970122041D-11)*T
* -4.32843814802265754D-10)*T +2.71124934991469715D-09)*T
* -2.19026888712002973D-08)*T +2.50504395196083566D-07)*T
* -4.75245434337472120D-06)*T +2.05252791097940732D-04)*T
* -5.46414841607309762D-02
SCBIP = (B/ZETA)*ROOT4Z
ZETA = ZETA + PIB4
RETURN
END
SUBROUTINE SET4(NLEV,JLEV,ATAU,EFACT,IUNIT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C THIS ROUTINE SETS UP BASIS FOR ITYPE=4.
C LINEAR RIGID ROTOR + ASYMMETRIC RIGID ROTOR SCATTERING.
C INITIAL ROUTINE WRITTEN BY T.R. PHILLIPS, GISS, AUGUST 1990
C DERIVED FROM ROUTINES SET6 AND SET3.
C EXTENSIVELY REVISED FOR MOLSCAT VERSION 12 BY TRP (JUL 93)
C CURRENT CODE ENTIRELY REWRITTEN (VERSION 14) BY S GREEN (5 AUG 94)
C
C IMPLEMENTS THREE METHODS TO INPUT BASIS:
C 1) A,B,C .GT. 0 SPECIFIED; GENERATE ASYM TOP FNS VIA SET6C ROUTINE
C 2) NLEVEL.GT.0 SPECIFIED; READ ASYM TOP FNS FROM IUNIT=IASYMU
C -- FOR BOTH 1 & 2, EXPAND WITH J2=J2MIN,J2MAX,J2STEP; LINEAR
C ROTOR ENERGIES MUST BE CALCULABLE FROM BE(2); SCREEN ON EMAX
C 3) NLEVEL.LT.0 SPECIFIED; READ ASYM TOP FNS FROM IUNIT=IASYMU
C FILTERING ON JLEVEL(3*I-1),JLEVEL(3*I)=J1,ITAU; J2=JLEVEL(3*I);
C LEVEL ENERGIES MAY BE SPECIFIED IN ELEVEL, OTHERWISE CALC'D
C
DIMENSION JLEV(2),ATAU(2)
C N.B. JLEV AND ATAU OCCUPY SAME STORAGE PASSED FROM DRIVER/BASIN
C ON ENTRY X(IXNEXT) SHOULD BE SAME AS ATAU(1)==JLEV(1)
C NOTE: NIPR NOT USED FOR JLEV STORAGE; THIS IS CONSERVATIVE
C IXNEXT MUST BE INCREMENTED TO REFLECT *ATAU* STORAGE USED.
C
LOGICAL EIN
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C CMBASE MADE COMPATIBLE WITH VERSION 14 (SG 2 AUG 94)
DIMENSION BE(2),ALPHAE(2),DE(2)
EQUIVALENCE (BE(1),AAE(1)), (ALPHAE(1),BBE(1)), (DE(1),CCE(1))
COMMON /CMBASE/ AAE(2),BBE(2),CCE(2),ROTI(6),ELEVEL(1000),EMAX,
1 WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10),
2 J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL
C
C DEFAULT UNIT IS STANDARD INPUT
DATA IDU/5/
C
C CHECK FOR CORRECT IV() FLAG IN INITIALIZATION ENTRY
IF (IVLFL.NE.0) THEN
WRITE(6,690) IVLFL
690 FORMAT(/' SET4 (JUL 93). ILLEGAL IVLFL =',I6)
STOP
ENDIF
C
IF (AAE(1).GT.0.D0.AND.BBE(1).GT.0.D0.AND.CCE(1).GT.0.D0)
1 GO TO 3000
C
C ASYMMETRIC TOP FUNCTIONS WILL BE INPUT FROM IUNIT; CHECK IT
WRITE(6,602) IUNIT
602 FORMAT(/' ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =',
1 I4)
IF (NLEVEL.GT.0) THEN
NREAD=NLEVEL
WRITE(6,603) NLEVEL
603 FORMAT(' NUMBER OF INPUT LEVELS SPECIFIED BY NLEVEL IS',I6)
ELSE
IF (IUNIT.EQ.IDU) THEN
WRITE(6,*) ' *** SET4. CANNOT READ FROM STD INPUT FOR',
1 ' NLEVEL.LE.0'
STOP
ENDIF
NREAD=1000000
WRITE(6,*) ' WILL INPUT LEVELS UNTIL END-OF-FILE'
ENDIF
C
IF (NLEVEL.LT.0) GO TO 7000
C
C BELOW IS 'CASE 2' -- RESULT SHOULD BE SAME AS FOR 'CASE 1'
C
C --- READ IN ASYMMETRIC RIGID ROTOR WAVEFUNCTIONS AND ENERGIES ---
C CODE BELOW FOLLOWS SET6 CODE
NLEV=0
IOFF=0
NKVAL=0
DO 2000 III=1,NREAD
READ(IUNIT,500,END=9000) JI,ITAU,EINP
500 FORMAT(2I5,F15.10)
NLEV=NLEV+1
JI=IABS(JI)
NK=2*JI+1
ELEVEL(NLEV)=EINP*EFACT
C SEE IF WE SHOULD SKIP ON JMIN,JMAX,JSTEP OR EMAX
IF (JMAX.LE.0) GO TO 2080
JDIF=JI-JMIN
JDIF=JDIF-JSTEP*(JDIF/JSTEP)
IF (JDIF.EQ.0 .AND. JI.GE.JMIN .AND. JI.LE.JMAX) GO TO 2080
WRITE(6,611) JI,ITAU,ELEVEL(NLEV),JMIN,JSTEP,JMAX
611 FORMAT(/' INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED. ',
1 'J NOT IN RANGE',I4,' (',I4,')',I4)
GO TO 2070
2080 IF (EMAX.LE.0.D0) GO TO 2090
IF (ELEVEL(NLEV).LE.EMAX) GO TO 2090
WRITE(6,612) JI,ITAU,ELEVEL(NLEV),EMAX
612 FORMAT(/' INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED ',
1 'DUE TO EMAX =',F11.3)
C REACH BELOW IF WE ARE SKIPPING THIS SET
2070 NLEV=NLEV-1
READ(IUNIT,501,END=9100) (ATAUX,I=1,NK)
GO TO 2000
C REACH BELOW IF WE ARE INCLUDING THIS SET
2090 CONTINUE
C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR NEW JLEV; NB. NIPR NOT USED
IOFF=IOFF+6
DO 2020 I=1,NKVAL
2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I)
INST=IOFF+NKVAL
READ(IUNIT,501,END=9100) (ATAU(INST+I),I=1,NK)
501 FORMAT(6F12.8)
C OUTPUT INFORMATION READ.
WRITE(6,614) NLEV,JI,ITAU,EINP,ELEVEL(NLEV)
614 FORMAT(/' INPUT LEVEL',I4,' J, TAU =',2I4,' ENERGY =',F15.5,
& ' = ',F15.5,' (1/CM)')
MJI=-JI
WRITE(6,615) (ATAU(INST+1+JI+I),I, I=MJI,JI)
615 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')')))
C GET PARITY CODE FROM ATAU SYMMETRIES. . .
IPAR=IPASYM(JI,NK,ATAU(INST+1))
C IPAR=-1 IS ERROR RETURN FROM IPASYM.
IF (IPAR.NE.-1) GO TO 2001
WRITE(6,*) ' *** SET4. TERMINAL ERROR.'
STOP
C REORDER JLEV TO RECEIVE NEW ROW.
2001 NRM1=NLEV-1
IF (NRM1.LE.0) GO TO 2100
IOLD=6*NRM1
IX=6*NLEV
DO 2110 II=1,6
IX=IX-1
DO 2120 I=1,NRM1
JLEV(IX)=JLEV(IOLD)
IX=IX-1
2120 IOLD=IOLD-1
2110 CONTINUE
2100 JLEV(NLEV)=JI
JLEV(2*NLEV)=ITAU
JLEV(3*NLEV)=IPAR
JLEV(4*NLEV)=NKVAL
JLEV(5*NLEV)=NK
JLEV(6*NLEV)=NLEV
NKVAL=NKVAL+NK
GO TO 2000
C
C * * * END OF FILE CONDITIONS * * *
9000 IF (NLEVEL.GT.0) GO TO 2200
WRITE(6,606) IUNIT,NLEV
606 FORMAT('0 END OF FILE ENCOUNTERED ON UNIT',I4,' AFTER',I5,
& ' FUNCTIONS.')
GO TO 2400
2200 WRITE(6,607) IUNIT,NLEV
607 FORMAT('0 PREMATURE E.O.F. ON UNIT',I4,'. NLEVEL REDUCED TO',I6)
GO TO 2400
9100 WRITE(6,608) IUNIT,NLEV
608 FORMAT('0 * * * ERROR. E.O.F. ON UNIT',I4,' BEFORE ATAU CARDS F
&OR NLEV =',I5)
WRITE(6,699)
699 FORMAT('0 * * * TERMINAL ERROR.')
STOP
2000 CONTINUE
C THIS COMPLETES READ(IASYMU) LOOP
C
C SET JLEVEL() (ITYPE=6 FORMAT); N.B. ELEVEL() ALREADY SET
2400 DO 2401 I=1,NLEV
JLEVEL(2*I-1)=JLEV(I)
2401 JLEVEL(2*I)=JLEV(I+NLEV)
C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . .
IF (IOFF.NE.6*NLEV) THEN
WRITE(6,698) IOFF, NLEV
698 FORMAT(' *** SET4. INDEXING ERROR. IOFF,NLEV =',2I6)
STOP
ENDIF
IX=3*NLEV+1
IXTOP=4*NLEV
DO 2410 I=IX,IXTOP
2410 JLEV(I)=JLEV(I)+IOFF
C INCREMENT IXNEXT FOR STORAGE TAKEN BY ATAU
IXNEXT=IXNEXT+NKVAL
C CHECK THAT FUNCTIONS ARE ORTHOGONAL
CALL CHECK6(NLEV,JLEV,ATAU)
GO TO 4000
C
C BELOW IS 'CASE 1', I.E. GENERATE BASIS VIA SET6C
3000 CALL SET6C(JLEV,ATAU,NLEV,.FALSE.)
C N.B. SET6C INCREMENTS IXNEXT FOR ATAU STORAGE
C IF VALID IASYMU IS GIVEN, OUTPUT ROTOR WFNS
IF (IUNIT.LE.0.OR.IUNIT.GE.100.OR.IUNIT.EQ.IDU) GO TO 4000
WRITE(6,*) ' *** SET4 WILL OUTPUT ROTOR WAVEFUNCTIONS TO UNIT',
1 IUNIT
WRITE(6,*) ' IN FORMAT FOR FUTURE INPUT'
DO 1011 I=1,NLEV
JI=JLEV(I)
ITAU=JLEV(NLEV+I)
ISTA=JLEV(3*NLEV+I)
NK=JLEV(4*NLEV+I)
INDX=JLEV(5*NLEV+I)
WRITE(IUNIT,500,ERR=1099) JI,ITAU,ELEVEL(INDX)
1011 WRITE(IUNIT,501,ERR=1099) (ATAU(ISTA+II),II=1,NK)
RETURN
1099 WRITE(6,*) ' *** SET4. ERROR WRITING TO IASYMU; WFNS NOT SAVED'
RETURN
C
C CALL J6TO4 TO EXPAND 'ITYPE=6' TO 'ITYPE=4' FORMAT
C SET UP WORKING STORAGE. IXNEXT ALREADY REFLECTS ATAU STORAGE
C N.B. JLEV STORAGE DOES *NOT* REFLECT NIPR; SHOULD BE CONSERVATIVE
4000 IOFF=6*NLEV
IXEL=IXNEXT+IOFF
IXJL=IXEL+MXEL
IXJNW=IXJL+MXJL
NAVAIL=MX-IXJNW
IF (NAVAIL.LT.8*NLEV) THEN
WRITE(6,*) ' *** SET4. INSUFFICIENT WORKING SPACE FOR J6TO4'
WRITE(6,*) ' IXNEXT,MX,NAVAIL =',IXNEXT,MX,NAVAIL
STOP
ENDIF
C J6TO4 EXPANDS ITYPE=6 DATA FORMAT WITH POSSIBLE J2 VALUES
C TO PRODUCE ITYPE=4 DATA FORMAT
CALL J6TO4(NLEV,JLEV,ATAU,X(IXJNW),NAVAIL,X(IXEL),X(IXJL))
RETURN
C
C CODE BELOW IS 'CASE 3' NLEVEL.LT.0; FILTER IASYMU INPUT ON JLEVEL
7000 NLEVEL=ABS(NLEVEL)
IF (NLEVEL.GT.MXEL) THEN
WRITE(6,*) ' *** SET4. REQUESTED NLEVEL.GT.MXEL'
STOP
ENDIF
WRITE(6,*) ' BASIS FUNCTIONS DETERMINED BY &BASIS JLEVEL()'
WRITE(6,*) ' NUMBER OF LEVELS (NLEVEL) =',NLEVEL
EIN=.FALSE.
DO 7001 I=1,NLEVEL
7001 EIN=EIN.AND.ELEVEL(I).GT.0.D0
IF (EIN) THEN
WRITE(6,*)
1 ' ENERGIES FOR BASIS FNS TAKEN FROM &BASIN ELEVEL VALUES'
ELSE
IF (BE(2).LE.0.D0) THEN
WRITE(6,*) ' *** SET4. CANNOT OBTAIN LINEAR ROTOR',
1 ' ENERGY FROM BE(2)'
STOP
ENDIF
WRITE(6,*) ' ASYMMETRIC TOP ENERGIES TAKEN FROM IASYMU'
WRITE(6,644) BE(2)
644 FORMAT(/' LINEAR ROTOR ENERGY LEVELS COMPUTED FROM B(E) =',
1 F12.8)
IF (ALPHAE(2).NE.0.D0) WRITE(6,645) ALPHAE(2)
645 FORMAT(27X,'CORRECTED FOR ALPHA(E) = ',F12.8)
IF (DE(2).NE.0.D0) WRITE(6,646) DE(2)
646 FORMAT(27X,'CORRECTED FOR D(E) = ',F12.8)
ENDIF
C BEGIN READ(IASYMU) LOOP
NLEV=0
IOFF=0
NKVAL=0
DO 7100 III=1,NREAD
READ(IUNIT,500,END=9200) JI,ITAU,EINP
NK=2*JI+1
EINX=EINP*EFACT
NMATCH=0
DO 7200 IND=1,NLEVEL
IF (JLEVEL(3*IND-2).NE.JI.OR.JLEVEL(3*IND-1).NE.ITAU) GO TO 7200
C WE'VE FOUND A MATCH ON JI, ITAU,
NMATCH=NMATCH+1
J2=JLEVEL(3*IND)
FJ=DBLE(J2)
FJ=FJ*(FJ+1.D0)
E2=(BE(2)-ALPHAE(2)*0.5D0)*FJ - DE(2)*FJ*FJ
IF (.NOT.EIN) ELEVEL(IND)=EINX+E2
C EXPAND JI WITH J2 TO J12 IN GENERATING NLEV,JLEV FROM THIS SET
J12MIN=ABS(JI-J2)
J12MAX=JI+J2
DO 7400 J12=J12MIN,J12MAX
NLEV=NLEV+1
C SHIFT ATAU BY 8 WORDS TO MAKE ROOM FOR INCOMING JLEV
IOFF=IOFF+8
DO 7220 I=1,NKVAL
7220 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-7-I)
C READ ATAU, BUT ONLY THE FIRST TIME WE USE THIS WAVEFUNCTION
IF (NMATCH.EQ.1) THEN
INST=IOFF+NKVAL
READ(IUNIT,501,END=9300) (ATAU(INST+I),I=1,NK)
C OUTPUT INFORMATION READ.
WRITE(6,651) JI,ITAU,EINP,EINX
651 FORMAT(/' INPUT LEVEL, J, TAU =',2I4,' ENERGY =',F12.4,
1 ' = ',F12.4,' (1/CM)')
MJI=-JI
WRITE(6,652) (ATAU(INST+1+JI+I),I,I=MJI,JI)
652 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')')))
C GET PARITY CODE FROM ATAU SYMMETRIES. . .
IPAR=IPASYM(JI,NK,ATAU(INST+1))
C IPAR=-1 IS ERROR RETURN FROM IPASYM.
IF (IPAR.EQ.-1) THEN
WRITE(6,*) ' *** SET4. ILEGAL SYMMETRY FOR INPUT WFN.'
STOP
ENDIF
ISTA=NKVAL
NKVAL=NKVAL+NK
ENDIF
C REORDER JLEV TO RECEIVE NEW ROW; ADAPTED FROM SET6 CODE.
NRM1=NLEV-1
IF (NRM1.LE.0) GO TO 7300
IOLD=8*NRM1
IX=8*NLEV
DO 7310 II=1,8
IX=IX-1
DO 7320 I=1,NRM1
JLEV(IX)=JLEV(IOLD)
IX=IX-1
7320 IOLD=IOLD-1
7310 CONTINUE
7300 JLEV(NLEV)=J12
JLEV(2*NLEV)=J2
JLEV(3*NLEV)=JI
JLEV(4*NLEV)=ITAU
JLEV(5*NLEV)=IPAR
JLEV(6*NLEV)=ISTA
JLEV(7*NLEV)=NK
JLEV(8*NLEV)=IND
7400 CONTINUE
C THIS ENDS J12 LOOP
7200 CONTINUE
C THIS ENDS LOOP OVER NLEVEL, JLEVEL() SETS.
C IF WE DID NOT USE THIS FUNCTION (NMATCH.EQ.0) SKIP ATAU CARDS
IF (NMATCH.LE.0) READ(IUNIT,501,END=9300) (ATAUX,I=1,NK)
GO TO 7100
C
C END OF FILE CONDITIONS
9300 WRITE(6,*) ' *** SET4. EOF ON IASYMU WHILE READING ATAU DATA'
STOP
9200 WRITE(6,*) ' *** SET4. NORMAL EOF ENCOUNTERED ON IASYMU'
GO TO 7500
C
7100 CONTINUE
C THIS ENDS LOOP OVER READ IASYMU
C
C CORRECT ISTA=JLEV(LEV,6) FOR SPACE TAKEN BY JLEV. . .
7500 IF (IOFF.NE.8*NLEV) THEN
WRITE(6,698) IOFF, NLEV
STOP
ENDIF
IX=5*NLEV+1
IXTOP=6*NLEV
DO 7505 I=IX,IXTOP
7505 JLEV(I)=JLEV(I)+IOFF
C
C NEED TO SET JMIN,JMAX FOR USE IN SELECTING ORBITAL L IN BASE
JMIN=JLEV(1)
JMAX=JMIN
DO 7510 I=1,NLEV
JMIN=MIN(JMIN,JLEV(I))
7510 JMAX=MAX(JMAX,JLEV(I))
C
C MAKE SURE THAT WE HAVE FOUND AN ASYMMETRIC ROTOR WFN FOR
C ALL NLEVEL JLEVEL() SETS. UNLIKE ITYPE=6, WE DO NOT REORDER
DO 7600 I=1,NLEVEL
DO 7601 IX=1,NLEV
IF (JLEV(7*NLEV+IX).EQ.IX) GO TO 7600
7601 CONTINUE
WRITE(6,660) I,JLEVEL(3*I-2),JLEVEL(3*I-1)
660 FORMAT(/' *** SET4. DID NOT FIND BASIS FUNCTIONS FOR LEVEL',I4/
1 ' JI,ITAU =',2I6)
STOP
7600 CONTINUE
C INCREMENT IXNEXT TO REFLECT ATAU STORAGE
IXNEXT=IXNEXT+NKVAL
RETURN
C
END
SUBROUTINE SET6(LEVIN,EIN,NLEV,JLEV,ATAU,EFACT,IUNIT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C REVISED FOR VERSION 14:
C THREE POSSIBLE METHODS OF SPECIFYING ASYMMETRIC TOP LEVELS
C 1. A,B,C .GT.0 IMPLIES GENERATE VIA SET6C
C 2. NLEVEL.GE.0 IMPLIES READ FROM IASYMU (FILTER ON JMIN,JMAX,
C JSTEP,EMAX); IF (NLEVEL.EQ.0) READ TO END-OF-FILE
C 3. NLEVEL.LT.0 IMPLIES READ FROM IASYMU BUT ACCEPT ONLY THOSE
C J,ITAU CORRESPONDING TO JLEVEL(2*I-1),JLEVEL(2*I),
C I=1,ABS(NLEVEL)
C
C BELOW REPLACES GENERIC SAVE IN V11, WHICH APPEARED UNNECESSARY.
SAVE IFIRST,NOMEM,NL12,IXMX,ISTART
C
C THIS ROUTINE HANDLES INPUT, ALSO MATRIX ELEMENTS FOR ITYPE=6.
C LATTER ARE OBTAINED VIA ENTRIES ASYME, CPL6, CPL26.
C FIRST VERSION WRITTEN AT MPI, MUNCHEN, JULY 1976.
C CURRENT VERSION 11 MAR 93 SAVES COUPLING ELEMENTS IN X ARRAY
C ASYME (EFF. POTL) COULD BE CHANGED, BUT PROBABLY NO LONGER USED
C
C N.B. NKVAL HERE COULD BE OBTAINED AS NEEDED - NK=2*J+1.
C THIS CODE IS MORE FLEXIBLE AS NOT ALL NEED BE STORED BUT
C K-VALUE COULD BE OBTAINED VIA ADDITIONAL VECTOR KVAL(IST+1).
C
LOGICAL LEVIN,EIN
LOGICAL LIN
LOGICAL NOMEM,ODD
INTEGER JLEV(2)
DIMENSION ATAU(2)
C N.B. JLEV AND ATAU OCCUPY SAME STORAGE PASSED FROM DRIVER/BASIS.
C IXNEXT MUST BE INCREMENTED TO REFLECT *ATAU* STORAGE USED
C (BUT NOT JLEV, BECAUSE BASIN INCREMENTS IXNEXT BY NQN*NLEV)
C
C SPECIFICATIONS FOR ASYME, CPL6, CPL26 ENTRIES.
INTEGER J(N),L(N),LAM(2)
DIMENSION VL(2)
INTEGER PRINT
LOGICAL LFIRST
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
COMMON /VLSAVE/ IVLU
C
COMMON /CMBASE/ AE(2),BE(2),CE(2),ROTI(6),ELEVEL(1000),EMAX,
& WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10),
& J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL
C
C DEFAULT INPUT UNIT IS STANDARD INPUT ...
DATA IDU/5/
DATA PI/3.14159 26535 89793 D0/
DATA EPS/1.D-9/, Z0/0.D0/
C
C STATEMENT FUNCTIONS
F(NN)=DBLE(NN+NN+1)
ODD(I)=I-2*(I/2).NE.0
C
C CHECK FOR CORRECT IV() FLAG IN INITIALIZATION ENTRY
IF (IVLFL.NE.0) THEN
WRITE(6,690) IVLFL
690 FORMAT(/' SET6 (JAN 93). ILLEGAL IVLFL =',I6)
STOP
ENDIF
C
C IF ROTATION CONSTANTS ARE INPUT, GENERATE BASIS VIA SET6C
IF (AE(1).GT.0.D0 .AND. BE(1).GT.0.D0 .AND. CE(1).GT.0.D0) THEN
CALL SET6C(JLEV,ATAU,NLEV,EIN)
C OPTION ADDED (AUG 94) TO OUTPUT ROTOR WFNS TO IASYMU
IF (IUNIT.LE.0.OR.IUNIT.GE.100.OR.IUNIT.EQ.IDU) RETURN
WRITE(6,*) ' *** SET6 WILL OUTPUT ROTOR WAVEFUNCTIONS TO UNIT',
1 IUNIT
WRITE(6,*) ' IN FORMAT FOR FUTURE INPUT'
DO 1011 I=1,NLEV
JI=JLEV(I)
ITAU=JLEV(NLEV+I)
ISTA=JLEV(3*NLEV+I)
NK=JLEV(4*NLEV+I)
INDX=JLEV(5*NLEV+I)
WRITE(IUNIT,500,ERR=1099) JI,ITAU,ELEVEL(INDX)
1011 WRITE(IUNIT,501,ERR=1099) (ATAU(ISTA+II),II=1,NK)
RETURN
1099 WRITE(6,*) ' *** SET6. ERROR WRITING TO IASYMU; WFNS NOT SAVED'
RETURN
ENDIF
C
C OTHERWISE, INPUT FROM UNIT IASYMU
IF (IUNIT.GT.0 .AND. IUNIT.LT.100) GO TO 1000
WRITE(6,601) IUNIT,IDU
601 FORMAT(/' ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, ',
1 'DEFAULTED TO ',I4)
IUNIT=IDU
C
1000 WRITE(6,602) IUNIT
602 FORMAT(/' ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =',
1 I4)
LIN=.FALSE.
IF (LEVIN) THEN
NREAD=NLEVEL
WRITE(6,603) NLEVEL
603 FORMAT(' ',10X,I6,' INPUT LEVELS SPECIFIED BY NLEVEL.')
ELSE
IF (IUNIT.EQ.IDU) THEN
WRITE(6,*) ' *** SET6. CANNOT READ FROM STD INPUT FOR',
1 ' NLEVEL.LE.0'
STOP
ENDIF
NREAD=1000000
IF (NLEVEL.LT.0) THEN
LIN=.TRUE.
WRITE(6,613) NLEVEL
613 FORMAT(5X,'NEGATIVE NLEVEL =',I5,
1 ' WILL SCREEN INPUT ON &BASIS JLEVEL()')
NLEVEL=-NLEVEL
IF (EIN) THEN
WRITE(6,*) ' ENERGIES TAKEN FROM &BASIS ELEVEL'
ELSE
WRITE(6,*) ' ENERGIES TAKEN FROM IASYMU'
ENDIF
ENDIF
ENDIF
C
NLEV=0
IOFF=0
NKVAL=0
DO 2000 III=1,NREAD
READ(IUNIT,500,END=9000) JI,ITAU,EINP
500 FORMAT(2I5,F15.10)
NLEV=NLEV+1
IF (NLEV.GT.MXEL) THEN
WRITE(6,*) ' *** SET6. DIMENSION OF ELEVEL EXCEEDED',NLEV
STOP
ENDIF
JI=IABS(JI)
NK=2*JI+1
IF (LIN) THEN
C CODE BELOW FILTERS IASYMU INPUT ON JLEVEL
DO 2099 IND=1,NLEVEL
IF (JLEVEL(2*IND-1).NE.JI.OR.JLEVEL(2*IND).NE.ITAU) GO TO 2099
INDX=IND
IF (.NOT.EIN) ELEVEL(INDX)=EINP*EFACT
GO TO 2090
2099 CONTINUE
WRITE(6,683) JI,ITAU,EINP
683 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED.',
1 ' NOT IN JLEVEL LIST')
GO TO 2070
ELSE
ELEVEL(NLEV)=EINP*EFACT
C SEE IF WE SHOULD SKIP ON JMIN,JMAX,JSTEP OR EMAX
IF (JMAX.LE.0) GO TO 2080
JDIF=JI-JMIN
JDIF=JDIF-JSTEP*(JDIF/JSTEP)
IF (JDIF.EQ.0 .AND. JI.GE.JMIN .AND. JI.LE.JMAX) GO TO 2080
WRITE(6,681) JI,ITAU,ELEVEL(NLEV),JMIN,JSTEP,JMAX
681 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED. ',
1 'J NOT IN RANGE',I4,' (',I4,')',I4)
GO TO 2070
2080 IF (EMAX.LE.0.D0) GO TO 2090
IF (ELEVEL(NLEV).LE.EMAX) GO TO 2090
WRITE(6,680) JI,ITAU,ELEVEL(NLEV),EMAX
680 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED ',
1 'DUE TO EMAX =',F11.3)
ENDIF
C
C REACH BELOW IF WE ARE SKIPPING THIS SET
2070 NLEV=NLEV-1
READ( IUNIT,501,END=9100) (ATAUX,I=1,NK)
GO TO 2000
C
C READ BELOW IF WE ARE INCLUDING THIS SET
2090 CONTINUE
C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR INCOMING JLEV.
IOFF=IOFF+6
DO 2020 I=1,NKVAL
2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I)
INST=IOFF+NKVAL
READ(IUNIT,501,END=9100) (ATAU(INST+I),I=1,NK)
501 FORMAT(6F12.8)
C OUTPUT INFORMATION READ.
WRITE(6,604) NLEV,JI,ITAU,EINP,ELEVEL(NLEV)
604 FORMAT('0 INPUT LEVEL',I4,' J, TAU =',2I4,' ENERGY =',F15.5,
& ' = ',F15.5,' (1/CM)')
MJI=-JI
WRITE(6,605) (ATAU(INST+1+JI+I),I, I=MJI,JI)
605 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')')))
C
C GET PARITY CODE FROM ATAU SYMMETRIES. . .
IPAR=IPASYM(JI,NK,ATAU(INST+1))
C IPAR=-1 IS ERROR RETURN FROM IPASYM.
IF (IPAR.NE.-1) GO TO 2001
WRITE(6,699)
STOP
C REORDER JLEV TO RECEIVE NEW ROW.
2001 NRM1=NLEV-1
IF (NRM1.LE.0) GO TO 2100
IOLD=6*NRM1
IX=6*NLEV
DO 2110 II=1,6
IX=IX-1
DO 2120 I=1,NRM1
JLEV(IX)=JLEV(IOLD)
IX=IX-1
2120 IOLD=IOLD-1
2110 CONTINUE
C
2100 JLEV(NLEV)=JI
JLEV(2*NLEV)=ITAU
JLEV(3*NLEV)=IPAR
JLEV(4*NLEV)=NKVAL
JLEV(5*NLEV)=NK
IF (LIN) THEN
JLEV(6*NLEV)=INDX
ELSE
JLEV(6*NLEV)=NLEV
ENDIF
NKVAL=NKVAL+NK
GO TO 2000
C
C * * * END OF FILE CONDITIONS * * *
9000 IF (LEVIN) GO TO 2200
WRITE(6,606) IUNIT,NLEV
606 FORMAT('0 END OF FILE ENCOUNTERED ON UNIT',I4,' AFTER',I5,
& ' FUNCTIONS.')
GO TO 2400
2200 WRITE(6,607) IUNIT,NLEV
607 FORMAT('0 PREMATURE E.O.F. ON UNIT',I4,'. NLEVEL REDUCED TO',I6)
GO TO 2400
9100 WRITE(6,608) IUNIT,NLEV
608 FORMAT('0 * * * ERROR. E.O.F. ON UNIT',I4,' BEFORE ATAU CARDS F
&OR NLEV =',I5)
WRITE(6,699)
699 FORMAT('0 * * * TERMINAL ERROR.')
STOP
2000 CONTINUE
C THIS COMPLETES READ(IASYMU) LOOP
C
2400 IF (LIN) THEN
C WE FILTERED ON JLEVEL(), MAKE SURE WE HAVE THEM ALL
IF (NLEV.NE.NLEVEL) THEN
WRITE(6,*) ' ALL LEVELS SPECIFIED BY JLEVEL() WERE NOT FOUND'
WRITE(6,*) ' *** TERMINAL ERROR.'
STOP
ENDIF
C MAKE SURE EACH VALUE IS THERE AND REORDER IF NECESSARY
C SO THAT JLEV(I,6)=I (EXPECTED BY PRBR, EG)
DO 2409 I=1,NLEVEL
DO 2408 IX=1,NLEV
IF (I.NE.JLEV(5*NLEV+IX)) GO TO 2408
IF (I.EQ.IX) GO TO 2409
DO 2407 IC=1,6
ITMP=JLEV((IC-1)*NLEV+I)
JLEV((IC-1)*NLEV+I)=JLEV((IC-1)*NLEV+IX)
2407 JLEV((IC-1)*NLEV+IX)=ITMP
GO TO 2409
2408 CONTINUE
WRITE(6,684) I,JLEVEL(2*I-1),JLEVEL(2*I)
684 FORMAT(' INPUT SET',I4,' J, TAU =',2I5,' NOT FOUND ON IASYMU'
1 /' *** TERMINAL ERROR')
STOP
2409 CONTINUE
ELSE
C SET J,TAU INTO JLEVEL; GET JMIN,JMAX (ARE THOSE NEEDED?)
NLEVEL=NLEV
C SET JLEVEL(), JMIN, AND JMAX.
JMIN=JLEV(1)
JMAX=JMIN
DO 2401 I=1,NLEV
JI=JLEV(I)
JLEVEL(2*I-1)=JI
JLEVEL(2*I)=JLEV(I+NLEV)
JMIN=MIN0(JMIN,JI)
2401 JMAX=MAX0(JMAX,JI)
ENDIF
C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . .
IF (IOFF.NE.6*NLEV) THEN
WRITE(6,698) IOFF, NLEV
698 FORMAT(' SET6. INDEXING ERROR. IOFF,NLEV =',2I6)
STOP
ENDIF
IX=3*NLEV+1
IXTOP=4*NLEV
DO 2410 I=IX,IXTOP
2410 JLEV(I)=JLEV(I)+IOFF
C CHECK THAT FUNCTIONS ARE ORTHOGONAL
CALL CHECK6(NLEV,JLEV,ATAU)
C CHECK THAT ENERGIES ARE NOT ALL IDENTICALLY ZERO.
DO 2500 I=1,NLEV
IF (ELEVEL(I).NE.0.D0) GO TO 2510
2500 CONTINUE
IF (NLEVEL.GT.1) THEN
WRITE(6,609)
609 FORMAT(' *** WARNING. SET6. ENERGIES ARE ALL ZERO')
ENDIF
2510 IXNEXT=IXNEXT+NKVAL
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C THESE ENTRY POINTS COMPUTE COUPLING MATRIX ELEMENTS . . .
C
ENTRY ASYME(N,J,L,MXLAM,LAM,VL,IV,JLEV,ATAU,NLEV)
ASSIGN 3003 TO IGO1
ASSIGN 3033 TO IGO2
GO TO 3000
C
ENTRY CPL6(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,ATAU,NLEV,PRINT,LFIRST)
IF (LFIRST) THEN
IFIRST=-1
LFIRST=.FALSE.
NOMEM=.FALSE.
ENDIF
IF (IFIRST.GT.-1) GO TO 5500
IF (NOMEM) GO TO 5900
NL12=NLEV*(NLEV+1)/2
IXMX=NL12*MXLAM
ISTART=MX+1
NAVAIL=ISTART-IXNEXT
IF (IXMX.LE.NAVAIL) GO TO 5100
IF (PRINT.GE.3) WRITE(6,694) IXMX,NAVAIL
694 FORMAT(/' CPL6 (MAR 93). UNABLE TO STORE JTOT-INDEPENDENT PART'
1 /' REQUIRED AND AVAILABLE STORAGE =',2I9)
NOMEM=.TRUE.
GO TO 5900
5100 IX=0
DO 5200 LL=1,MXLAM
LM=LAM(2*LL-1)
XLM=LM
MU=LAM(2*LL)
XMU=MU
DO 5201 IC=1,NLEV
JC=JLEV(IC)
XJC=JC
ISTC=JLEV(IC+3*NLEV)
NKC=JLEV(IC+4*NLEV)
DO 5201 IR=1,IC
IX=IX+1
JR=JLEV(IR)
XJR=JR
ISTR=JLEV(IR+3*NLEV)
NKR=JLEV(IR+4*NLEV)
XCPL=Z0
KKC=-JC
DO 5300 KC=1,NKC
C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL.
IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 5300
XKC=KKC
KKR=-JR
DO 5400 KR=1,NKR
C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL.
IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 5400
XKR=KKR
C AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)*PARITY3(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*PARITY3(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=PARITY3(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=PARITY3(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*PARITY3(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*PARITY3(MU)
GO TO IGO2,(3011,3022,3033)
3011 VL(IX)=VL(IX)+AF*FSYMTP(JC,KKC,L(IC),JR,KKR,L(IR),JTOT,LM,-MU)
GO TO 3400
3022 VL(IX)=VL(IX)+AF*GSYMTP(JC,KKC,JR,KKR,MVAL,LM,-MU)
GO TO 3400
3033 VL(IX)=VL(IX)+AF*ESYMTP(JC,KKC,JR,KKR,LM,-MU)
C
3400 KKR=KKR+1
3300 KKC=KKC+1
IF (VL(IX).NE.0.D0) NNZ=NNZ+1
IF (IVLU.EQ.0) THEN
IX=IX+MXLAM
ELSE
IX=IX+1
ENDIF
3200 CONTINUE
IF (NNZ.EQ.0) WRITE(6,697) LM,MU
697 FORMAT(' * * * NOTE. ALL COUPLING COEFFICIENTS ARE ZERO FOR ',
& 'LAMBDA, MU =', 2I4)
IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2)
3100 CONTINUE
RETURN
END
SUBROUTINE SET6C(JLEV,ATAU,NLEV,EIN)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C save statement should be unnec; only called once (sg aug 94)
SAVE
LOGICAL EIN
DIMENSION JLEV(1),ATAU(1)
DIMENSION ROTI(12),WT(2),ELEVEL(1000),JLEVEL(4000)
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C MODS 11 JUL 94 FOR V14 CMBASE
C n.b IPAR was equivalenced to J2MAX, now to ISYM(1)
EQUIVALENCE (IPAR,ISYM(1))
COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,
1 NLEVEL,JLEVEL,JMIN,JMAX,JSTEP,ISYM(10),J2MIN,J2MAX,
2 J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL
DATA TOL/1.D-8/
C
C CALCULATE ASYMMETRIC ROTOR ENERGY LEVELS AND WAVEFUNCTIONS
C FROM ROTATIONAL CONSTANTS. WRITTEN BY JMH, MARCH 1989.
C MODIFIED TO HANDLE SPHERICAL TOP SYMMETRY, APRIL 1991.
C MODIFIED TO USE WORKSPACE PROPERLY FOR VERSION 12, NOV 1993.
C
IF(EIN) WRITE(6,601)
601 FORMAT('0 TARGET ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL)'/
1 ' WILL OVERRIDE THOSE CALCULATED FROM ROTATIONAL CONSTANTS')
IF(ROTI(1).EQ.ROTI(3) .AND. ROTI(3).EQ.ROTI(5)) THEN
WRITE(6,602) ROTI(1),ROTI(7),ROTI(10)
602 FORMAT('0 SPHERICAL ROTOR LEVELS CALCULATED FROM'/
1 ' A = B = C =',F11.5/' DJ',8X,'=',E11.3/' DT',8X,'=',E11.3)
IF(ABS(ROTI(10)).LT.1.D-8) WRITE(6,603)
603 FORMAT(' *** WARNING: IF ABS(DT) IS LESS THAN ABOUT 1.D-8,',
1 ' THE PROGRAM MAY FAIL TO DISTINGUISH LEVELS OF DIFFERENT',
2 ' SYMMETRY')
ELSE
WRITE(6,604) ROTI(1),ROTI(3),ROTI(5),
1 ROTI(7),ROTI(8),ROTI(9)
604 FORMAT('0 ASYMMETRIC ROTOR LEVELS CALCULATED FROM'/
1 ' A =',F10.5,8X,'B =',F10.5,8X,'C =',F10.5/
2 ' DJ =',E10.3,8X,'DJK =',E10.3,8X,'DK =',E10.3/
3 '0 A, B AND C MUST CORRESPOND TO THE X, Y AND Z',
4 ' COORDINATES USED TO DEFINE THE INTERACTION POTENTIAL')
ENDIF
WRITE(6,605) IPAR
605 FORMAT('0 INPUT ENERGY LEVELS WILL BE INCLUDED ONLY IF THEY',
1 ' MEET SELECTION CRITERIA SPECIFIED BITWISE BY ISYM =',I4)
C
C NTAU IS SAFELY ABOVE ANYTHING WE MAY NEED FOR JLEV
C
NLVL=0
ESAVE=-999.D0
NLEV=0
NTAU=6*(JMAX+1)**2
NORIG=NTAU
IXSAVE=IXNEXT
DO 450 J=JMIN,JMAX,JSTEP
NVEC=NTAU
NK=J+J+1
C
C ASROT NEEDS SOMEWHERE TO PUT THE EIGENVALUES AND EIGENVECTORS
C AND SOME WORKSPACE. USE THE TOP OF THE ATAU ARRAY.
C
IC2=NVEC+1+NK*NK
IC3=IC2+NK*NK
IC4=IC3+NK
IXNEXT=IC4+NK
NUSED=1
CALL CHKSTR(NUSED)
CALL ASROT(J,ATAU(NVEC+1),ATAU(IC2),ATAU(IC3),ATAU(IC4),NK)
DO 440 IK=1,NK
C
C CHECK LEVEL ENERGY AND PARITY TO SEE WHETHER WE REALLY WANT IT
C
ELEV=ATAU(IC3+IK-1)
IF(EMAX.GT.0.D0 .AND. ELEV.GT.EMAX) GOTO 430
IPLEV=IPASYM(J,NK,ATAU(NVEC+1))
C
C IPAR IS INTERPRETED BITWISE: THE BITS ARE FLAGS AS FOLLOWS
C 1 - ODD K EXCLUDED
C 2 - EVEN K EXCLUDED
C 3 - ODD +/-K * (-1)**J EXCLUDED
C 4 - EVEN +/-K * (-1)**J EXCLUDED
C 5 - DEGENERACY = 1 EXCLUDED
C 6 - DEGENERACY = 2 EXCLUDED
C 7 - DEGENERACY = 3 EXCLUDED
C 8 - DEGENERACY > 3 EXCLUDED
C
C NOTE THAT THIS LOGIC WAS CHANGED IN AUGUST 1992,
C IN A WAY THAT ALTERS THE INPUT VALUE OF ISYM REQUIRED,
C FOLLOWING BETA TESTING OF VERSION 11
C
IF(IPAR.LE.0) GOTO 410
C
C FIND DEGENERACY
C
IDEG=0
DO 400 KK=1,NK
IF(ABS(ATAU(IC3+KK-1)-ELEV).LT.TOL) IDEG=IDEG+1
400 CONTINUE
C
JPAR=IPAR
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. IPLEV.GE.2) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. IPLEV.LE.1) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. MOD(IPLEV+J,2).EQ.1) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. MOD(IPLEV+J,2).EQ.0) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. IDEG.EQ.1) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. IDEG.EQ.2) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. IDEG.EQ.3) GOTO 430
C
IP=MOD(JPAR,2)
JPAR=JPAR/2
IF(IP.EQ.1 .AND. IDEG.GT.3) GOTO 430
C
410 NLEV=NLEV+1
IF(NLEVEL.GT.0 .AND. NLEV.GT.NLEVEL) GOTO 430
C
C ARRIVE HERE IF WE DO: STORE JLEV AND TAU IN TEMPORARY LOCATIONS
C
PREV=ESAVE
ESAVE=ELEV
IF(ABS(ESAVE-PREV).GT.TOL) THEN
NLVL=NLVL+1
JLEVEL(2*NLVL-1)=J
JLEVEL(2*NLVL)=IK
IF(.NOT.EIN) ELEVEL(NLVL)=ELEV
ENDIF
C
JLEV(6*NLEV-5)=J
JLEV(6*NLEV-4)=IK
JLEV(6*NLEV-3)=IPLEV
JLEV(6*NLEV-2)=NTAU
JLEV(6*NLEV-1)=NK
JLEV(6*NLEV )=NLVL
C
C NTAU KEEPS TRACK OF WHERE WE ARE PUTTING THE COEFFICIENTS,
C AND NVEC KEEPS TRACK OF WHERE THEY ARE COMING FROM.
C NTAU IS NEVER LESS THAN NVEC.
C
DO 420 I=1,NK
ATAU(NTAU+I)=ATAU(NVEC+I)
420 CONTINUE
NTAU=NTAU+NK
430 NVEC=NVEC+NK
440 CONTINUE
450 CONTINUE
C
C COPY ATAU INTO THE RIGHT PLACE
C
IF(NLEVEL.GT.0) NLEV=MIN(NLEV,NLEVEL)
IF(NLEVEL.EQ.0) NLEVEL=NLVL
NBASE=6*NLEV
NSHIFT=NORIG-NBASE
DO 460 I=NORIG+1,NTAU
460 ATAU(I-NSHIFT)=ATAU(I)
NTAU=NTAU-NSHIFT
C
C COPY JLEV INTO WORKSPACE ABOVE ATAU AND REARRANGE IT,
C REMEMBERING TO MODIFY THE POINTER TO ATAU.
C
NBASE=2*NTAU
I=0
DO 470 NL=1,NLEV
DO 470 IQ=1,6
I=I+1
IF(IQ.EQ.4) JLEV(I)=JLEV(I)-NSHIFT
JLEV(NBASE+NL+NLEV*(IQ-1))=JLEV(I)
470 CONTINUE
C
C THEN COPY IT BACK TO WHERE IT BELONGS
C
DO 480 I=1,6*NLEV
480 JLEV(I)=JLEV(NBASE+I)
IXNEXT=IXSAVE+NTAU
RETURN
END
SUBROUTINE SET6I(JLEV,MXLV,NLEV,A,MXA,IUNIT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JLEV(MXLV)
DIMENSION A(MXA)
DATA IDU/5/
C
NTOP=MXLV/4
ISTA=0
C ALLOW FOR EMPTY SET OF BASIS FUNCTIONS, I.E., NLEV.LE.0
IF (NLEV.LE.0) GO TO 3000
IF (NLEV.LE.NTOP) GO TO 1000
WRITE(6,603) NLEV,NTOP
603 FORMAT('0 INPUT NLEVEL =',I7,
1 ' REPLACED BY MAX ALLOWED BY DIMENSIONS =',I5)
NLEV=NTOP
C
1000 IF (IUNIT.GT.0) GO TO 1001
WRITE(6,601) IUNIT,IDU
601 FORMAT('0 ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, CHANGED TO'
& ,I4)
IUNIT=IDU
1001 WRITE(6,602) IUNIT,NLEV
602 FORMAT('0 ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =',
& I4/'0 NUMBER OF REQUESTED LEVELS, NLEVEL =',I4 )
C
NL=0
DO 2000 III=1,NLEV
READ(IUNIT,500,END=9000) JI,ITAU,EIN
500 FORMAT(2I5,F15.10)
C N.B. ENERGY (EIN) NOT USED FOR IOS, KEPT FOR MOLSCAT COMPATIBILITY
NL=NL+1
JI=IABS(JI)
NK=2*JI+1
IF (ISTA+NK.GT.MXA) GO TO 9001
READ(IUNIT,501,END=9100) (A(ISTA+I),I=1,NK)
501 FORMAT(6F12.8)
WRITE(6,604) NL,JI,ITAU
604 FORMAT('0 INPUT LEVEL',I4,' J, TAU =',2I4)
MJI=-JI
WRITE(6,605) (A(ISTA+1+JI+I),I,I=MJI,JI)
605 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')')))
IPAR=IPASYM(JI,NK,A(ISTA+1))
IF (IPAR.NE.-1) GO TO 2001
WRITE(6,619)
619 FORMAT('0 *** ILLEGAL PARITY. BASIS FUNCTION REMOVED.')
NL=NL-1
GO TO 2000
C ADD INDICES TO JLEV. . .
2001 JLEV(4*NL-3)=JI
JLEV(4*NL-2)=ITAU
JLEV(4*NL-1)=IPAR
JLEV(4*NL )=ISTA
ISTA=ISTA+NK
GO TO 2000
C END OF FILE AND OTHER ERROR CONDITIONS
9000 WRITE(6,606) IUNIT,NL
606 FORMAT('0 END OF FILE ON UNIT',I4,' AFTER',I4,' FUNCTIONS.')
GO TO 2400
9001 WRITE(6,607) MXA,NL
607 FORMAT('0 OUT OF ROOM IN ATAU MATRIX. MXA, NLEV =',2I6)
NL=NL-1
GO TO 2400
9100 WRITE(6,608) NL
608 FORMAT('0 * * * ERROR. END OF FILE BEFORE ATAU CARDS FOR LEVEL',
& I4,'. * * * TERMINATING.')
STOP
2000 CONTINUE
C
2400 NLEV=NL
3000 MXA=ISTA
CALL CHCK6I(NLEV,JLEV,A)
RETURN
END
SUBROUTINE SETBAS
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE
C
LOGICAL LEVIN,EIN
INTEGER NLEV,JLEV(1)
C
C VERSION 14 CMBASE
C COMMON BLOCK FOR BASIS DATA
DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),WE(2),WEXE(2),A(2),B(2),
1 C(2),WT(2),ELEVEL(1000)
DIMENSION JLEVEL(4000),ISYM(10),ISYM2(10)
EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)),
1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),(JSTEP,J1STEP),
2 (ROTI(7),WE(1)), (ROTI(9),WEXE(1)),(KMAX,J2MAX)
COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL,
1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT
C
C
ENTRY SET1(LEVIN,EIN,NLEV,JLEV)
IF (LEVIN) GO TO 1902
WRITE(6,601) JMIN,JMAX,JSTEP
601 FORMAT(/' TARGET ROTATIONAL LEVELS COMPUTED FROM JMIN =',I3,
1 ', JMAX =',I3,', AND JSTEP =',I2)
JMIN=MAX0(0,JMIN)
JMAX=MAX0(JMIN,JMAX)
NLEVEL=0
DO 1012 I=JMIN,JMAX,JSTEP
NLEVEL=NLEVEL+1
1012 JLEVEL(NLEVEL)=I
GO TO 1802
1902 WRITE(6,632) NLEVEL
632 FORMAT(/' TARGET ROTATIONAL LEVELS TAKEN FROM &BASIS (JLEVEL) ',
1 'INPUT. NLEVEL =',I3)
1802 JMIN=JLEVEL(1)
JMAX=JMIN
NLEV=NLEVEL
DO 1912 I=1,NLEVEL
JI=JLEVEL(I)
IF (JI.LT.JMIN) JMIN=JI
IF (JI.GT.JMAX) JMAX=JI
JLEV(NLEV+I)=I
1912 JLEV(I)=JI
IF (EIN) GO TO 7002
WRITE(6,633) BE(1)
633 FORMAT(/' ENERGY LEVELS COMPUTED FROM B(E) =',F12.6)
IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1)
634 FORMAT(' WITH B(V) COMPUTED FROM B(E) AND ALPHA(E) =',F10.6)
IF (DE(1).NE.0.D0) WRITE(6,635) DE(1)
635 FORMAT(' ROTATIONAL ENERGIES CORRECTED FOR D(E) =',F12.8)
DO 1702 I=1,NLEV
JI=JLEV(I)
FJ=JI*(JI+1)
1702 ELEVEL(I)=(BE(1)-ALPHAE(1)/2.D0)*FJ - DE(1)*FJ*FJ
RETURN
7002 WRITE(6,631)
631 FORMAT(/' TARGET ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL) INPUT')
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY SET2(LEVIN,EIN,NLEV,JLEV)
IF (LEVIN) GO TO 2902
WRITE(6,201)
201 FORMAT(/' * * * ERROR. FOR ITYPE=2 &BASIS MUST SPECIFY NLEVEL ',
1 'AND J, V PAIRS')
STOP
2902 WRITE(6,632) NLEVEL
JMIN=JLEVEL(1)
JMAX=JMIN
NLEV=NLEVEL
DO 2912 I=1,NLEVEL
JI=JLEVEL(2*I-1)
JVI=JLEVEL(2*I)
JMIN=MIN0(JMIN,JI)
JMAX=MAX0(JMAX,JI)
JLEV(2*NLEV+I)=I
JLEV(NLEV+I)=JVI
2912 JLEV(I)=JI
IF(EIN) GO TO 2002
WRITE(6,202) WE(1),BE(1)
202 FORMAT(/' ENERGY LEVELS COMPUTED FROM W(E) =',F10.4,
1 ', B(E) =',F10.4/9X,'WITH ZERO ENERGY AT V=0, J=0')
IF (WEXE(1).NE.0.D0) WRITE(6,636) WEXE(1)
636 FORMAT(' CORRECTED FOR W(E)X(E) =',F10.4)
IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1)
IF (DE(1).NE.0.D0) WRITE(6,635) DE(1)
DO 2702 I=1,NLEV
JI=JLEV(I)
JVI=JLEV(NLEV+I)
FJ=JI*(JI+1)
FV=JVI
2702 ELEVEL(I)=WE(1)*FV-WEXE(1)*FV*(FV+1.D0)+(BE(1)-ALPHAE(1)
1 *(FV+0.5D0))*FJ - DE(1)*FJ*FJ
RETURN
2002 WRITE(6,631)
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY SET3(LEVIN,EIN,NLEV,JLEV)
IF (IDENT.EQ.0) GO TO 1993
J2MIN=J1MIN
J2MAX=J1MAX
J2STEP=J1STEP
IF (BE(2).EQ.0.D0) BE(2)=BE(1)
IF (ALPHAE(2).EQ.0.D0) ALPHAE(2)=ALPHAE(1)
IF (DE(2).EQ.0.D0) DE(2)=DE(1)
1993 IF (LEVIN) GO TO 5303
WRITE(6,310) J1MIN,J1MAX,J1STEP,J2MIN,J2MAX,J2STEP
310 FORMAT(/' TARGET ROTOR LEVELS COMPUTED FROM J1MIN =',I3,
1 ', J1MAX =',I3,', J1STEP =',I2//
2 ' PROJECTILE ROTOR LEVELS COMPUTED FROM J2MIN =',I3,
3 ', J2MAX =',I3,', J2STEP =',I2)
J1MIN=MAX0(J1MIN,0)
J1MAX=MAX0(J1MIN,J1MAX)
J1STEP=MAX0(J1STEP,1)
J2MIN=MAX0(J2MIN,0)
J2MAX=MAX0(J2MAX,J2MIN)
J2STEP=MAX0(J2STEP,1)
NLEVEL=0
I=1
DO 1013 JJ1=J1MIN,J1MAX,J1STEP
DO 1013 JJ2=J2MIN,J2MAX,J2STEP
IF (IDENT.NE.0 .AND. JJ1.GT.JJ2) GO TO 1013
JLEVEL(I)=JJ1
JLEVEL(I+1)=JJ2
I=I+2
NLEVEL=NLEVEL+1
1013 CONTINUE
GO TO 1023
5303 WRITE(6,333) NLEVEL
333 FORMAT(/' TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS ',
1 '(JLEVEL) INPUT. NLEVEL =',I3)
C PROCESS JLEVEL TO JLEV FORMAT. JMIN(JMAX) ARE LOW(HIGH) OF J12.
1023 JMIN=IABS(JLEVEL(1)-JLEVEL(2))
JMAX=JMIN
C EXPAND J1, J2 TO J1, J2, J12
NLEV=0
DO 1033 I=1,NLEVEL
JJ1=JLEVEL(2*I-1)
JJ2=JLEVEL(2*I)
JK=IABS(JJ1-JJ2)
JTOP=JJ1+JJ2
DO 1033 J12=JK,JTOP
JLEV(4*NLEV+1)=JJ1
JLEV(4*NLEV+2)=JJ2
JLEV(4*NLEV+3)=J12
JLEV(4*NLEV+4)=I
NLEV=NLEV+1
JMIN=MIN0(JMIN,J12)
JMAX=MAX0(JMAX,J12)
1033 CONTINUE
C REARRANGE TO PROPER ORDER IN HIGHER JLEV STORAGE
JK=4*NLEV
DO 1043 I=1,NLEV
JLEV(JK+I)=JLEV(4*I-3)
JLEV(JK+NLEV+I)=JLEV(4*I-2)
JLEV(JK+2*NLEV+I)=JLEV(4*I-1)
1043 JLEV(JK+3*NLEV+I)=JLEV(4*I)
C COPY BACK . . .
DO 1053 I=1,JK
1053 JLEV(I)=JLEV(JK+I)
C SET ELEVEL VALUES
IF (EIN) GO TO 1073
WRITE(6,633) BE(1)
IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1)
IF (DE(1).NE.0.D0) WRITE(6,635) DE(1)
WRITE(6,313) BE(2)
313 FORMAT(/' PROJECTILE ENERGY LEVELS COMPUTED FROM B(E) =',F12.6)
IF (ALPHAE(2).NE.0.D0) WRITE(6,634) ALPHAE(2)
IF (DE(2).NE.0.D0) WRITE(6,635) DE(2)
DO 1063 I=1,NLEVEL
FJ=DBLE(JLEVEL(2*I-1))
GJ=DBLE(JLEVEL(2*I))
FJ=FJ*(FJ+1.D0)
GJ=GJ*(GJ+1.D0)
1063 ELEVEL(I)=(BE(1)-ALPHAE(1)*0.5D0)*FJ - DE(1)*FJ*FJ
1 + (BE(2)-ALPHAE(2)*0.5D0)*GJ - DE(2)*GJ*GJ
RETURN
1073 WRITE(6,312)
312 FORMAT(/' TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS ',
1 '(ELEVEL) INPUT')
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
ENTRY SET5(LEVIN,EIN,NLEV,JLEV)
C
C N.B. WE USE D(L,K,M) WITH EDMONDS CONVENTIONS OF PHASE FOR THE
C BASIS FUNCTIONS. THIS IS SAME AS THADDEUS IN H2CO PAPER.
C
IF (LEVIN) GO TO 5305
NLEVEL=0
I=0
WRITE(6,601) JMIN,JMAX,JSTEP
IF(KMAX.LT.0) WRITE(6,602) -KMAX
602 FORMAT(10X,' ABS(K) FOR ALL LEVELS SET TO',I4)
IF(KMAX.GE.0 .AND. KMAX.LT.JMAX) WRITE(6,603) KMAX
603 FORMAT(10X,' ONLY LEVELS WITH K <=',I3,' INCLUDED IN BASIS')
JMIN=MAX0(JMIN,0)
JMAX=MAX0(JMIN,JMAX)
DO 5315 JJ=JMIN,JMAX
DO 5315 KK=0,JJ
IF (KMAX.LT.0 .AND. KK+KMAX.NE.0) GO TO 5315
IF (KMAX.GE.0 .AND. KK.GT.KMAX) GO TO 5315
IF (MOD(JJ+KK,JSTEP).NE.JMIN) GO TO 5314
JLEVEL(I+1)=JJ
JLEVEL(I+2)=KK
JLEVEL(I+3)=2
I=I+3
NLEVEL=NLEVEL+1
5314 IF(KK.EQ.0) GOTO 5315
IF (MOD(JJ+KK+1,JSTEP).NE.JMIN) GO TO 5315
JLEVEL(I+1)=JJ
JLEVEL(I+2)=KK
JLEVEL(I+3)=1
I=I+3
NLEVEL=NLEVEL+1
5315 CONTINUE
GO TO 5355
5305 WRITE(6,632) NLEVEL
5355 JMIN=JLEVEL(1)
JMAX=JMIN
NLEV=NLEVEL
DO 5325 I=1,NLEVEL
JLEV(I)=JLEVEL(3*I-2)
JLEV(NLEV+I)=JLEVEL(3*I-1)
JLEV(2*NLEV+I)=JLEVEL(3*I)
JLEV(3*NLEV+I)=I
JJ=JLEV(I)
IF (JJ.LT.JMIN) JMIN=JJ
IF (JJ.GT.JMAX) JMAX=JJ
5325 CONTINUE
IF (EIN) GO TO 5335
WRITE(6,604) A(1),B(1),C(1)
604 FORMAT(/' ENERGY LEVELS COMPUTED FROM ZEROTH ORDER ',
1 'NEAR-SYMMETRIC TOP FORMULA'/
2 10X,'ROTATIONAL CONSTANTS ARE A, B, C (1/CM) =',3F12.4/
3 10X,'N.B. THESE MOMENTS MUST CORRESPOND RESPECTIVELY TO ',
4 'X, Y, Z COORDINATES USED TO DEFINE INTERACTION POTENTIAL')
DO 5345 I=1,NLEV
JJ=JLEV(I)
KK=IABS(JLEV(I+NLEV))
SS=(-1.D0)**JLEV(I+2*NLEV)
HKK=(A(1)+B(1))*DBLE(JJ*(JJ+1)-KK*KK)/2.D0+ C(1)*DBLE(KK*KK)
C OFF-DIAGONAL CONTRIBUTION ONLY FROM K=1/K=-1 CASE. . .
IF (KK.EQ.1) HKK=HKK+ SS * (A(1)-B(1)) *
1 SQRT(DBLE((JJ*(JJ+1)-KK*(KK-1))*(JJ*(JJ+1)-(KK-1)*(KK-2))))/4.D0
5345 ELEVEL(I)=HKK
RETURN
5335 WRITE(6,631)
RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
END
SUBROUTINE SGNCHK(A,B,N)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION A(1),B(1)
IND=-N
DO 1 I=1,N
IND=IND+N
VMAX=0.D0
JMAX=0
DO 2 J=1,N
IF(ABS(B(IND+J)).LT.VMAX) GO TO 2
JMAX=J
VMAX=B(IND+JMAX)
2 CONTINUE
IF(JMAX.EQ.0) GO TO 999
TEST=SIGN(B(IND+JMAX),A(IND+JMAX))
IF(TEST.EQ.B(IND+JMAX)) GO TO 1
DO 3 J=1,N
B(IND+J)=-B(IND+J)
3 CONTINUE
1 CONTINUE
RETURN
999 WRITE(6,100)
100 FORMAT(/10X,'JMAX EQ. 0 IN SGNCHK')
RETURN
END
SUBROUTINE SHRINK(ICODE,RNOW,W,N,VL,IV,NB,J,L,EINT,CENT,WVEC,
1 CLOSE,VECOLD,EIGOLD,R,T,DEEP,NSQ,NPOTL,ISCRU,NOPMAX,PRINT)
C
C SUBROUTINE TO PERFORM A CHANNELECTOMY.
C SHRINK REMOVES THE HIGHEST-ENERGY CHANNEL(S) FROM THE PRIMITIVE
C BASIS SET, AND MODIFIES NUMEROUS ARRAYS TO REFLECT THIS.
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER PRINT
DIMENSION W(1),VL(1),IV(1),NB(N),J(N),L(N),EINT(N),CENT(N),
1 WVEC(N),CLOSE(N),VECOLD(NSQ),EIGOLD(N),R(1),T(1)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
IF(ISCRU.LE.0) GOTO 100
IF(ICODE.EQ.1) WRITE(ISCRU) VECOLD
IF(ICODE.EQ.2) READ(ISCRU) VECOLD
100 CALL TRNSP(VECOLD,N)
CALL TRNSFM(VECOLD,R,T,N,.FALSE.,.TRUE.)
C
DEEP2=DEEP
DO 1000 NNEW=N,1,-1
IF(NNEW.LE.NOPMAX .OR. CLOSE(NNEW).LT.DEEP2) GOTO 1100
ISKIP=NB(NNEW)
C
I=0
INEW=0
DO 200 II=1,NNEW
DO 200 JJ=1,NNEW
I=I+1
IF(II.EQ.ISKIP .OR. JJ.EQ.ISKIP) GOTO 200
INEW=INEW+1
W(INEW)=W(I)
R(INEW)=R(I)
200 CONTINUE
C
INEW=0
DO 300 I=1,NNEW
IF(I.EQ.ISKIP) GOTO 300
INEW=INEW+1
J(INEW)=J(I)
L(INEW)=L(I)
EINT(INEW)=EINT(I)
CENT(INEW)=CENT(I)
WVEC(INEW)=WVEC(I)
300 CONTINUE
C
I=0
INEW=0
DO 400 II=1,NNEW
DO 400 JJ=1,II
DO 400 K=1,NPOTL
I=I+1
IF(II.EQ.ISKIP .OR. JJ.EQ.ISKIP) GOTO 400
INEW=INEW+1
VL(INEW)=VL(I)
IF (IVLFL.NE.0) IV(INEW)=IV(I)
400 CONTINUE
C
DO 500 I=1,NNEW
500 IF(NB(I).GE.ISKIP) NB(I)=NB(I)-1
C
1000 CONTINUE
C
1100 N=NNEW
IF (ICODE.EQ.2) GOTO 1300
IF(PRINT.GE.8) WRITE(6,601) N,RNOW
601 FORMAT(' BASIS SET CONTRACTED TO N =',I3,' AT R =',F6.2,' A')
IFAIL=0
CALL F02ABF(W,N,N,EIGOLD,VECOLD,N,T,IFAIL)
IF(ISCRU.GT.0) WRITE(ISCRU) VECOLD
GOTO 1400
C
1300 IF(ISCRU.GT.0) READ(ISCRU) VECOLD
1400 CALL TRNSFM(VECOLD,R,T,N,.FALSE.,.TRUE.)
NSQ=N*N
C
RETURN
END
SUBROUTINE SIG6(NLEV,JLEV,A,LI,LF,SIG,S,IMSG,QL,IXQL,NIXQL,NQL,
1 LM,LMAX)
C ROUTINE TO EVALUATE SIG(J,TAU->J',TAU') FROM IOS Q(L,M1,M2)
C VALUE FOR LEVEL LI TO LF RETURNED IN SIG
C SG(2/1/93) VERSION TAKES STORAGE FOR REAL/IMAGINARY COEFFS
C FROM /MEMORY/ ..,X
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION JLEV(4,NLEV),A(2),IXQL(NIXQL,NQL),LM(3,LMAX)
DIMENSION QL(2)
CHARACTER*1 S,STAR
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DATA STAR/'*'/
DATA EPS/1.D-8/
C
C STATEMENT FUNCTION FOR INDEX M1.GE.M2, M STARTING AT ZERO.
IX(M1,M2)=M1*(M1+1)/2+M2+1
C
SIG=0.D0
JI=JLEV(1,LI)
XJI=JI
NKI=2*JI+1
ISTAI=JLEV(4,LI)
JF=JLEV(1,LF)
XJF=JF
NKF=2*JF+1
ISTAF=JLEV(4,LF)
LMN=IABS(JI-JF)
LMX=JI+JF
DO 1100 L=LMN,LMX
XL=L
C DETERMINE AMOUNT OF AVAILABLE SCRATCH STORAGE IN X().
MAXC=MX-IXNEXT+1
C M-VALUES CAN RANGE UP TO L. CHECK ABILITY TO STORE IN CR,CI
MMAX=L
1101 IXMX=IX(MMAX,MMAX)
IF (2*IXMX.LE.MAXC) GO TO 1102
WRITE(6,699) L,IXMX,MAXC
699 FORMAT(' *** CANNOT STORE ALL CR,CI FOR L=',I3,
1 '. REQUIRED, AVAILABLE =',2I7)
MMAX=MMAX-1
S=STAR
IMSG=1
IF (MMAX.LT.0) THEN
WRITE(6,698) LI,LF
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=PARITY3(MP)
SIGNR=P*SIGNR
SIGNI=P*SIGNI
MP=IABS(MP)
1401 IF (MQ.GE.0) GO TO 1402
P=PARITY3(MQ)
SIGNR=P*SIGNR
SIGNI=P*SIGNI
MQ=IABS(MQ)
1402 IF (MP.GE.MQ) GO TO 1403
SIGNI=-SIGNI
MT=MP
MP=MQ
MQ=MT
1403 INDX=IX(MP,MQ)
IF (MP.EQ.MQ) SIGNI=0.D0
X(IXR+INDX)=X(IXR+INDX)+SIGNR*FACT
X(IXI+INDX)=X(IXI+INDX)+SIGNI*FACT
C**** WRITE(6,686) INDX,X(IXR+INDX),X(IXI+INDX) **** DEBUGGING ****
686 FORMAT(' INDX, REAL/IMAG =',I5,2F10.5)
1300 CONTINUE
1301 CONTINUE
C ---------- THIS ENDS LOOP OVER IQI,IQF
1200 CONTINUE
1201 CONTINUE
C ---------- THIS ENDS LOOP OVER IPI,IPF
C MATCH CONTRIBUTING (I.E., NON-ZERO) CR WITH QL VALUES
IZERO=0
INDX=0
DO 1500 MP=IZERO,MMAX
DO 1500 MQ=IZERO,MP
INDX=INDX+1
C N.B. IMAGINARY PART SHOULD VANISH; ERROR MESSAGE IF ANY SURVIVE.
IF (ABS(X(IXI+INDX)).LE.EPS) GO TO 1501
WRITE(6,694) L,MP,MQ,X(IXI+INDX),LI,LF
694 FORMAT('0 *** ERROR. NON-ZERO IMAGINARY COEFF QL(',
& 3I4,' ) =',F12.6,' FOR LI,LF =',2I4)
1501 IF (ABS(X(IXR+INDX)).LE.EPS) GO TO 1500
C CALL IXQLF TO GET INDEX OF L,MP,MQ IN QL
C AND ACCUMULATE IN CROSS SECTION
CALL IXQLF(LM,LMAX,L,MP,MQ,1,INDEX,IXQL,NIXQL,NQL)
C N.B. 6TH ARG (1) ASKS FOR REAL PART; SHOULD WORK OK FOR MP.EQ.MQ
IF (INDEX.GT.0) GO TO 1502
IF (INDEX.EQ.-1) GO TO 1500
S=STAR
IMSG=1
GO TO 1500
1502 SIG=SIG + X(IXR+INDX)*QL(INDEX)
C WRITE(6,602) LI,LF,L,MP,MQ,X(IXR+INDX),QL(INDEX) *** DEBUGGING**
602 FORMAT(2X,'I/F=',2I3,' QL(',3I3,' ) COEFF/QL =',2F10.5)
1500 CONTINUE
C RECOVER TEMPORARY STORAGE ...
1100 IXNEXT=IXSAVE
C ---------- THIS ENDS LOOP OVER L - VALUES
C MULTIPLY FINALLY BY 2*JF+1
SIG = SIG * (2*JF+1)
RETURN
END
FUNCTION SIXJ(J1,J2,J5,J4,J3,J6)
C
C CALCULATES 6-J SYMBOL: _(J1 J2 J3 )_
C (J4 J5 J6 )
C INTERFACE TO J6J ROUTINE.
C MODIFIED BY S. GREEN 20 AUG 93; PASS DIMENSION OF XJ6J FOR CHECKING
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER(MXDIM=200)
DIMENSION XJ6J(MXDIM)
IVAL=MXDIM
CALL J6J( DBLE(J2),DBLE(J3),
1 DBLE(J4),DBLE(J5),DBLE(J6),
3 IVAL,XJ1MIN,XJ6J)
IND=1+J1-INT(XJ1MIN+0.1D0)
SIXJ=0.D0
IF(IND.GE.1 .AND. IND.LE.IVAL) SIXJ=XJ6J(IND)
RETURN
END
* ----------------------------------------------------------------------
SUBROUTINE SPROPN (WIDTH, EIGNOW, HP, Y1, Y4, Y2, NCH)
* CURRENT REVISION DATE: 23-9-87
*-----------------------------------------------------------------------
* THIS SUBROUTINE CALCULATES THE DIAGONAL MATRICES TO PROPAGATE THE
* LOG-DERIVATIVE MATRIX THROUGH THE CURRENT INTERVAL
* THE KEY EQUATIONS, REPRODUCED BELOW, ARE TAKEN FROM
* M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR REFERENCE POTENTIA
* ALGORITHM FOR SOLUTION ..."
* EACH UNCOUPLED EQUATION CAN BE WRITTEN AS:
* 2 2
* [ D / DR + EIGNOW - HP * R ] F(R) = 0
* WHERE R IS THE DISTANCE FROM THE MIDPOINT OF THE CURRENT INTERVAL
* THE LINEARLY INDEPEDENT SOLUTIONS ARE THE AIRY FUNCTIONS AI(X) AND BI
* WHERE X = ALPHA (R + BETA)
* 1/3
* WITH ALPHA = HP , AND BETA = (-EIGNOW) / HP
* THE THREE DIAGONAL ELEMENTS OF THE CAUCHY PROPAGATOR NECESSARY TO PRO
* THE LOG-DERIVATIVE MATRIX ARE:
* B = PI [ AI(X ) BI(X ) - AI(X )BI(X ) ] / ALPHA
* 1 2 2 1
* A = PI [ - AI'(X ) BI(X ) + AI(X ) BI'(X ) ]
* 1 2 2 1
* D = PI [ AI(X ) BI'(X ) - AI'(X ) BI(X ) ]
* 1 2 2 1
* WHERE X = ALPHA ( BETA + WIDTH / 2) AND
* 2
* X = ALPHA ( BETA - WIDTH / 2)
* 1
* HERE "WIDTH" DENOTES THE WIDTH OF THE INTERVAL
* THE DIAGONAL ELEMENTS OF THE "IMBEDDING TYPE" PROPAGATOR ARE GIVEN IN
* OF THE DIAGONAL ELEMENTS OF THE CAUCHY PROPAGATOR BY:
* Y = A/B Y = Y = 1/B AND Y = D/B
* 1 2 3 4
*-----------------------------------------------------------------------
* VARIABLES IN CALL LIST:
* WIDTH: WIDTH OF THE CURRENT INTERVAL
* EIGNOW: ARRAY CONTAINING THE WAVEVECTORS
* THESE ARE DEFINED BY EQ. (6) OF M.ALEXANDER,
* J. CHEM. PHYS. 81,4510 (1984)
* HP: ARRAY CONTAINING THE NEGATIVE OF DIAGONAL ELEMENTS OF T
* DERIVATIVE OF THE WAVEVECTOR MATRIX AT THE CENTER OF TH
* CURRENT INTERVAL [SEE EQ. (9) OF M.ALEXANDER,
* J. CHEM. PHYS. 81,4510 (1984)
* THIS ARRAY THUS CONTAINS THE DERIVATIVE OF THE DIAGONAL
* ELEMENTS OF THE TRANSFORMED HAMILTONIAN MATRIX
* Y1, Y2, Y4: ON RETURN, CONTAIN THE DESIRED DIAGONAL ELEMENTS OF THE
* IMBEDDING PROPAGATOR
* NCH: THE NUMBER OF CHANNELS, THIS EQUALS THE DIMENSIONS OF T
* EIGNOW, HP, Y1, Y4, AND B ARRAYS
*-----------------------------------------------------------------------
* THE AIRY FUNCTIONS ARE DEFINED IN TERMS OF THEIR MODULI AND PHASES
* FOR NEGATIVE X THESE DEFINITIONS ARE:
* AI(-X) = M(X) COS[THETA(X)]
* BI(-X) = M(X) SIN[THETA(X)]
* AI'(-X) = N(X) COS[PHI(X)]
* BI'(-X) = N(X) SIN[PHI(X)]
* IN OTHER WORDS
* 2 2 2
* M(X) = SQRT[ AI(X) + BI(X) ]
* 2 2 2
* N(X) = SQRT[ AI'(X) + BI'(X) ]
* THETA(X) = ATAN [ BI(X) / AI(X) ]
* PHI(X) = ATAN [ BI'(X) / AI'(X) ]
* FOR POSITIVE X THE MODULI AND PHASES ARE DEFINED BY:
* AI(X) = M(X) SINH[THETA(X)]
* BI(X) = M(X) COSH[THETA(X)]
* AI'(X) = N(X) SINH[PHI(X)]
* BI'(X) = N(X) COSH[PHI(X)]
* IN OTHER WORDS
* 2 2 2
* M(X) = SQRT[ BI(X) - AI(X) ]
* 2 2 2
* N(X) = SQRT[ BI'(X) - AI'(X) ]
* THETA(X) = ATANH [ AI(X) / BI(X) ]
* PHI(X) = ATANH [ AI'(X) / BI'(X) ]
* HERE THE THE EXPONENTIALLY SCALED AIRY FUNCTIONS
* AI(X), AI'(X), BI(X), BI'(X) ARE:
* AI(X) = AI(X) * EXP[ZETA]
* AI'(X) = AI'(X) * EXP[ZETA]
* BI(X) = BI(X) * EXP[-ZETA]
* BI'(X) = BI'(X) * EXP[-ZETA]
* 3/2
* WHERE ZETA = (2/3) X
* NOTE THAT FOR POSITIVE X THE PHASES ARE LABELED CHI AND ETA IN
* M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR REFERENCE POTENTIA
* ALGORITHM FOR SOLUTION ..."
*-----------------------------------------------------------------------
* FOR BOTH X AND X NEGATIVE
* 1 2
* (THIS CORRESPONDS TO A CHANNEL WHICH IS CLASSICALLY OPEN AT BOTH ENDS
* INTERVAL)
* WE FIND:
* Y = 1 / { M M SIN[THETA -THETA ] }
* 2 1 2 2 1
* N SIN[PHI -THETA ]
* 1 1 2
* Y = ----------------------
* 1 M SIN[THETA - THETA ]
* 1 2 1
* N SIN[PHI -THETA ]
* 2 2 1
* Y = ----------------------
* 4 M SIN[THETA - THETA ]
* 2 2 1
* HERE THE SUBSCRIPTS 1 AND 2 IMPLY THE MODULI AND PHASES EVALUATED AT
*
* AND X = X , RESPECTIVELY
* 2
*-----------------------------------------------------------------------
* FOR BOTH X AND X POSITIVE
* 1 2
* (THIS CORRESPONDS TO A CHANNEL WHICH IS CLASSICALLY CLOSED AT BOTH EN
* THE INTERVAL)
* WE FIND:
* 1 / Y = M M COSH[Z -Z ] { SINH[THETA -THETA ]
* 2 1 2 2 1 1 2
* + TANH[Z -Z ] SINH[THETA +THETA ] }
* 2 1 1 2
* 3/2
* WHERE Z = (2/3) X AND SIMILARLY FOR Z
* 1 1 2
* N { SINH [THETA -PHI ] - TANH[Z -Z ] SINH[THETA +PHI ] }
* 1 2 1 2 1 2 1
* Y = --------------------------------------------------------
* 1 M { SINH [THETA -THETA ] + TANH[Z -Z ] SINH[THETA +THETA ] }
* 1 2 1 2 1 2 1
* N { SINH [THETA -PHI ] - TANH[Z -Z ] SINH[THETA +PHI ] }
* 2 1 2 2 1 1 2
* Y = --------------------------------------------------------
* 4 M { SINH [THETA -THETA ] + TANH[Z -Z ] SINH[THETA +THETA ] }
* 2 2 1 2 1 2 1
*-----------------------------------------------------------------------
* FOR X POSITIVE AND X NEGATIVE WE FIND:
* 1 2
* 1 / Y = M M COSH[Z ] COSH[THETA ] { - COS[THETA ] (1 + TANH[Z ])
* 2 1 2 1 1 2 1
* + TANH[THETA ] SIN[THETA ] (1 - TANH
* 1 2
* N { COS[THETA ](1 + TANH[Z ]) - TANH[PHI ] SIN[THETA ] (1 - TANH[
* 1 2 1 1 2
* Y = ------------------------------------------------------------------
* 1 M {-COS[THETA ](1 + TANH[Z ]) + TANH[THETA ] SIN[THETA ] (1 - TAN
* 1 2 1 1 2
* N {-COS[PHI ](1 + TANH[Z ]) + TANH[THETA ] SIN[PHI ] (1 - TANH[Z
* 2 2 1 1 2 1
* Y = -----------------------------------------------------------------
* 4 M {-COS[THETA ](1 + TANH[Z ]) + TANH[THETA ] SIN[THETA ] (1 - TAN
* 2 2 1 1 2
*-----------------------------------------------------------------------
* FOR X NEGATIVE AND X POSITIVE WE FIND:
* 1 2
* 1 / Y = M M COSH[Z ] COSH[THETA ] { COS[THETA ] (1 + TANH[Z ])
* 2 1 2 2 2 1 2
* - TANH[THETA ] SIN[THETA ] (1 - TANH[
* 2 1
* N {-COS[PHI ](1 + TANH[Z ]) + TANH[THETA ] SIN[PHI ] (1 - TANH[Z
* 1 1 2 2 1 2
* Y = -----------------------------------------------------------------
* 1 M {COS[THETA ](1 + TANH[Z ]) - TANH[THETA ] SIN[THETA ] (1 - TANH
* 1 1 2 2 1
* N { COS[THETA ](1 + TANH[Z ]) - TANH[PHI ] SIN[THETA ] (1 - TANH[
* 2 1 2 2 1
* Y = -----------------------------------------------------------------
* 4 M {COS[THETA ](1 + TANH[Z ]) - TANH[THETA ] SIN[THETA ] (1 - TANH
* 2 1 2 2 1
*-----------------------------------------------------------------------
* FOR THE SPECIAL CASE OF A CONSTANT REFERENCE POTENTIAL (HP=0)
* THEN THE PROPAGATORS ARE:
* FOR EIGNOW .GT. 0 (THE CLASSICALLY ALLOWED REGION)
* Y1 = Y4 = K COT (K WIDTH)
* Y2 = K / SIN (K WIDTH)
* WHERE K = SQRT (EIGNOW)
* FOR EIGNOW .LT. 0 (THE CLASSICALLY FORBIDDEN REGION)
* Y1 = Y4 = KAP COTH (KAP WIDTH)
* Y2 = KAP / SINH (KAP WIDTH)
*
* WHERE KAP = SQRT (-EIGNOW)
*-----------------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DOUBLE PRECISION DALPHA, DBETA, DHALF, DONETH, DROOT, DSLOPE,
: DTWOTH, DLZETA, DMMOD1, DMMOD2, DNMOD1, DNMOD2,
: DPI, DX1, DX2, DZETA1, DZETA2, DPHI1, DPHI2,
: DTHET1, DTHET2, DTNHFM, DTNHFP, DARG, DCAY, DKAP,
: OFLOW,X1,X2
* REAL B, BFACT, TNHFAC, WIDTH
* REAL EIGNOW(1), HP(1), Y1(1), Y2(1), Y4(1)
DIMENSION EIGNOW(1), HP(1), Y1(1), Y2(1), Y4(1)
INTEGER I, NCH
DATA DONETH, DTWOTH, DHALF
: / 0.333333333333333D0, 0.666666666666667D0, 0.5D0 /
DATA DPI / 3.1415926535897932D0 /
* THE PARAMETER OFLOW IS THE LARGEST VALUE OF X FOR WHICH EXP(X)
* DOES NOT CAUSE A SINGLE PRECISION OVERFLOW
* N
* A REASONABLE VALUE IS X = [ LN(2) 2 ] - 5, WHERE N IS THE NUMBER OF B
* THE CHARACTERISTIC OF A FLOATING POINT NUMBER
DATA OFLOW / 83.D0 /
* NOW DETERMINE B_MIN1, Y1, AND Y4 PARAMETERS FOR ALL NCH CHANNELS
DO 10 I = 1, NCH
DSLOPE = HP(I)
DARG = 1.E+10
IF (DSLOPE .NE. 0.D0)
: DARG = LOG (ABS(EIGNOW(I))) - LOG (ABS(DSLOPE))
IF (DARG .GT. 20.D0 ) THEN
* HERE IF THE RELATIVE SLOPE IN THE WAVEVECTOR MATRIX IS LESS THAN 1.**
* IN MAGNITUDE, IN WHICH CASE THE POTENTIAL IS ASSUMED TO BE CONSTANT
IF (EIGNOW(I) .GT. 0) THEN
* HERE FOR CLASSICALLY ALLOWED REGION (SINES AND COSINES AS REFERENCE
* SOLUTIONS)
DCAY = SQRT (EIGNOW(I))
DARG = DCAY * WIDTH
Y1(I) = DCAY / TAN (DARG)
Y4(I) = Y1(I)
Y2(I) = DCAY / SIN (DARG)
ELSE
* HERE FOR CLASSICALLY FORBIDDEN REGION (HYPERBOLIC SINES AND COSINES A
* REFERENCE SOLUTIONS)
DKAP = SQRT ( - EIGNOW(I))
DARG = DKAP * WIDTH
Y1(I) = DKAP / TANH (DARG)
Y4(I) = Y1(I)
Y2(I) = DKAP / SINH (DARG)
END IF
ELSE
* HERE IF THE RELATIVE SLOPE IN THE WAVEVECTOR MATRIX IS GREATER THAN
* 1.**(-20) IN MAGNITUDE, IN WHICH CASE A LINEAR REFERENCE POTENTIAL IS
* WITH AIRY FUNCTIONS AS REFERENCE SOLUTIONS
DROOT = ( ABS (DSLOPE) ) ** DONETH
DALPHA = SIGN (DROOT, DSLOPE)
DBETA = - EIGNOW(I) / DSLOPE
DX1 = DALPHA * ( DBETA - WIDTH * DHALF)
DX2 = DALPHA * ( DBETA + WIDTH * DHALF)
IF (DX1 .GT. 0.) DZETA1 = DTWOTH * DX1 * SQRT(DX1)
IF (DX2 .GT. 0.) DZETA2 = DTWOTH * DX2 * SQRT(DX2)
CALL AIRYMP (DX1, DTHET1, DPHI1, DMMOD1, DNMOD1)
CALL AIRYMP (DX2, DTHET2, DPHI2, DMMOD2, DNMOD2)
X1 = DX1
X2 = DX2
*-----------------------------------------------------------------------
IF (X1 .GT. 0. .AND. X2 .GT. 0.) THEN
* HERE FOR BOTH X AND X POSITIVE
* 1 2
TNHFAC = TANH(DZETA2 - DZETA1)
BFACT = SINH(DTHET1 - DTHET2) +
: TNHFAC * SINH(DTHET1 + DTHET2)
DLZETA = ABS(DZETA2 - DZETA1)
Y2(I) = 0.
IF (DLZETA .LE. OFLOW) THEN
B = DMMOD1 * DMMOD2 * COSH(DZETA2 - DZETA1) * BFACT
Y2(I) = 1. / B
END IF
Y1(I) = DNMOD1 * (SINH(DTHET2 - DPHI1)
: - TNHFAC * SINH(DTHET2 + DPHI1) ) / (DMMOD1 * BFACT)
Y4(I) = DNMOD2 * (SINH(DTHET1 - DPHI2)
: + TNHFAC * SINH(DTHET1 + DPHI2) ) / (DMMOD2 * BFACT)
*-----------------------------------------------------------------------
ELSE IF (X1 .LE. 0. .AND. X2 .LE. 0.) THEN
* HERE FOR BOTH X AND X NEGATIVE
* 1 2
B = DMMOD1 * DMMOD2 * SIN(DTHET2 - DTHET1)
Y2(I) = 1. / B
Y1(I) = DNMOD1 * SIN(DPHI1 - DTHET2)
: / (DMMOD1 * SIN(DTHET2 - DTHET1) )
Y4(I) = DNMOD2 * SIN(DPHI2 - DTHET1)
: / (DMMOD2 * SIN(DTHET2 - DTHET1) )
*-----------------------------------------------------------------------
ELSE IF (X1 .GT. 0. .AND. X2 .LE. 0.) THEN
* HERE FOR X POSITIVE AND X NEGATIVE
* 1 2
DTNHFP = 1 + TANH(DZETA1)
DTNHFM = 1 - TANH(DZETA1)
BFACT = COSH(DTHET1) * ( - COS(DTHET2) * DTNHFP
: + TANH(DTHET1) * SIN(DTHET2) * DTNHFM)
Y2(I) = 0.
IF (ABS(DZETA1) .LE. OFLOW) THEN
Y2(I) = COSH(DZETA1) * (DMMOD1 * DMMOD2 * BFACT)
Y2(I) = 1. / Y2(I)
END IF
Y1(I) = (DNMOD1 * COSH(DPHI1) * ( COS(DTHET2) * DTNHFP
: - TANH(DPHI1) * SIN(DTHET2) * DTNHFM) )
: / (DMMOD1 * BFACT)
Y4(I) = (DNMOD2 * COSH(DTHET1) * ( - COS(DPHI2) * DTNHFP
: + TANH(DTHET1) * SIN(DPHI2) * DTNHFM) )
: / (DMMOD2 * BFACT)
*-----------------------------------------------------------------------
ELSE IF (X2 .GT. 0. .AND. X1 .LE. 0.) THEN
* HERE FOR X POSITIVE AND X NEGATIVE
* 2 1
DTNHFP = 1 + TANH(DZETA2)
DTNHFM = 1 - TANH(DZETA2)
BFACT = COSH(DTHET2) * ( COS(DTHET1) * DTNHFP
: - TANH(DTHET2) * SIN(DTHET1) * DTNHFM)
Y2(I) = 0.
IF (ABS(DZETA2) .LE. OFLOW) THEN
Y2(I) = COSH(DZETA2) * (DMMOD1 * DMMOD2 * BFACT)
Y2(I) = 1. / Y2(I)
END IF
Y4(I) = (DNMOD2 * COSH(DPHI2) * ( COS(DTHET1) * DTNHFP
: - TANH(DPHI2) * SIN(DTHET1) * DTNHFM) )
: / (DMMOD2 * BFACT)
Y1(I) = (DNMOD1 * COSH(DTHET2) * ( - COS(DPHI1) * DTNHFP
: + TANH(DTHET2) * SIN(DPHI1) * DTNHFM) )
: / (DMMOD1 * BFACT)
*-----------------------------------------------------------------------
END IF
Y1(I) = DALPHA * Y1(I)
Y4(I) = DALPHA * Y4(I)
Y2(I) = DALPHA * Y2(I) / DPI
* AT THIS POINT THE Y1, Y2, AND Y4 PROPAGATORS CORRESPOND IDENTICALLY T
* EQS. (38)-(44) OF M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR
* REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..."
END IF
10 CONTINUE
RETURN
END
SUBROUTINE STABIL(N,NB,Y,YP,F1,F2,SCR,YN,YPN,F1N,F2N)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C FIND SCR SUCH THAT Y*SCR IS (PERMUTED) UNIT MATRIX,
C THEN TRANSFORM Y, YP, F1, AND F2 BY RIGHT MULTIPLICATION WITH SCR.
C
DIMENSION NB(N),Y(1),YP(1),F1(1),F2(1),
& YN(1),YPN(1),F1N(1),F2N(1),SCR(1)
C
C SAVE OLD INPUT MATRICES AND INITIALIZE SCR
C
NSQ=N*N
CALL DCOPY(NSQ,Y,1,YN,1)
CALL DCOPY(NSQ,YP,1,YPN,1)
CALL DCOPY(NSQ,F1,1,F1N,1)
CALL DCOPY(NSQ,F2,1,F2N,1)
DO 1100 IJ=1,NSQ
Y(IJ)=0.D0
1100 SCR(IJ)=0.D0
DO 1200 I=1,N
IJ=N*(I-1)+NB(I)
Y(IJ)=1.D0
1200 SCR(IJ)=1.D0
C
CALL DGESV(N,N,YN,N,YP,SCR,N,IER)
IF (IER.EQ.0) GO TO 2000
WRITE(6,600)
600 FORMAT(' * * * WARNING - STABILIZATION WITH BAD MATRIX.')
C
2000 CALL DGEMUL(YPN,N,'N',SCR,N,'N',YP,N,N,N,N)
CALL DGEMUL(F1N,N,'N',SCR,N,'N',F1,N,N,N,N)
CALL DGEMUL(F2N,N,'N',SCR,N,'N',F2,N,N,N,N)
C
RETURN
END
FUNCTION STEFF(X1,X2,IFLAG)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE D
C
C STEFFENSON ITERATION
C CONVERGENCE ACCELERATION FOR LINEAR CONVERGENCE
C
STEFF=X2
IF(IFLAG.EQ.1) D=0.D0
DEL=X2-X1
IF(DEL.EQ.0.D0) RETURN
RINV=D/DEL
D=DEL
IF(ABS(RINV).LE.0.4D0) RETURN
STEFF=STEFF+DEL/(RINV-1.D0)
D=0.D0
RETURN
END
SUBROUTINE STORAG(INTFLG,N,MXLAM,NV,NPOTL,
1 ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9,
2 ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT, NUMDER)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER PRINT
LOGICAL NUMDER
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C N.B. NIPR WAS NOT USED IN V11 STORAGE ROUTINE! SHOULD IT BE?
C
NSQ=N*N
C
C IC2 IS NEXT AVAILABLE LOCATION ...
IC2=IXNEXT
NUSED=0
C
C SOLVE COUPLED EQUATIONS BY METHOD OF DEVOGELAERE
C
IF(INTFLG.EQ.2) THEN
IT1=IC2
IT2=IT1+MXLAM
IT3=IT2+4*NSQ
IT4=IT3+2*NSQ
IT5=IT4+4*NSQ
IT6=IT5+NSQ
IT7=IT6+NSQ
IXNEXT=IT7+N
CALL CHKSTR(NUSED)
C
CALL DVSCAT(N,NSQ,MXLAM,NPOTL,
1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7),
2 X(IS8),X(IS9),
3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),
4 ESHIFT,ICODE,PRINT)
C
C SOLVE COUPLED EQUATIONS BY WALKER-LIGHT R-MATRIX PROPAGATOR METHOD
C
ELSE IF(INTFLG.EQ.3) THEN
IT1=IC2
IT2=IT1+MXLAM
IT3=IT2+NSQ
IT4=IT3+NSQ
IT5=IT4+N
IT6=IT5+N
IT7=IT6+N
IT8=IT7+N
IT9=IT8+N
IT10=IT9+N
IT11=IT10+N
IXNEXT=IT11+N
CALL CHKSTR(NUSED)
C
CALL RMTPRP(N,NSQ,MXLAM,NPOTL,
1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7),
2 X(ISJ),X(IS8),X(IS9),
3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8),
4 X(IT9),X(IT10),X(IT11),
5 NOPMAX,DEEP,IK,ICODE,PRINT,NV,0)
C
C SOLVE COUPLED EQUATIONS BY LOG DERIVATIVE/VIVAS
C
ELSE IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN
IT1=IC2
IT2=IT1+MXLAM
IF(NUMDER) IT2=IT2+2*MXLAM
IT3=IT2+N
IT4=IT3+N
IT5=IT4+N
IT6=IT5+N
IVIV=1
IF(INTFLG.EQ.5) IVIV=0
IT7=IT6+N*IVIV
IT8=IT7+N*IVIV
IT9=IT8+N*IVIV
IT10=IT9+N*IVIV
IT11=IT10+N*IVIV
IT12=IT11+N*IVIV
IT13=IT12+N*IVIV
IT14=IT13+N*IVIV
IT15=IT14+N*IVIV
IT16=IT15+N*IVIV
IT17=IT16+N*IVIV
IT18=IT17+NSQ*IVIV
IT19=IT18+NSQ*IVIV
IT20=IT19+NSQ*IVIV
IT21=IT20+NSQ*IVIV
IT22=IT21+NSQ*IVIV
IT23=IT22+NSQ*IVIV
IT24=IT23+NSQ*IVIV
IXNEXT=IT24+NSQ*IVIV
CALL CHKSTR(NUSED)
C
CALL LDVIVS(N,NSQ,MXLAM,NPOTL,
1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7),
2 X(IS8),X(IS9),
3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8),
4 X(IT9),X(IT10),X(IT11),X(IT12),X(IT13),X(IT14),
5 X(IT15),X(IT16),X(IT17),X(IT18),X(IT19),X(IT20),X(IT21),
6 X(IT22),X(IT23),X(IT24),
7 ICODE,PRINT)
C
C DIABATIC MODIFIED LOG DERIVATIVE ALGORITHM.
C
ELSE IF(INTFLG.EQ.6) THEN
IT1=IC2
IT2=IT1+MXLAM
IT3=IT2+N
IT4=IT3+N
IT5=IT4+N
IXNEXT=IT5+N
CALL CHKSTR(NUSED)
C
C N.B. IT5 IS PASSED SO SPECIAL N=1 CODE CAN OVERLAY STORAGE
CALL DASCAT(N,NSQ,MXLAM,NPOTL,
1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7),
2 X(IS8),X(IS9),
3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),
4 ICODE,PRINT, IT5 )
C
C QUASIADIABATIC MODIFIED LOG DERIVATIVE ALGORITHM.
C
ELSE IF(INTFLG.EQ.7) THEN
IT1=IC2
IT2=IT1+MXLAM
IT3=IT2+NSQ
IT4=IT3+NSQ
IT5=IT4+N
IT6=IT5+N
IT7=IT6+N
IT8=IT7+N
IT9=IT8+N
IXNEXT=IT9+N
CALL CHKSTR(NUSED)
C
CALL QASCAT(N,NSQ,MXLAM,NPOTL,
1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7),
2 X(IS8),X(IS9),
3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8),
4 X(IT9),
5 ICODE,PRINT)
C
C HYBRID DMLD/AIRY ALGORITHM OF ALEXANDER AND MANOLOPOULOS
C
ELSE IF(INTFLG.EQ.8) THEN
IT1=IC2
IT2=IT1+MXLAM
IT3=IT2+N
IT4=IT3+N
IT5=IT4+N
IT6=IT5+N
IT7=IT6+NSQ
IT8=IT7+NSQ
IT9=IT8+N
IU1=IT9+N
IXNEXT=IU1+N
CALL CHKSTR(NUSED)
C
CALL AXSCAT(N,NSQ,MXLAM,NPOTL,
1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7),
2 X(IS8),X(IS9),
3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),
$ X(IT6),X(IT7),X(IT8),X(IT9),X(IU1),
4 ICODE,PRINT)
C
ELSE IF (INTFLG.EQ.-1) THEN
C
C SOLVE EQUATIONS BY WKB USING GAUSS-MEHLER INTEGRATION.
C ONLY GOOD FOR ONE-CHANNEL CASES
C
IF (N.EQ.1) GO TO 810
WRITE(6,601) N
601 FORMAT('0 ***** ERROR. WKB (INTFLG=-1) ONLY IMPLEMENTED FOR',
1 ' ONE-CHANNEL CASE. TERMINATED WITH N =',I4)
STOP
810 IT1=IC2
IT2=IT1+1
IT3=IT2+1
IXNEXT=IT3+MXLAM
IF (NUMDER) IXNEXT=IXNEXT+2*MXLAM
CALL CHKSTR(NUSED)
CALL WKB(N,MXLAM,NPOTL,X(IT1),X(IS0),X(IS1),X(IT3),X(IS8),
1 X(IS5),X(IS6),X(IT2),X(IS9),X(IS7),X(IS3),X(IS4),
2 NUMDER,PRINT)
C
ELSE
WRITE(6,699) INTFLG
699 FORMAT('0 STORAG CALLED WITH AN ILLEGAL INTFLG=',I4)
STOP
ENDIF
C
C WE ARE FINISHED WITH THIS TEMPORARY STORAGE; RESTORE IXNEXT.
C THIS IS CONSISTENT W/ V11 WHICH DID NOT MODIFY STORAG IC2 ARGUMENT
C HOWEVER, THIS MEANS THAT ONE CANNOT EXPECT ALLOCATED STORAGE
C TO BE RETAINED BEYOND A SCATTERING CALL
IXNEXT=IC2
RETURN
END
SUBROUTINE STRY(NLB,NUB,N,ITRY,EIGNEW)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE ITOLD
C
C THIS TESTS TO SEE IF ALL THE OFF-DIAGONAL ELEMENTS OF THE
C EIGENVECTORS HAVE BECOME NEGLIGIBLE COMPARED TO VTOL
C
DIMENSION NLB(1),NUB(1)
DIMENSION EIGNEW(1)
C TOLERANCE TO DETERMINE DEGENERACY.
DATA EPSIL / 1.D-2/
C STORE OLD VALUE OF ITRY
ITOLD = ITRY
IF(N.LE.1) GO TO 15
DO 10 I=1,N
C TEST FOR DEGENERACY
IF(I.EQ.1) GO TO 8
DIFF = ABS(EIGNEW(I)-EIGNEW(I-1))
C IF NEARLY DEGENERATE, DON'T BOTHER TO CHECK OFF-DIAGONAL
C EIGENVECTOR COMPONENTS
IF(DIFF.LT.EPSIL ) GO TO 10
IF(I.EQ.N) GO TO 9
8 DIFF = ABS(EIGNEW(I)-EIGNEW(I+1))
IF(DIFF.LT.EPSIL ) GO TO 10
9 IF(NLB(I).NE.NUB(I)) GO TO 20
10 CONTINUE
C IF THE FOLLOWING STATEMENT IS REACHED, ALL COMPONENTS ARE
C INDEED NEGLIGIBLE OR DEGENERATE
15 ITRY = 0
GO TO 30
C THIS IS REACHED WHEN AN ELEMENT IS TOO LARGE.
20 ITRY = -1
RETURN
30 IF(ITOLD.EQ.0 .AND. ITRY.EQ.0) ITRY = 1
C THIS MAKES SURE THAT THE ELEMENTS WERE ALSO NEGLIGIBLE AT THE
C LAST STEP.
C ITRY = 1 ON RETURN MEANS READY TO TRY FOR S-MATRIX CONVERGENCE
RETURN
END
LOGICAL FUNCTION STSRCH(LOG,LLOG,LSTR,N,I4)
C VERSION OF 21 MAR 95
CHARACTER*1 LOG,LLOG,LSTR(N)
IF (N.LE.0) GO TO 9000
DO 1000 I=1,N
IF (LSTR(I).NE.LOG.AND.LSTR(I).NE.LLOG) GO TO 1000
I4=I
STSRCH=.TRUE.
RETURN
1000 CONTINUE
9000 STSRCH=.FALSE.
I4=0
RETURN
END
SUBROUTINE SURBAS(JLEV, N, J, L, EINT, CENT, VL, IV,
1 MXLAM, NPOTL, LAM, ERED, WVEC, LCNT, THETA, PHI, EMAXK)
C
C SUBROUTINE TO SET UP ATOM-SURFACE SCATTERING.
C THIS VERSION USES 2 ELEMENTS OF THE VL ARRAY FOR EACH PAIR OF
C BASIS FUNCTIONS, SO REQUIRES NPOTL=2 RETURNED FROM POTENL.
C COMMON BLOCK NPOT COMMUNICATES THIS TO POTENL
C VERSION 14 CMBASE
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
SAVE
INTEGER FIND
LOGICAL LCNT,LEVIN,EIN,HEX,ORTHOG,EQUIV
DIMENSION JLEV(1), J(1), L(1), EINT(1), CENT(1),
1 WVEC(1), VL(1), IV(1), LAM(1)
COMMON/NPOT/NPTL
COMMON/CMBASE/ROTI(12),ELEVEL(1000),EMAX,WT(2),SPNUC,NLEVEL,
1 JLEVEL(4000),J1MIN,
2 J1MAX,J1STEP,IS1(10),J2MIN,J2MAX,J2STEP,IS2(10),JHALF,IDENT
3 ,MXJL,MXEL
COMMON/LATSYM/HEX,ORTHOG,EQUIV
DATA BFCT/16.857630D0/
C
SQUARE(A,B) = A*A + B*B + 2.D0*A*B*COSLAT
C
C ISYM IS A LABEL FOR THE TYPE OF SYMMETRIZATION:
C < 0 NO SYMMETRIZATION
C = 0 0 DEGREE SYMMETRIZATION FOR RECTANGULAR OR HEX LATTICE
C = 1 30 DEGREE SYMMETRIZATION FOR HEX LATTICE
C = 2 45 DEGREE SYMMETRIZATION FOR SQUARE LATTICE
C
ISYM = -1
IF((HEX.OR.ORTHOG) .AND. ABS(PHI).LT.1.D-10) ISYM = 0
IF(HEX .AND. ABS(MOD(PHI,60.D0)-30.D0).LT.1.D-10) ISYM = 1
IF(ORTHOG .AND. EQUIV .AND. ABS(MOD(PHI,90.D0)-45.D0).LT.1.D-10)
1 ISYM = 2
C
PARA=SQRT(ERED)*SIN(THETA*PI/180.D0)
SINPHI=SIN(PHI*PI/180.D0)
COSPHI=COS(PHI*PI/180.D0)
XK2=PARA*SINPHI/SINLAT
XK1=PARA*COSPHI-XK2*COSLAT
IF(LCNT) GOTO 50
WRITE(6,598)N,THETA,PHI,XK1,XK2
598 FORMAT(/I4,' CHANNEL BASIS FOR THETA =',F8.3,' PHI =',F8.3,
1 ' DEGREES'/' CORRESPONDING TO K = (',2F10.6,' ) A-1')
IF(ISYM.GE.0) WRITE(6,599)
599 FORMAT(' SYMMETRIZED BASIS USED FOR THESE ANGLES'/
1 ' NOTE THAT CALCULATED INTENSITIES FOR OUT-OF-PLANE BEAMS',
2 ' ARE IMPLICITLY SUMMED OVER EQUIVALENT PAIRS')
IF(EMAXK.NE.EMAX) WRITE(6,600) EMAXK
600 FORMAT(' BASIS FUNCTIONS LIMITED BY EMAXK =',F10.3)
C
50 I=0
N=0
DO 200 N1=1,NLEVEL
J1=JLEV(N1+NLEVEL)
IF(ISYM.GE.0 .AND. 2*J1.LT.ISYM*JLEV(N1)) GOTO 200
A=XK1+XH*DBLE(JLEV(N1))
B=XK2+XK*DBLE(J1)
ECHAN=SQUARE(A,B)
IF(ECHAN*ESCALE.GT.EMAXK) GOTO 200
N=N+1
IF(LCNT) GOTO 200
EINT(N)=ECHAN
DIF=ERED-ECHAN
WVEC(N)=SIGN(SQRT(ABS(DIF)),DIF)
J(N)=JLEV(N1+NLEV2)
L(N)=0
CENT(N)=0.D0
DO 100 M=1,N
N2=J(M)
J2=JLEV(N2+NLEVEL)
IF(ISYM.GE.0 .AND. 2*J2.LT.ISYM*JLEV(N2)) GOTO 100
I=I+1
I1=JLEV(N2)-JLEV(N1)
I2=J2-J1
IV(I)=FIND(I1,I2,LAM,MXLAM)
VL(I)=1.D0
IF(IV(I).EQ.0) VL(I)=0.D0
I=I+1
IV(I)=0
VL(I)=0.D0
IF(ISYM.LT.0) GOTO 100
IF(2*J1.EQ.ISYM*JLEV(N1) .NEQV. 2*J2.EQ.ISYM*JLEV(N2))
1 VL(I-1)=VL(I-1)*ROOT2
IF(2*J1.EQ.ISYM*JLEV(N1) .OR. 2*J2.EQ.ISYM*JLEV(N2)) GOTO 100
C
C IDENTIFY FOURIER COMPONENT CONNECTING SIGMA(N1) TO N2
C
GOTO(70,80),ISYM
I1=JLEV(N1)
IF(HEX) I1=I1-J1
I2=-J1
GOTO 90
70 I1=JLEV(N1)
I2=I1-J1
GOTO 90
80 I1=J1
I2=JLEV(N1)
90 I1=JLEV(N2)-I1
I2=J2-I2
IV(I)=FIND(I1,I2,LAM,MXLAM)
VL(I)=1.D0
IF(IV(I).EQ.0) VL(I)=0.D0
100 CONTINUE
200 CONTINUE
RETURN
C
C
ENTRY SET8(LEVIN,EIN,NLEV,JLEV,URED)
C
NPTL=2
ROOT2=SQRT(2.D0)
ESCALE=BFCT/URED
C
EMIN=0.D0
PI=ACOS(-1.D0)
COSLAT=COS(ROTI(3)*PI/180.D0)
SINLAT=SIN(ROTI(3)*PI/180.D0)
ORTHOG = ABS(COSLAT).LT.1.D-8
EQUIV = ABS(ROTI(1)-ROTI(2)).LT.1.D-8
HEX = EQUIV .AND. ABS(COSLAT+0.5D0).LT.1.D-8
XH=2.D0*PI/SINLAT/ROTI(1)
XK=2.D0*PI/SINLAT/ROTI(2)
WRITE(6,601)(ROTI(I),I=1,3),COSLAT
601 FORMAT(' LATTICE LENGTHS ARE',F10.6,' AND',F10.6,' A'/
1 ' RECIPROCAL LATTICE ANGLE IS ',F10.3,' DEGREES,',
2 ' COSINE =',F10.6/)
C
IF(LEVIN) GOTO 500
WRITE(6,602)EMIN,EMAX,J1MAX,J2MAX
602 FORMAT(' BASIS FUNCTIONS GENERATED WITH'/5X,'EMIN =',F10.3/
1 5X,'EMAX =',F10.3/5X,'G1MAX =',I10/5X,'G2MAX =',I10/)
N1MAX=SQRT(EMAX)/(SINLAT*XH)
N1MAX=MIN0(N1MAX,J1MAX)
NLEVEL=0
DO 300 N1=-N1MAX,N1MAX
A=DBLE(N1)*XH
B=A*COSLAT
N2MAX=(ABS(B)+SQRT(EMAX+B*B-A*A))/XK
N2MAX=MIN0(N2MAX,J2MAX)
DO 300 N2=-N2MAX,N2MAX
B=DBLE(N2)*XK
E=SQUARE(A,B)*ESCALE
IF(E.LT.EMIN .OR. E.GT.EMAX) GOTO 300
NLEVEL=NLEVEL+1
JLEVEL(2*NLEVEL-1)=N1
JLEVEL(2*NLEVEL) =N2
ELEVEL(NLEVEL)=E
300 CONTINUE
C
C SORT CHANNELS ON ENERGY FOR K=0
C
DO 400 N1=1,NLEVEL
DO 400 N2=N1+1,NLEVEL
IF(ELEVEL(N2).GE.ELEVEL(N1)) GOTO 400
E=ELEVEL(N1)
ELEVEL(N1)=ELEVEL(N2)
ELEVEL(N2)=E
I1=2*N1
I2=2*N2
I=JLEVEL(I1-1)
JLEVEL(I1-1)=JLEVEL(I2-1)
JLEVEL(I2-1)=I
I=JLEVEL(I1)
JLEVEL(I1)=JLEVEL(I2)
JLEVEL(I2)=I
400 CONTINUE
GOTO 700
C
500 DO 520 N1=1,NLEVEL
DO 520 N2=N1+1,NLEVEL
520 IF (JLEVEL(2*N1-1).EQ.JLEVEL(2*N2-1)
1 .AND. JLEVEL(2*N1) .EQ.JLEVEL(2*N2)) GOTO 530
GOTO 540
530 WRITE(6,603)N1,N2
603 FORMAT(' **** BASIS FUNCTIONS',I3,' AND',I3,' ARE THE SAME.',
1 ' TERMINATING.')
STOP
540 WRITE(6,604)NLEVEL
604 FORMAT(' BASIS FUNCTIONS TAKEN FROM JLEVEL INPUT WITH NLEVEL =',
1 I3)
700 NLEV=NLEVEL
NLEV2=NLEV+NLEV
DO 800 I=1,NLEV
N1=JLEVEL(2*I-1)
N2=JLEVEL(2*I)
JLEV(I)=N1
JLEV(I+NLEV)=N2
JLEV(I+NLEV2)=I
IF(.NOT.LEVIN) GOTO 800
A=DBLE(N1)*XH
B=DBLE(N2)*XK
ELEVEL(I)=SQUARE(A,B)*BFCT/URED
800 CONTINUE
C
IF(EIN) WRITE(6,605)
605 FORMAT(' *** NOTE. INPUT CHANNEL ENERGIES OVERWRITTEN BY VALUES',
1 ' CALCULATED FROM LATTICE PARAMETERS'/)
RETURN
END
SUBROUTINE SWRITE(IU,N,S)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION S(N,N)
C
WRITE(IU) ((S(I,J),J=1,I),I=1,N)
RETURN
C
ENTRY SREAD(IU,N,S,IEND)
IEND=0
READ(IU,END=9999) ((S(I,J),J=1,I),I=1,N)
DO 1000 I=1,N
DO 1000 J=1,I-1
1000 S(J,I)=S(I,J)
RETURN
9999 IEND=1
RETURN
END
SUBROUTINE SYMINV(A, IA, N, INERT)
C
C SIMULATES SYMINV SYMMETRIC MATRIX INVERTER WITH LAPACK CALLS
C THIS VERSION USES ONLY THE UPPER TRIANGLE OF A:
C NOT COMPATIBLE WITH MOLSCAT VERSION 11.
C JMH MAY 93
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
DIMENSION A(IA,N)
C
IT1=IXNEXT
IT2=IT1+(N+1)/NIPR
LWORK=MX-IT2+1
C
NB=ILAENV(1,'DSYTRF','L',N,-1,-1,-1)
LWREQ=N*NB
IF(LWORK.LT.LWREQ) THEN
WRITE(6,100) LWORK,N,NB
100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE',
1 ' IN SYMINV.'/' LAPACK ROUTINE DSYTRF NEEDS AT LEAST N*NB:',
2 ' N =',I5,' AND NB =',I5,' ON THIS CALL.')
STOP
ENDIF
C
IXNEXT=IT2+LWREQ
NUSED=0
CALL CHKSTR(NUSED)
C
CALL DSYTRF('L',N,A,IA,X(IT1),X(IT2),LWORK,INFO)
C
IF (INFO .NE. 0) THEN
WRITE (6,120) INFO
120 FORMAT(' *** ERROR IN DSYTRF: INFO =',I3)
STOP
END IF
C
INERT=0
C CALL DSYNEG(A,X(IT1),N,INERT)
C
CALL DSYTRI('L',N,A,IA,X(IT1),X(IT2),INFO)
C
IF (INFO .NE. 0) THEN
WRITE (6,130) INFO
130 FORMAT(' *** ERROR IN DSYTRI: INFO =',I3)
STOP
END IF
C
IXNEXT=IT1
C
RETURN
END
FUNCTION THREEJ (J1,J2,J3)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C COMPUTATION OF SPECIAL WIGNER 3J COEFFICIENT WITH
C VANISHING PROJECTIONS. SEE EDMONDS, P. 50.
C
C THIS VERSION EVALUATES BINOM AND PARITY IN-LINE
C SHOULD IMPROVE EFFICIENCY, ESPECIALLY ON CRAY;
C ALSO GIVES IMPROVEMENT ON AMDAHL (SG: 20 DEC 92)
C
C STATEMENT FUNCTION FOR DELTA ASSOCIATED W/ RACAH AND SIXJ SYMBOLS
C DELTA(I,J,K)= SQRT(1.D0/ ( BINOM(I+J+K+1,I+J-K) *
C 1 BINOM(K+K+1,I-J+K) * DBLE(K+J-I+1) ) )
C
I1=J1+J2+J3
IF (I1-2*(I1/2).NE.0) GO TO 8
1 I2=J1-J2+J3
IF (I2) 8,2,2
2 I3=J1+J2-J3
IF (I3) 8,3,3
3 I4=-J1+J2+J3
IF (I4) 8,4,4
4 I5=I1/2
I6=I2/2
SIGN=1.D0
IF (I5-2*(I5/2).NE.0) SIGN=-SIGN
C 7 THREEJ=SIGN*DELTA(J1,J2,J3)*BINOM(I5,J1)*BINOM(J1,I6)
C B1,B2 ARE BINOM ASSOCIATED W/ DELTA
N=J1+J2+J3+1
M=J1+J2-J3
NM = N-M
MNM = MIN(NM,M)
IF(MNM.LE.0) THEN
B1=1.D0
ELSE
FN = N+1
F = 0.D0
B = 1.D0
DO 101 I = 1,MNM
F = F+1.D0
C = (FN-F)*B
101 B = C/F
B1 = B
ENDIF
N=J3+J3+1
M=J1-J2+J3
NM = N-M
MNM = MIN(NM,M)
IF(MNM.LE.0) THEN
B2=1.D0
ELSE
FN = N+1
F = 0.D0
B = 1.D0
DO 102 I = 1,MNM
F = F+1.D0
C = (FN-F)*B
102 B = C/F
B2 = B
ENDIF
DELTA=SQRT(1.D0/(B1*B2*(J3+J2-J1+1)))
C B3=BINOM(I5,J1), B4=BINOM(J1,I6)
N=I5
M=J1
NM = N-M
MNM = MIN(NM,M)
IF(MNM.LE.0) THEN
B3=1.D0
ELSE
FN = N+1
F = 0.D0
B = 1.D0
DO 103 I = 1,MNM
F = F+1.D0
C = (FN-F)*B
103 B = C/F
B3 = B
ENDIF
N=J1
M=I6
NM = N-M
MNM = MIN(NM,M)
IF(MNM.LE.0) THEN
B4=1.D0
ELSE
FN = N+1
F = 0.D0
B = 1.D0
DO 104 I = 1,MNM
F = F+1.D0
C = (FN-F)*B
104 B = C/F
B4 = B
ENDIF
THREEJ=SIGN*DELTA*B3*B4
RETURN
8 THREEJ=0.D0
RETURN
END
FUNCTION THRJ(F1,F2,F3,G1,G2,G3)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C SMALL CHANGES 31 JUL 95 (SG)
SAVE MUNG,X,Y
PARAMETER (MXIX=302)
DIMENSION X(MXIX),Y(MXIX)
DATA MUNG/0/
IF (MUNG.EQ.21) GO TO 69
MUNG = 21
X(1) = 0.D0
DO 100 I = 1, MXIX-1
A = I
X(I+1) = LOG(A) +X(I)
Y(I+1) = LOG(A)
100 CONTINUE
69 IF(F1-ABS(G1)) 1,13,13
13 IF(F2-ABS(G2))1,14,14
14 IF(F3-ABS(G3))1,15,15
15 SUM=F1+F2+F3
NSUM=SUM+.001D0
IF(SUM-NSUM)2,2,1
1 THRJ=0.D0
RETURN
2 IF(ABS(G1+G2+G3)-1.D-08)3,3,1
3 IF(F1+F2-F3)1,4,4
4 IF(F1+F3-F2)1,5,5
5 IF(F2+F3-F1)1,6,6
6 J1=2.D0*F3+2.001D0
J2=F1+F2-F3+1.001D0
J3=F1-F2+F3+1.001D0
J4=-F1+F2+F3+1.001D0
J5=F1+F2+F3+2.001D0
J6=F1+G1+1.001D0
J7=F1-G1+1.001D0
J8=F2+G2+1.001D0
J9=F2-G2+1.001D0
J10=F3+G3+1.001D0
J11=F3-G3+1.001D0
IF(J5.GT.MXIX) THEN
WRITE(6,601) J5,MXIX
601 FORMAT(' *** DIMENSION ERROR IN THRJ - INDEX.GT.MXIX',2I5)
STOP
ENDIF
R=0.5D0*(Y(J1)+X(J2)+X(J3)+X(J4)-X(J5)
1+X(J6)+X(J7)+X(J8)+X(J9)+X(J10)+X(J11))
SUM=0.D0
F=-1
KZ=-1
7 KZ=KZ+1
F=-F
J1=KZ+1
J2=F1+F2-F3-KZ+1.001D0
IF(J2)20,20,8
8 J3=F1-G1-KZ+1.001D0
IF(J3)20,20,9
9 J4=F2+G2-KZ+1.001D0
IF(J4)20,20,10
10 J5=F3-F2+G1+KZ+1.001D0
IF(J5)7,7,11
11 J6=F3-F1-G2+KZ+1.001D0
IF(J6)7,7,12
12 JMAX=MAX(J1,J2,J3,J4,J5,J6)
IF(JMAX.GT.MXIX) THEN
WRITE(6,601) JMAX,MXIX
STOP
ENDIF
S=-(X(J1)+X(J2)+X(J3)+X(J4)+X(J5)+X(J6))
SUM=SUM+F*EXP(R+S)
GO TO 7
20 INT=ABS(F1-F2-G3)+0.0001D0
VAL=((-1.D0)**INT)*SUM/SQRT(2.D0*F3+1.D0)
IF(ABS(VAL).LE.1.D-6) VAL=0.D0
THRJ=VAL
RETURN
END
SUBROUTINE TRNSFM(T,W,A,N,ISTOP,ISYM)
C-------------------------------------------------------------------
C WRITTEN BY G. A. PARKER.
C MODIFIED TO USE BLAS BY J. M. HUTSON
C THIS ROUTINE TRANSFORMS THE MATRIX W INTO A NEW BASIS SET
C ISTOP=.TRUE. ==> RETURN AFTER A = TRANSPOSE(W) * T
C ISTOP=.FALSE. ==> CONTINUE TO FORM W = TRANSPOSE(T) * W * T
C ISYM =.TRUE. ==> FORCE THE RESULTING MATRIX TO BE SYMMETRIC.
C N IS THE DIMENSION OF THE MATRICES.
C-------------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
LOGICAL ISTOP,ISYM
DIMENSION T(1),W(1),A(1)
DATA ZERO/0.D0/,HALF/0.5D0/,ONE/1.D0/
C-------------------------------------------------------------------
C MULTIPLY THE TRANSPOSE OF THE MATRIX W TIMES T AND
C STORE THE RESULT INTO MATRIX A.
C-------------------------------------------------------------------
IF (N.EQ.1) GOTO 300
IF (ISYM) GOTO 140
CALL DGEMUL(W,N,'T',T,N,'N',A,N,N,N,N)
IF (ISTOP) RETURN
C-------------------------------------------------------------------
C MULTIPLY THE TRANSPOSE OF MATRIX A TIMES MATRIX
C T AND STORE THE RESULT INTO MATRIX W
C-------------------------------------------------------------------
CALL DGEMUL(A,N,'T',T,N,'N',W,N,N,N,N)
RETURN
C-------------------------------------------------------------------
C THIS IS REACHED ONLY WHEN W AND THE RESULT MATRIX ARE SYMMETRIC,
C SO THAT ONLY HALF THE MATRIX NEED BE COMPUTED
C AND THE OTHER HALF STORED BY SYMMETRY.
C-------------------------------------------------------------------
140 CALL DSYMM('L','L',N,N,ONE,W,N,T,N,ZERO,A,N)
IF (ISTOP) RETURN
CALL DSYR2K('L','T',N,N,HALF,A,N,T,N,ZERO,W,N)
CALL DSYFIL('U',N,W,N)
RETURN
C
300 A(1)=W(1)*T(1)
IF (ISTOP) RETURN
W(1)=A(1)*T(1)
RETURN
END
SUBROUTINE TRNSP(A,N)
C
C SUBROUTINE FOR IN-PLACE TRANSPOSITION OF N X N MATRIX A
C BASED ON MILLARD ALEXANDER'S TRANSP
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION A(1)
ICOLPT = 2
IROWPT = N + 1
DO 100 ICOL = 1, N - 1
C ICOLPT POINTS TO FIRST SUB-DIAGONAL ELEMENT IN COLUMN ICOL
C IROWPT POINTS TO FIRST SUPER-DIAGONAL ELEMENT IN ROW ICOL
C NROW IS NUMBER OF SUBDIAGONAL ELEMENTS IN THIS COLUMN
NROW = N - ICOL
CALL DSWAP (NROW, A(ICOLPT), 1, A(IROWPT), N)
ICOLPT = ICOLPT + N + 1
IROWPT = IROWPT + N + 1
100 CONTINUE
RETURN
END
SUBROUTINE VINIT(I,RM,EPSIL)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
RM=.529177D0
EPSIL=219474.63D0
c ENTRY VSTAR (I,RR,SUM)
c ENTRY VSTAR1(I,RR,SUM)
c ENTRY VSTAR2(I,RR,SUM)
c WRITE(6,601) I
c 601 FORMAT('0 *** ERROR. DUMMY VERSION OF VINIT CALLED WITH I =',
c 1 I4/14X,'VINIT MUST BE PROVIDED IF NTERM(I) IS ZERO.')
c STOP
END
SUBROUTINE VIVAS(N,NSQ,DRNOW,RMIN,RMAX,DRMAX,TLDIAG,TOFF,
X ESHIFT,RMAT,EYE11,EYE12,EYE22,W,W0,W1,W2,TSTORE,
X VECOLD,VECNEW,G1,G1P,G2,G2P,A1,A1P,B1,B1P,
X XSQ,XK,COSX,SINX,SINE,DIAG,NOPEN,PRNTLV,ISC,
X P,VL,IVL,ERED,EINT,CENT,RMLMDA,MXLAM,WKS,NPOTL)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C------------------------------------------------------------------
C MODIFIED FROM NRCC CODE FOR COMPATIBILITY WITH MOLSCAT
C BY S. GREEN (FEB. 1981) AND J.M. HUTSON (OCT. 1984)
C APR 87 MODIFY WARNING OUTPUT ASSOC. W/ 1800 FORMAT
C------------------------------------------------------------------
C ROUTINES USED
C WAVMAT -CALCULATES THE POTENTIAL ENERGY INTERACTION MATRIX
C DERMAT -CALCULATES THE FIRST AND SECOND DERIVATIVES OF THE POTENTIAL
C TRNSFM -TRANSFORMS MATRICES INTO THE NEW BASIS VIA A
C SIMILARITY TRANSFORMATION
C PERT1 -CALCULATES THE PERTURBATION CORRECTIONS TO THE
C PERT2 WAVEFUNCTONS.
C DGESV -SOLVES A LINEAR SYSTEMS OF EQUATIONS.
C DELRD -PREDICTS THE NEW STEP SIZE.
C F02ABF -DIAGONALIZES A REAL SYMMETRIC MATRIX AND RETURN THE
C EIGENVALUES AND EIGENVECTORS.
C------------------------------------------------------------------
C ON ENTERING
C N - NUMBER OF CHANNELS
C NSQ - N*N
C DRNOW - INITIAL STEP SIZE
C RMIN - MINIMUM RADIAL DISTANCE
C RMAX - MAXIMUM RADIAL DISTANCE
C DRMAX - MAXIMUM ALLOWED STEP SIZE
C TLDIAG- STEP TOLERANCE PARAMETER
C TOFF - INTERVAL TOLERANCE PARAMETER
C ISC - SCRATCH UNIT USED IF IREAD/IWRITE IS TRUE
C--------------------------------------------------------------------
C PRINT LEVEL FOR MOLSCAT
INTEGER PRNTLV
C------------------------------------------------------------------
C CHARACTER VARIABLES
C------------------------------------------------------------------
CHARACTER*4 LRMAT,LUDP,LUD,LDG2P,LDG2,LDG1P,LDG1,LG2P,
1 LG2,LG1P,LG1,LW0,LW2,LVECNW,LDIAG,LW1,LEYE11,LEYE12,LEYE22
C-------------------------------------------------------------------
C LOGICAL VARIABLES
C-------------------------------------------------------------------
LOGICAL IVD,IVPD,IVPPD,IALFP,NUMDER
LOGICAL IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,ITHS
LOGICAL ITRUE,IFALSE,NEWINT
LOGICAL IV,IVP,IVPP,ISHIFT,IREAD,IDIAG,IWRITE,ICRMAT
LOGICAL IPERT,LAST,ISYM
C-------------------------------------------------------------------
C LABELLED COMMONS
C CONTROL VARIABLES PASSED FROM DRIVER
C-------------------------------------------------------------------
COMMON/LDVVCM/ XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP,
1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE
C-------------------------------------------------------------------
C IF THE LOGICAL VARIABLE IS TRUE THEN
C IV - CALCULATES PERTURBATION CORRECTIONS FROM THE CONSTANT
C TERMS IN THE INTERACTION POTENTIAL.
C IVP - CALCULATES PERTURBATION CORRECTIONS FROM THE FIRST
C DERIVATIVE OF THE INTERACTION POTENTIAL.
C IVPP - CALCULATES PERTURBATION CORRECTIONS FROM THE SECOND
C DERIVATIVE OF THE INTERACTION POTENTIAL.
C ISHIFT- SHIFTS THE REFERENCE POTENTIAL TO BEST FIT THE TRUE
C POTENTIAL.
C NUMDER- CALCULATES POTENTIAL DERIVATIVES NUMERICALLY
C IDIAG - INCLUDES ALL OF THE DIAGONAL PERTUBATION CORRECTIONS.
C ISYM - SYMMETRIZES THE R-MATRIX AT EACH INTERVAL.
C IPERT - USES THE PERTURBATIONS CORRECTIONS.
C IALFP - THE GEOMETRIC PROGRESSION PARAMETER ALPHA IS PREDICTED.
C ALPHA1- MINIMUM GEOMETRIC PROGRESSION PARAMETER.
C ALPHA2- MAXIMUM GEOMETRIC PROGRESSION PARAMETER.
C IALPHA- IF IALPHA.GT.0 THEN THE STEP SIZE IS DETERMINED USING
C A GEOMETRIC PROGRESSION AND THE INTERVAL IS DIVIDED
C INTO IALPHA STEPS.
C------------------------------------------------------------------
COMMON/POPT/IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,IOC
LOGICAL LPOPT(7)
EQUIVALENCE (LPOPT(1),IVECT)
C LPOPT CONTAINS PRINTING OPTIONS FROM NRCC VERSION.
C THESE ARE ALL SET FALSE HERE. CHANGE TO DEBUG.
C WHEN THE LOGICAL VARIABLE IS TRUE,
C IVECT - EIGENVALUES AND EIGENVECTORS.
C IPOTL - POTENTIAL ENERGY MATRICES AND ITS DERIVATIVES.
C IEYE - ACCUMULATED PERTURBATION INTEGRALS.
C IGZRO - ZERO-TH ORDER WAVEFUNCTIONS.
C IGPERT- PERTURBED WAVEFUNCTIONS.
C IWAVE - PERTURBED WAVEFUNCTIONS.
C IRMAT - R-MATRIX
C IOC - INFORMATION PRINTED EVERY IOC-TH STEP
C--------------------------------------------------------------------
C ARRAYS DIMENSIONED AS VECTORS
C-------------------------------------------------------------------
DIMENSION G1(N),G1P(N),G2(N),G2P(N)
DIMENSION A1(N),A1P(N),B1(N),B1P(N)
DIMENSION XSQ(N),XK(N),COSX(N),SINX(N),SINE(N),DIAG(N)
C-------------------------------------------------------------------
C ARRAYS DIMENSIONED AS MATRICES
C-------------------------------------------------------------------
DIMENSION EYE11(NSQ),EYE12(NSQ),EYE22(NSQ)
DIMENSION W0(NSQ),W1(NSQ),W2(NSQ),W(NSQ)
DIMENSION RMAT(NSQ)
DIMENSION TSTORE(NSQ),VECOLD(NSQ),VECNEW(NSQ)
DIMENSION P(MXLAM),VL(2),IVL(2),EINT(N),CENT(N),WKS(N)
C-------------------------------------------------------------------
C DATA STATEMENTS FOR PRINTING
C-------------------------------------------------------------------
DATA LRMAT/'RMAT'/,LUDP/' UP'/,LUD/' U'/,LDG2P/'DG2P'/
DATA LDG2/' DG2'/,LDG1P/'DG1P'/,LDG1/' DG1'/,LG2P/' G2P'/
DATA LG2/' G2'/,LG1P/' G1P'/,LG1/' G1'/,LW0/' W0'/
DATA LW2/' W2'/,LVECNW/'VCNW'/,LDIAG/'DIAG'/
DATA LW1/' W1'/,LEYE11/' I11'/,LEYE12/' I12'/,LEYE22/' I22'/
C-------------------------------------------------------------------
C LOGICAL DATA STATEMENTS
C-------------------------------------------------------------------
DATA IFALSE/.FALSE./,ITRUE/.TRUE./
C-------------------------------------------------------------------
C
C SET DEFAULT VALUES FOR PRINTING
NSGERR=0
IOC=5
DO 100 I=1,7
100 LPOPT(I)=.FALSE.
IF(.NOT.(IREAD.AND.IWRITE)) GO TO 101
WRITE(6,699)
699 FORMAT('0 * * * ERROR. IREAD AND IWRITE CANNOT BOTH BE TRUE.')
IREAD=.FALSE.
IWRITE=.FALSE.
101 CONTINUE
IVD = IV .OR. IDIAG
IVPD = IVP .OR. IDIAG
IVPPD = IVPP .OR. IDIAG
C-------------------------------------------------------------------
C PRINT CONTROL DATA
IF(PRNTLV.LE.15) GO TO 110
WRITE(6,1200)
WRITE(6,1300) IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,
X IWRITE,IREAD,IOC
WRITE(6,1400)
WRITE(6,1500) IV,IVP,IVPP,ISHIFT,IDIAG,ISYM,IPERT,IALFP
WRITE(6,1600) ALPHA1,ALPHA2,IALPHA
WRITE(6,2500)
WRITE(6,2600) RMIN,RMAX,DRNOW,DRMAX,TOFF,TLDIAG
110 COFFL = 0.D0
IF(N .EQ. 0) RETURN
NEWINT = .FALSE.
NP1 = N+1
ICRMAT = .TRUE.
TOL = 1.D-11
LAST = .FALSE.
ITRANS = 0
IK = 0
DO 130 I = 1,N
G1(I) = 0.D0
G1P(I) = 1.D0
G2(I) = 1.D0
G2P(I) = 0.D0
DO 130 K = 1,N
IK = IK+1
VECNEW(IK) = 0.D0
IF(I .EQ. K) VECNEW(IK) = 1.D0
EYE11(IK) = 0.D0
EYE12(IK) = 0.D0
130 EYE22(IK) = 0.D0
IF(PRNTLV.GE.15) WRITE(6,3100)
ISTEP = 1
NTRVL = 0
DINT = DRNOW
DIAGI = RMIN+0.5D0*DINT
RMID = RMIN
RLAST = RMIN
XBAR = 0.D0
XSBAR = 0.D0
EBAR = 0.D0
EXBAR = 0.D0
IF(IALPHA .LE. 0) GO TO 150
BALPHA = (ALPHA2-ALPHA1)/(RMAX-RMIN)
ALPHA = ALPHA1+BALPHA*(DIAGI-RMIN)
IF(IALFP) ALPHA = ALPHA1
IF(ALPHA .NE. 1.D0) GO TO 140
DRNOW = DINT/IALPHA
GO TO 150
140 DRNOW = DINT*(ALPHA-1.D0)/(ALPHA**IALPHA-1.D0)
150 RNOW = RMIN+DRNOW
IF(IWRITE) WRITE(ISC) RMIN,RMAX,DINT,DIAGI,RMID,IALPHA,BALPHA,
X ALPHA1,ALPHA2,IALPHA
IF(.NOT. IREAD) GO TO 160
READ(ISC) RMIN,RMAX,DINT,DIAGI,RMID,IALPHA,BALPHA,
X ALPHA1,ALPHA2,IALPHA
C-------------------------------------------------------------------
C START OF THE PROPAGATION LOOP
C-------------------------------------------------------------------
155 READ(ISC) ISTEP,RNOW,DRNOW,LAST,N,DIAG,TSTORE,
X W0,W1,W2,VECNEW,NTRVL,RMIDI,RLAST,RCENT,ITRANS
READ(ISC) NEWINT
DO 158 I=1,N
158 DIAG(I)=DIAG(I)+ESHIFT
160 RCENT = RNOW-0.5D0*DRNOW
ITHS = .FALSE.
IF(((NTRVL+1)/IOC)*IOC .EQ. NTRVL+1) ITHS = .TRUE.
IF(IREAD) GO TO 300
C-------------------------------------------------------------------
C EVALUATE THE POTENTIAL AND ITS DERIVATIVES.
C-------------------------------------------------------------------
CALL WAVMAT(W,N,RCENT,
1 P,VL,IVL,ERED,EINT,CENT,RMLMDA,WKS,MXLAM,NPOTL)
DO 165 I = 1, NSQ
165 W0(I) = W(I)
IF(IVPD .AND. IVPPD) GO TO 200
DO 170 I = 1, NSQ
W1(I) = 0.D0
170 W2(I) = 0.D0
200 IF(IVPPD .OR. ISHIFT) CALL DERMAT(2,W2,N,RCENT,
1 P,VL,IVL,CENT,RMLMDA,MXLAM,NPOTL,NUMDER)
IF (IVPD) CALL DERMAT(1,W1,N,RCENT,
1 P,VL,IVL,CENT,RMLMDA,MXLAM,NPOTL,NUMDER)
FACTOR = DRNOW*DRNOW/24.D0
IF( .NOT. ISHIFT) FACTOR = 0.D0
IF( .NOT. ICRMAT) GO TO 270
RMIDI = DIAGI
C-------------------------------------------------------------------
C EVALUATE THE POTENTIAL AT THE RMIDI WHERE THE INTERACTION IS TO
C BE DIAGONALIZED AND SAVE THE OLD EIGENVECTORS.
C-------------------------------------------------------------------
IF(RMIDI .NE. RCENT) CALL WAVMAT(W,N,RMIDI,
1 P,VL,IVL,ERED,EINT,CENT,RMLMDA,WKS,MXLAM,NPOTL)
DO 240 I = 1,NSQ
240 VECOLD(I) = VECNEW(I)
ITRANS = ITRANS+1
C-------------------------------------------------------------------
C DIAGONALIZE THE INTERACTION POTENTIAL.
C-------------------------------------------------------------------
IFAIL=0
CALL F02ABF(W,N,N,DIAG,VECNEW,N,WKS,IFAIL)
IF( .NOT. ITHS) GO TO 270
IF( .NOT. IVECT) GO TO 270
WRITE(6,2900) LDIAG
WRITE(6,2800) (DIAG(I),I = 1,N)
WRITE(6,2900) LVECNW
WRITE(6,2800) (VECNEW(I),I = 1,NSQ)
C--------------------------------------------------------------------
C TRANSFORM THE POTENTIAL AND ITS DERIVATIVES INTO THE LOCAL BASIS.
C--------------------------------------------------------------------
270 CALL TRNSFM(VECNEW,W0,TSTORE,N,IFALSE,ITRUE)
IF(IVPD) CALL TRNSFM(VECNEW,W1,TSTORE,N,IFALSE,ITRUE)
IF(IVPPD .OR. ISHIFT) CALL TRNSFM(VECNEW,W2,TSTORE,N,IFALSE,
X ITRUE)
C-------------------------------------------------------------------
C DETERMINE THE NEW TRANSFORMATION MATRIX
C-------------------------------------------------------------------
IF(ICRMAT) CALL DGEMUL(VECOLD,N,'T',VECNEW,N,'N',TSTORE,N,N,N,N)
C-------------------------------------------------------------------
C TRANSFORM THE R-MATRIX INTO THE NEW BASIS.
C-------------------------------------------------------------------
300 IF(ICRMAT) CALL TRNSFM(TSTORE,RMAT,W,N,IFALSE,ISYM)
ICRMAT = .FALSE.
IF(IREAD) GO TO 350
C-------------------------------------------------------------------
C SHIFT THE EIGENVALUES AND INITIALIZE FOR CONTRIBUTIONS NOT DESIRED.
C-------------------------------------------------------------------
INDEX = -N
DO 330 J = 1,N
INDEX = INDEX+NP1
DIAG(J) = -W0(INDEX)-FACTOR*W2(INDEX)
330 W0(INDEX) = -FACTOR*W2(INDEX)
IF(IVD .AND. IVPD .AND. IVPPD) GO TO 350
CTERM0 = 1.D0
CTERM1 = 1.D0
CTERM2 = 1.D0
IF( .NOT. IVD) CTERM0 = 0.D0
IF( .NOT. IVPD) CTERM1 = 0.D0
IF( .NOT. IVPPD) CTERM2 = 0.D0
DO 340 I = 1,NSQ
W0(I) = W0(I)*CTERM0
W1(I) = W1(I)*CTERM1
340 W2(I) = W2(I)*CTERM2
C-------------------------------------------------------------------
C WRITE ON UNIT ISC THE INFORMATION NECESSARY FOR SUBSEQUENT ENERGY
C CALCULATIONS.
C-------------------------------------------------------------------
350 IF(IWRITE) WRITE(ISC) ISTEP,RNOW,DRNOW,LAST,N,DIAG,TSTORE,
X W0,W1,W2,VECNEW,NTRVL,RMIDI,RLAST,RCENT,ITRANS
IF( .NOT. ITHS) GO TO 360
IF( .NOT. IPOTL) GO TO 360
WRITE(6,2900) LDIAG
WRITE(6,2800) (DIAG(I),I = 1,N)
WRITE(6,2900) LW0
WRITE(6,2800) (W0(I),I = 1,NSQ)
WRITE(6,2900) LW1
WRITE(6,2800) (W1(I),I = 1,NSQ)
WRITE(6,2900) LW2
WRITE(6,2800) (W2(I),I = 1,NSQ)
WRITE(6,2900) IALPHA
C-------------------------------------------------------------------
C CALCULATE THE ZERO-TH ORDER WAVEFUNCTIONS AND DERIVATIVES.
C-------------------------------------------------------------------
360 NOPLOC = 0
DO 390 I = 1,N
DIF = DIAG(I)
XSQ(I) = DIF*DRNOW*DRNOW
XLMBDA = SQRT(ABS(DIF))
X = XLMBDA*DRNOW
IF(DIF .LT. 0.D0) GO TO 370
NOPLOC = NOPLOC+1
SX = SIN(X)/XLMBDA
CX = COS(X)
GO TO 380
370 IF(X.GT.173.D0) WRITE(6,1700) I,DIF,DRNOW,X
SX = SINH(X)/XLMBDA
CX = COSH(X)
380 A = G1P(I)
SINX(I) = SX
SINE(I) = SX*XLMBDA
IF(DIF .LT. 0.D0) SINE(I) = -SINE(I)
COSX(I) = CX
XK(I) = X
B = G1(I)
G1(I) = A*SX+B*CX
G1P(I) = A*CX-DIF*B*SX
C = G2P(I)
D = G2(I)
A1(I) = B
A1P(I) = A
B1(I) = D
B1P(I) = C
G2(I) = C*SX+D*CX
390 G2P(I) = C*CX-DIF*D*SX
C-------------------------------------------------------------------
C ESTIMATE G2P(N) AT END OF NEXT STEP. IF IT IS TOO LARGE,
C A NEW INTERVAL WILL BE STARTED.
C-------------------------------------------------------------------
IF(ABS(G2P(N)).LE.1.D04) GO TO 1801
IF (PRNTLV.GT.3) WRITE(6,1800) RNOW,DRNOW,G2P(N)
NSGERR=NSGERR+1
1801 G2PMAX=G2P(N)*CX
IF(IREAD .AND. .NOT. IPERT) GO TO 410
C-------------------------------------------------------------------
C CALCULATE THE INTEGRALS NECESSARY FOR THE PERTURBATION CORRECTIONS.
C THE STEP INTEGRALS ARE STORED IN W0, W1 AND W2, AND THE ACCUMULATED
C INTEGRALS OVER THE INTERVAL ARE SAVED IN EYE11, EYE12 AND EYE22.
C-------------------------------------------------------------------
IF(IVPP) CALL PERT2(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11,
X EYE12,EYE22,A1,B1,A1P,B1P)
IF(IVPP) GO TO 400
IF(IVP) CALL PERT1(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11,
X EYE12,EYE22,A1,B1,A1P,B1P)
IF(IVP) GO TO 400
IF(IV) CALL PERT2(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11,
X EYE12,EYE22,A1,B1,A1P,B1P)
400 CONTINUE
410 IF(IREAD .AND. .NOT. NEWINT) GO TO 590
SOFF = 0.D0
COFF = 0.D0
CDIAG = 0.D0
SDIAG = 0.D0
C-------------------------------------------------------------------
C THE FOLLOWING IS USED TO DETERMINE THE MAXIMUM PERTURBATION
C CORRECTIONS TO THE UNPERTURBED WAVEFUNCTIONS. SINCE THE STEP
C SIZE FOR SUBSEQUENT ENERGIES HAS ALREADY BEEN STORED ON DISK
C THIS INFORMATION IS NOT NECESSARY FOR SUBSEQUENT ENERGIES.
C-------------------------------------------------------------------
IF( .NOT. IPERT .AND. IREAD) GO TO 460
IF(IREAD) GO TO 430
DO 420 I = 1,N
A1(I) = 1.D0/SQRT(A1P(I)*A1P(I)/ABS(DIAG(I))+A1(I)*A1(I))
B1(I) = 1.D0/SQRT(B1P(I)*B1P(I)/ABS(DIAG(I))+B1(I)*B1(I))
A1P(I) = DRNOW*A1(I)/XK(I)
B1P(I) = DRNOW*B1(I)/XK(I)
SINE(I) = 1.D0
IF(DIAG(I) .GT. 0.D0) GO TO 420
EXPX = EXP(-XK(I)*DINT/DRNOW)
IF(DIAG(I).LT.-XSQMAX)EXPX=0.D0
SINE(I) = EXPX
A1(I) = A1(I)*EXPX
B1(I) = B1(I)*EXPX
A1P(I) = A1P(I)*EXPX
B1P(I) = B1P(I)*EXPX
420 CONTINUE
430 IJ = 0
C-------------------------------------------------------------------
C CALCULATE THE PERTURBATION CORRECTIONS TO THE WAVEFUNCTION AND
C ITS DERIVATIVE.
C-------------------------------------------------------------------
DO 450 J = 1,N
A1J = A1(J)
A1PJ = A1P(J)
DO 450 I = 1,N
JI = J+(I-1)*N
IJ = IJ+1
PRT1 = G1(J)*EYE12(IJ)-G2(J)*EYE11(IJ)
PRT2 = G1(I)*EYE22(IJ)-G2(I)*EYE12(IJ)
PRT1P = G1P(J)*EYE12(IJ)-G2P(J)*EYE11(IJ)
PRT2P = G1P(I)*EYE22(IJ)-G2P(I)*EYE12(IJ)
C-------------------------------------------------------------------
C DON'T DETERMINE THE MAXIMUM PERTURBATION CORRECTION FOR
C SUBSEQUENT ENERGIES.
C-------------------------------------------------------------------
IF(IREAD) GO TO 440
B1I = B1(I)
B1PI = B1P(I)
E1 = ABS(PRT1)*A1J
E2 = ABS(PRT2)*B1I
E3 = ABS(PRT1P)*A1PJ
E4 = ABS(PRT2P)*B1PI
IF(I .NE. J) COFF = MAX(COFF,E1,E2,E3,E4)
IF(I .EQ. J) CDIAG = MAX(CDIAG,E1,E2,E3,E4)
IF(J .GT. I) GO TO 440
CCIJ = W0(IJ)
CCJI = W0(JI)
CSIJ = W1(IJ)
CSJI = W1(JI)
SSIJ = W2(IJ)
SSJI = W2(JI)
E1 = ABS(SINX(J)*CSJI-COSX(J)*SSIJ)*SINE(J)*XK(J)/DRNOW
E2 = ABS(SINX(I)*CCIJ-COSX(I)*CSJI)*SINE(I)
E3 = ABS(COSX(J)*CSJI+DIAG(J)*SINX(J)*SSIJ)*SINE(J)
E4 = ABS(COSX(I)*CCIJ+DIAG(I)*SINX(I)*CSJI)*SINE(I)*DRNOW/XK(I)
E5 = ABS(SINX(I)*CSIJ-COSX(I)*SSJI)*SINE(I)*XK(I)/DRNOW
E6 = ABS(SINX(J)*CCJI-COSX(J)*CSIJ)*SINE(J)
E7 = ABS(COSX(I)*CSIJ+DIAG(I)*SINX(I)*SSJI)*SINE(I)
E8 = ABS(COSX(J)*CCJI+DIAG(J)*SINX(J)*CSIJ)*SINE(J)*DRNOW/XK(J)
IF(I .NE. J) SOFF = MAX(SOFF,E1,E2,E3,E4,E5,E6,E7,E8)
IF(I .EQ. J) SDIAG = MAX(SDIAG,E1,E2,E3,E4,E5,E6,E7,E8)
440 W2(IJ) = PRT1
W(JI) = PRT2
W0(IJ) = PRT1P
450 W1(JI) = PRT2P
IF(SOFF.EQ.0.D0) SOFF=1.D-30
IF(IPERT) GO TO 480
460 DO 470 I = 1,NSQ
W2(I) = 0.D0
W0(I) = 0.D0
W(I) = 0.D0
470 W1(I) = 0.D0
480 IF(LAST) GO TO 500
IF(IALPHA.LE.0) GO TO 485
IF((ISTEP/IALPHA)*IALPHA.EQ.ISTEP) GO TO 500
GO TO 590
C-------------------------------------------------------------------
C ARRIVE HERE ONLY FOR IALPHA.EQ.0 OPTION.
C START NEW INTERVAL IF PREDICTED G2P FOR NEXT STEP IS TOO LARGE
C-------------------------------------------------------------------
485 IF(.NOT.IREAD .AND. ABS(G2PMAX).GT.1.D04) GO TO 500
IF(COFFL .EQ. 0.D0) GO TO 490
FACC = COFF/COFFL
FACS = SOFF/SOFF1
IF(FACC .GT. 2.D0) FACC = 2.D0
IF(FACS .GT. 2.D0) FACS = 2.D0
IF(FACC*COFF .GT. 0.8D0*TOFF) GO TO 500
IF(FACS*SOFF .GT. 0.8D0*TLDIAG) GO TO 500
490 COFFL = COFF
SOFF1 = SOFF
SDIAG1 = SDIAG
COFFL = COFF
IF(IREAD .AND. NEWINT) GO TO 500
C-------------------------------------------------------------------
C CHECK TO SEE IF THE PERTURBATION CORRECTIONS ARE LARGE ENOUGH
C TO WARRANT A NEW INTERVAL AND BASIS SET TRANSFORMATION.
C-------------------------------------------------------------------
IF(COFF .LT. 0.8D0*TOFF .AND. CDIAG .LT. 0.8D0*TOFF) GO TO 590
500 COFFL = 0.D0
SOFF1 = SOFF
SDIAG1 = SDIAG
ICRMAT = .TRUE.
IF( .NOT. ITHS) GO TO 510
IF( .NOT. IEYE) GO TO 510
WRITE(6,2900) LEYE11
WRITE(6,2800) (EYE11(I),I = 1,NSQ)
WRITE(6,2900) LEYE12
WRITE(6,2800) (EYE12(I),I = 1,NSQ)
WRITE(6,2900) LEYE22
WRITE(6,2800) (EYE22(I),I = 1,NSQ)
C-------------------------------------------------------------------
C MULTIPLY THE OLD R-MATRIX TIMES IRREGULAR WAVEFUNCTION AND ITS
C PERTURBATION CORRECTION.
C-------------------------------------------------------------------
510 NP1 = N+1
II = 1
DO 520 I = 1,N
W0(II) = W0(II)+G1P(I)
W1(II) = W1(II)+G2P(I)
W2(II) = W2(II)+G1(I)
W(II) = W(II)+G2(I)
520 II = II+NP1
CALL DCOPY(NSQ,W0,1,TSTORE,1)
CALL DSYMM('L','L',N,N,1.D0,RMAT,N,W1,N,1.D0,TSTORE,N)
CALL DCOPY(NSQ,W2,1,VECOLD,1)
CALL DSYMM('L','L',N,N,1.D0,RMAT,N,W ,N,1.D0,VECOLD,N)
IF( .NOT. ITHS) GO TO 550
IF( .NOT. IGZRO) GO TO 540
WRITE(6,2900) LG1
WRITE(6,2800) (G1(I),I = 1,N)
WRITE(6,2900) LG1P
WRITE(6,2800) (G1P(I),I = 1,N)
WRITE(6,2900) LG2
WRITE(6,2800) (G2(I),I = 1,N)
WRITE(6,2900) LG2P
WRITE(6,2800) (G2P(I),I = 1,N)
540 IF( .NOT. IGPERT) GO TO 550
WRITE(6,2900) LDG1
WRITE(6,2800) (W2(I),I = 1,NSQ)
WRITE(6,2900) LDG1P
WRITE(6,2800) (W0(I),I = 1,NSQ)
WRITE(6,2900) LDG2
WRITE(6,2800) (W(I),I = 1,NSQ)
WRITE(6,2900) LDG2P
WRITE(6,2800) (W1(I),I = 1,NSQ)
550 IF( .NOT. ITHS) GO TO 560
IF( .NOT. IWAVE) GO TO 560
WRITE(6,2900) LUD
WRITE(6,2800) (EYE12(I),I = 1,NSQ)
WRITE(6,2900) LUDP
WRITE(6,2800) (EYE11(I),I = 1,NSQ)
560 IER = 0
C-------------------------------------------------------------------
C SOLVE A LINEAR SYSTEM OF EQUATIONS TO DETERMINE THE NEW R-MATRIX
C-------------------------------------------------------------------
CALL DGESV(N,N,TSTORE,N,WKS,VECOLD,N,IER)
C-------------------------------------------------------------------
C REINITIALIZE FOR THE NEXT INTERVAL. STORE THE NEW R-MATRIX IN RMAT.
C-------------------------------------------------------------------
DO 570 I = 1,N
G1(I) = 0.D0
G2(I) = 1.D0
G1P(I) = 1.D0
G2P(I) = 0.D0
DO 570 J = 1,N
IJ = I+(J-1)*N
JI = J+(I-1)*N
RMAT(JI) = VECOLD(IJ)
IF(ISYM) RMAT(JI) = 0.5D0*(VECOLD(IJ)+VECOLD(JI))
EYE11(IJ) = 0.D0
EYE12(IJ) = 0.D0
570 EYE22(IJ) = 0.D0
NTRVL = NTRVL+1
IF( .NOT. ITHS) GO TO 580
IF( .NOT. IRMAT) GO TO 580
WRITE(6,2900) LRMAT
WRITE(6,2800) (RMAT(I),I = 1,NSQ)
GO TO 590
580 CONTINUE
590 CONTINUE
IF( .NOT. IWRITE) GO TO 600
NEWINT=ICRMAT
WRITE(ISC) NEWINT
C-------------------------------------------------------------------
C WRITE THE MINIMAL STEP INFORMATION AND DETERMINE THE NEW STEP SIZE
C AND PREDICT THE NEW INTERVAL SIZE.
C-------------------------------------------------------------------
600 IF(PRNTLV.GE.15) WRITE(6,2700) ITRANS,RMIDI,DRNOW,RLAST,RNOW,
X DIAG(1),DIAG(N),CDIAG,COFF,SDIAG,SOFF,ALPHA,NOPLOC,ISTEP
IF( .NOT. LAST) ISTEP = ISTEP+1
IF(LAST) GO TO 670
IF(IREAD) GO TO 155
XBAR = XBAR+RNOW
XSBAR = XSBAR+RNOW*RNOW
EBAR = EBAR+SDIAG
EXBAR = EXBAR+RNOW*SDIAG
TMXX = 0.5D0*TOFF
IF(TLDIAG .GT. TMXX) TMXX = TLDIAG
IF(DINT.NE.DRNOW) SOFF = 0.8D0*TLDIAG*(SOFF/(0.8D0*TMXX))**1.5D0
IF(IALPHA .GT. 0) DRNOW = DRNOW*ALPHA
IF(IALPHA. LE. 0) CALL DELRD(DRNOW,SDIAG,SOFF,TLDIAG,DRMAX,
1 DIAG(1),DIAG(N),RNOW,RMAX)
IF( .NOT. ICRMAT) GO TO 650
DINT = RNOW-RMID
DINT1 = DINT
IF(IALPHA.LE.0) GO TO 630
XBAR = XBAR/IALPHA
XSBAR = XSBAR/IALPHA
EBAR = EBAR/IALPHA
EXBAR = EXBAR/IALPHA
IF(IALPHA.EQ.1) SLOPE=0.D0
IF(IALPHA.NE.1) SLOPE = (EXBAR-XBAR*EBAR)/(XSBAR-XBAR*XBAR)
BINT = EBAR-XBAR*SLOPE
EMAX = BINT+SLOPE*RNOW
EMIN = BINT+SLOPE*(RNOW-DINT)
ALFNEW = ALPHA
IF(IALPHA .LE. 1) GO TO 630
IF(EMAX.EQ.0.D0) EMAX=1.D-30
FAC = EMIN/EMAX
IF(FAC .LE. 0.D0) GO TO 620
FAC = (FAC)**(1.D0/DBLE(3*IALPHA-3))
IF(FAC .GT. 1.1D0) FAC = 1.1D0
IF(FAC .LT. 0.9D0) FAC = 0.9D0
ALFNEW = ALPHA*FAC
GO TO 630
620 FAC = 1.1D0
IF(EMIN .LE. 0.D0) FAC = 0.9D0
ALFNEW = ALPHA*FAC
630 XBAR = 0.D0
XSBAR = 0.D0
EBAR = 0.D0
EXBAR = 0.D0
TMXX = TOFF
IF(TLDIAG .GT. TOFF) TMXX = TLDIAG
IF(DINT.NE.DRNOW) COFF = 0.8D0*TMXX*(COFF/(0.8D0*TMXX))**1.5D0
CALL DELRD(DINT,CDIAG,COFF,TMXX,DRMAX,DIAG(1),DIAG(N),RNOW,RMAX)
IF(DINT1.NE.DRNOW) SOFF1 = TLDIAG*(2.D0*SOFF1/TLDIAG)**1.5D0
CALL DELRD(DINT1,SDIAG1,SOFF1,TLDIAG,DRMAX,DIAG(1),DIAG(N),RNOW,
1 RMAX)
IF(ABS(DINT1) .LT. ABS(DINT)) DINT = DINT1
IF(DINT .LT. DRNOW) DINT = DRNOW
IF(ABS(RMAX-RNOW-DINT) .LT. ABS(0.01D0*DINT)) DINT = RMAX-RNOW
IF((RMAX-RNOW-DINT)*DINT .LT. 0.D0) DINT = RMAX-RNOW
RMID = RNOW
DIAGI = RNOW+0.5D0*DINT
IF(IALPHA .LE. 0) GO TO 650
ALPHA = ALPHA1+BALPHA*(DIAGI-RMIN)
IF(IALFP) ALPHA = ALFNEW
IF(ALPHA .NE. 1.D0) GO TO 640
DRNOW = DINT/IALPHA
GO TO 650
640 DRNOW = DINT*(ALPHA-1.D0)/(ALPHA**IALPHA-1.D0)
650 IF(ABS(RMAX-RNOW-DRNOW) .LT. ABS(0.01D0*DRNOW))
1 DRNOW = RMAX-RNOW
IF((RMAX-RNOW-DRNOW)*DRNOW .LT. 0.D0) DRNOW = RMAX-RNOW
RLAST = RNOW
RNOW = RNOW+DRNOW
DEL = (RNOW-RMAX)/DRNOW
IF(ABS(DEL) .LT. 0.005D0) LAST = .TRUE.
GO TO 160
C-------------------------------------------------------------------
C THE INTEGRATION IS NOW COMPLETE. TRANSFORM THE R-MATRIX INTO THE
C ORIGINAL BASIS.
C-------------------------------------------------------------------
670 NCOL = 1
NLAST = N
DO 690 IR = 1,N
NORIG = IR
DO 680 NTRANS = NCOL,NLAST
VECOLD(NTRANS) = VECNEW(NORIG)
680 NORIG = NORIG+N
NLAST = NLAST+N
690 NCOL = NCOL+N
CALL TRNSFM(VECOLD,RMAT,TSTORE,N,IFALSE,ISYM)
IF(PRNTLV.GE.3) WRITE(6,3000) RMIN,RMAX,ISTEP
IF (PRNTLV.LE.3 .AND. NSGERR.GT.0) WRITE(6,1802) NSGERR
RETURN
C-------------------------------------------------------------------
C FORMAT STATEMENTS
C-------------------------------------------------------------------
1200 FORMAT(1H0, 98H IVECT IPOTL IEYE IGZRO IGPERT IWAVE IRMAT IWRITE
XIREAD IOC )
1300 FORMAT(1H , 9L6,I4)
1400 FORMAT(1H0, 43H IV IVP IVPP ISHIFT IDIAG ISYM IPERT IALFP )
1500 FORMAT(1H ,L3,L4,L5,L7,L6,L5,4L6)
1600 FORMAT(1H0,21H ALPHA1 ALPHA2 IALPHA/1X,2F7.2,I7)
1700 FORMAT('0 *** ERROR IN VIVAS. FOR CHANNEL',I3,', REDUCED V-E =',
1 E13.5/6X,'FOR STEP SIZE',E13.5,', COSH ARGUMENT OF',E13.5,
2 ' WILL CAUSE OVERFLOW.'/6X,'USE A SMALLER STEP SIZE TO AVOID',
3 ' THIS ERROR.')
1800 FORMAT('0 *** WARNING IN VIVAS. INTERVAL SIZE TOO LARGE, SO',
1 ' CLOSED CHANNEL GROWTH MAY CAUSE NUMERICAL INSTABILITY.'/
2 24X,'RNOW =',F8.3,', DRNOW =',F8.3,', G2P(N) =',E13.5)
1802 FORMAT('0 *** WARNING IN VIVAS. INTERVAL SIZE POSSIBLY TOO',
1 ' LARGE FOR',I5,' STEPS. INCREASE PRNTLV FOR DETAILS')
2500 FORMAT(79H0 RMIN RMAX DRNOW DRMAX TOFF TLD
XIAG )
2600 FORMAT(F9.5,10F10.5,I10)
2700 FORMAT(1H ,I5,10E11.4,F6.3,2I5)
2800 FORMAT(1H ,9D14.7)
2900 FORMAT(1H0,A10)
3000 FORMAT('0 VIVAS. R-MATRIX INTEGRATED FROM',F12.4,' TO',
& F12.4,' IN',I6,' STEPS.')
3100 FORMAT(132H0NTRVL RCENT DRNOW RLAST RNOW DI
XAG(1) DIAG(N) CDIAG COFF SDIAG SOFF ALF
XP NOPN ISTP )
C----------------***END-VIVAS***-------------------------------------
END
SUBROUTINE WAVEIG (W, EIGNOW, SCR1, SCR2, RNOW, NCH,
1 P,MXLAM,VL,IV,RMLMDA,ERED,EINT,CENT,NPOTL)
* THIS SUBROUTINE FIRST SETS UP THE WAVEVECTOR MATRIX AT RNOW
* THEN OBTAINS ITS EIGENVALUES
* WRITTEN BY: MILLARD ALEXANDER
* CURRENT REVISION DATE: 25-SEPT-87
* ----------------------------------------------------------------
* VARIABLES IN CALL LIST:
* W: MATRIX OF MAXIMUM ROW DIMENSION NCH USED TO STORE
* WAVEVECTOR MATRIX
* EIGNOW: ON RETURN: ARRAY CONTAINING EIGENVALUES OF WAVEVECTOR M
* SCR1, SCR2: SCRATCH VECTORS OF DIMENSION AT LEAST NCH
* RNOW: VALUE OF INTERPARTICLE SEPARATION AT WHICH WAVEVECTOR MA
* IS TO BE EVALUATED
* NCH: NUMBER OF CHANNELS
* SUBROUTINES CALLED:
* WAVMAT: DETERMINES WAVEVECTOR MATRIX
* F02AAF: NAG ROUTINE TO OBTAIN EIGENVALUES OF REAL,
* SYMMETRIC MATRIX
* DSCAL, DCOPY: LINPACK BLAS ROUTINES
* ----------------------------------------------------------------
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INTEGER IERR, NCH, NCHM1, NCHP1
EXTERNAL DSCAL, DCOPY, WAVMAT, F02AAF
* SQUARE MATRIX (OF ROW DIMENSION NCH)
DIMENSION W(1)
* VECTORS DIMENSIONED AT LEAST NCH
DIMENSION EIGNOW(1), SCR1(1), SCR2(1),P(1),VL(1),IV(1),EINT(1)
DIMENSION CENT(1)
* ------------------------------------------------------------------
DATA XMIN1 / -1.D0/
NCHP1 = NCH + 1
NCHM1 = NCH - 1
CALL WAVMAT (W, NCH, RNOW, P, VL, IV, ERED, EINT, CENT, RMLMDA,
1 SCR1, MXLAM, NPOTL)
C
* SINCE WAVMAT RETURNS NEGATIVE OF LOWER TRIANGLE OF W(R) MATRIX (EQ.(3
* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."),
* NEXT LINE CHANGES ITS SIGN
CALL DSCAL(NCH*NCH, XMIN1, W, 1)
C
IERR=0
CALL F02AAF(W, NCH, NCH, EIGNOW, SCR1, IERR)
IF (IERR .NE. 0) THEN
WRITE (6, 120) IERR
120 FORMAT(' *** F02AAF IERR =', I3, ' .NE. 0 IN WAVEIG; ABORT ***')
STOP
ENDIF
C
RETURN
END
SUBROUTINE WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,
1 MXLAM,NPOTL)
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C EVALUATES THE MATRIX W OF WAVE-VECTORS AT RADIUS R
C W = VCOUPL + EINT + VCENT - ETOT
C ORDER OF THE REAL SYMMETRIC MATRIX W IS N
C THE FULL MATRIX IS COMPUTED
C VL IS THE PREVIOUSLY COMPUTED MATRIX OF THE COUPLING POTENTIAL
C IV IS AN INDEX ARRAY MAPPING P ONTO VL, SUCH THAT VL(I) IS
C A COEFFICIENT TO MULTIPLY P(IV(I))
C ERED IS THE TOTAL ENERGY ETOT IN REDUCED UNITS
C (ETOT/EPSILON)*(2.*URED*EPSIL*RM**2/HBAR**2)
C EINT(I) IS THE REDUCED INTERNAL ENERGY OF THE I-TH CHANNEL
C CENT(I) IS L*(L+1) FOR THE I-TH CHANNEL
C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO THE DEBROGLIE
C WAVELENGTH AT RELATIVE ENERGY EPSILON
C RMLMDA = 2.*URED*RM**2*EPSIL/HBAR**2
C RMLMDA MULTIPLIES THE POTENTIAL IN UNITS OF EPSIL
C
DIMENSION W(N,N),VL(1),IV(1),EINT(N),CENT(N),P(MXLAM),DIAG(N)
COMMON/MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
RSQ=1.D0/(R*R)
IF(IVLFL.LT.0) THEN
NPOT=NPOTL-2
P(NPOT+1)=RSQ
P(NPOT+2)=1.D0
ELSE
NPOT=NPOTL
ENDIF
C
C COMPUTE THE RADIAL PARTS OF THE POTENTIAL
C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE.
CALL POTENL(0,MXLAM,NPOT,IDUM1,R,P,IDUM2)
C CALL PERTRB(R,P,MXLAM,0)
C
DO 15 I=1,MXLAM
15 P(I)=RMLMDA*P(I)
C
CALL WAVVEC(VL,P,IV,W,N,NPOTL)
C
C NOW COMPUTE THE DIAGONAL CONTRIBUTIONS W(I,I).
C
DO 18 I=1,N
W(I,I) = W(I,I) - ERED
DIAG(I) = W(I,I)
18 CONTINUE
C
IF(IVLFL.LT.0) RETURN
C
DO 20 I=1,N
W(I,I) = W(I,I) + EINT(I) + RSQ*CENT(I)
DIAG(I) = W(I,I)
20 CONTINUE
RETURN
END
SUBROUTINE WAVVEC(VL,P,IV,W,N,NPOTL)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION VL(1),P(1),IV(1),W(N,N)
C
C DYNAMIC STORAGE COMMON BLOCK ...
COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
COMMON/VLSAVE/IVLU
C
IF(IVLFL.GT.0) GOTO 10
C
C REACH HERE ONLY FOR IVLFL=0: NO IV ARRAY FOR INDEXING
C
IF(IVLU.EQ.0) THEN
I=1
DO 1 J=1,N
CALL DGEMV('T',NPOTL,J,1.D0,VL(I),NPOTL,P,1,0.D0,W(1,J),1)
1 I=I+J*NPOTL
ELSE
REWIND IVLU
ISV=IXNEXT
IXNEXT=ISV+N*(N+1)/2
NUSED=1
CALL CHKSTR(NUSED)
DO 2 J=1,N
DO 2 K=1,J
2 W(K,J)=0.D0
DO 5 LL=1,NPOTL
READ(IVLU) (X(ISV+I),I=0,N*(N+1)/2-1)
I=1
DO 4 J=1,N
CALL DAXPY(J,P(LL),X(ISV+I-1),1,W(1,J),1)
4 I=I+J
5 CONTINUE
IXNEXT=ISV
ENDIF
C
C FILL IN LOWER TRIANGLE
C
CALL DSYFIL('L',N,W,N)
RETURN
C
C ARRIVE HERE FOR NON-TRIVIAL USE OF THE IV ARRAY
C
10 IF(IVLU.NE.0) THEN
WRITE(6,601)
601 FORMAT(' *** ERROR IN WAVVEC. IVLU =',I2,' AND IVLFL =',I2/
1 ' USE OF THE IV ARRAY IS NOT SUPPORTED FOR IVLU > 0.')
STOP
ENDIF
C
I2=0
DO 12 J=1,N
DO 12 K=1,J
I1=I2+1
I2=I2+NPOTL
WW=0.D0
DO 11 I=I1,I2
IF(VL(I).NE.0.D0) WW=WW+VL(I)*P(IV(I))
11 CONTINUE
W(J,K)=WW
W(K,J)=WW
12 CONTINUE
C
RETURN
END
SUBROUTINE WKB(N,MXLAM,NPOTL,W,SREAL,SIMAG,P,L,EINT,CENT,
1 DIAG,NBASIS,WVEC,VL,IV,NUMDER,IPRINT)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C THIS ROUTINE GETS PHASE SHIFT (S-MATRIX) FOR 1-DIMENSIONAL
C SCATTERING EQUATION VIA THE WKB APPROXIMATION USING GAUSS-MEHLER
C NUMERICAL INTEGRATION AS SUGGESTED BY R.T PACK, J. CHEM. PHYS.
C 60, 633 (1974).
C
C THIS ROUTINE IS COMPATIBLE WITH MOLSCAT/IOS CODE
C WRITTEN OCT 1977 BY S. GREEN (GISS), MODIFIED APR 1986 FOR CCP6.
C MODIFIED JUL 86 WITH MORE SOPHISTICATED START (FIND TURNING PT.)
C>>SG MODIFIED SOME OUTPUT FORMATS 5/13/92
C
C VARIABLES FOR MOLSCAT COMPATIBILITY . . .
LOGICAL NUMDER
DIMENSION W(2),SIMAG(2),SREAL(2),P(2),L(2),EINT(2),CENT(2),
1 DIAG(2),NBASIS(2),WVEC(2),VL(2),IV(2)
C
C
C THE NUMBER OF GAUSS POINTS IS INCREASED CHECKING FOR CONVERGENCE
C PARAMETERS TO CONTROL GAUSS-MEHLER CONVERGENCE ITERATION. . .
COMMON /WKBCOM/ NGMP(3)
C
C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS
C
COMMON/DRIVE/DTOL,STEPS,STABIL,CONV,RMIN,RSTOP,XEPS,
1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA,
2 NOPEN,JKEEP,ISCRU,MAXSTP
C
C TOLERANCES FOR NEWTON-RAPHSON SEARCH FOR R0 . . .
DATA EPS/5.D-5/ , ITMX/24/
DATA IDER/1/
C
C MODIFY CENTRIFUGAL POTENTIAL (CENT) VIA 'LANGER' CORRECTION
PI=ACOS(-1.D0)
DCENT=DBLE(L(1))+.5D0
DCENT=DCENT*DCENT
CSAVE=CENT(1)
CENT(1)=DCENT
C INITIALIZE OTHER VARIABLES
PI2=2.D0*PI
C
C FIND TURNING POINT VIA NEWTON-RAPHSON METHOD. START WITH RMIN
C
IT=0
ECNV=EPS*ERED
RCNV=EPS*RMIN
R=RMIN
C IF POTENTIAL IS NOT DECREASING, TRY BACKING UP . . .
1198 CALL DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,MXLAM,NPOTL,NUMDER)
IF (W(1).LE.0.D0) GO TO 1000
IF (IPRINT.GT.3) WRITE(6,699) IT,R,W(1)
699 FORMAT('0* * * WKB BAD START. TRY 7/86 FIX. ITER, R, DV/DR =',
1 I4,2F15.5)
R=0.9D0*R
IT=IT+1
IF (IT.LE.ITMX) GO TO 1198
WRITE(6,697) ITMX
697 FORMAT('0 * * * ERROR (7/86). WKB CANNOT START. ITMX =',I4)
STOP
1000 CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
V=W(1)
CALL DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,MXLAM,NPOTL,NUMDER)
DVDR=W(1)
DR=-V/DVDR
C TO PREVENT OCCASIONAL ERRATIC BEHAVIOR ALLOW ONLY 25% CHANGE IN R
DRMAX=2.5D-1*ABS(R)
IF (ABS(DR).LE.DRMAX) GO TO 1199
IF (DR.LT.0.D0) DRMAX=-DRMAX
IF (IPRINT.GT.3) WRITE(6,698) IT,R,DR,DRMAX
698 FORMAT(' * * WKB. 7/86 FIX. ITER, R, DR, DRMAX =',I4,3F15.5)
DR=DRMAX
1199 IF (ABS(DR).LE.RCNV.OR.ABS(V).LE.ECNV) GO TO 1009
IT=IT+1
R=R+DR
IF (IT.LE.ITMX) GO TO 1000
IF (IPRINT.GT.3) WRITE(6,694) IT,R,DR,V,DVDR
694 FORMAT(' WKB: NEWTON-RAPHSON START FAILED TO CONVERGE. IT =',I4
& /16X,'R,DR,V,DVDR=',4D12.4)
C
C TRY A REGULA-FALSI METHOD. 1ST, UNDO LAST R CHANGE, RESET IT.
R=R-DR
IT=0
XL=R
YL=V
C STEP IN DIRECTION OF OPPOSITE SIGN FOR POTENTIAL.
IF (V*DVDR*DR.LT.0) GO TO 1201
DR=-DR
1201 RSV=R
DO 1202 ITX=1,5
R=R+DR
CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
V=W(1)
IF (V*YL.LT.0.D0) GO TO 1205
1202 CONTINUE
DR=-DR
R=RSV
DO 1203 ITX=1,5
R=R+DR
CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
V=W(1)
IF (V*YL.LT.0.D0) GO TO 1205
1203 CONTINUE
WRITE(6,620)
620 FORMAT('0 WKB. * * * CRASH IN REGULA-FALSI. GIVING UP.')
STOP
1205 XR=R
YR=V
1210 SLOPE=(YR-YL)/(XR-XL)
XINT=YL-SLOPE*XL
XNEW=-XINT/SLOPE
CALL WAVMAT(W,N,XNEW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,
1 NPOTL)
YNEW=W(1)
IT=IT+1
IF (ABS(YNEW).GT.ECNV) GO TO 1211
1215 DR=XR-XL
IF (IPRINT.GT.3) WRITE(6,621) IT,XNEW,DR,YNEW
621 FORMAT(' WKB: REGULA-FALSI CONVERGED. IT,R,DR,V =',I4,3F10.4)
R=XNEW
GO TO 1009
1211 IF (YNEW*YR.GT.0.D0) GO TO 1212
IF (YNEW*YL.GT.0.D0) GO TO 1213
WRITE(6,622) XL,XNEW,XR,YL,YNEW,YR
622 FORMAT('0 WKB. IMPOSSIBLE X(L,NEW,R) AND Y(L,NEW,R)=',6D12.4)
STOP
1212 YR=YNEW
XR=XNEW
GO TO 1220
1213 YL=YNEW
XL=XNEW
1220 IF (ABS(XR-XL).LE.RCNV) GO TO 1215
C ALLOW FOR TWICE AS MANY ITERATIONS AS NEWTON-RAPHSON.
IF (IT.LT.2*ITMX) GO TO 1210
WRITE(6,623) IT,XL,XNEW,XR,YL,YNEW,YR
623 FORMAT(' WKB: REGULA-FALSI START FAILED TO CONVERGE. IT=',I4/
1 16X, 'X(L,NEW,R) AND Y(L,NEW,R)=',6D12.4)
C STOP
C
C GET WKB PHASE SHIFT BY PACK'S GAUSS-MEHLER QUADRATURE
C
C FORCE NGMP TO REASONABLE VALUES IF NECESSARY.
1009 NSTART=MAX0(NGMP(1),3)
NADD=MAX0(NGMP(2),1)
NHI=MAX0(NGMP(3),NSTART+3*NADD)
RMIN=R
DR0=R
DWVEC=WVEC(1)
XKR=DWVEC*DR0
DO 2000 NPOINT=NSTART,NHI,NADD
NPSV=NPOINT
X2NP1=DBLE(2*NPOINT+1)
SUM=0.D0
XJ=0.D0
DO 2100 J=1,NPOINT
XJ=XJ+1.D0
X=COS(XJ*PI/X2NP1)
X2=X*X
WT=(1.D0-X2)*PI/X2NP1
XCOMP=SQRT(1.D0-X2)
R=DR0/X
CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL)
C WAVMAT GIVES NEGATIVE OF WHAT WE WANT
W(1)=-W(1)
C GUARD AGAINST SQAURE ROOTS OF NEGATIVE DW
IF (W(1).GE.0.D0) GO TO 2109
C JUDGE AS ROUND-OFF ERROR IF ABS(W) LE. 0.001*ERED
IF (ABS(W(1)).LE.1.D-3*ERED) GO TO 2108
WRITE(6,696) R,W(1)
696 FORMAT(' * * * ERROR. WKB IN CLASSICALLY FORBIDDEN REGION. R, W
& =',2E16.6)
2108 W(1)=0.D0
2109 DW=W(1)
F=(SQRT(DW)/(DWVEC*XCOMP)-1.D0)/X2
2100 SUM=SUM+WT*F
ETA=XKR*SUM+(SQRT(DCENT)-XKR)*PI*.5D0
IF (NPOINT.GT.NSTART) GO TO 2200
C ON FIRST ITERATION, GET SET FOR CONVERGENCE TEST.
C SUBTRACT OUT AN INTEGRAL NUMBER OF 2*PI TO NORMALIZE
NPI=ETA/PI2
IF (ETA.LT.0.D0) NPI=NPI-1
PIMIN=DBLE(NPI)*PI2
ETA=ETA-PIMIN
ETAOLD=ETA
GO TO 2000
C TEST FOR CONVERGENCE
2200 ETA=ETA-PIMIN
X2=ABS(ETA-ETAOLD)
IF (X2.LE.DTOL) GO TO 2900
X=ETAOLD
ETAOLD=ETA
2000 CONTINUE
C NOT CONVERGED IF THIS POINT IS REACHED. . .
NPOINT=NPSV
NM1=NPOINT-NADD
WRITE(6,695) NPI,DTOL, NM1,X, NPOINT,ETA
695 FORMAT('0 * * * WARNING. NO CONVERGENCE OF GAUSS-MEHLER INTEGRATI
&ON. NPI =',I4,' STEST =',D12.4/
A (15X,'FOR',I4,' GAUSS POINTS, ETA-NPI*(2*PI) =',F12.7) )
C SET CONVERGENCE FLAG, IF CONVERGENCE IS REALLY POOR
IF (X2.GT.5.D0*DTOL) CONV=-1.D0
2900 IF (IPRINT.GE.3) WRITE(6,612) NPSV,X2,DR0,NPI,ETA
612 FORMAT('0 * * * NOTE. WKB PHASE SHIFT BY',I4,'-POINT QUAD, TOL ='
& ,D12.4,', R0 =',F8.4,', ETA IS',I5,'*(2*PI) +',F9.5)
C
C CONVERT PHASE SHIFT TO SREAL, SIMAAG / RESTORE FOR RETURN
SREAL(1)=COS(2.D0*ETA)
SIMAG(1)=SIN(2.D0*ETA)
CENT(1)=CSAVE
RETURN
C
END
FUNCTION XNINEJ(IX1,IY1,IZ1,IX2,IY2,IZ2,IX3,IY3,IZ3)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION XJ9J(200)
DATA MXDIM/200/
C
IVAL=MXDIM
CALL J9J(DBLE(IX1),DBLE(IY1),
1 DBLE(IX2),DBLE(IY2),DBLE(IZ2),
2 DBLE(IX3),DBLE(IY3),DBLE(IZ3),
3 IVAL,Z1MIN,XJ9J)
IND=1+IZ1-INT(Z1MIN+0.1D0)
XNINEJ=0.D0
IF(IND.GE.1 .AND. IND.LE.IVAL) XNINEJ=XJ9J(IND)
RETURN
END
FUNCTION YRR(L1,L2,L,CT1,CT2,DP)
C
C BISPHERICAL HARMONIC ANGULAR FUNCTIONS FOR TWO DIATOMS
C CT1, CT2 ARE COS(THETA-1) AND COS(THETA-2), AND
C DP IS DELTA(PHI), I.E., PHI2-PHI1, IN RADIANS
C CF. GREEN, JCP 62, 2271 (1975) APPENDIX.
C N.B. P(L,M;X) THERE IS (2*PI)**-1/2 NORMALIZED P(L,M;X)
C MOLSCAT PLM(L,M,CT) ROUTINE IS NORMALIZED ON CT, AND
C PLM(L,0,1.D0)=SQRT((2L+1)/2) .
C THUS, MUST MULT EACH PLM BY (2*PI)**-1/2
C
C ODD L1+L2+L *NOT* ALLOWED; TRAPPED W/MESSAGE AND STOP
C
C NEEDS ROUTINES THRJ(XJ1,XJ2,XJ3,XM1,XM2,XM3)
C PLM(L,M,COSTH)
C PARITY3(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)*PARITY3(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*PARITY3(M)*THRJ(XL1,XL2,XL,XM,-XM,0.D0)*
1 PLM(L1,M,CT1)*PLM(L2,M,CT2)*COS(XM*DP)
GO TO 2000
3000 YRR=FACT*SUM
RETURN
9999 WRITE(6,699) L1,L2,L
699 FORMAT('0 YRR *** ERROR. ODD ARGUMENTS NOT ALLOWED',3I5)
STOP
END
SUBROUTINE YTOK(NB,WVEC,L,N,NOPEN,SJ,SJP,SN,SNP,Y,T,Q,RUP)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C ROUTINE TO OBTAIN THE K MATRIX FROM THE LOG DERIVATIVE MATRIX
C ON ENTRY, Y HOLDS THE LOG DERIVATIVE MATRIX
C ON EXIT, Q HOLDS THE K MATRIX
C SEE: B.R.JOHNSON, JOURNAL OF COMPUTATIONAL PHYSICS 13, 445 (1973)
C
DIMENSION NB(N), WVEC(N), L(N), SJ(N), SJP(N), SN(N), SNP(N),
1 Y(1), T(1), Q(1)
C
IF(NOPEN.EQ.0) RETURN
DO 10 I = 1,NOPEN
NX = NB(I)
DW = WVEC(NX)
DARG = DW*RUP
CALL RBES(L(NX), DARG, UJ, UJP, UN, UNP)
ROOTDW = SQRT(DW)
SJ(NX) = UJ/ROOTDW
SJP(NX) = UJP*ROOTDW
SN(NX) = UN/ROOTDW
SNP(NX) = UNP*ROOTDW
10 CONTINUE
IF (NOPEN.EQ.N) GO TO 30
NCLOSE = N - NOPEN
DO 20 I = 1,NCLOSE
J = NOPEN + I
NX = NB(J)
DW = ABS(WVEC(NX))
DARG = DW*RUP
CALL RMSBF(L(NX), DARG, RATIO)
SN(NX) = 1.D0
SNP(NX) = RATIO*DW
20 CONTINUE
30 CONTINUE
C
CALL DSYFIL('U',N,Y,N)
C
IND = 0
DO 40 J = 1,NOPEN
NXJ = NB(J)
NXJJ = (NXJ - 1)*N
DO 40 I = 1,N
IND = IND + 1
INDY = NXJJ + NB(I)
T(IND) = Y(INDY)*SJ(NXJ)
40 CONTINUE
C
IND = - N
DO 50 I = 1,NOPEN
IND = IND + N + 1
T(IND) = T(IND) - SJP(NB(I))
50 CONTINUE
C
IND = 0
DO 60 J = 1,N
NXJ = NB(J)
NXJJ = (NXJ - 1)*N
DO 60 I = 1,N
IND = IND + 1
INDY = NXJJ + NB(I)
Q(IND) = Y(INDY)*SN(NXJ)
60 CONTINUE
C
IND = - N
DO 70 I = 1,N
IND = IND + N + 1
Q(IND) = Q(IND) - SNP(NB(I))
70 CONTINUE
C
CALL DGESV(N,NOPEN,Q,N,SJ,T,N,IER)
IF (IER.NE.0) GO TO 900
C
IND = 0
DO 80 J = 1,NOPEN
INDA = (J - 1)*N
DO 80 I = 1,NOPEN
IND = IND + 1
INDA = INDA + 1
Q(IND) = T(INDA)
80 CONTINUE
C
C Q NOW HOLDS THE K MATRIX. FORCE SYMMETRY ON IT.
C
CALL KSYM(Q, NOPEN)
RETURN
C
900 WRITE (6,901) IER
901 FORMAT('0***** ERROR IN LINEAR EQUATION SOLVER IN YTOK.',
1 ' IER =',I4,'. RUN HALTED.')
STOP
END
FUNCTION ZBES(K)
C *** ROUTINE REQUIRED BY GASLEG (GAUSS LEGENDRE PT/WT GENERATOR)
C *** TAKEN FROM AD VAN DER AVOIRD'S N2-N2 CODE (SG 11/7/91)
DOUBLE PRECISION PI,ZBES,B,BB,B3,B5,B7
DATA PI/3.14159 26535 89793 D0/
B=(DBLE(K)-0.25D0)*PI
BB=1.0D0/(8.0D0*B)
B3=BB*BB*BB
B5=B3*BB*BB
B7=B5*BB*BB
ZBES=B+BB-(124.0D0/3.0D0)*B3+(120928.0D0/15.0D0)*B5-(401743168.0D0
1/105.0D0)*B7
RETURN
END
Reference in New Issue View Git Blame Copy Permalink