c=======================================================================
PROGRAM MAIN
c=======================================================================
c------------------- Last updated 9 February 2004 ---------------------
c=======================================================================
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
c-----------------------------------------------------------------------
INTEGER AN1,AN2,C,CHARGE,ERR,FITIT,FREQYN,MN1(mxisot),MN2(mxisot),
1 GEGS1,GEGS2,GNS1,GNS2, I,IFR,IFS,ILRF,IP,IR2F,IROUND,ISET,
2 ISO,IVJ,IWRSCH,IWROVR,J,JFRPW,JREF,K,LNPT,LPDER,LPFS,LPRINT,
3 LPTMF,LPRWF,M,MAXV,MCALC, N,NCNF,NCNI,NFS,NIN,NISTP,NPRS,NPRF,
4 NPRM,NDATA,NBEG,NEND,NPTOT,NPPFREE,NSETS,NUSEF, PRINTYN,RPD,V,
5 NGPRND, BOLTZ(mxsets),DTYPE(mxsets),IFRPW(mxsets),ISOT(mxsets),
6 J1ST(mxsets),VMAX(mxsets),JMAX(mxsets),NFREQ(mxsets),NJ(mxsets),
7 NVJ(mxsets),PUNITS(mxsets),PQR(mxsets),SCALE(mxsets),
7 GFS(mxfs),
8 CD(mxsets,mxfs),CN(mxsets,mxfs),STYPE(mxfs),FSVAR(mxprm,mxfs),
9 FSTYPE(mxfs),NFSPRM(mxfs),NTPFS(mxfs),OMEGA(0:mxfs),OTMF(mxfs),
a TMFTYP(mxfs),TMFVAR(0:mxprm-1,mxfs),V1ST(mxsets),VFIX(mxfreq),
b JFIX(mxfreq),XCOORD(mxfs), INNER(0:mxv,mxisot),INNR(0:mxv)
c-----------------------------------------------------------------------
REAL*8 AB1,AB2,ADD,AVALUE(mxfs),BFCT(mxisot),BVALUE(mxfs),
1 CM(mxnp,mxnp),CNNF,DFREQ,dIdT(0:mxprm-1,mxfreq,mxfs,mxsets),
2 DFACT,DSE,EPS,FACTOR(mxsets),FCT(mxfsp),FREQ(mxfreq,mxsets),
3 FREQ1,FSPRM(mxprm,mxfs),MASS1(mxisot),MASS2(mxisot),
4 GV(0:mxv),RCNST(7),MCI(0:mxv,0:7,mxisot),MU(mxisot),
5 OBS(mxfreq,mxsets),OVRCRT,OUTPUT(mxfreq,mxsets),POPCRT,
6 PS(mxnp),PU(mxnp),PV(mxnp),RAD(mxfsp),REXFS,REXTMF,RFACTF,RH,
7 RMAX,RMAXOUT,RMIN,RMS(mxsets),RTP(2,mxfs),RTPF(mxfsp),
8 SF(mxsets),
8 SQRTMU(mxisot),TMFPRM(0:mxprm-1,mxfs),TEMP(mxsets),TSTPS,TSTPU,
9 UNC(mxfreq,mxsets),VFACTF,VF(mxfsp,mxfs),VI(mxisp,mxisot),
a VIS(mxisp),VLIMI,VLIMF(mxfs),VSHFTF(mxfs),VTP(2,mxfs),
b RM2(mxisp),VICD(mxisp,mxisot),VTPF(mxfsp),WAVL(mxfreq,mxsets),
c XM2(mxfsp),YD(mxdata),YO(mxdata),YU(mxdata),zfs(mxfsp,mxfs),
d WF1(mxisp),ztmf(mxisp,mxfs),TWOPIC, PMAX,BvWN,GAMA, UCUTOFF
c-----------------------------------------------------------------------
CHARACTER*2 N1,N2,NAME1(mxisot),NAME2(mxisot)
CHARACTER*75 TITLE
CHARACTER*70 INFO(mxsets)
c-----------------------------------------------------------------------
COMMON /MF/ BFCT,EPS,FACTOR,FREQ,MCI,OBS,UNC,OVRCRT,POPCRT,TEMP,
1 VI,VICD,VLIMI,WAVL,BOLTZ,CD,CN,DTYPE,FITIT,INNER,ISOT,IWRSCH,
2 IWROVR,J1ST,JFIX,JFRPW,JMAX,MCALC,NJ,OMEGA,PQR,printyn,
3 V1ST,VFIX,VMAX
COMMON /MD/ DFACT,FSVAR,LPDER,NPPFREE
COMMON /MGt/ REXTMF
COMMON /MGf/ AVALUE,BVALUE,REXFS,RTP,VTP,zfs,FSTYPE,XCOORD
COMMON /MFD/ dIdT,OUTPUT,SF,IFRPW,NFREQ,NFS,NSETS,NVJ,RPD,SCALE,
1 TMFVAR,INFO
COMMON /MFGf/ VF,VLIMF
COMMON /MFGt/ XM2,ztmf,LPTMF,NIN,TMFTYP
COMMON /MDGf/ FSPRM,NFSPRM
COMMON /MFGtGf/ RAD
COMMON /MFDGt/ TMFPRM,OTMF,GFS
c?????
real*8 xtmf
c?????
c-----------------------------------------------------------------------
c LNPT needed in prepot.f (must be greater that zero here)
c NPRS needed in prepot.f subroutine genint
c MCALC - specifies how radial overlap calculations are performed
c <= 0 to use delta function approximation (UNAVAILABLE)
c > 0 for exact quantal calculation
c EPS is converged precision (in cm-1) of calculated eigenvalues
c POPCRT is fraction of initial-state population to be included when
c the thermal sums terminate in direct sums over the rotational
c or vibrational populations.
c-----------------------------------------------------------------------
DATA LNPT/1/,NPRS/1/,NDATA/0/,NGPRND/1/
EPS= 1.d-05
POPCRT= 0.9999d0
MCALC= 1
TWOPIC= 2.d0*PI*CCM
c=======================================================================
c TITLE is a title or output header of up to 75 characters, read on a
c single line enclosed between single quotes: e.g. 'title of problem'
c=======================================================================
READ(5,*) TITLE
c=======================================================================
c AN1 - atomic number of atom 1
c AN2 - atomic number of atom 2
c CHARGE - +/-(integer) charge on the molecule
c NISTP - number of isotopomers to be considered
c NFS - number of final state potentials considered
c NSETS - the number of data sets to be predicted or fitted to
c FITIT - if > 1 do a fit to experimental data
c if = 0 do forward calculation only
c=======================================================================
READ(5,*) AN1, AN2, CHARGE, NISTP, NFS, NSETS, FITIT
c=======================================================================
IF(NSETS.gt.mxsets) THEN
WRITE(6,617) mxsets
STOP
ENDIF
IF(NISTP.gt.mxisot) THEN
WRITE(6,619) mxisot
STOP
ENDIF
IF(NFS.gt.mxfs) THEN
WRITE(6,621) mxfs
STOP
ENDIF
WRITE(6,600) TITLE,NISTP
DO iso= 1,NISTP
c** Loop over isotopomers: read mass numbers & calcuate reduced masses
c Read data for lightest isotomer first and repeat for subsequent ones
c=======================================================================
c MN1(iso) - mass number of atom 1 of isotopomer 'iso'
c MN2(iso) - mass number of atom 2 of isotopomer 'iso'
c=======================================================================
READ(5,*) MN1(iso), MN2(iso)
c=======================================================================
IF((AN1.GT.0).AND.(AN1.LE.109)) THEN
CALL MASSES(AN1,MN1(iso),NAME1(iso),GEGS1,GNS1,
1 MASS1(iso),AB1)
ELSE
c ... If particle-1 is not a normal stable atomic species, read in a
c particle name (2-characters surrounded by 's) and mass in [u]
c=======================================================================
READ(5,*) NAME1(iso), MASS1(iso)
c=======================================================================
ENDIF
IF((AN2.GT.0).AND.(AN2.LE.109)) THEN
CALL MASSES(AN2,MN2(iso),NAME2(iso),GEGS2,GNS2,
1 MASS2(iso),AB2)
ELSE
c ... If particle-2 is not a normal stable atomic species, read in a
c particle name (2-characters surrounded by 's) and mass in [u]
c=======================================================================
READ(5,*) NAME2(iso), MASS2(iso)
c=======================================================================
ENDIF
c-----------------------------------------------------------------------
MU(iso)= MASS1(iso)*MASS2(iso)/(MASS1(iso)+MASS2(iso))
SQRTMU(iso)= DSQRT(MU(iso))
WRITE(6,602) NAME1(iso),MN1(iso),NAME2(iso),MN2(iso),
1 MASS1(iso),MASS2(iso),MU(iso)
ENDDO
c=======================================================================
c RH - radial mesh size (in angstroms) for numerical integration
c RMIN - lower limit (in angstroms) for numerical integration
c RMAX - upper limit (in angstroms) for numerical integration is
c internally set to the smaller of the read-in RMAX, or the
c largest distance allowed by array dimensions
c OVRCRT - convergence criterion for exact quantal calculation of
c continuum wavefunctions
c=======================================================================
READ(5,*) RH, RMIN, RMAX, OVRCRT
c=======================================================================
IF(FITIT.GT.0) THEN
WRITE(6,606) NSETS
ELSE
FITIT= 0
WRITE(6,610) NSETS
ENDIF
IF(MCALC.GT.0) THEN
WRITE(6,626) OVRCRT
ELSE
WRITE(6,628)
STOP
ENDIF
NIN= (RMAX - RMIN)/RH + 1
c-----------------------------------------------------------------------
c NIN is the number of initial-state potential mesh points
c-----------------------------------------------------------------------
IF(NIN.GE.mxisp) NIN = mxisp
RMAXOUT= RMIN + NIN*RH
WRITE(6,652) RMIN,RMAXOUT,RH
c======================================================================
c IWRSCH controls print level in matrix element subroutines in SCHRQ
c < 0 allows only printing of errors/warnings [normal setting]
c = 0 prevents all printing there
c > 0 prints results; > 1 more details; ; > 2 even more details; ...
c IWROVR controls print level inside OVRLAP and OVRPD
c < 0 allows only printing of errors/warnings [normal setting]
c = 0 no print
c = 1 prints overlap integrals and converged amplitudes
c > 1 prints additional details
c=======================================================================
READ(5,*) IWRSCH, IWROVR
c=======================================================================
IF(FITIT.GT.0) THEN
c=======================================================================
c IROUND controls rounding in nllssrr subroutine
c not equal 0 causes sequential rounding and re-fitting to be
c performed, with each parameter being rounded at the |iround|th
c significant digit of its local uncertainty
c > 0 rounding selects in turn remaining parameter w/ largest
c relative uncertainty
c < 0 rounds parameters sequentially from last to first
c = 0 simply stops after full convergence (no rounding)
c LPDER : if greater than zero, partial derivative array is written
c to channel 10
c UCUTOFF : ignore input data with uncertaities > UCUTOFF
c DFACT : (real) scaling factor in calculation of derivatives by
c differences in dyidpj subroutine; typically set to 1.0 (this
c is still under development)
c LPRINT : specifies the level of printing inside nllssrr.f
c = 0 no print except for failed convergence.
c < 0 only converged, unrounded parameters, PU & PS's
c >= 1 print converged parameters, PU & PS's
c >= 2 also print parameter change each rounding step
c >= 3 also indicate nature of convergence
c >= 4 also print convergence tests on each cycle
c >= 5 also parameters changes & uncertainties, each cycle
c=======================================================================
READ(5,*) IROUND, LPDER, UCUTOFF, DFACT, LPRINT
c=======================================================================
IF(IROUND.NE.0) WRITE(6,607) IABS(IROUND)
IF(IROUND.GT.0) WRITE(6,608)
IF(IROUND.LT.0) WRITE(6,609)
ENDIF
DO 10 iset= 1,NSETS
c=======================================================================
c INFO is a name for the data set, of up to 70-characters, read in on a
c single line, enclosed in single quotes: e.g. 'name for data set'
c ISOT specifies the isotopomer to be considered for this data set
c BOLTZ > 0 for calculation with Boltzman population of initial states
c = 0 does calculation for a specific (v,J) level
c DTYPE = 1 if property is (a sum) of final-state intensities
c = 2 if property is ratio of (sums of) final-state intensities
c IFRPW identifies type of data in this set
c = 0 for predissociation
c = 1 for (decadic) molar absorption coefficients
c = 3 for spontaneous emission
c = -1 for constant freqency factor in absorption
c = -3 for constant freqency factor in emission
c PQR = 0 if using the Q-branch approximation (J'= J")
c = 1 if the P, Q, and R braches are calculated, weighted by the
c Honl-London factor and summed over.
c=======================================================================
READ(5,*) INFO(iset)
READ(5,*) ISOT(iset), BOLTZ(iset), DTYPE(iset), IFRPW(iset),
1 PQR(iset)
c=======================================================================
WRITE(6,637) iset,INFO(iset)
IF(NFS.LE.1) THEN
CN(iset,1)= 1
ELSE
IF(DTYPE(iset).EQ.1) THEN
c=======================================================================
c If property is sum of intensities for multiple final states, read
c integer final-state weight coefficients here
c E(tot)= CN1*E(fs1) + CN2*E(fs2) + ... + CNnfs*E(nfs); CNi = 1 or 0
c=======================================================================
READ(5,*) (CN(iset,ifs), ifs= 1,NFS)
c=======================================================================
WRITE(6,629) NFS,(CN(iset,ifs),ifs= 1,NFS)
ELSEIF(DTYPE(iset).EQ.2) THEN
c=======================================================================
c If property is ratio of intensities, read (integer) numerator (CN)
c and denominator (CD) final-state sum weight coefficients here.
c E(ratio) = {CN(1)*E(fs1) + CN(2)*E(fs2) + ... + CN(nfs)*E(nfs)}/
c {CD(1)*E(fs1) + CD(2)*E(fs2) + ... + CD(nfs)*E(nfs)}
c CN(i) = 1 or 0
c CD(i) = 1 or 0
c=======================================================================
READ(5,*) (CN(iset,ifs), ifs= 1,NFS)
READ(5,*) (CD(iset,ifs), ifs= 1,NFS)
c=======================================================================
WRITE(6,630) iset,(CN(iset,ifs),ifs= 1,NFS)
WRITE(6,631) (CD(iset,ifs),ifs= 1,NFS)
ELSEIF((DTYPE(iset).LE.0).OR.(DTYPE(iset).GE.3)) THEN
WRITE(6,633) iset,DTYPE(iset)
STOP
ENDIF
ENDIF
TEMP(iset)= 0.d0
JFRPW= IABS(IFRPW(iset))
IF((JFRPW.NE.0).AND.(JFRPW.NE.1).AND.(JFRPW.NE.3)) THEN
WRITE (6,604) IFRPW(iset)
STOP
ENDIF
IF(JFRPW.EQ.1) WRITE(6,632)
IF(JFRPW.EQ.3) WRITE(6,634)
BFCT(ISOT(iset))= MU(ISOT(iset))*RH*RH/16.85762908d0
IF(JFRPW.EQ.0) FACTOR(iset)= 9.17555390D10*SQRTMU(ISOT(iset))
IF(JFRPW.EQ.1) FACTOR(iset)= 8.4397201D0*SQRTMU(ISOT(iset))
IF(JFRPW.EQ.3) FACTOR(iset)= 2.4313849D-8*SQRTMU(ISOT(iset))
IF(PQR(iset).GT.0) WRITE(6,613)
IF(PQR(iset).LE.0) WRITE(6,615)
c
c** Data/control parameter input for fit/prediction of predissociation
c-----------------------------------------------------------------------
IF(IFRPW(iset).EQ.0) THEN
BOLTZ(iset)= 0
NJ(iset)= 0
c=======================================================================
c NVJ is number of (v,J) states for which predissociation calculated
c In forward calculation, if NFV=0, perform for specified (v,J) range
c=======================================================================
READ(5,*) NVJ(iset)
c=======================================================================
IF(FITIT.LE.0) THEN
IF(NVJ(iset).GT.0) THEN
c** For No-FIT predictions: either read in (v,J)'s for predissociating
c levels (if NVJ > 0), ... OR (if NVJ=0) read integers to specify a
c range of initial-state levels V1ST.le.v.le.VMAX; J1ST.le.J.le.JMAX
c=======================================================================
c If NVJ > 0 read in list of initial (v,J) levels.
c VFIX - specific value of v for level (v,J) in forward calculation
c JFIX - specific value of J for level (v,J)
c=======================================================================
READ(5,*) (VFIX(ivj), JFIX(ivj), ivj= 1,NVJ(iset))
c=======================================================================
VMAX(iset)= 0
DO ivj= 1, NVJ(iset)
VMAX(iset)= MAX0(VMAX(iset),VFIX(ivj))
ENDDO
WRITE(6,645) NVJ(iset),iset,NAME1(ISOT(iset)),
1 MN1(ISOT(iset)),NAME2(ISOT(iset)),MN2(ISOT(iset)),
2 (VFIX(ivj),JFIX(ivj),ivj= 1,NVJ(iset))
ELSEIF(NVJ(iset).LE.0) THEN
c=======================================================================
c If read-in NVJ=0 , calculate predissociation rates for all levels
c from v= V1ST up to VMAX, for J= J1ST up to JMAX
c=======================================================================
READ(5,*) V1ST(iset),VMAX(iset), J1ST(iset),
1 JMAX(iset)
c=======================================================================
WRITE(6,649) V1ST(iset),J1ST(iset),VMAX(iset),
1 JMAX(iset)
ENDIF
c
ELSEIF(FITIT.GT.0) THEN
IF(NVJ(iset).LE.0) THEN
WRITE(6,603) iset,NVJ(iset),FITIT
STOP
ENDIF
c=======================================================================
c PUNITS > 0 for predissociation data input as widths (FWHM in cm-1)
c = 0 for predissociation data input as lifetimes (seconds)
c < 0 for predissociation data input as rates (inverse seconds)
c [Predissociation internally treated as rates (in s-1), so convert
c values if in other units. For not fitting, PUNITS is dummy variable]
c FWHM(cm-1) = RATE(s-1)/2*pi*c = 1/TAU(s)*2*pi*c
c ** 1/(2*pi*c) = 0.5308837458D-11
c=======================================================================
READ(5,*) PUNITS(iset)
c=======================================================================
ivj= 1
DO i= 1,nvj(iset)
c=======================================================================
c For a FIT, need to read each predissociation datum OBS and its
c uncertainty UNC for each initial-state level (v,J)= (VFIX,JFIX)
c Note: PUNITS (above) specifies units of input OBS and UNC values;
c calculation done as rates (s-1) so OBS and UNC converted internally
c=======================================================================
READ(5,*) VFIX(ivj), JFIX(ivj), OBS(ivj,iset),
1 UNC(ivj,iset)
c=======================================================================
IF(UNC(ivj,iset).LT.UCUTOFF) ivj= ivj+1
ENDDO
nvj(iset)= ivj-1
IF(PUNITS(iset).LT.0) THEN
WRITE(6,643) NVJ(iset),iset,(VFIX(ivj),JFIX(ivj),
1 OBS(ivj,iset),UNC(ivj,iset),ivj= 1,NVJ(iset))
ELSEIF(PUNITS(iset).EQ.0) THEN
WRITE(6,647) NVJ(iset),iset,(VFIX(ivj),JFIX(ivj),
1 OBS(ivj,iset),UNC(ivj,iset),ivj= 1,NVJ(iset))
DO ivj= 1,NVJ(iset)
OBS(ivj,iset)= 1.d0/OBS(ivj,iset)
UNC(ivj,iset)= 1.d0/UNC(ivj,iset)
ENDDO
ELSEIF(PUNITS(iset).GT.0) THEN
WRITE(6,648) NVJ(iset),iset,(VFIX(ivj),JFIX(ivj),
1 OBS(ivj,iset),UNC(ivj,iset),ivj= 1,NVJ(iset))
DO ivj= 1,NVJ(iset)
OBS(ivj,iset)= TWOPIC*OBS(ivj,iset)
UNC(ivj,iset)= TWOPIC*UNC(ivj,iset)
ENDDO
ENDIF
VMAX(iset)= 0
cc JMAX(iset)= 0
DO ivj= 1,nvj(iset)
c ... now - finally save OBS in correct units for fitting.
NDATA= NDATA+1
YO(NDATA)= OBS(ivj,iset)
YU(NDATA)= UNC(ivj,iset)
VMAX(iset)= MAX(VMAX(iset),VFIX(ivj))
cc JMAX(iset)= MAX(JMAX(iset),JFIX(ivj))
ENDDO
NFREQ(iset)= NVJ(iset)
ENDIF
c??? (not clear why Geoff set these ... but ...
NFREQ(iset)= 1
FREQ(1,iset)= 0.d0
WAVL(1,iset)= 0.d0
ENDIF
c ... end of input for case of a predissociation dataset
c
IF(IFRPW(iset).NE.0) THEN
c** Case of absorption or emission data sets for either thermal initial
c state or transitions (normally emission) from one initial (v,J)
IF(BOLTZ(iset).GT.0) THEN
c-----------------------------------------------------------------------
c** Data/control parameter input for a "thermal" property: BOLTZ > 0
c=======================================================================
c TEMP is the Kelvin temperature of the current input data set
c VMAX is the upper bound cutoff v value for the thermal sum over v
c NJ specifies how sum over a thermal rotational population is done
c < 0 for direct sum from J= 0 to J= |NJ|
c = 0 perform all calculations with J= 0
c > 0 sums over nj average J values in nj equally weighted
c segments of the rotational population for that v
c=======================================================================
READ(5,*) TEMP(iset), VMAX(iset), NJ(iset)
c=======================================================================
WRITE(6,625) TEMP(iset),NAME1(ISOT(iset)),
1 MN1(ISOT(iset)),NAME2(ISOT(iset)),MN2(ISOT(iset)),VMAX(iset)
WRITE(6,624) POPCRT
IF(NJ(iset).GT.mxnj) THEN
WRITE(6,611) mxnj,NJ(iset),NJ(iset)
NJ(iset)= -NJ(iset)
ENDIF
IF(NJ(iset).LE.0) THEN
JMAX(iset)= IABS(NJ(iset))
IF(JMAX(iset).GT.0) WRITE(6,618) JMAX(iset)
IF(JMAX(iset).EQ.0) WRITE(6,620)
ELSE
JMAX(iset)= NJ(iset)-1
WRITE(6,622) NJ(iset)
ENDIF
ELSEIF(BOLTZ(iset).LE.0) THEN
c** Control parameters for non-thermal absorption/emission from the
c particular initial-state level: v= V1ST, J= J1ST
c=======================================================================
READ(5,*) V1ST(iset), J1ST(iset)
c=======================================================================
WRITE(6,623) NAME1(ISOT(iset)),MN1(ISOT(iset)),
1 NAME2(ISOT(iset)),MN2(ISOT(iset)),V1ST(iset),J1ST(iset)
VMAX(iset)= V1ST(iset)
JMAX(iset)= J1ST(iset)
NVJ(iset)= 0
ENDIF
c
IF(FITIT.LE.0) THEN
c** For Non-FIT forward calculation, specify frequencies for calculations
c=======================================================================
c* For forward calculation, specify desired transition energy mesh
c NFREQ is the number of transition energies (in cm-1) for this set
c FREQ(i)= FREQ1 + (i-1)*DFREQ ; values negative for emission
c=======================================================================
READ(5,*) NFREQ(iset), FREQ1, DFREQ
c=======================================================================
IF(NFREQ(iset).GT.mxfreq) THEN
c** If number of requested frequencies exceeds array size - STOP!)
WRITE(6,888)
888 FORMAT(/' *** ERROR *** input NFREQ=',i10,' > array dimension',
1 ' mxfreq=',i6)
STOP
ENDIF
DO ifr= 1,NFREQ(iset)
FREQ(ifr,iset)= FREQ1 + (ifr-1)*DFREQ
WAVL(ifr,iset)= 1.d7/FREQ(ifr,iset)
ENDDO
WRITE(6,640) NFREQ(iset),(FREQ(ifr,iset),
1 ifr= 1,NFREQ(iset))
ENDIF
c
IF(FITIT.GT.0) THEN
c** For a FIT, read experimental absorption/emiss. intensities or ratios
c=======================================================================
c NFREQ is the number of data to be read in the current set
c FREQYN > 0 if read-in ordinate values are energies in (cm-1)
c = 0 if read-in ordinate values are wavelengths in (nm)
c=======================================================================
READ(5,*) NFREQ(iset), FREQYN
c=======================================================================
IF(NFREQ(iset).GT.mxfreq) THEN
WRITE(6,616) mxfreq
STOP
ENDIF
ifr= 1
DO i= 1, NFREQ(iset)
c=======================================================================
c FREQ input transition energies (cm-1) [or wavelengths (nm)]
c (for emission, values should be negative)
c OBS experimentally observed intensity values for current set
c UNC uncertainties in the experimental values
c=======================================================================
READ(5,*) FREQ(ifr,iset), OBS(ifr,iset),
1 UNC(ifr,iset)
c=======================================================================
IF(UNC(ifr,iset).LT.UCUTOFF) ifr= ifr+1
ENDDO
NFREQ(iset)= ifr-1
DO ifr= 1,NFREQ(iset)
NDATA= NDATA+1
YO(NDATA)= OBS(ifr,iset)
YU(NDATA)= UNC(ifr,iset)
ENDDO
IF(FREQYN.GT.0) THEN
c** As required ... generate wavelengths/frequencies for calculation
DO ifr= 1,NFREQ(iset)
WAVL(ifr,iset)= 1.d7/FREQ(ifr,iset)
ENDDO
ELSE
DO ifr= 1,NFREQ(iset)
WAVL(ifr,iset)= FREQ(ifr,iset)
FREQ(ifr,iset)= 1.d7/WAVL(ifr,iset)
ENDDO
ENDIF
WRITE(6,638) NFREQ(iset),iset,(FREQ(ifr,iset),
1 WAVL(ifr,iset),OBS(ifr,iset),UNC(ifr,iset),ifr= 1,NFREQ(iset))
ENDIF
ENDIF
IF(IFRPW(iset).LT.0) WRITE(6,644) JFRPW,FREQ(1,iset),JFRPW
10 CONTINUE
c=======================================================================
c ... end of loop to input data/cases for performing calculations
c=======================================================================
DO iset= 1,NSETS
SCALE(iset)= 0
SF(iset)= 1.d0
ENDDO
IF((FITIT.GT.0).AND.(NSETS.GT.1)) THEN
c
c** For a fit to multiple data sets, may wish to apply a global scaling
c to certain data subsets to allow for (say) uncertainties in
c concentration measurements for different isotopomers.
c=======================================================================
c SF(iset) is a multiplicative factor for scaling 2'nd, 3'rd, ... etc.
c data set values relative to 1'st data set.
c SCALE is a integer flag that tells whether or not scaling factors for
c 2'nd, 3'rd, ...) data sets are to be held fixed or varied in a fit.
c = 0 does not vary scaling factor for the set
c = 1 all scaling factor to vary in the fit.
c=======================================================================
READ(5,*) (SF(iset), iset= 2, NSETS)
READ(5,*) (SCALE(iset), iset= 2, NSETS)
c=======================================================================
ENDIF
c=======================================================================
c Preparation of Initial-State Potential
c=======================================================================
c Prepare distance array R = RAD(i) defining potential mesh points up
c to the upper dimensioned limit mxfsp
c Also prepare array XM2(i) = 1/R^2
c-----------------------------------------------------------------------
DO i= 1,mxfsp
RAD(i)= RMIN + (i-1)*RH
XM2(i)= 1.d0/RAD(i)**2
ENDDO
c
WRITE(6,656)
c** Allow different isotopomers to have different initial-state potentials
DO 20 iso= 1,NISTP
DO i= 1,NIN
RM2(i)= XM2(i)
ENDDO
CALL PREPOT(LNPT,AN1,AN2,MN1(iso),MN2(iso),NIN,OMEGA(0),
1 RAD,RM2,VLIMI,VIS,NCNI)
c-----------------------------------------------------------------------
c prepot inputs: LNPT,MASS1(iso),MASS2(iso),VLIMI,NIN,RAD(i),RM2(i)
c prepot outputs: VIS(i) - the generated initial-state potential array
c in units cm-1
c NCNI - read inside subroutine regarding potential tail
c RM2(i) - array may change to account for corrections
c=======================================================================
c in PREPOT: READ(5,*) NTPI, LPPOTI, OMEGA(0), VLIMI
c=======================================================================
c NTPI > 0 if reading in potential points and interpolating over
c and extrapolating beyond them to get desired potential
c = 0 to generate an analytic potential to be specified below
c LPPOTI > 0 to print generated potential and its derivatives-by-
c differences at every |LPPOTI|th point
c = 0 to prevent such printing
c OMEGA the (integer) total electronic angular momentum projection
c quantum number (required for proper rotational intensities)
c VLIMI - the absolute energy (in cm-1) at large R asymptote
c=======================================================================
c For pointwise potential (NTPI > 0)
c in PREPOT: READ(5,*) NUSEI, IR2I, ILRI, NCNI, CNNI
c in PREPOT: READ(5,*) RFACTI, EFACTI, VSHIFTI
c in PREPOT: READ(5,*) (XI(I), YI(I),I=1,NTPI)
c=======================================================================
c NUSEI > 0 to use NUSEI-point piecewise polynomial interpolation for
c read in potential points (typically 6,8,or 10)
c = 0 to use cubic spline interpolation scheme
c
c IR2I > 0 causes numerical interpolation to be performed over YI*XI^2
c rather than over the potential YI themselves; this may
c improve interpolation for a steep repulsive wall.
c
c ILRI specifies how to extrapolate beyond outer turning points
c < 0 fits last 3 to: VLIMI - A exp[-b(R-R0)^2]
c = 0 fits last 3 to: VLIMI - A R^p exp(-bR)
c = 1 fits last 2 to: VLIMI - A/(R^B)
c = 2 or 3 fit last 2 or 3 points to:
c VLIMI - sum[C(NCNI+2m)/R^(NCNI+2m)]; m = 0,ILRI-1
c > 3 fits last few points to:
c VLIMI - sum[C(NCNI+m)/R^(NCNI+m)]; m = 0,ILRI-1
c
c NCNI is used (if ILR > 1) to specify limiting inverse-power behavior
c of function tail; see ILRI.
c
c For ILRI > 1 cases, if CNNI.NE.0 fix limiting coefficient C(NCNI) at
c this read-in value, rather than from fit to outermost turning points.
c
c RFACTI - factor to convert read-in turning point x-values to angstroms
c EFACTI - factor to convert read-in turning point y-values to cm-1
c VSHIFTI - the energy (in cm-1) which must be added to the read-in
c potential points to make then consistent with the VLIMI value.
c
c (Xi,Yi) - are the NTPI pairs of potential points
c=======================================================================
c Generate analytical initial-state potential (NTPI.LE.0) in PREPOT
c* Potentials generated in cm-1 with potential asymptote at energy VLIM
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** IPOTL specifies the type of potential function to be generated.
c** MPAR & NPAR are integers for specifying potential types.
c** NVARB is number of (real*8) potential parameters read in.
c** IBOB specifies whether (if > 0) or not (if .le. 0) atomic mass
c dependent Born-Oppenheimer breakdown corrections will be included
c** For all functions considered, well depth and equilibrium distance
c are read as DSCM (cm-1) and REQ (Angstroms), respectively.
c* [Most read-in parameters are dimensionless (scaled by DSCM & REQ).]
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c** If IPOTL=1 generate an L.J.(MPAR,NPAR) potential.
c** If IPOTL=2 generate an MLJ(NPAR) potential [JCP 112, 3949 (2000)]
c If MPAR.ge.0 exponent parameter is polynomial of order (NVARB-1)
c in z=(R-Re)/(R+Re), with the NVARB coefficients PARM(j)
c If MPAR < 0 exponent polynomial in z has order (NVARB-4) with
c coefficients PARM(i) (i= 1,NVARB-3), & includes a switching
c function with exponent coefficient ALPHA= PARM(NVARB) and
c RSW= PARM(NVARB-1), defined to yield limiting inverse-power
c potential coefficient Cn= PARM(NVARB-2).
c** If IPOTL=3 generate a Morse or Extended Morse Oscillator potential
c with exponent factor "beta" defined as a power series of order
c (NVARB-1) in z=(R-Re)/(R+Re) with NVARB coefficients PARM(i).
c Set NVARB= 1 for conventional "simple" Morse potential.
c* Special option #1: set MPAR= -1 to produce Wei Hua's 4-parameter
c modified Morse function with b= PARM(1) and C= PARM(2).
c* Special option #2: set MPAR= -2 to produce Coxon's "Generalized
c Morse Oscillator" potential with exponent expansion in (R-Re)]
c ... otherwise, set MPAR.ge.0
c** If IPOTL=4 use Seto's modification of Surkus' GPEF expansion in
c z = [R^NPAR - Re^NPAR]/[a*R^NPAR + b*Re^NPAR] where
c a=PARM(NVARB-1) & b=PARM(NVARB), which incorporates Dunham, SPF,
c O-T and other forms: V(z) = c_0 z^2 [1 + c_1 z + c_2 z^2 + ...]
c where c_0 [cm-1] is read in as DSCM, and the first (NVARB-2)
c PARM(i)'s are the c_i (i > 0). [MPAR is dummy parameter here]
c * For Dunham case: NPAR=1, PARM(NVARB-1)= 0.0, PARM(NVARB)= 1.0
c * For SPF case: NPAR=1, PARM(NVARB-1)= 1.0, PARM(NVARB)= 0.0
c * For Ogilvie-Tipping: NPAR=1, PARM(NVARB-1)= 0.5 = PARM(NVARB)
c * NOTE that for Surkus NPAR < 0 case: z(NPAR,a,b)= z(|NPAR|,-b,-a)
c Generate & return the D_e value implied by these coefficients.
c** If IPOTL=5 generate generalized HFD(NPAR,6,8,10,12,14) potential.
c PARM(1-3) are the parameters defining the HFD damping function
c D(x)=exp[-pparm(1)*(PARM(2)/x - 1)**PARM(3)] {for x < PARM(2)}
c PARM(4) the quadratic coefficient in the exponent, and
c PARM(5) is the power of x=R/Req multiplying the repulsive term
c AREP*x**PARM(5) *exp[-beta*x - PARM(4)*x**2] ;
c PARM(6-11) are the reduced C_NPAR, C_6, C_8, C_10, C_12 and C14
c parameters (NPAR < 6), while AREP and beta are defined
c by having the potential minimum at x=1. For NVARB < 11, higher
c C_m coefficients automatically zero; necessarily NVARB.ge.7 .
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c** IBOB > 0, add atomic-mass-dependent Born-Openheimer breakdown
c correction functions to rotationless and/or centrifugal potential(s).
c Both expressed as power series in z= (R-Re)/(R+Re) starting with the
c constant term, using the mass shift convention of Le Roy [J.Mol.Spec.
c 194, 189 (1999)]. Adiabatic B-O-B potential correction fx. defined
c by polynomials of order NC1 with (NC1+1) coefficients {CA1(i)} for
c atom-1 and order NC2 with (NC2+1) coefficients {CA2(i)} for atom-2,
c while centrifugal correction fx. defined polynomial of order NG1 with
c (NG1+1) coefficients {GA1(i)} for atom-1 a nd order NG2 with (NG2+1)
c coefficients {GA2(i)} for atom-2.
c** Input parameters IANi & IMNi are the atomic & mass number of atom-i
c (i=1,2), while integers RMN1 & RMN2 read here are the mass numbers of
c the reference isotopes defining the B-O-B correction functions.
c** NC1 & NC2 are orders of polynomials DELTA(V,atom-i) defining
c 'adiabatic' corrections to the rotationless potential for atoms 1 & 2
c DELTA(V)= (1-M1ref/M1)*DELTA(V,atom-1) + (1-M2ref/M2)*DELTA(V,atom-2)
c** NG1 & NG2 are orders of polynomials q1(z) & q2(z) defining B-O-B
c correction to the centrifugal potential:
c V(centrifugal)= [1 + (M1ref/M1)*q1(z) + (M2ref/M2)*q2(z)]/R**2
c ... to omit a particular correction set associated NCi or NGi .lt.0
c** RX > 0.0 invokes Coxon's (older) expansions in (R-Re) for potential
c correction and in [(R-Rx)**j - (Re-Rx)**j] for centrifugal corrn.
c ... OTHERWISE (to use Le Roy B-O-B formalism) set RX.le.0.d0 !!
c-----------------------------------------------------------------------
c** Read inside subroutine POTGEN
c IF(LNPT.GT.0) THEN
c READ(5,*) IPOTL, MPAR, NPAR, NVARB, IBOB, DSCM, REQ
c IF(NVARB.GT.0) READ(5,*) (PARM(I), I=1,NVARB)
c IF(IBOB.GT.0) THEN
c READ(5,*) RMN1, RMN2, NC1, NC2, NG1, NG2, RX
c IF(NC1.GE.0) READ(5,*) (CA1(I), I=0,NC1)
c IF(NC2.GE.0) READ(5,*) (CA2(I), I=0,NC2)
c IF(NG1.GE.0) READ(5,*) (GA1(I), I=0,NG1)
c IF(NG2.GE.0) READ(5,*) (GA2(I), I=0,NG2)
c ENDIF
c ENDIF
c-----------------------------------------------------------------------
DO i= 1,NIN
c* Need to scale VIS(i) potential to internal units before entering ALF
VIS(i)= BFCT(iso)*VIS(i)
VI(i,iso)= VIS(i)
VICD(i,iso)= RM2(i)
ENDDO
MAXV= 0
DO iset= 1,NSETS
IF(VMAX(iset).GT.MAXV) MAXV= VMAX(iset)
ENDDO
c-----------------------------------------------------------------------
c Automatic Level Finder ALF:
c inputs: NIN,RMIN,RH,VIS,VLIMI,VMAX,ZMU,EPS,NCNI
c outputs: GV(v) calculated eigenvalue array
c INNR(v) associates level v with (=1) inner vs. outer (=0) well
c ERR - value representing degree of subroutine success
c-----------------------------------------------------------------------
CALL ALF(NIN,RMIN,RH,VIS,WF1,VLIMI,MAXV,ERR,MU(iso),EPS,
1 NCNI,GV,INNR,IWRSCH)
c** Now call CDJOEL to get CDC's needed for eigenvalue predictions
JREF= 0
BvWN= RH**2/BFCT(iso)
DO v=0,MAXV
MCI(v,0,iso)= GV(v)
INNER(v,iso)= INNR(v)
CALL SCHRQ(v,JREF,GV(v),GAMA,PMAX,VLIMI,VIS,WF1,BFCT(iso),
1 EPS,RMIN,RH,NIN,NBEG,NEND,INNR(v),IWRSCH,LPRWF)
CALL CDJOEL(GV(v),NBEG,NEND,BvWN,RH,IWRSCH,VIS,WF1,RM2,
1 RCNST)
DO c= 1,7
MCI(v,c,iso)= RCNST(c)
ENDDO
ENDDO
c-----------------------------------------------------------------------
WRITE(6,662) NAME1(iso),MN1(iso),NAME2(iso),MN2(iso),MAXV,
1 (v,(MCI(v,c,iso),c= 0,5),v= 0,MAXV)
WRITE(6,699)
20 CONTINUE
c=======================================================================
c REXFS - reference distance about which the final-state potentials
c are expanded
c REXTMF - reference point about which the transition moment functions
c are expanded
c LPFS > 0 causes every LPFS'th point of the final-state potential
c arrays to be written to channel-9; otherwise no print-out.
c LPTMF > 0 causes every LPFS'th point of transition moment function
c arrays to be written to channel-9; otherwise no print-out.
c For predissociation with derivative operator coupling, the
c separate dW/dR and dPSIc/dR components are collected and
c written WHEN FITIT = 0 (forward calc).
c=======================================================================
READ(5,*) REXFS, REXTMF, LPFS, LPTMF
c=======================================================================
c Preparation of Final-State Potentials and Transition Moment Functions
c-----------------------------------------------------------------------
WRITE(6,664) NFS
NPTOT= 0
NPPFREE= 0
DO 60 ifs= 1,NFS
c=======================================================================
c* FSTYPE = 1 for exponential repulsive potential
c VF = VLIMF + A * exp{-(R-REXFS)*[B + C*z + D*z^2 + E*z^3 + F*z^4};
c Values of A-F read as parameters FSPRM(i,ifs), i= 1-6 respectively
c
c* FSTYPE = 3 for Extended Morse Oscillator potential
c VF = VLIMF + A1*[exp{-(R-A2)*(A3 + A4*z + ...)} -1]**2 - A1
c Values of A1-A6 read as parameters FSPRM(i,ifs), i= 1-6 respectively
c
c* FSTYPE = 2 for pot'l defined by NTPFS turning pts. [RTPF(i),VTPF(i)]
c with a repulsive exponential inner wall attached to the 2
c innermost points. Interpolate to get potential array at required
c mesh with NUSEF-point piecewise polynomials or cubic splines.
c In this option, also add energy VSHFTF (cm-1) to the read-in
c potential points to make them consistent with the stated VLIMF
c value (often VSHFTF=Te). Read-in turning point distances and
c energies are multiplied by RFACT and VFACT, respectively,
c converting units to Angstroms and cm-1.
c
c Repulsive inner wall defined by fitting the 2 innermost read-in
c turning points to the form:
c
c VF(R) = A + B exp[-(R-REXFS)*(b0 + b1*z + b2*z^2 + ... + b5*z^5)
c
c where A and B are determined by the first 2 turning points;
c parameters b(j)= FSPRM[(j+1),nfsprm]
c
c OMEGA - is the total electronic angular momentum progection quantum
c number. Required when calculating Honl-London factor needed
c for P/Q/R intensity calculation for option 'PQR(iset)=1'
c
c NFSPRM - total number of final state parameters, fixed and free
c
c VLIMF - absolute energy (cm-1) at potential asymptote (large R)
c
c XCOORD is integer specifying expansion coordinate for the potential
c = p (p=1-9) for zfs = (R^p - REXFS^p)/(R^p + REXFS^p)
c = 10 for zfs = (R-REXFS)/R
c = 11 for zfs = (R-REXFS)/(REXFS)
c=======================================================================
READ(5,*) FSTYPE(ifs), OMEGA(ifs), NFSPRM(ifs), VLIMF(ifs),
1 XCOORD(ifs)
c=======================================================================
IF(NFSPRM(ifs).GT.6) THEN
NFSPRM(ifs)= mxprm
WRITE(6,666) NFSPRM(ifs)
ENDIF
c=======================================================================
c FSPRM(i) - array of nfsprm parameters defining the final state PES
c=======================================================================
READ(5,*) (FSPRM(j,ifs), j=1, NFSPRM(ifs))
c=======================================================================
IF (FITIT.GT.0) THEN
c=======================================================================
c FSVAR(i) - specifies the variability of fsprm(i)
c = 1 if parameter allowed to vary
c = 0 if parameter fixed
c=======================================================================
READ(5,*) (FSVAR(j,ifs), j=1, NFSPRM(ifs))
c=======================================================================
DO j= 1,NFSPRM(ifs)
IF((DABS(FSPRM(j,ifs)).LT.1.d-5).AND.
1 (FSVAR(j,ifs).GE.1)) THEN
FSPRM(j,ifs)= 1.d-3
WRITE(6,698) j,ifs
ENDIF
ENDDO
ENDIF
WRITE(6,667) ifs,OMEGA(ifs)
IP= XCOORD(ifs)
IF(XCOORD(ifs).EQ.1) WRITE(6,668) REXFS
IF((XCOORD(ifs).GE.2).AND.(XCOORD(ifs).LE.9))
1 WRITE(6,669) IP,IP,IP,IP,REXFS
IF(XCOORD(ifs).EQ.10) WRITE(6,670) REXFS
IF(XCOORD(ifs).EQ.11) WRITE(6,671) REXFS
IF((XCOORD(ifs).LE.0).OR.(XCOORD(ifs).GE.12)) THEN
WRITE(6,672) XCOORD(ifs)
ENDIF
IF(FSTYPE(ifs).EQ.1) THEN
CALL GENFS(ifs)
WRITE(6,674) VLIMF(ifs),(i,FSPRM(i,ifs),i=1,NFSPRM(ifs))
ELSEIF(FSTYPE(ifs).GE.3) THEN
CALL GENFS(ifs)
WRITE(6,675) VLIMF(ifs),(i,FSPRM(i,ifs),i=1,NFSPRM(ifs))
c-----------------------------------------------------------------------
c GENFS has ability to calculate and re-calculate new final state
c potentials for fitting iterations or forward calculation
c-----------------------------------------------------------------------
ELSEIF(FSTYPE(ifs).EQ.2) THEN
c=======================================================================
c NTPFS - number of data points KNOWN for potential: see description
c in PREPOT (above) for meanings of NUSEF, IR2F, ILRF, NCNF, CNNF
c RFACTF - conversion factor so that radial array is in Angstroms
c VFACTF - conversion factor so that potential array is in cm-1
c VSHFTF - the energy (cm-1) which must be added to the potential to
c make it consistent with the chosen VLIMF value
c RTPF(i) - radial array of turning points
c VTPF(i) - potential array of turning points
c=======================================================================
READ(5,*) NTPFS(ifs)
READ(5,*) NUSEF, IR2F, ILRF, NCNF, CNNF
READ(5,*) RFACTF, VFACTF, VSHFTF(ifs)
READ(5,*) (RTPF(i), VTPF(i), i= 1,NTPFS(ifs))
c=======================================================================
IF(NUSEF.GT.0) WRITE(6,676) VLIMF(ifs),NUSEF,NTPFS(ifs)
IF(NUSEF.LE.0) WRITE(6,677) VLIMF(ifs),NTPFS(ifs)
IF(IR2F.GT.0) WRITE(6,678)
IF((ILRF.GT.1).AND.(DABS(CNNF).GT.0.D0))
1 WRITE(6,679) CNNF,NCNF
WRITE(6,680) VSHFTF(ifs),RFACTF,VFACTF,
1 (RTPF(i),VTPF(i),i=1,NTPFS(ifs))
WRITE(6,681)
DO i= 1,NTPFS(ifs)
RTPF(i)= RTPF(i)*RFACTF
VTPF(i)= VTPF(i)*VFACTF + VSHFTF(ifs)
ENDDO
c-----------------------------------------------------------------------
c RTP(i) and VTP(i) arrays are 1st and 2nd radial turning points
c needed later in determination of inner repulsive wall.
c-----------------------------------------------------------------------
DO i=1,2
RTP(i,ifs)= RTPF(i)
VTP(i,ifs)= VTPF(i)
ENDDO
IF(IR2F.GT.0) THEN
DO i= 1,NTPFS(ifs)
VTPF(i)= VTPF(i)*RTPF(i)**2
ENDDO
ENDIF
NPRF= mxfsp
CALL GENINT(LNPT,mxfsp,RAD,FCT,NUSEF,IR2F,NTPFS(ifs),
1 RTPF,VTPF,VLIMF(ifs),ILRF,NCNF,CNNF,NPRS,NPRF)
WRITE(6,681)
c-----------------------------------------------------------------------
c GENINT subroutine used to interpolate over the entire range and
c extrapolate for both inner and outer regions of final state 2. The
c inner region will later be overwritten as it is fit to experimental
c data. Points found using GENINT will remain fixed for the mesh from
c RTPF(2) and outward but inner points must be variable (to fit data);
c mesh here will be determined by the added repulsive inner wall.
c
c GENINT inputs: LNPT, mxfsp, RAD(i), NUSEF, IR2F, {RTPF(i),VTPF(i)},
c VLIMF(ifs), ILRF, NCNF, CNNF, NPRS, NPRF
cgtk NPRS - no purpose here (to be removed ?????)
cgtk NPRF - no purpose here (to be removed ?????)
c
c GENINT outputs: FCT is 1-dimensional final-state potential array
c-----------------------------------------------------------------------
c Now need to get Final State array into 2 dimensional form.
c-----------------------------------------------------------------------
DO i=1,mxfsp
VF(i,ifs)= FCT(i)
ENDDO
CALL GENFS(ifs)
IF(FSTYPE(ifs).EQ.2) WRITE(6,601) AVALUE(ifs),
1 BVALUE(ifs),(j,FSPRM(j,ifs),j=1,NFSPRM(ifs))
ENDIF
c-----------------------------------------------------------------------
c Prepare Transition Moment Function arrays here
c=======================================================================
c GFS is a positive integer defining the electronic degeneracy of the
c transition associated with this state.
c TMFTYP specifies coordinate ztmf(R) in power series expansion
c < 0 for predisociation case where the TMF is not a power
c series but an operator instead
c P= -hbar^2/2*mu {dW/dr + 2W*d/dr}
c where W(r)= a/{4a^2 + (r - Rc)^2}
c [TWO CASES: -1 for one Lorentzian, -2 for two Lorentzians]
c * for the 1 Lorentzian case read in a, Rc as tmf parameters
c * for the 2 Lorentzian case read in as a1, Rc1, a2, Rc2
c = 0 for TMF defined by read-in array of points
c = 1 for ztmf = (r - Rextmf)/(r + Rextmf)
c = p = 2-10 for ztmf = (r^p - Rextmf^p)/(r^p + Rextmf^p)
c = 11 for ztmf = (r - Rextmf)/Rextmf [Dunham]
c = 12 for ztmf = 1/r^2
c = 13 for ztmf = r [the distance R itself]
c
c OTMF - the order transition moment function power series in {ztmf}
c - this is a DUMMY value for TMFTYP < 0
c=======================================================================
READ(5,*) GFS(ifs), TMFTYP(ifs), OTMF(ifs)
c=======================================================================
IF(TMFTYP(ifs).LT.0) OTMF(ifs)= 2*IABS(TMFTYP(ifs)) - 1
IF(OTMF(ifs)-1.GT.mxprm) THEN
WRITE(6,682) OTMF(ifs),mxprm-1
STOP
ENDIF
c=======================================================================
c TMFPRM - coefficients of the transition moment function power series
c - note that for TMFTYP = 0, these coefficients create a power
c series in function defined by read-in points (usually want
c linear function with leading coefficient fixed at zero)
c - for TMFTYP = -1, enter the "a" and "Rc" as
c parameters 0 and 1, respectively
c - for TMFTYP = -2, enter the "a" and "Rc" values for the 1st
c Lorentzian followed by the "a" and "Rc" values for the 2nd
c=======================================================================
READ(5,*) (TMFPRM(m,ifs), m=0, OTMF(ifs))
c=======================================================================
IF(FITIT.GT.0) THEN
c=======================================================================
c TMFVAR(i) - specifies whether the TMFPRM(i) are fixed or free in fit
c = 1 if parameter allowed to vary
c = 0 if parameter fixed
c=======================================================================
READ(5,*) (TMFVAR(m,ifs), m=0, OTMF(ifs))
c=======================================================================
ELSE
DO m= 0,OTMF(ifs)
TMFVAR(m,ifs)= 0
ENDDO
ENDIF
c=======================================================================
c GENTMF SUMMARY
c inputs - ifs, TMFTYP
c outputs ztmf(i,ifs) - radial array for transition moment function
c when TMFTYP .ge. 0
c - transition moment array itself when TMFTYP < 0
c=======================================================================
c IF TMFTYP(ifs)= 0 , GENTMF implements the following reads statements:
c READ(5,*) NPTMF, TMFLIM
c READ(5,*) NUSETMF, ILRTMF, NCNTMF, CNNTMF
c READ(5,*) RFACTMF, MFACTMF
c READ(5,*) (Xi(i),Yi(i),i=1,NPTMF)
c=======================================================================
c RFACTMF - factor to convert read-in distances to angstroms
c MFACTMF - factor to convert read-in y-values to moment fct. units
c=======================================================================
IF(TMFTYP(ifs).GE.0) THEN
CALL GENTMF(ifs)
WRITE(6,686)(TMFPRM(i,ifs),i=0,OTMF(ifs))
ENDIF
IF(TMFTYP(ifs).EQ.-1) WRITE(6,695) (TMFPRM(i,ifs),i= 0,1)
c
IF(FITIT.GT.0) THEN
DO i=1,NFSPRM(ifs)
IF(FSVAR(i,ifs).GT.0) THEN
NPPFREE= NPPFREE+ 1
NPTOT= NPTOT + 1
PV(NPTOT)= FSPRM(i,ifs)
ENDIF
ENDDO
DO m= 0,OTMF(ifs)
IF(TMFVAR(m,ifs).GT.0) THEN
NPTOT= NPTOT + 1
PV(NPTOT)= TMFPRM(m,ifs)
ENDIF
ENDDO
ENDIF
60 CONTINUE
WRITE(6,654) (GFS(i),i= 1,NFS)
WRITE(6,687)
DO ifs= 1,NFS
WRITE(6,688) (i,ifs,FSPRM(i,ifs),FSVAR(i,ifs),i=1,NFSPRM(ifs))
ENDDO
WRITE(6,689)
DO ifs= 1,NFS
WRITE(6,690) (m,ifs,TMFPRM(m,ifs),TMFVAR(m,ifs),m=0,OTMF(ifs))
ENDDO
IF((FITIT.GT.0).AND.(NSETS.GT.1)) THEN
WRITE(6,691)
DO iset= 1,NSETS
IF(SCALE(iset).GE.1) THEN
NPTOT= NPTOT + 1
PV(NPTOT)= SF(iset)
ENDIF
WRITE(6,692) iset,SF(iset),SCALE(iset)
ENDDO
ENDIF
WRITE(6,699)
IF(FITIT.LE.0) THEN
printyn= 1
CALL FORWARD
ENDIF
IF(FITIT.GT.0) THEN
printyn= 0
CALL NLLSSRR(NDATA,NPTOT,mxnp,IROUND,NGPRND,LPRINT,YO,YU,YD,
1 PV,PU,PS,CM,TSTPS,TSTPU,DSE)
c-----------------------------------------------------------------------
c nllssrr input - ndata,nptot,mxnp,iround,lprint,yo,yu,pv
c nllssrr output - yd,pv,pu,ps,cm,tstps,tstpu,dse
c
c write out the correlation matrix below
c-----------------------------------------------------------------------
IF(NPTOT.GT.1) THEN
WRITE(6,693) CM(1,1)
DO i= 2,NPTOT
WRITE(6,694) i,(CM(i,k),k= 1,i)
ENDDO
ENDIF
c-----------------------------------------------------------------------
c Before doing final calculation, map final parameters from nllssrr
c (pv values) back onto internal variables of bcont
c-----------------------------------------------------------------------
nprm= 0
DO ifs= 1,NFS
DO n= 1,NFSPRM(ifs)
IF(FSVAR(n,ifs).GT.0) THEN
nprm= nprm + 1
FSPRM(n,ifs)= PV(nprm)
ENDIF
ENDDO
DO m= 0,OTMF(ifs)
IF(TMFVAR(m,ifs).GT.0) THEN
nprm= nprm + 1
TMFPRM(m,ifs)= PV(nprm)
ENDIF
ENDDO
CALL GENFS(ifs)
IF(FSTYPE(ifs).EQ.2) WRITE(6,601) AVALUE(ifs),
1 BVALUE(ifs),(j,FSPRM(j,ifs),j= 1,NFSPRM(ifs))
ENDDO
DO iset= 1,NSETS
IF(SCALE(iset).EQ.1) THEN
nprm= nprm + 1
SF(iset)= PV(nprm)
ENDIF
ENDDO
c-----------------------------------------------------------------------
c Now do final calculation of intensities
c-----------------------------------------------------------------------
printyn= 1
CALL FORWARD
ENDIF
IF(FITIT.GT.0) THEN
i= 0
DO iset= 1,NSETS
RMS(iset)= 0.d0
IF(BOLTZ(iset).GT.0) THEN
c WRITE(8,802) iset,INFO(iset)
DO ifr= 1,NFREQ(iset)
i= i + 1
ADD= (OUTPUT(ifr,iset)-YO(i))/YU(i)
ADD= ADD*ADD
RMS(iset)= RMS(iset) + ADD
c WRITE(8,803) FREQ(ifr,iset),YO(i),YU(i),
c 1 OUTPUT(ifr,iset),OUTPUT(ifr,iset)-YO(i),
c 2 (OUTPUT(ifr,iset)-YO(i))/YU(i)
ENDDO
ELSE
c WRITE(8,804) iset,INFO(iset)
DO ivj= 1,NVJ(iset)
i= i + 1
ADD= (OUTPUT(ivj,iset)-YO(i))/YU(i)
ADD= ADD*ADD
RMS(iset)= RMS(iset) + ADD
c WRITE(8,805) VFIX(ivj),JFIX(ivj),YO(i),YU(i),
c 1 OUTPUT(ivj,iset),OUTPUT(ivj,iset)-YO(i),
c 2 (OUTPUT(ivj,iset)-YO(i))/YU(i)
ENDDO
ENDIF
IF(BOLTZ(iset).GT.0) RMS(iset)= RMS(iset)/NFREQ(iset)
IF(BOLTZ(iset).LE.0) RMS(iset)= RMS(iset)/NVJ(iset)
RMS(iset)= DSQRT(RMS(iset))
c WRITE(8,806) NFREQ(iset),iset,RMS(iset)
WRITE(6,806) NFREQ(iset),iset,RMS(iset)
ENDDO
ENDIF
c** If desired ... print potential & TMF arrays compactly to channel-9
DO ifs= 1, NFS
IF (LPFS.GT.0) THEN
WRITE(9,900) ifs,LPFS
WRITE(9,902) (RAD(i),VF(i,ifs),i=1,NIN,LPFS)
ENDIF
IF (LPTMF.GT.0) THEN
WRITE(9,904) ifs,LPTMF
DO i= 1,NIN,LPTMF
ztmf(i,5)= 0.d0
xtmf= 1.d0
DO m= 0,OTMF(ifs)
zTMF(i,5)= zTMF(i,5) + TMFPRM(m,ifs)*xtmf
xtmf= xtmf*ztmf(i,ifs)
ENDDO
ENDDO
WRITE(9,902) (RAD(i),zTMF(i,5), i= 1,NIN,LPTMF)
ENDIF
ENDDO
STOP
c-----------------------------------------------------------------------
600 FORMAT(/1x,a75/1x,25('===')/' Consider',I3,' isotopomer(s)'/1x,
1 69('-')/6x,'Isotopomer',7x,'Mass of atom-1 Mass of atom-2 Re
2duced mass'/2x,'----------------- ',3(' --------------'))
601 FORMAT(/" Potential is type-2, so PREPOT's inward extrapolation is
1 replaced by"/10x,'a variable inner exponential wall ',
2 'of the form:'/' V(r)= A + B*exp{-(r - REXFS)*[A1 + A2*y + ',
3 'A3*y^2 + ...]};'/16x,'A =',f14.6/16x,'B =',F14.6/
4 (15x,'A',i1,' =',F14.8))
602 FORMAT(2x,A2,'(',i3,') - ',A2,'(',I3,')',3(3x,F14.9))
603 FORMAT(/' *** ERROR *** Read-in NVJ(iset=',i2,')=',i3,
1 ' when FITIT=',i2)
604 FORMAT(/' **BCONT ERROR** ',I3,' is an invalid value for IFRPW.')
606 FORMAT(2x,69('-')//' Perform a Fit to',i3,' Set(s) of Experimental
1 Data.'/1x,48('='))
607 FORMAT(/' Apply "Sequential Rounding & Refitting" at digit-',
1 i1,' of the (local) parameter')
608 FORMAT(3x,'uncertainty, selecting remaining parameter with largest
1 relative uncertainty.')
609 FORMAT(3x,'uncertainty, proceeding sequentially from the LAST para
1meter to the FIRST.')
610 FORMAT(2x,69('-')//' Perform Forward Calculations for',i3,' Cases'
1 /1x,52('='))
611 FORMAT(/' Value of nj above upper limit, mxnj =',i3,'. Instead ',
1 'of dividing the population'/1x,'into',i3,' equal segments, do ',
2 'direct sum from J = 0 to J =',i3,'.')
612 FORMAT(' * Assume Boltzman population of initial states.')
613 FORMAT(' * Sum over P, Q and R branches for final-state rotational
1 levels')
615 FORMAT(' * Use Q-branch approximation for final state rotational l
1evels')
616 FORMAT(/' ** DIMENSIONING ERROR ** number of input frequencies ',
1 'cannot exceed ',i4)
617 FORMAT(/' ** DIMENSIONING ERROR ** number of input data sets ',
1 'cannot exceed ',i3)
618 FORMAT(' * Directly sum over thermally weighted rotational levels'
1 ,' from J = 0 to',I4)
619 FORMAT(/' ** DIMENSIONING ERROR ** number of input isotopes ',
1 'cannot exceed ',i2)
620 FORMAT(/' Fix J = 0 rather than summing over rotational ',
1 'distribution.')
621 FORMAT(/' ** DIMENSIONING ERROR ** number of final states ',
1 'cannot exceed ',i2)
622 FORMAT(/' Divide rotational distbn for each vib. level into',I3,
1 ' equally weighted segments.')
623 FORMAT(' Transitions from initial-state ',A2,'(',i3,')-',A2,'(',
1 i3,') level v=',i3,' J=',i4)
624 FORMAT(' * Initial-state thermal sum includes',F8.5,' of the vibra
1tional population')
625 FORMAT(' * Thermal T=',F7.2,'K initial state sum for ',A2,'(',
1 i3,') - ',A2,'(',i3,') has VMAX=',i3)
626 FORMAT( ' Calculations use exact (numerical) final-state continuum
1 wave functions'/' Amplitude convergence assumed when constant to'
2 ,1PD8.1,' at 3 successive maxima')
628 FORMAT(2x,69('-')/' Perform calculations using delta function appr
1oximation for final-state'/' continuum wave functions (reflectio
2n method).'//' *** NB. ONLY EXACT QUANTAL CALCULATION AVAILABLE ',
3 'AT THIS TIME ***')
629 FORMAT(' Property is sum of intensities over all',i2,
1 ' final states with weight factors:'/(5x,10I4))
630 FORMAT(' Case',i2,' property is ratio of final-state intensities w
1ith'/8x,'Numerator weight coefficients:',10I4:/(38x,10I4))
631 FORMAT(6x,'& Denomator weight coefficients:',10I4)
632 FORMAT(' * Units for calculated Molar Absorption Coefficients: ',
1 '(L/mol*cm)/(cm-1)')
633 FORMAT(/' *** ERROR *** For case',i2,' read-in DTYPE=',i2,' INVAL
1ID (Not equal 1 or 2)!')
634 FORMAT(' * Units of calculated Einstein Emission Intensity ',
1 'Coefficients: (sec-1)/(cm-1)')
637 FORMAT(/' Set-',i2,': ',A70/1x,35('=='))
638 FORMAT(/i4,' Set #',i2,' Experimental Intensity Coefficients:'/
1 3x,69('-')/2(' FREQ/cm-1 WAVL/nm OBS UNC ')/
2 2(3x,11('---'))/(2(f12.2,f10.4,f8.2,f6.2)))
640 FORMAT(/' Predict',i4,' Intensities at Frequencies (cm-1):'/
1 (8f10.2:))
643 FORMAT(/i4,' Experimental Predisociation Rates (s-1) in Data Set #
1',i2/1x,36('--')/2(' v J RATE(sec-1) UNC ',8x)/
2 2(' - - ----------- ---------',8x)/
3 (2(i4,i4,1PD13.4,D11.3,8x)))
644 FORMAT(/' **NOTE** For modelling purposes, replace (frequency)^',
1 I1,' factor'/' with the constant: (',F8.2,')^',I1)
645 FORMAT(/' Consider ',i3,' specific (v,J) Levels for Set #',i2,';',
1 2x,A2,'(',i3,') - ',A2,'(',I3,')'/
2 1x,39('--')/(8(2x:'(',i2,',',i2,')')):)
647 FORMAT(/1x,i3,' Experimental Predisociation Lifetimes for Set ',
1 i2/1x,36('--')/2(' v J LIFETIME(s) UNC ',8x)/
2 2(' - - ----------- ---------',8x)/
3 (2(i4,i4,1PD13.4,D11.3,8x)))
648 FORMAT(/1x,i3,' Experimental Predisociation Linewidths (FWHM) for'
1 ,' Set ',i2/1x,36('--')/2(' v J WIDTH(cm-1) UNC ',8x)/
2 2(' - - ----------- ---------',8x)/
3 (2(i4,i4,1PD13.4,D11.3,8x)))
649 FORMAT(/' Perform calculations for ALL (v,J) levels ',
1 'between (',I3,',',I3,') and (',I3,',',I3,')')
652 FORMAT(' Integrate initial-state wavefunctions from RMIN =',f6.3,
1 ' to RMAX =',f7.3/5x,'with mesh RH =',f10.7,' [Angstroms].')
654 FORMAT(/' Calculations use electronic state degeneracy factors:',
1 8i4)
656 FORMAT(/' For the initial electronic state:'/1x,17('=='))
662 FORMAT(/' Data for ',A2,'(',i3,')-',A2,'(',I3,
1 ') uses initial-state levels up to v = ',I2/1x,12('=='),14x,
2 'whose molecular constants are:'/2x,'v',7x,'Gv',
3 9x,'Bv',9x,'-Dv',11x,'Hv',10x,'Lv',11x,'Mv'/1x,39('--')/
4 (I3,0PF13.5,F11.7,1PD13.5,D13.5,D13.5,D13.5))
664 FORMAT(/1x,25('==')/' Consider transitions to',i3,' separate final
1 state(s)'/1x,25('=='))
666 FORMAT(/' **CAUTION** Value for NFSPRM was too large, ',
1 'internally reduced to',I3)
667 FORMAT(/' Final State',i2,' with OMEGA=',i2/1x,13('='))
668 FORMAT(' Radial expansion variable is y = (r - REXFS)/(r + REXFS
1) & REXFS=',F9.6)
669 FORMAT(' Radial expansion variable is y = (r^',i1,' - REXFS^',
1 i1,')/(r^',i1,' + REXFS^',i1,')'/11x,'where REXFS=',F9.6)
670 FORMAT(' Radial expansion variable is y = (r - REXFS)/r',
1 ' & REXFS=',F9.6)
671 FORMAT(' Radial expansion variable is y = (r - REXFS)/REXFS',
1 ' & REXFS=',F9.6)
672 FORMAT(/' *** Value for XCOORD(ifs)=',i3,' INVALID **** (must be
1 .ge.1 and .le.11).')
674 FORMAT(' Potential is type-1, an exponential of the form:'/7x,
1 'V(r) = VLIMF + A1*exp[-(r - REXFS)*(A2 + A3*y + A4*y^2 + ...)]'/
2 6x,'VLIMF =',f17.8/(9x,'A',i1,' =',F17.8))
675 FORMAT(' Potential is type-3, an Extended Morse Oscillator functi
1on:'/7x,'V(r) = VLIMF + A1*{exp[-(r - A2)*(A3 + A4*y + A5*y^2 + ..
2.)] - 1}**2 - A1'/6x,'VLIMF =',f17.8/(9x,'A',i1,' =',F17.8))
676 FORMAT('- Absolute energy at potential asymptote:',T45,'VLIMF =',
1 F12.5,' cm-1'/'- Perform',I3,'-point piecewise polynomial interpo
2lation over',I5,' input points')
677 FORMAT('- Absolute energy at potential asymptote:',T45,'VLIMF =',
1 F12.5,' cm-1'/'- Perform cubic spline interpolation over the',
2 I5,' input points')
678 FORMAT('- Interpolation actually performed over modified input arr
1ay: V(i) * R(i)**2')
679 FORMAT('- Beyond read-in points extrapolate to limiting asymptotic
1 behaviour:'/20x,'V(R) = V(lim) - (',D16.7,')/R**',I2)
680 FORMAT('- To make input points V(i) consistent with V(lim), add'
1 ,' V(shift)=',F12.4/'- Scale input points: (distance)*',
2 1PD16.9,' & (energy)*',D16.9/13x,'to get required internal unit
3s [Angstroms & cm-1 for potentials]'/
4 3(' R(i) Y(i) ')/3(3X,11('--'))/(3(0PF13.8,F12.4)))
681 FORMAT(1x,38('--'))
682 FORMAT(/' *** Fatal Error in TMF *** OTMF =',i3,' unallowed - ',
1 'must be less than ',I2)
686 FORMAT(' Coefficients of power series expansion for transition mom
1ent function are:'/(3x,6(f12.8):))
687 FORMAT(/' Parameter Summary'/1x,17('=')/' i ifs FSPRM(i,ifs)',
1 ' FSVAR(i,ifs)'/' - --- ----------------- ------------')
688 FORMAT(1x,i1,2x,i1,1x,f18.10,9x,i1)
689 FORMAT(/' m ifs TMFPRM(m,ifs) TMFVAR(m,ifs)'/
1 ' - --- ----------------- -------------')
690 FORMAT(1x,i1,2x,i1,1x,f18.10,9x,i1)
691 FORMAT(/' iset SCALING FACTOR SCALE '/
1 ' ---- ----------------- -------------')
692 FORMAT(1x,i2,13x,f8.6,9x,i1)
693 FORMAT(/14x,'Correlation Matrix'/' 1',f7.3,4x,9('--'))
694 FORMAT(i3,20(f7.3))
695 FORMAT(' Use Lorentzian Function for TMF; W= a/{4a^2 + (R-Rc)^2}'
1 /6x,'a= ',f12.8,/5x,'Rc= ',f12.8)
698 FORMAT(/' *WARNING* Variable Final State Param. cannot be zero, so
1 set FSPRM(',i1,',',i1,')= 0.001')
699 FORMAT(1x,39('--'))
802 FORMAT(/' Summary for data set #',i1/1x,a70/56x,'CALC-OBS'/
1 ' FREQUENCY',5x,'Y(obs) UNC Y(calc) CALC-OBS',
2 5x,'/UNC'/1x,31('--'))
803 FORMAT(2(f11.3),f8.3,3(f11.4))
804 FORMAT(/' Summary for data set #',i1/1x,a70/71x,'CALC-OBS'/
1 2x,' v J ',5x,'Y(obs) UNC Y(calc) CALC-OBS',
2 5x,'/UNC'/1x,31('--'))
805 FORMAT(2(i4),5(1PD13.5),f13.4)
806 FORMAT(' RMS deviation for the',i4,' data of set-',i2,' = ',f8.3)
900 FORMAT(/1x,'Final State',I2,' potential array written at every ',
1 i3,'th mesh point.')
902 FORMAT((4(F8.3,F12.4)):)
904 FORMAT(/' Transition Moment Function for Final State',i2,
1 ' written every ',i3,'th mesh point.')
c-----------------------------------------------------------------------
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE FORWARD
c=======================================================================
c-------------------- Last updated 9 February 2004 --------------------
c=======================================================================
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
c=======================================================================
INTEGER c,FITIT,i,ifr,ifs,INNER(0:mxv,mxisot),iset,IV,ivj,IWRSCH,
1 IWROVR,j,JDP,JFRPW,JNNER,JMIN,jp,jpmax,jpmin,JPWR,KV,LPRWF,LPTMF,
2 m,MCALC,MISS,NBEG,NEND,NFS,NIN,NSETS,printyn,RPD,v,VMIN,VLAST,
3 BOLTZ(mxsets),CD(mxsets,mxfs),CN(mxsets,mxfs),DTYPE(mxsets),
4 GFS(mxfs),IFRPW(mxsets),ISOT(mxsets),J1ST(mxsets),JFIX(mxfreq),
5 JM(mxnj),JMAX(mxsets),NFREQ(mxsets),NJ(mxsets),NVJ(mxsets),
6 OMEGA(0:mxfs),OTMF(mxfs),PQR(mxsets),SCALE(mxsets),TMFTYP(mxfs),
7 TMFVAR(0:mxprm-1,mxfs),V1ST(mxsets),VFIX(mxfreq),VMAX(mxsets)
c=======================================================================
REAL*8 CHNG,EVIN,ESAV,FACT,FACT1,FRQFCT,FTST,GAMA,HLFACT,JSCALE,
1 EDIF,EFN,EJTST,EPS,OVR,OVRCRT,QTOT,QTOTI,QTST,RDF,RH,RMIN,SUM,
2 TCM,VLIMI,ZKLIM,
3 BFCT(mxisot),DER(0:mxprm-1),dIdT(0:mxprm-1,mxfreq,mxfs,mxsets),
4 ESEGM(mxnj),FACTOR(mxsets),FREQ(mxfreq,mxsets),
5 MCI(0:mxv,0:7,mxisot),OBS(mxfreq,mxsets),UNC(mxfreq,mxsets),
6 OUTPUT(mxfreq,mxsets),
6 POPCRT,POPF,PSI(mxfsp),QVB(0:mxv),RAD(mxfsp),SF(mxsets),
7 TMFPRM(0:mxprm-1,mxfs),TEMP(mxsets),TOTFS(mxfreq,mxfs,mxsets),
8 UMAX,UJ(mxfsp),VF(mxfsp,mxfs),VI(mxisp,mxisot),
9 VICD(mxisp,mxisot),VLIMF(mxfs),WAVL(mxfreq,mxsets),XM2(mxfsp),
a ztmf(mxisp,mxfs),zin(mxisp)
CHARACTER*70 INFO(mxsets)
c=======================================================================
COMMON /MF/ BFCT,EPS,FACTOR,FREQ,MCI,OBS,UNC,OVRCRT,POPCRT,TEMP,
1 VI,VICD,VLIMI,WAVL,BOLTZ,CD,CN,DTYPE,FITIT,INNER,ISOT,IWRSCH,
2 IWROVR,J1ST,JFIX,JFRPW,JMAX,MCALC,NJ,OMEGA,PQR,printyn,
3 V1ST,VFIX,VMAX
COMMON /MFD/ dIdT,OUTPUT,SF,IFRPW,NFREQ,NFS,NSETS,NVJ,RPD,SCALE,
1 TMFVAR,INFO
COMMON /MFGf/ VF,VLIMF
COMMON /MFGt/ XM2,ztmf,LPTMF,NIN,TMFTYP
COMMON /MFGtGf/ RAD
COMMON /MFDGt/ TMFPRM,OTMF,GFS
c=======================================================================
DATA LPRWF/0/
c=======================================================================
c LPRWF specifies print level for initial state wavefuntion (chan.8)
c > 0 print wavefunction every LPRWF-th point.
c < 0 print every |LPRWF|-th point of wave function starting at
c R(NBEG) with step size |LPRWF|*RH
c = 0 to avoid printing
c-----------------------------------------------------------------------
RMIN= RAD(1)
RH= RAD(2)-RAD(1)
ivj= 0
c-----------------------------------------------------------------------
c begin by zeroing state-intensity and partial derivative arrays
c-----------------------------------------------------------------------
DO iset = 1,NSETS
DO ifr = 1,mxfreq
DO ifs = 1,NFS
TOTFS(ifr,ifs,iset)= 0.d0
IF(RPD.GT.0) THEN
DO m=0,OTMF(ifs)
dIdT(m,ifr,ifs,iset)= 0.d0
ENDDO
ENDIF
ENDDO
ENDDO
ENDDO
c-----------------------------------------------------------------------
c Begin actual calculation ... consider NSETS of data
c-----------------------------------------------------------------------
IF(FITIT.GT.0) WRITE(12,1200)
1200 FORMAT(' VARIABLES = FREQ,OBS,unc,calc,int1,int2,int3,int4')
1201 FORMAT(/'zone t="',a70,'"')
DO 1000 iset = 1,NSETS
IF(printyn.EQ.1) THEN
WRITE(6,697)
WRITE(6,690) INFO(iset)
ENDIF
IF((IFRPW(iset).EQ.0).AND.(printyn.EQ.1)) THEN
c ... for predissociation calculations
WRITE(6,600) (ifs,ifs= 1,NFS)
WRITE(6,699)
IF(FITIT.GT.0) THEN
WRITE(11,1105) (ifs,ifs= 1,NFS)
WRITE(11,699)
WRITE(12,1201) INFO(iset)
ENDIF
ENDIF
IF(BOLTZ(iset).GT.0) THEN
c ... for thermal absorption/emission calculations
VMIN = 0
JMIN = 0
TCM= 0.6950387D0*TEMP(iset)
ELSE
c ... for a transition from a specified state V1ST,J1ST
TCM= 9.d9
IF(NVJ(iset).GT.0) THEN
c ... if that transition is predissociation
VMIN= 1
VMAX(iset)= 1
JMIN= 1
JMAX(iset)= NVJ(iset)
ELSE
c ... if that transition is absorption/emission
VMIN= V1ST(iset)
VMAX(iset)= V1ST(iset)
JMIN= J1ST(iset)
JMAX(iset)= J1ST(iset)
ENDIF
ENDIF
QTOT= 0.d0
c-----------------------------------------------------------------------
c Specify rotational energy at which to cut off (direct) thermal J-sum
c-----------------------------------------------------------------------
IF((NJ(iset).LT.0).AND.(BOLTZ(iset).GT.0))
1 EJTST= -TCM*DLOG(1.d0-POPCRT)
c-----------------------------------------------------------------------
c Begin loop over vibrational levels
c-----------------------------------------------------------------------
DO 250 v = VMIN,VMAX(iset)
QVB(v)= 0.d0
IF((NJ(iset).GE.0).AND.(BOLTZ(iset).GT.0))
1 CALL JAVGE(v,NJ(iset),JM,MCI(v,1,ISOT(iset)),TCM)
c-----------------------------------------------------------------------
c** JAVGE uses equally weighted segments of the rotational population
c intead of doing complete sum over all J" values.
c Inputs: v,NJ,{MCI(v,1,isot)= Bv},TCM
c Output: JM(NJ)- the average J for each of the nj equally weighted
c segments of the rotational population for vibrational
c level whose rotational constant is BV
c-----------------------------------------------------------------------
c For predissociation, calculations, the counters below are used to
c represent the jth predissociating state. j runs from 1 to NVJ(iset)
c-----------------------------------------------------------------------
DO 200 j = JMIN,JMAX(iset)
c-----------------------------------------------------------------------
c j is the counter for loop over lower state J" (=JDP)
c Loop to incorporate population scaling factor for absolute result
c-----------------------------------------------------------------------
ivj= ivj + 1
IF((BOLTZ(iset).GT.0).OR.(NVJ(iset).LE.0)) THEN
IV= v
IF(NJ(iset).LE.0) JDP= j
IF(NJ(iset).GT.0) JDP= JM(j+1)
ELSE
IV= VFIX(j)
JDP= JFIX(j)
ENDIF
EVIN= 0.d0
JPWR= 1
DO c= 0,7
EVIN= EVIN + MCI(IV,c,ISOT(iset))*JPWR
JPWR= JPWR*JDP*(JDP+1)
ENDDO
JSCALE= DBLE(RH*RH*(JDP*(JDP+1)-OMEGA(0)**2))
c-----------------------------------------------------------------------
c now create centrifugally-distorted potential UJ(i) for initial state
c-----------------------------------------------------------------------
DO i= 1,NIN
UJ(i)= VI(i,ISOT(iset))+ JSCALE*VICD(i,ISOT(iset))
ENDDO
MISS= 0
c-----------------------------------------------------------------------
c UJ(i) above is used here for the initial state potential array
c WARNING - definition changes later and is used for final state
c-----------------------------------------------------------------------
50 KV= IV
c-----------------------------------------------------------------------
c SCHRQ Summary
c inputs KV,JDP,EVIN,VLIMI,UJ,BFCT,EPS,RMIN,RH,NIN,INNER,IWRSCH,LPRWF
c outputs KV - value of v may change inside program
c EVIN - which is now more precisely calculated
c GAMA -
c UMAX - maximum value of potential barrier (real)
c PSI - wavefunction array
c NBEG - beginning mesh point for wavefunction array
c NEND - final mesh point for wavefunction array
c-----------------------------------------------------------------------
c INNER specifies wave func'n matching (& initiation) condition (schrq)
c = 0 match inward & outward solutions at outermost wave function
c maximum; otherwise match at inner edge of classically allowed
c region
c < 0 uses zero slope inner boundary condition.
c
c For most cases set INNER = 0 but to find "inner-well-dominated"
c solutions of an asymmetric double minimum potential, set INNER > 0
c To find symmetric eigenfunctions of a symmetric potential, set
c INNER < 0 & start integration (set RMIN) at potential mid point
c-----------------------------------------------------------------------
JNNER= INNER(KV,ISOT(iset))
ESAV= EVIN
CALL SCHRQ(KV,JDP,EVIN,GAMA,UMAX,VLIMI,UJ,PSI,
1 BFCT(ISOT(iset)),EPS,RMIN,RH,NIN,NBEG,NEND,
2 JNNER,IWRSCH,LPRWF)
IF(KV.NE.IV) THEN
c** If find the WRONG level, try to fix it up!
MISS= MISS+1
IF(MISS.EQ.1) THEN
c ... first, assuming a double-well problem, switch the value of INNER
IF(INNER(KV,ISOT(iset)).GT.0) JNNER= 0
IF(INNER(KV,ISOT(iset)).LE.0) JNNER= 1
ELSE
c ... otherwise ... just jiggle up or down with original INNER
JNNER= INNER(KV,ISOT(iset))
IF(KV.GT.IV) THEN
CHNG= (MCI(KV,0,ISOT(iset))-
1 MCI(IV,0,ISOT(iset)))*(KV-IV)/ABS(KV-IV+1)
WRITE(6,602) IV,JDP,ESAV,KV,EVIN,ESAV-CHNG
EVIN= ESAV - CHNG
ELSE
CHNG= (MCI(IV,0,ISOT(iset))-
1 MCI(KV,0,ISOT(iset)))*(IV-KV)/ABS(IV-KV+1)
WRITE(6,602) IV,JDP,ESAV,KV,EVIN,ESAV+CHNG
EVIN= ESAV + CHNG
ENDIF
ENDIF
IF(MISS.GT.4) STOP
GOTO 50
ENDIF
IF((NJ(iset).GE.0).AND.(BOLTZ(iset).GT.0))
1 ESEGM(j+1)= EVIN
c-----------------------------------------------------------------------
c ESEGM(J") is the energy of the Jth equally weighted rotational segment
c-----------------------------------------------------------------------
IF(BOLTZ(iset).GT.0) THEN
IF(NJ(iset).LT.0) THEN
POPF=(2.d0*JDP + 1)*
1 DEXP(-(EVIN-MCI(0,0,ISOT(iset)))/TCM)
ELSE
POPF= DEXP(-(MCI(v,0,ISOT(iset))-
1 MCI(0,0,ISOT(iset)))/TCM)*TCM/
2 (MAX(NJ(iset),1)*MCI(v,1,ISOT(iset)))
ENDIF
ELSEIF(BOLTZ(iset).LE.0) THEN
POPF= 1.d0
ENDIF
QVB(v)= QVB(v) + POPF
QTOT= QTOT + POPF
FACT1= FACTOR(iset)*POPF
c-----------------------------------------------------------------------
c Now loop over contributions from excited electronic final states
c-----------------------------------------------------------------------
DO 150 ifs = 1,NFS
c-----------------------------------------------------------------------
c Change TMF array dimensions from 2 to 1 (for ovrlap subroutine)
c-----------------------------------------------------------------------
DO i= 1,NIN
zin(i)= ztmf(i,ifs)
ENDDO
c-----------------------------------------------------------------------
c For model predissociation calculations, calculate bound-state
c expectation value of transition moment function.
c-----------------------------------------------------------------------
cgtk - please check if this entire IF loop is even necessary
cgtk IF(IFRPW(iset).EQ.0) THEN
cgtk SUM= 0.d0
cgtk DO i= NBEG,NEND
cgtk RDF= 1.D0
cgtk DO m= 0,OTMF(ifs)
cgtk SUM= SUM + (TMFPRM(m,ifs)*RDF)*PSI(i)**2
cgtk RDF= RDF*ztmf(i,ifs)
cgtk ENDDO
cgtk ENDDO
cgtk SUM= SUM*RH
cgtk IF(printyn.EQ.1) WRITE(6,604) KV,JDP,EVIN,SUM
cgtk ENDIF
c-----------------------------------------------------------------------
c If PQR = 0, program collapses sum over final-state rotational
c quantum numbers to the single (Q-branch) term
c If PQR = 1, program allows for P,Q, and R branches with appropriate
c Honl-London factors
c-----------------------------------------------------------------------
IF(PQR(iset).LE.0) THEN
jpmin= JDP
jpmax= JDP
ELSE
jpmin= JDP-1
jpmax= JDP+1
ENDIF
DO 125 jp= jpmin,jpmax
c-----------------------------------------------------------------------
c jp = J', the upper state value of J
c-----------------------------------------------------------------------
CALL HONL(HLFACT,JDP,jp,OMEGA,PQR(iset),ifs)
c-----------------------------------------------------------------------
c HONL inputs: JDP,jp,OMEGA(i=0,ifs),PQR(iset),ifs
c output: HLFACT - the Honl-London factor, divided by (2J+1), for
c a specified branch for a given delta-omega value
c-----------------------------------------------------------------------
IF(HLFACT.LE.0.d0) GOTO 125
c** Include Electronic degeneracy factor ...
HLFACT= HLFACT*GFS(ifs)
c-----------------------------------------------------------------------
c Add centrifugal term to final-state potential before overlap calcn.
c Note that here UJ(i) is used for the final state potential array
c since the initial potential is no longer needed - wavefunction array
c already calculated and stored.
c Note that final-state potential is in (scaled) internal units
c-----------------------------------------------------------------------
JSCALE= DBLE(RH*RH*jp*(jp+1))
DO i= 1,mxfsp
UJ(i)= VF(i,ifs)*BFCT(ISOT(iset)) +
1 JSCALE*XM2(i)
ENDDO
c-----------------------------------------------------------------------
DO 100 ifr= 1,NFREQ(iset)
IF(JFRPW.EQ.3) THEN
EFN= EVIN - FREQ(ifr,iset)
ELSE
EFN= EVIN + FREQ(ifr,iset)
ENDIF
IF((EFN.LE.VLIMF(ifs)).AND.
1 (IFRPW(iset).EQ.0)) THEN
IF(printyn.EQ.1)
1 WRITE(6,606) IV,JDP,EFN,0.d0
OUTPUT(ivj,iset)= 0.d0
TOTFS(ivj,ifs,iset)= 0.d0
GOTO 200
ENDIF
IF(EFN.LE.VLIMF(ifs)) GOTO 100
c-----------------------------------------------------------------------
c EFN must be above the lower asymptote for upper potential
c-----------------------------------------------------------------------
FRQFCT= 1.d0
IF(IFRPW(iset).GT.0)
1 FRQFCT= FREQ(ifr,iset)**IFRPW(iset)
IF(IFRPW(iset).LT.0)
1 FRQFCT= FREQ(1,iset)**JFRPW
ZKLIM= DSQRT(EFN - VLIMF(ifs))
FACT= FACT1*HLFACT*FRQFCT/ZKLIM
c-----------------------------------------------------------------------
c Perform overlap integral calculation in OVRLAP or OVRPD
c **OVRPD is the special case for PreDissociation with TMF as operator
cgtk OVRDLT not available at this time
c-----------------------------------------------------------------------
cgtk IF (MCALC.EQ.0) CALL OVRDLT()
c-----------------------------------------------------------------------
IF (MCALC.GT.0) THEN
IF(TMFTYP(ifs).GE.0) THEN
CALL OVRLAP(BFCT(ISOT(iset)),DER,EFN,OVR,OVRCRT,PSI,RH,RMIN,
1 TMFPRM,UJ,VLIMF(ifs),zin,ifs,IWROVR,jp,NEND,OTMF(ifs),TMFTYP)
ELSE
CALL OVRPD(BFCT(ISOT(iset)),DER,EFN,OVR,OVRCRT,RAD,PSI,TMFPRM,UJ,
1 VLIMF(ifs),FITIT,ifs,IWROVR,jp,LPTMF,NEND,OTMF(ifs),TMFVAR)
ENDIF
ENDIF
OVR= FACT*OVR
IF(RPD.GT.0) THEN
DO m= 0,OTMF(ifs)
IF(IFRPW(iset).EQ.0) THEN
dIdT(m,ivj,ifs,iset)=
1 FACT*DER(m)*SF(iset)
c note that for predissociation, there is no accumulation of TOTFS
c since dealing with only one frequency... easiest to add scaling
c factor here for predissociation - scale abs/emmission cases later
ELSE
dIdT(m,ifr,ifs,iset)=
1 dIdT(m,ifr,ifs,iset)+ FACT*DER(m)
ENDIF
ENDDO
ENDIF
IF(IFRPW(iset).EQ.0) THEN
c???
c??? Geoff Had SF scaling here???? TOTFS(ivj,ifs,iset)= OVR*SF(iset)
c???
TOTFS(ivj,ifs,iset)= OVR
ELSE
TOTFS(ifr,ifs,iset)=
1 TOTFS(ifr,ifs,iset)+OVR
ENDIF
100 CONTINUE
c ... end of loop over frequencies
c-----------------------------------------------------------------------
125 CONTINUE
c ... end of loop over J'
c-----------------------------------------------------------------------
150 CONTINUE
c ... end of loop over final electronic states
c-----------------------------------------------------------------------
IF(IFRPW(iset).EQ.0) THEN
CALL ADD(iset,ivj,NFS,DTYPE(iset),CN,CD,TOTFS,
1 RPD,OTMF,dIdT,OUTPUT)
c subroutine "ADD" simply adds the contribution of each final state
IF(printyn.EQ.1) THEN
WRITE(6,606) KV,JDP,EFN,OUTPUT(ivj,iset),
1 (TOTFS(ivj,ifs,iset),ifs=1,NFS)
IF(FITIT.GT.0) THEN
WRITE(11,1106) KV,JDP,EFN,OBS(ivj,iset),
1 OUTPUT(ivj,iset),(TOTFS(ivj,ifs,iset),ifs=1,NFS)
WRITE(12,1106) KV,JDP,EFN,OBS(ivj,iset),
1 OUTPUT(ivj,iset),(TOTFS(ivj,ifs,iset),ifs=1,NFS)
ENDIF
ENDIF
ENDIF
IF((NJ(iset).LT.0).AND.(BOLTZ(iset).GT.0)) THEN
c-----------------------------------------------------------------------
c In appropriate case, truncate direct sum over initial-state
c rotational population when fraction POPCRT of the rotational
c population for that vibrational level is accounted for.
c-----------------------------------------------------------------------
IF((EVIN-MCI(v,0,ISOT(iset))).GT.EJTST) THEN
IF(printyn.EQ.1)
1 WRITE(6,608) KV,TEMP(iset),JDP,EVIN
GOTO 210
ENDIF
ELSEIF((BOLTZ(iset).LE.0).AND.(IFRPW(iset).NE.0))
1 THEN
WRITE(6,609) V1ST(iset),J1ST(iset)
ENDIF
200 CONTINUE
c ... end of loop over initial-state J"
c-----------------------------------------------------------------------
210 IF((IFRPW(iset).NE.0).AND.(printyn.EQ.1).AND.
1 (NJ(iset).GT.0)) WRITE(6,610) KV,(JM(i),ESEGM(i),i=1,NJ(iset))
c-----------------------------------------------------------------------
c** As appropriate, truncate thermal vibrational sum when fraction
c POPCRT of possible levels have been accounted for. (Missing levels'
c effect estimated using a harmonic approximation).
c-----------------------------------------------------------------------
IF((v.GT.0).AND.(BOLTZ(iset).GT.0)) THEN
IF (v.LT.VMAX(iset)) THEN
EDIF= MCI(v+1,0,ISOT(iset))-MCI(v,0,ISOT(iset))
ELSE
EDIF= MCI(v,0,ISOT(iset))-MCI(v-1,0,ISOT(iset))
ENDIF
FTST= DEXP(-(EDIF+MCI(v,0,ISOT(iset))-
1 MCI(0,0,ISOT(iset)))/TCM)*TCM/MCI(v,1,ISOT(iset))/
2 (1.d0-DEXP(-EDIF/TCM))
QTST= QTOT/(QTOT+FTST)
VLAST= v
IF(QTST.GT.POPCRT) GOTO 252
ENDIF
250 CONTINUE
c-----------------------------------------------------------------------
c ... 250 ends loop over initial-state v"
c at this point multiply by scaling factor and boltzman factor for
c absorption and emmission cases
c-----------------------------------------------------------------------
cc 252 IF(BOLTZ(iset).GT.0) THEN
252 CONTINUE
IF(BOLTZ(iset).GT.0) THEN
DO i= 0,VLAST
QVB(i)= QVB(i)/(QTOT+FTST)
ENDDO
IF(printyn.EQ.1) WRITE(6,620) TEMP(iset),VLAST+1,QTST,
1 (i,QVB(i),i= 0,VLAST)
cc ENDIF
QTOTI= 1.d0/QTOT
DO ifs = 1,NFS
DO ifr= 1,NFREQ(iset)
TOTFS(ifr,ifs,iset)= QTOTI*TOTFS(ifr,ifs,iset)
1 *SF(iset)
c???
c??? Omit SF here ... property of OBS not of CALC !!
c??? TOTFS(ifr,ifs,iset)= QTOTI*TOTFS(ifr,ifs,iset)
c???
IF(RPD.gt.0) THEN
DO m= 0,OTMF(ifs)
dIdT(m,ifr,ifs,iset)= QTOTI*
1 dIdT(m,ifr,ifs,iset)*SF(iset)
ENDDO
ENDIF
ENDDO
ENDDO
ENDIF
CALL ADD(iset,NFREQ(iset),NFS,DTYPE(iset),CN,CD,TOTFS,RPD,
1 OTMF,dIdT,OUTPUT)
IF((IFRPW(iset).NE.0).AND.(printyn.EQ.1)) THEN
IF(SF(iset).NE.1.d0) WRITE(6,617) SF(iset)
WRITE(6,699)
IF(DTYPE(iset).EQ.1) THEN
WRITE(6,614) iset,TEMP(iset),(ifs,ifs=1,NFS)
WRITE(6,699)
DO ifr=1,NFREQ(iset)
WRITE(6,616) FREQ(ifr,iset),WAVL(ifr,iset),
1 OUTPUT(ifr,iset),(TOTFS(ifr,ifs,iset),ifs=1,NFS)
ENDDO
IF(FITIT.GT.0) THEN
WRITE(11,1100) iset,TEMP(iset),
1 INFO(iset),(ifs,ifs=1,NFS)
WRITE(11,699)
WRITE(12,1201) INFO(iset)
ENDIF
ENDIF
IF(DTYPE(iset).EQ.2) THEN
WRITE(6,615) iset,TEMP(iset),
1 (CN(iset,ifs),ifs,ifs= 1,NFS)
WRITE(6,623) (CD(iset,ifs),ifs,ifs= 1,NFS)
WRITE(6,622) (ifs,ifs=1,NFS)
WRITE(6,699)
DO ifr=1,NFREQ(iset)
WRITE(6,618) FREQ(ifr,iset),WAVL(ifr,iset),
1 OUTPUT(ifr,iset),(TOTFS(ifr,ifs,iset),ifs=1,NFS)
ENDDO
IF(FITIT.GT.0) THEN
WRITE(11,1101) iset,TEMP(iset),INFO(iset),
1 (ifs,ifs=1,NFS)
WRITE(11,699)
WRITE(12,1201) INFO(iset)
ENDIF
ENDIF
WRITE(6,698)
IF(FITIT.GT.0) WRITE(11,699)
DO ifr=1,NFREQ(iset)
IF(FITIT.GT.0) THEN
WRITE(11,1102) FREQ(ifr,iset),
1 OBS(ifr,iset),UNC(ifr,iset),OUTPUT(ifr,iset),
2 (OUTPUT(ifr,iset)-OBS(ifr,iset))/UNC(ifr,iset),
3 (TOTFS(ifr,ifs,iset),ifs=1,NFS)
WRITE(12,1102) FREQ(ifr,iset),
1 OBS(ifr,iset),UNC(ifr,iset),OUTPUT(ifr,iset),
2 (TOTFS(ifr,ifs,iset),ifs=1,NFS)
ENDIF
ENDDO
IF(FITIT.GT.0) WRITE(11,698)
ENDIF
1000 CONTINUE
RETURN
c-----------------------------------------------------------------------
600 FORMAT(' Predissociation Rates [s-1]'//3x,'v',3x,'J"',3x,
1 'E(v,J)',4x,'TOTAL RATE',5x,'State-',I1,4(8x:'State-',I1))
602 FORMAT(' *** WARNING ... while searching for v=',I3,', J=',i3,
1 ' with EVIN=',f9.2/5x,'actually find v=',I3,' at E=',F9.2,
2 ' Reset EVIN=',f10.2,' & try again.')
604 FORMAT(' For E(v=',I2,' J=',I3,') =',F11.4,', <coupling ',
1 'function> =',G16.8)
606 FORMAT(1x,i3,1x,i3,f11.3,6(1PD14.6))
608 FORMAT(1x,'Truncate v=',I2,' thermal T=',f7.2,'K rotational su
1m at E(v,J=',i3,')=',f8.2,'[wn]')
609 FORMAT(' Calculation is for initial-state level v=',i3,' J=',
1 I3)
610 FORMAT(' Initial-state level v =',I2,' has rotational sublevels'/
1(4(3x:'E(',I3,')=',F10.3)))
614 FORMAT(' Calculated Transition Intensity Coefficients for set #',
1 I2,' [T = ',F6.1,']'/' FREQ/cm-1 WAVL/nm TOTAL',
2 5(4x:'State-',I1)/)
615 FORMAT(' Calculated Transition Intensity Ratios for set #',I2,
1 ' [Temp = ',F6.1,']'/11x,I2,'*I(fs',SS,I1,')',
2 5(SP,I3,'*I(fs',SS,I1,')':))
623 FORMAT(' Ratio = ',60('-')/11x,I2,'*I(fs',SS,I1,')',
1 5(SP,I3,'*I(fs',SS,I1,')':))
622 FORMAT(' FREQ/cm-1 WAVL(nm) Ratio',5(4x,'State-',I1:))
616 FORMAT(f9.2,f10.4,f12.2,6(f11.5))
617 FORMAT( ' Calculated absorption coefficients multiplied by scaling
1 factor:',f9.5)
618 FORMAT(f9.2,f10.4,f12.6,6(f11.5))
620 FORMAT(' At T=',f7.2,'K population fraction factors for',I3,
1 ' vibrational levels containing'/5x,'population fraction',f11.8,
2 ' are: Fvib(v=',I2,')=',f12.9/(43x,'Fvib(v=',I2,')=',f12.9))
690 FORMAT(1x,a70)
697 FORMAT(/40('=='))
698 FORMAT(40('=='))
699 FORMAT(40('--'))
1100 FORMAT(/' Calculated Transition Intensity Coefficients for ',
1 'Data Set #',I2,' [Temp = ',F6.1,']'/1x,a70/' FREQ(cm-1) ',
2 ' OBS UNC CALC [c-o]/u',5(2x:'State-',I1)/)
1101 FORMAT(/' Calculated Transition Intensity Ratios for ',
1 'Data Set #',I2,' [Temp = ',F6.1,']'/1x,a70/' FREQ(cm-1) ',
2 ' OBS UNC CALC [c-o]/u',5(2x:'State-',I1)/)
1102 FORMAT(f10.2,f9.3,f8.3,f9.3,f8.3,6(f9.3:))
1105 FORMAT(/1x,79('-')/1x,'Calculated Predissociation Rates'//3x,
1 'v',3x,'J"',3x,'E(v,J)',4x,' OBS RATE ',4x,'CALC RATE',6x,
2 'State-',I1,4(8x:'State-',I1))
1106 FORMAT(1x,i3,1x,i3,f11.3,7(1PD14.6))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE ADD(iset,n,nfs,type,cn,cd,totfs,rpd,otmf,dIdT,output)
c-----------------------------------------------------------------------
c Add individual intensity contributions to get total sum or ratio value
c-----------------------------------------------------------------------
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
INTEGER i,ifs,m,n,nfs,cd(mxsets,mxfs),cn(mxsets,mxfs),rpd,
1 iset,otmf(mxfs),type
REAL*8 dIdT(0:mxprm-1,mxfreq,mxfs,mxsets),
1 output(mxfreq,mxsets),sumnum,sumden,
2 totfs(mxfreq,mxfs,mxsets)
c
DO i= 1,n
sumnum= 0.d0
sumden= 0.d0
DO ifs= 1,nfs
IF(type.EQ.1) THEN
sumnum= sumnum + cn(iset,ifs)*totfs(i,ifs,iset)
ELSEIF(type.EQ.2) THEN
sumnum= sumnum + cn(iset,ifs)*totfs(i,ifs,iset)
sumden= sumden + cd(iset,ifs)*totfs(i,ifs,iset)
ENDIF
ENDDO
IF((type.EQ.2).AND.(rpd.GT.0)) THEN
DO ifs= 1,nfs
DO m= 0,otmf(ifs)
dIdT(m,i,ifs,iset)= dIdT(m,i,ifs,iset)*
1 (cn(iset,ifs)*sumden - cd(iset,ifs)*sumnum)/(sumden*sumden)
ENDDO
ENDDO
ENDIF
IF(type.EQ.1) THEN
output(i,iset)= sumnum
ELSEIF(type.EQ.2) THEN
output(i,iset)= sumnum/sumden
ENDIF
ENDDO
RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
c last updated 5 Oct'01 rjl
c=======================================================================
SUBROUTINE GENFS(ifs)
c=======================================================================
c** Subroutine to prepare final-state potential: currently 3 options:
c* FSTYPE= 1 : Repulsive exponential with variable exponent
c V = VLIMF + A1*exp{-(r- Rexfs)*[A2 + A3*y + A4*y^2 ...]}
c* FSTYPE= 2 : Numerical potential@ longer range with the 2 innermost
c points defining B0 & B1 in expansion
c V = B0 + B1*exp{-(r- Rexfs)*[A2 + A3*y +A4*y^2 ...]}
c* FSTYPE= 3 : EMO potential
c V = VLIMF + A1*[1 + exp{-(r- A2))*[A3 + A4*y + ...]}]^2 - A1
c-----------------------------------------------------------------------
c inputs FSPRM(j,ifs) - final state parameters (one set per final
c state)
c FSTYPE(ifs) - specifies the type of final state potential
c ifs - final state counter
c mxfsp - number of final state potential points
c NFSPRM(ifs) - number of final state parameters
c RAD(i) - radial distance array
c REXFS - point about which potential is expanded
c RTP(i,ifs) - (for FSTYPE=2) radial distance for turning
c points i= 1 or 2
c VTP(i,ifs) - (for FSTYPE=2) potential value for turning
c points i= 1 or 2
c XCOORD(ifs) - expansion COORDinate y for final-state potenl.
c XCOORD = p (p=1-9)
c for y= zfs= (r^p - REXFS^p)/(r^p + REXFS^p)
c XCOORD = 10 for y= zfs= (r-REXFS)/r
c XCOORD = 11 for y= zfs= (r-REXFS)/(REXFS)
c
c outputs VF(i,ifs) - final state potential array
c-----------------------------------------------------------------------
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
c-----------------------------------------------------------------------
INTEGER FSTYPE(mxfs),i,ifs,IP,j,NFSPRM(mxfs),NUMIMP,XCOORD(mxfs)
c-----------------------------------------------------------------------
REAL*8 AVALUE(mxfs),BETA,EF,ES,EXPON1,EXPON2,BVALUE(mxfs),
1 FSPRM(mxprm,mxfs),numer,R1,R2,RAD(mxfsp),REXFS,REQFS,RH,RMIN,
2 RTP(2,mxfs),VF(mxfsp,mxfs),VLIMF(mxfs),VTP(2,mxfs),
3 zfs(mxfsp,mxfs),z1,z2,ZZ,ZZ1,ZZ2
c-----------------------------------------------------------------------
COMMON /MGf/ AVALUE,BVALUE,REXFS,RTP,VTP,zfs,FSTYPE,XCOORD
COMMON /MFGf/ VF,VLIMF
COMMON /MDGf/ FSPRM,NFSPRM
COMMON /MFGtGf/ RAD
c-----------------------------------------------------------------------
RMIN= RAD(1)
RH= RAD(2)-RAD(1)
c
IP= XCOORD(ifs)
IF(FSTYPE(ifs).EQ.1) THEN
c-----------------------------------------------------------------------
c Final state type 1 has a purely repulsive analytic potential form:
c VF = VLIMF + A1 * exp{-(R-REXFS)*[A2 + A3*y + ... + A6*y^4};
c Parameters A1-A6 are read in as FSPRM(i), i= 1-6 respectively.
c Note that VLIMF is added to this potential in main program.
c-----------------------------------------------------------------------
DO i=1, mxfsp
numer= RAD(i)-REXFS
IF(IP.EQ.0) zfs(i,ifs)= numer/REXFS
IF(IP.EQ.1) zfs(i,ifs)= numer/(RAD(i)+REXFS)
IF(IP.GE.2) zfs(i,ifs)= (RAD(i)**IP - REXFS**IP)/
1 (RAD(i)**IP + REXFS**IP)
BETA= 0.d0
ZZ= 1.d0
DO j= 2,NFSPRM(ifs)
BETA= BETA + FSPRM(j,ifs)*ZZ
ZZ= ZZ*zfs(i,ifs)
ENDDO
VF(i,ifs)= VLIMF(ifs) + FSPRM(1,ifs)*DEXP(-(numer)*BETA)
ENDDO
ENDIF
IF(FSTYPE(ifs).EQ.2) THEN
c-----------------------------------------------------------------------
c Final State 2 is defined by NTPFS turning points [RTPF(i),VTPF(i)]
c with a repulsive exponential inner wall attached to the 2 innermost
c points. Outer portion was previously obtained by interpolating (in
c GENINT) to get potential array with piecewise polynomials or cubic
c splines. VSHFTF (cm-1) was added to the read-in potential points to
c make them consistent with the stated VLIMF value.
c Units for distance and energy are Angstroms and cm-1 repectively.
c-----------------------------------------------------------------------
c Repulsive inner wall is defined by fitting the 2 innermost read-in
c turning points to the form:
c VF(R) = A + B exp[-(R-REXFS)*(b0 + b1*y + b2*y^2 + ... + b5*y^5)
c if XCOORD = 1 y = zfs(R) = (R-REXFS)/(R+REXFS)
c if XCOORD = p(=1-9) y = zfs(R) = (R^p - REXFS^p)/
c (R^p + REXFS^p)
c if XCOORD = 10 y = zfs(R) = (R-REXFS)/R
c if XCOORD = 11 y = zfs(R) = (R-REXFS)/REXFS
c where A and B are determined by the 2 turning points
c and parameters b(j)= FSPRM[(j+1),ifs]
c-----------------------------------------------------------------------
R1= RTP(1,ifs) - REXFS
R2= RTP(2,ifs) - REXFS
IF (XCOORD(ifs).EQ.10) THEN
z1= R1/RTP(1,ifs)
z2= R2/RTP(2,ifs)
ELSEIF (XCOORD(ifs).EQ.11) THEN
z1= R1/REXFS
z2= R2/REXFS
ELSEIF (XCOORD(ifs).EQ.1) THEN
z1= R1/(RTP(1,ifs) + REXFS)
z2= R2/(RTP(2,ifs) + REXFS)
ELSEIF ((XCOORD(ifs).GE.2).AND.(XCOORD(ifs).LE.9)) THEN
z1=(RTP(1,ifs)**IP -REXFS**IP)/(RTP(1,ifs)**IP +REXFS**IP)
z2=(RTP(2,ifs)**IP -REXFS**IP)/(RTP(2,ifs)**IP +REXFS**IP)
ENDIF
c-----------------------------------------------------------------------
c Now solve two equations & two unknowns to get A and B parameters for
c inner wall of final state 2 (force exponential to go through the
c first two turning points). A= AVALUE and B= BVALUE below.
c-----------------------------------------------------------------------
ZZ1= 1.d0
ZZ2= 1.d0
EXPON1= 0.d0
EXPON2= 0.d0
DO j=1,NFSPRM(ifs)
EXPON1= EXPON1 + FSPRM(j,ifs)*ZZ1
EXPON2= EXPON2 + FSPRM(j,ifs)*ZZ2
ZZ1= ZZ1*z1
ZZ2= ZZ2*z2
ENDDO
ES= DEXP(-R1*EXPON1)
EF= DEXP(-R2*EXPON2)
BVALUE(ifs)= (VTP(1,ifs)-VTP(2,ifs))/(ES-EF)
AVALUE(ifs)= VTP(1,ifs)-BVALUE(ifs)*ES
c-----------------------------------------------------------------------
c NUMIMP is NUMber of Inner Mesh Points (for repulsive inner wall)
c-----------------------------------------------------------------------
NUMIMP= IDNINT((RTP(2,ifs) - RMIN)/RH + 1.d0)
IF(NUMIMP.LE.0) NUMIMP= 1
c-----------------------------------------------------------------------
c Now add on the exponential inner wall in region up to RTP(2,ifs)
c-----------------------------------------------------------------------
DO i=1,NUMIMP
numer= RAD(i)-REXFS
IF(XCOORD(ifs).EQ.1) zfs(i,ifs)= numer/(RAD(i)+REXFS)
IF((XCOORD(ifs).GE.2).AND.(XCOORD(ifs).GE.9))
1 zfs(i,ifs)= (RAD(i)**IP -REXFS**IP)/(RAD(i)**IP +REXFS**IP)
IF(XCOORD(ifs).EQ.10) zfs(i,ifs)= numer/RAD(i)
IF(XCOORD(ifs).EQ.11) zfs(i,ifs)= numer/REXFS
BETA= 0.d0
ZZ= 1.d0
DO j= 1,NFSPRM(ifs)
BETA= BETA + FSPRM(j,ifs)*ZZ
ZZ= ZZ*zfs(i,ifs)
ENDDO
VF(i,ifs)= AVALUE(ifs) + BVALUE(ifs)*DEXP(-(numer)*BETA)
ENDDO
ENDIF
c
IF(FSTYPE(ifs).EQ.3) THEN
c-----------------------------------------------------------------------
c** Generate an Extended Morse Oscillator final-state potential
c V = VLIMF + A1*[1 + exp{-(R- A2)*[A3 + A4*y + A5*y^2 +...]}]^2 - A1
c* Parameters A1-A6 are read in as FSPRM(i), i= 1-6 respectively, while
c VLIMF is added to this potential in main program.
c-----------------------------------------------------------------------
DO i=1, mxfsp
REQFS= FSPRM(2,ifs)
numer= (RAD(i) - REQFS)
zfs(i,ifs)= (RAD(i)**IP - REXFS**IP)/
1 (RAD(i)**IP + REXFS**IP)
BETA= 0.d0
ZZ= 1.d0
DO j= 3,NFSPRM(ifs)
BETA= BETA + FSPRM(j,ifs)*ZZ
ZZ= ZZ*zfs(i,ifs)
ENDDO
VF(i,ifs)= VLIMF(ifs) + FSPRM(1,ifs)*
1 ((DEXP(-numer*BETA)- 1.d0)**2 - 1.d0)
ENDDO
ENDIF
RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE GENTMF(ifs)
c=======================================================================
c Last modified 6 October 2001
c=======================================================================
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
INTEGER I,ifs,IP,IR2TMF,J,LNPT,LPTMF,ILRTMF,m,NCNTMF,NIN,NPRS,
1 NPRF,NPTMF,NUSETMF,NROW, GFS(mxfs),OTMF(mxfs),TMFTYP(mxfs)
REAL*8 CNNTMF,FCT(mxisp),MFACTMF,RAD(mxfsp),REXTMF,RFACTMF,
1 TMF(mxfsp),TMFLIM,TMFPRM(0:mxprm-1,mxfs),Xi(mxntp),xtmf,
2 XM2(mxfsp),Yi(mxntp),ztmf(mxisp,mxfs)
c-----------------------------------------------------------------------
COMMON /MGt/ REXTMF
COMMON /MFGt/ XM2,ztmf,LPTMF,NIN,TMFTYP
COMMON /MFGtGf/ RAD
COMMON /MFDGt/ TMFPRM,OTMF,GFS
c-----------------------------------------------------------------------
DATA LNPT/1/,NPRS/1/,IR2TMF/0/
c-----------------------------------------------------------------------
IF(TMFTYP(ifs).EQ.0) THEN
c-----------------------------------------------------------------------
c** Read NPTMP points of transition moment function with asymptotic
c value of TMFLIM
c* Interpolate with NUSETMF-point piecewise polynomials (or splines for
c NUSETMF.le.0), which are extrapolated to the asymptote as specified by
c parameters ILRTMF, CNC & CNN (see read #20).
c RFACT - factor converts read-in distances to angstroms
c MFACT - factor converts read-in moment values to debye (for absorption
c or emission or cm-1 for predissociation).
c=======================================================================
READ(5,*) NPTMF, TMFLIM
READ(5,*) NUSETMF, ILRTMF, NCNTMF, CNNTMF
READ(5,*) RFACTMF, MFACTMF
READ(5,*) (XI(i), YI(i), i=1, NPTMF)
c=======================================================================
WRITE(6,610) NPTMF, TMFLIM
IF(NUSETMF.GT.0) WRITE(6,616) NUSETMF, NPTMF
IF(NUSETMF.LE.0) WRITE(6,618) NPTMF
IF((ILRTMF.GT.1).AND.(DABS(CNNTMF).GT.0.D0))
1 WRITE(6,610) CNNTMF, NCNTMF
WRITE(6,622) RFACTMF, MFACTMF
NROW= (NPTMF+2)/3
DO J= 1,NROW
WRITE(6,624) (XI(I), YI(I), I=J, NPTMF, NROW)
ENDDO
DO I= 1,NPTMF
XI(I)= XI(I)*RFACTMF
YI(I)= YI(I)*MFACTMF
ENDDO
616 FORMAT(' Perform',I3,'-point piecewise polynomial interpolation ov
1er',I5,' input points' )
618 FORMAT(' Perform cubic spline interpolation over the',I5,' input p
1oints' )
622 FORMAT(' Scale input points: (distance)*',1PD16.9,' & (moment)
1*',D16.9/4x,'to get required units [Angstroms & debye (or cm-1 fo
2r predissociation)]'/
3 3(' X(i) Y(i) ')/3(3X,11('--')))
624 FORMAT((3(F12.6,F13.6)))
NPRF= NIN
CALL GENINT(LNPT,NIN,RAD,FCT,NUSETMF,IR2TMF,NPTMF,XI,YI,
1 TMFLIM,ILRTMF,NCNTMF,CNNTMF,NPRS,NPRF)
DO i=1,NIN
ztmf(i,ifs)= FCT(i)
ENDDO
ELSEIF((TMFTYP(ifs).GE.1).AND.(TMFTYP(ifs).LE.9)) THEN
IP= TMFTYP(ifs)
WRITE(6,614) IP,IP,IP,IP,REXTMF
DO i=1,NIN
ztmf(i,ifs)= (RAD(i)**IP - REXTMF**IP)/
1 (RAD(i)**IP + REXTMF**IP)
ENDDO
ELSEIF(TMFTYP(ifs).EQ.10) THEN
WRITE(6,623) REXTMF
DO i=1,NIN
ztmf(i,ifs)= (RAD(i) - REXTMF)/RAD(i)
ENDDO
ELSEIF(TMFTYP(ifs).EQ.11) THEN
WRITE(6,613) REXTMF
DO i=1,NIN
ztmf(i,ifs)= (RAD(i) - REXTMF)/REXTMF
ENDDO
ELSEIF(TMFTYP(ifs).EQ.12) THEN
WRITE(6,612)
DO i= 1,NIN
ztmf(i,ifs)= XM2(i)
ENDDO
ELSEIF(TMFTYP(ifs).EQ.13) THEN
WRITE(6,611)
DO i= 1,NIN
ztmf(i,ifs)= RAD(i)
ENDDO
ELSEIF(TMFTYP(ifs).EQ.14) THEN
WRITE(6,621)
DO i= 1,NIN
ztmf(i,ifs)= 2.d0
ENDDO
ELSE
WRITE(6,601) TMFTYP(ifs)
STOP
ENDIF
RETURN
c-----------------------------------------------------------------------
601 FORMAT(/' *Fatal Error in GENTMF* TMFTYP =',i3,' unallowed ',
1 '- must be .LE. 14')
610 FORMAT(' Transition moment function defined by interpolating over'
1 ,I4,' read-in points'/5x,'and approaching the asymptotic value',
2 f12.6)
621 FORMAT(' Transition moment function is a power series in the CONST
1ANT 2.d0 {for testing}')
611 FORMAT(' Transition moment function is a power series in the dista
1nce R [Angstroms]')
612 FORMAT(' Transition moment function is a power series in the varia
1ble z = 1/R**2')
613 FORMAT(' Transition moment function is a power series in the Dunha
1m variable'/4x,'z = (R - REXTMF)/REXTMF with REXTMF =',F8.5,
2 ' [Angstroms]')
623 FORMAT(' Transition moment function is a power series in the SPF v
1ariable'/4x,'z = (R - REXTMF)/R with REXTMF=',F8.5,
2 ' [Angstroms]')
614 FORMAT(' Transition moment function is a power series in the Surku
1s variable'/4x,'z = (R^',i1,' - REXTMF^',i1,')/(R^',i1,
2 ' + REXTMF^',i1,') with REXTMF=',F8.5,' [Angstroms]')
820 FORMAT(' Coefficients of power series expansion for transition mom
1ent function are:'/(3x,6(f12.8):))
c-----------------------------------------------------------------------
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE DYIDPJ(i,NDATA,NPTOT,YC,PV,PD,PS,RMSR)
c=======================================================================
c Last modified 29 April 2001
c=======================================================================
c i - datum whose derivative is required
c nptot - total number of parameters to be varied
c yc - current Ycalc value
c pv - parameter array, pv(n)
c pd - partial derivative array, pd(i)
c ps - parameter sensitivities, ps(i)
c rmsr - root mean square residuals
c-----------------------------------------------------------------------
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
INTEGER cycle,i,ifr,ifs,iset,m,n,idata,LPDER,NDATA,NFS,nprm,
1 NPTOT,NPPFREE,NSETS,RPD, GFS(mxfs),
2 FSVAR(mxprm,mxfs),IFRPW(mxsets),NFREQ(mxsets),NFSPRM(mxfs),
3 NVJ(mxsets),OTMF(mxfs),SCALE(mxsets),TMFVAR(0:mxprm-1,mxfs),
4 UPPER(mxsets)
REAL*8 DELTAP(mxnp),dIdT(0:mxprm-1,mxfreq,mxfs,mxsets),
1 DTIVE(mxdata,mxnp),FSPRM(mxprm,mxfs),
2 OUTPUT(mxfreq,mxsets),PD(mxnp),DFACT,PS(mxnp),
3 PV(mxnp),RMSR,SF(mxsets),TMFPRM(0:mxprm-1,mxfs),YC,
4 YCALC(mxdata)
CHARACTER*70 INFO(mxsets)
c-----------------------------------------------------------------------
COMMON /MD/ DFACT,FSVAR,LPDER,NPPFREE
COMMON /MFD/ dIdT,OUTPUT,SF,IFRPW,NFREQ,NFS,NSETS,NVJ,RPD,SCALE,
1 TMFVAR,INFO
COMMON /MDGf/ FSPRM,NFSPRM
COMMON /MFDGt/ TMFPRM,OTMF,GFS
c-----------------------------------------------------------------------
SAVE DTIVE,YCALC,cycle
DATA cycle/0/
c-----------------------------------------------------------------------
c When called for first datum, create complete partial derivative array
c to will be used in the subsequent calls for rest of the data
c-----------------------------------------------------------------------
IF(i.EQ.1) THEN
cycle= cycle + 1
IF(NPPFREE.GT.0) WRITE(6,600)
DO idata= 1,NDATA
DO nprm= 1,NPTOT
DTIVE(idata,nprm)= 0.d0
ENDDO
ENDDO
nprm= 0
c-----------------------------------------------------------------------
c First copy current PV values onto internal potential and transition
c moment function parameter arrays
c-----------------------------------------------------------------------
DO ifs= 1,NFS
DO n= 1,NFSPRM(ifs)
IF(FSVAR(n,ifs).GT.0) THEN
nprm= nprm + 1
FSPRM(n,ifs)= PV(nprm)
IF(RMSR.GT.0.d0) THEN
DELTAP(nprm)= DFACT*PS(nprm)*NPTOT/RMSR
c 1 *DSQRT(DBLE(NDATA-NPTOT)/DBLE(NDATA))/RMSR
ELSE
DELTAP(nprm)= 0.0010d0*FSPRM(n,ifs)
c-----------------------------------------------------------------------
c DELTAP - step size used to define derivatives-by-differences
c-----------------------------------------------------------------------
ENDIF
WRITE(6,601) nprm, DELTAP(nprm)
IF(LPDER.GT.0) WRITE(10,601) nprm, DELTAP(nprm)
ENDIF
ENDDO
CALL GENFS(ifs)
DO m= 0,OTMF(ifs)
IF(TMFVAR(m,ifs).GT.0) THEN
nprm= nprm + 1
TMFPRM(m,ifs)= PV(nprm)
ENDIF
ENDDO
ENDDO
DO iset= 1,NSETS
IF(SCALE(iset).EQ.1) THEN
nprm= nprm + 1
SF(iset)= PV(nprm)
ENDIF
ENDDO
RPD= 1
c-----------------------------------------------------------------------
c RPD is a flag that tells FORWARD whether or not to return transition
c moment function partial derivatives (RPD= 1 to return derivatives)
c-----------------------------------------------------------------------
CALL FORWARD
RPD= 0
IDATA= 0
DO iset= 1,NSETS
IF(IFRPW(iset).EQ.0) UPPER(iset)= NVJ(iset)
IF(IFRPW(iset).NE.0) UPPER(iset)= NFREQ(iset)
DO ifr= 1,UPPER(iset)
idata= idata + 1
YCALC(idata)= OUTPUT(ifr,iset)
ENDDO
ENDDO
c-----------------------------------------------------------------------
c begin partial derivative calculation for final state potential
c parameters here - do SYMMETRIC partial derivatives-by-differences
c-----------------------------------------------------------------------
nprm= 0
DO ifs= 1,NFS
DO n= 1,NFSPRM(ifs)
IF(FSVAR(n,ifs).GT.0) THEN
nprm= nprm + 1
FSPRM(n,ifs)= PV(nprm) + DELTAP(nprm)
CALL GENFS(ifs)
CALL FORWARD
idata= 0
DO iset= 1,NSETS
DO ifr= 1, UPPER(iset)
idata= idata + 1
DTIVE(idata,nprm)= (OUTPUT(ifr,iset)-
1 YCALC(idata))/DELTAP(nprm)
ENDDO
ENDDO
FSPRM(n,ifs)= PV(nprm) - 2*DELTAP(nprm)
CALL GENFS(ifs)
CALL FORWARD
idata= 0
DO iset= 1,NSETS
DO ifr= 1, UPPER(iset)
idata= idata + 1
DTIVE(idata,nprm)=0.5d0*(DTIVE(idata,nprm)
1 + (YCALC(idata)-OUTPUT(ifr,iset))/DELTAP(nprm))
ENDDO
ENDDO
FSPRM(n,ifs)= PV(nprm)
ENDIF
ENDDO
CALL GENFS(ifs)
DO m= 0,OTMF(ifs)
IF(TMFVAR(m,ifs).GT.0) THEN
nprm= nprm + 1
idata= 0
DO iset= 1,NSETS
DO ifr= 1,UPPER(iset)
idata= idata + 1
DTIVE(idata,nprm)= dIdT(m,ifr,ifs,iset)
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
idata= 0
DO iset= 1,NSETS
IF(SCALE(iset).EQ.0) THEN
idata= idata + UPPER(iset)
ELSE
nprm= nprm + 1
DO ifr= 1,UPPER(iset)
idata= idata + 1
DTIVE(idata,nprm)= OUTPUT(ifr,iset)/SF(iset)
ENDDO
ENDIF
ENDDO
IF(LPDER.GT.0) THEN
WRITE(10,100) cycle
DO idata= 1,NDATA
WRITE(10,101) YCALC(idata),(DTIVE(idata,nprm),
1 nprm= 1,NPTOT)
ENDDO
ENDIF
ENDIF
c-----------------------------------------------------------------------
c For each datum i, collect yalculated values and partial derivatives
c below
c-----------------------------------------------------------------------
YC= YCALC(i)
DO nprm= 1,NPTOT
PD(nprm)= DTIVE(i,nprm)
ENDDO
RETURN
600 FORMAT(/' Change in Potential Parameter Values (Derivatives-',
1 'by-Differences)')
601 FORMAT(1x,'DELTAP(',i2,')= ',f12.6)
100 FORMAT(/5x,'YCALC',10x,'Partial Derivatives for fitting cycle',i3)
101 FORMAT(1x,30(1PD14.6))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE OVRLAP(BFCT,DER,EFN,OVR,OVRCRT,PSI,RH,RMIN,TMFPRM,VJ,
1 VLIM,z,ifs,IWR,JP,NEND,OTMF,TMFTYP)
c=======================================================================
c Routine by R.J. Le Roy; Last Modified 19 August 2003
c=======================================================================
c Calculate overlap integral Franck-Condon Moment FCM(i) array
c between the given bound state wave function PSI(i) (which is zero
c for i > NEND) and the J' = JP continuum final state wave function
c (asymptotocally normalized to unit amplitude) at energy EFN on the
c effective potential VJ(I) with asymptote VLIM, with input array
c z(i). z(i) is the input (radial) array whose moments are being taken.
c NOTE that z(i) = zin(i) = ztmf
c
c On entry, energy units for EFN and VLIM are (cm-1), while VJ(I)
c incorporates the factor BFCT (i.e., VJ/BFCT has units cm-1).
c
c Convergence of asymptotic wave function normalization defined by
c requirement that W.K.B. fits to 3 successive maxima must agree
c relatively to within OVRCRT.
c-----------------------------------------------------------------------
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
INTEGER i,ifs,MESH1,MESH2,MESH3,step,first,last,IWR,JP,TURNPT,m,
1 OTMF,NAMP,NEND,TMFTYP(mxfs)
REAL*8 AMP1,AMP2,AMP3,AMP4,BFCT,DER(0:mxprm-1),DI,FCFACT,
1 EFN,ELIM,ER,FCM(0:MXPRM-1),EDIFF1,EDIFF2,EDIFFi,HALF,HARG,
2 NFACT,
2 RH,RMIN,OVR,OVRCRT,PSI(NEND),S0,S1,S2,SG1,SG2,SGi,Si,
3 SNARG,SQKINF,
3 THIRD,TMFPRM(0:mxprm-1,mxfs),VLIM,VJ(mxfsp),VV,XIITH,XX,
4 Y1,Y2,Y3,z(mxisp),
4 ZTST,ZZ0,ZZ1
c-----------------------------------------------------------------------
HALF= 1.D0/2.D0
XIITH= 1.D0/12.D0
THIRD= 1.D0/3.D0
ER= EFN*BFCT
ELIM= VLIM*BFCT
SQKINF= DSQRT(ER-ELIM)
AMP1= 1.D0
AMP2= 2.D0
AMP3= 0.D0
AMP4= 0.D0
DO m= 0,OTMF
DER(m)= 0.D0
FCM(m)= 0.d0
ENDDO
c-----------------------------------------------------------------------
c** Locate first turning point and use Airy function to estimate
c appropriate integration starting point such that PSI(1) .LE. 1.D-10
c-----------------------------------------------------------------------
MESH1= 1
EDIFF1= VJ(MESH1)-ER
step= DINT(0.05d0/RH)
IF(step.LT.1) step= 1
first= step+1
DO i= first,mxfsp,step
TURNPT= i
EDIFF2= VJ(i)-ER
IF(EDIFF2.LE. 0.D0) GOTO 4
MESH1= i
EDIFF1= EDIFF2
ENDDO
IF(IWR.NE.0) THEN
WRITE(6,607) JP,EFN
OVR= 0.d0
RETURN
ENDIF
4 MESH2= TURNPT
TURNPT= MESH1+(MESH2-MESH1)*EDIFF1/(EDIFF1-EDIFF2)
IF(IABS(TURNPT-MESH2).LE.1) GOTO 6
IF((TURNPT.LE.0).OR.(TURNPT.GT.mxfsp)) THEN
IF(IWR.NE.0) WRITE(6,601) JP,EFN
OVR= 0.d0
RETURN
ENDIF
MESH1= MESH2
EDIFF1= EDIFF2
EDIFF2= VJ(TURNPT)-ER
GOTO 4
6 DI= 10.D0/(VJ(TURNPT-1)-VJ(TURNPT))**THIRD
step= DINT(DI)
MESH1= MAX0(1,TURNPT-step)
IF(MESH1.GE.NEND) THEN
OVR= 0.D0
RETURN
ENDIF
8 EDIFF1= VJ(MESH1)-ER
IF(EDIFF1.LT.10.D0) GOTO 10
c-----------------------------------------------------------------------
c** Adjust starting point outward to ensure integration scheme stability
c-----------------------------------------------------------------------
MESH1= MESH1+1
IF((MESH1-mxfsp).LT.0) GOTO 8
IF((MESH1-mxfsp).GE.0) THEN
OVR= 0.D0
RETURN
ENDIF
10 MESH2= MESH1+1
MESH3= MESH2+1
c-----------------------------------------------------------------------
c** WKB starting condition for wave function
c-----------------------------------------------------------------------
S0= 1.D0
EDIFF1= VJ(MESH1)-ER
EDIFFi= VJ(MESH2)-ER
IF((EDIFF1.GT. 0.D0).AND.(EDIFFi.GT. 0.D0)) THEN
SG1= DSQRT(EDIFF1)
SGi= DSQRT(EDIFFi)
Si= S0*DSQRT(SG1/SGi)*DEXP((SG1+SGi)/2.D0)
IF(Si.LE.S0) S0= 0.D0
ELSE
VV= VJ(MESH2)/BFCT
IF(IWR.NE.0) WRITE(6,608) JP,EFN,VV,MESH2
S0= 0.D0
Si= 1.D0
ENDIF
c-----------------------------------------------------------------------
c notationally speaking, all Yi's refer to values used in the Numerov
c Algorithm for wavefunciont propagation.
c-----------------------------------------------------------------------
Y1= S0*(1.D0-XIITH*EDIFF1)
Y2= Si*(1.D0-XIITH*EDIFFi)
c-----------------------------------------------------------------------
c Use trapezoid rule for numerical integration. Initialize FCM(m)
c values using first section of area.
c-----------------------------------------------------------------------
ZZ0= 1.D0
ZZ1= 1.D0
DO m= 0,OTMF
FCM(m)= HALF*S0*PSI(MESH1)*ZZ0 + Si*PSI(MESH2)*ZZ1
ZZ0= ZZ0*z(MESH1)
ZZ1= ZZ1*z(MESH2)
ENDDO
S2= S0
c-----------------------------------------------------------------------
c** Integrate outward to first turning point. NOTE that Airy-estimated
c initialization minimizes need for renormalizations.
c-----------------------------------------------------------------------
DO 16 i= MESH3,TURNPT
Y3= Y2+Y2-Y1+EDIFFi*Si
Y1= Y2
Y2= Y3
EDIFFi= VJ(I)-ER
S1= S2
S2= Si
Si= Y3/(1.D0-XIITH*EDIFFi)
c-----------------------------------------------------------------------
c** If bound wavefx. non-negligible, accumulate overlap moments
c NOTE that FCFACT is the Franck-Condon factor
c-----------------------------------------------------------------------
IF(I.LE.NEND) THEN
FCFACT= Si*PSI(i)
DO m= 0,OTMF
FCM(m)= FCM(m) + FCFACT
FCFACT= FCFACT*z(i)
ENDDO
ENDIF
c-----------------------------------------------------------------------
c** If wavefuntion too large in forbidden region, renormalize it ...
c-----------------------------------------------------------------------
IF((Si.GE.1.D32).OR.(i.EQ.TURNPT)) THEN
NFACT= 1.D0/Si
Si= 1.D0
IF(S0.GT.1.D-30) S0= S0*NFACT
DO m= 0,OTMF
FCM(m)= FCM(m)*NFACT
ENDDO
Y1= Y1*NFACT
Y2= Y2*NFACT
ENDIF
16 CONTINUE
IF((IWR.NE.0).AND.(S0/SI.GT.1.D-8))
1 WRITE(6,602)JP,EFN,MESH1,S0/Si,TURNPT
MESH2= TURNPT+1
c-----------------------------------------------------------------------
c** If turning point NOT past end of range for bound state wavefx., then
c integrate from turning point to end of bound-state wave function
c-----------------------------------------------------------------------
IF(TURNPT.LT.NEND) THEN
DO i= MESH2,NEND
Y3= Y2 + Y2 - Y1 + EDIFFi*Si
Y1= Y2
Y2= Y3
EDIFFi= VJ(i)-ER
S1= S2
S2= Si
Si= Y3/(1.D0 - XIITH*EDIFFi)
FCFACT= Si*PSI(i)
DO m= 0,OTMF
FCM(m)= FCM(m) + FCFACT
FCFACT= FCFACT*z(i)
ENDDO
ENDDO
MESH2= NEND+1
ENDIF
c-----------------------------------------------------------------------
c** Continue wave function propagation until amplitude converges
c-----------------------------------------------------------------------
NAMP= 0
DO 30 i= MESH2,mxfsp
Y3= Y2 + Y2 - Y1 + EDIFFi*Si
Y1= Y2
Y2= Y3
EDIFF2= EDIFFi
EDIFFi= VJ(i)-ER
S1= S2
S2= Si
Si= Y3/(1.D0-XIITH*EDIFFi)
IF((Si.GE.S2).OR.(S1.GT.S2)) GOTO 30
c-----------------------------------------------------------------------
c** At successive maxima, fit solution to W.K.B. form to determine
c apparent asymptotic amplitude.
c-----------------------------------------------------------------------
SG2= DSQRT(-EDIFF2)
SGi= DSQRT(-EDIFFi)
HARG= (SG2 + SGi)/2.D0
SNARG= 1.D0/DSQRT(1.D0 + ((DSQRT(SG2/SGi)*S2/Si- DCOS(HARG))
1 /DSIN(HARG))**2)
NAMP= NAMP+1
AMP4= AMP3
AMP3= AMP2
AMP2= AMP1
AMP1= Si*DSQRT(SGi/SQKINF)/SNARG
XX= RMIN + (i-1)*RH
IF(IWR.GE.3) WRITE(6,604) JP,EFN,XX,AMP1
last= i
c-----------------------------------------------------------------------
c** Test successive amplitudes for convergence
c-----------------------------------------------------------------------
ZTST= OVRCRT*AMP1
IF((DABS(AMP1-AMP2).LT.ZTST).AND.(DABS(AMP2-AMP3).LT.ZTST))
1 GOTO 35
30 CONTINUE
IF(IWR.NE.0) WRITE(6,603) JP,EFN,AMP1,AMP2,AMP3,AMP4
35 OVR= 0.d0
DO m= 0,OTMF
FCM(m)= FCM(m)*RH/AMP1
OVR= OVR + TMFPRM(m,ifs)*FCM(m)
ENDDO
IF(IWR.GE.1) WRITE(6,605) JP,EFN,last,XX,(m,FCM(m),m=0,OTMF)
IF(IWR.GE.2) WRITE(6,606) S0,AMP1,AMP2,AMP3,AMP4
DO m= 0,OTMF
DER(m)= 2.d0*OVR*FCM(m)
ENDDO
OVR= OVR*OVR
RETURN
c-----------------------------------------------------------------------
601 FORMAT(' *** OVRLAP BOMBed *** For J = ',I3,' EFN = ',
1 F10.2,' never got to first turning point')
602 FORMAT(' ** WARNING ** For J = ', I3 ,' EFN = ',F10.2,
1 ' starting wavefunction is PSI(',I4,') = ',D10.3,' and I(turn.p
2t.) = ',I4)
603 FORMAT(' ** WARNING ** For J= ',I3,' EFN= ',F9.2,' amplitude not',
1 ' converged by end of range'/3x,'Last four values are ',
2 4(1PD14.6))
604 FORMAT(' At J=',I3,' E=',F9.2,' R=',F6.3,' apparent asymptot
1ic amplitude',1PD14.6)
605 FORMAT(' At J=',I3,' E= ',F12.2,' R(end)= R(',I5,')=',
1 F7.4,' FCM(',I1,')=',F12.8:/
2 (4x,3(5x,'FCM(',I1,')=',F12.8:)))
606 FORMAT(5X,'S0= ',1PD10.3,' & last 4 amplitudes are',2D14.6/
1 45x,2D14.6)
607 FORMAT(' *** ERROR *** At J = ',I3,' EFN = ',F10.2,
1 ' have V .GT. E everywhere.' )
608 FORMAT(' *** Caution *** For J = ',I3,' (EFN= ',F10.2,
1 ') .GE. (V = ',F10.2,') at I = ',I4,' ,so initialize with a n
2ode.')
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE OVRPD(BFCT,DER,EFN,OVR,OVRCRT,RAD,PSI,TMFPRM,
1 VJ,VLIM,FITIT,ifs,IWR,JP,LPTMF,NEND,OTMF,TMFVAR)
c-----------------------------------------------------------------------
c ** USE THIS ROUTINE FOR TMFTYP < 0
c * TMFTYP = -1 for predisociation case where the TMF is not
c a power series but an operator instead
c P= -hbar^2/2*mu {dW/dR + 2W*d/dR}
c where W(R)= a/{4a^2 + (R-Rc)^2}
c-----------------------------------------------------------------------
c Calculate overlap integral, OVR,
c between the given bound state wave function PSI(i) (which is zero
c for i > NEND) and the J' = JP continuum final state wave function
c (asymptotocally normalized to unit amplitude) at energy EFN on the
c effective potential VJ(I) with asymptote VLIM, with input array
c
c On entry, energy units for EFN and VLIM are (cm-1), while VJ(I)
c incorporates the factor BFCT (i.e., VJ/BFCT has units cm-1).
c
c Convergence of asymptotic wave function normalization defined by
c requirement that W.K.B. fits to 3 successive maxima must agree
c relatively to within OVRCRT.
c-----------------------------------------------------------------------
c Original routine by R.J. Le Roy; Modified by G.T. Kraemer;
c Current version 29 April 2001
c ** updating to take 5 points of continuum wavefunction
c for obtaining derivative, dPSIc/dR
c-----------------------------------------------------------------------
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
INTEGER FITIT,i,ifs,j,m,MESH1,MESH2,MESH5,NL,step,first,last,IWR,
1 JP,LPTMF,TURNPT,OTMF,NAMP,NEND,NLORZ,
2 TMFVAR(0:mxprm-1,mxfs)
REAL*8 ADD1,ADD2,
1 AI1(3,mxisp),AI2(3,mxisp),ACCUM1(mxisp),ACCUM2(mxisp),
2 AMP1,AMP2,AMP3,AMP4,AVAL(3),BFCT,DA(3),DRc(3),
1 DEN,DER(0:mxprm-1),
1 dIda1,dIda2,dIda3,dIda4,dIdRc1,dIdRc2,dIdRc3,DI,dSdR,EFN,
2 ELIM,ER,EDIFF(5),FACT1,FACT2,HALF,HARG,NFACT,OVR,
3 OVR1,OVR1a,OVR1b,OVR2,OVRCRT,OVRLAP(3),RAD(mxfsp),RC(3),RH,
4 RMIN,RR(mxfsp),PSI(NEND),PSIc(5),PSIc0,SIXTH,SG1,SG2,SNARG,
5 SQKINF,THIRD,TMFPRM(0:mxprm-1,mxfs),
6 TOT,VLIM,VJ(mxfsp),VV,XIIth,XX,Y1,Y2,Y3,W(mxisp),ZTST
REAL*8 gtk,gtk1,gtk2,gtkfact,AIgtk(3,mxisp),ACCUMgtk(mxisp),
1 OVRgtk,gtkLAP(3)
c-----------------------------------------------------------------------
c RAD(i) - radial distance array
c NEND - last mesh point for bound state wavefunction
NLORZ= (OTMF+1)/2
i= 0
DO NL= 1,NLORZ
AVAL(NL)= TMFPRM(i,ifs)
RC(NL)= TMFPRM(i+1,ifs)
i= 2*NL
ENDDO
last= 0
HALF= 1.D0/2.D0
THIRD= 1.D0/3.D0
SIXTH= 1.D0/6.D0
XIIth= 1.D0/12.D0
RMIN= RAD(1)
RH= RAD(2)-RAD(1)
ER= EFN*BFCT
ELIM= VLIM*BFCT
SQKINF= DSQRT(ER-ELIM)
AMP1= 1.D0
AMP2= 2.D0
AMP3= 0.D0
AMP4= 0.D0
DO m= 0,OTMF
DER(m)= 0.D0
ENDDO
c-----------------------------------------------------------------------
c** Locate first turning point and use Airy function to estimate
c appropriate integration starting point such that PSI(1) .LE. 1.D-10
c-----------------------------------------------------------------------
MESH1= 1
EDIFF(1)= VJ(MESH1)-ER
step= DINT(0.2/RH)
IF(step.LT.1) step= 1
first= step+1
DO i= first,mxfsp,step
TURNPT= i
EDIFF(2)= VJ(i)-ER
IF(EDIFF(2).LE. 0.D0) GOTO 4
MESH1= i
EDIFF(1)= EDIFF(2)
ENDDO
IF(IWR.NE.0) THEN
WRITE(6,607) JP,EFN
OVR= 0.D0
RETURN
ENDIF
4 MESH2= TURNPT
TURNPT= MESH1+(MESH2-MESH1)*EDIFF(1)/(EDIFF(1)-EDIFF(2))
IF(IABS(TURNPT-MESH2).LE.1) GOTO 6
IF((TURNPT.LE.0).OR.(TURNPT.GT.mxfsp)) THEN
IF(IWR.NE.0) WRITE(6,601) JP,EFN
STOP
ENDIF
MESH1= MESH2
EDIFF(1)= EDIFF(2)
EDIFF(2)= VJ(TURNPT)-ER
GOTO 4
6 DI= 10.D0/(VJ(TURNPT-1)-VJ(TURNPT))**THIRD
step= DINT(DI)
MESH1= MAX0(1,TURNPT-step)
IF(MESH1.GE.NEND) THEN
OVR= 0.D0
RETURN
ENDIF
8 EDIFF(1)= VJ(MESH1)-ER
IF(EDIFF(1).LT.10.D0) GOTO 10
c-----------------------------------------------------------------------
c** Adjust starting point outward to ensure integration scheme stability
c-----------------------------------------------------------------------
MESH1= MESH1+1
IF((MESH1-mxfsp).LT.0) GOTO 8
IF((MESH1-mxfsp).GE.0) THEN
OVR= 0.D0
RETURN
ENDIF
10 MESH2= MESH1+1
c-----------------------------------------------------------------------
c** WKB starting condition for wave function
c-----------------------------------------------------------------------
DO 100 NL= 1,NLORZ
PSIc(1)= 1.D0
DO i= 1,4
EDIFF(i)= VJ(MESH1-1+i)-ER
ENDDO
IF((EDIFF(1).GT. 0.D0).AND.(EDIFF(2).GT. 0.D0)) THEN
SG1= DSQRT(EDIFF(1))
SG2= DSQRT(EDIFF(2))
PSIc(2)= PSIc(1)*DSQRT(SG1/SG2)*DEXP((SG1+SG2)/2.D0)
IF(PSIc(2).LE.PSIc(1)) PSIc(1)= 0.D0
ELSE
VV= VJ(MESH2)/BFCT
IF(IWR.NE.0) WRITE(6,608) JP,EFN,VV,MESH2
PSIc(1)= 0.D0
PSIc(2)= 1.D0
ENDIF
PSIc0= PSIc(2)
c-----------------------------------------------------------------------
c notationally speaking, all Yi's refer to values used in the Numerov
c Algorithm for wavefunction propagation.
c-----------------------------------------------------------------------
Y1= PSIc(1)*(1.D0-XIIth*EDIFF(1))
Y2= PSIc(2)*(1.D0-XIIth*EDIFF(2))
DO i= 3,4
Y3= Y2 + Y2 - Y1 + EDIFF(i-1)*PSIc(i-1)
PSIc(i)= Y3/(1.D0-XIIth*EDIFF(i))
Y1= Y2
Y2= Y3
ENDDO
c-----------------------------------------------------------------------
c Use trapezoid rule for numerical integration. Initialize OVR
c values using first section of area. Note that intensity is
c proportional to 2*PSIb*dW/dR*PSIc + 4*PSIb*W*dPSIc/dR
c W= a/{4a^2 + (R-Rc)^2}
c dW/da= W/a - 8W^2
c dW/dR= -2(R-Rc)W^2/a
c use Lagrangian interpolation scheme for determining derivative at
c mid-point of 5-equally-spaced wavefunction points...
c dPSIc/dR= {PSIc(i-2) + 8[PSIc(i+1)-PSIc(i-1)] - PSIc(i+2)}/12*RH
c assume dPSIc/dR = 0 for first and last mesh points (MESH1 & NEND)
c assume dPSIc/dR = [PSIc(mesh3)-PSIc(mesh1)]/2RH @ MESH2
c assume dPSIc/dR = [PSIc(NEND)-PSIc(NEND-2)]/2RH @ NEND-1
c PSI(i) is the stored bound state wavefunction array
c PSIc(i) is the stored continuum state wavefunction
c
c see end of program for multiplicative factors for integration
c-----------------------------------------------------------------------
c Initialize overlap integrals
c NOTE that the AIi arrays are cumulative integrands at a given mesh
c-----------------------------------------------------------------------
DO i= 1,NEND
RR(i)= RAD(i)-RC(NL)
DEN= 4*AVAL(NL)*AVAL(NL) + RR(i)*RR(i)
W(i)= AVAL(NL)/DEN
ENDDO
OVR1a= HALF*PSI(MESH1)*RR(MESH1)*W(MESH1)*W(MESH1)*PSIc(1)
OVR1b= PSI(MESH2)*RR(MESH2)*W(MESH2)*W(MESH2)*PSIc(2)
gtk1= HALF*PSI(MESH1)*PSIc(1)
gtk2= PSI(MESH2)*PSIc(2)
gtk= gtk1 + gtk2
OVR1= OVR1a + OVR1b
OVR2= PSI(MESH2)*W(MESH2)*6.d0*(PSIc(3)-PSIc(1))
c3pt OVR2= PSI(MESH2)*W(MESH2)*(PSIc(3)-PSIc(1))
AI1(NL,MESH1)= OVR1a
AI1(NL,MESH2)= OVR1b
AI2(NL,MESH1)= 0.d0
AI2(NL,MESH2)= OVR2
AIgtk(NL,MESH1)= gtk1
AIgtk(NL,MESH2)= gtk2
c-----------------------------------------------------------------------
c for portion of operator involving the derivative of final-state wave
c function, assume dPSI/dR @ MESH1 = 0
c use dPSI/dR @ MESH2 = (PSI3-PSI1)/2RH... below as 6*(PSI3-PSI1)
c since entire sum is (later) divided by 12
c-----------------------------------------------------------------------
IF(TMFVAR(2*NL-2,ifs).GT.0) THEN
dIda2= OVR1a*W(MESH1) + OVR1b*W(MESH2)
dIda4= OVR2*W(MESH2)
ENDIF
IF(TMFVAR(2*NL-1,ifs).GT.0) THEN
dIdRc1= OVR1a/RR(MESH1) + OVR1b/RR(MESH2)
dIdRc2= OVR1a*RR(MESH1)*W(MESH1) + OVR1b*RR(MESH2)*W(MESH2)
dIdRc3= OVR2*RR(MESH2)*W(MESH2)
ENDIF
c-----------------------------------------------------------------------
c Note that there is no contribution at mesh1 for dI/da(4) or dI/dRc(4)
c since the derivative of the final state wave function is zero here
c-----------------------------------------------------------------------
c** Integrate outward to first turning point. NOTE that Airy-estimated
c initialization minimizes need for renormalizations.
c-----------------------------------------------------------------------
MESH5= MESH2 + 3
Y3= Y2 + Y2 - Y1 + EDIFF(4)*PSIc(4)
DO 16 i= MESH5,TURNPT
EDIFF(5)= VJ(i)-ER
PSIc(5)= Y3/(1.D0-XIIth*EDIFF(5))
Y3= Y2 + Y2 - Y1 + EDIFF(5)*PSIc(5)
Y1= Y2
Y2= Y3
c----------------------------------------------------------------------
c NOW, If bound wavefx. non-negligible, accumulate overlap integrals
c **Do ALL integration calculations 2 steps behind the propagating front
c of the wavefunction (since MUST do this for dPSIc/dR)
c-----------------------------------------------------------------------
IF(i.LE.NEND) THEN
ADD1= PSI(i-2)*RR(i-2)*W(i-2)*W(i-2)*PSIc(3)
dSdR= PSIc(1) + 8.d0*(PSIc(4) - PSIc(2)) - PSIc(5)
c3pt dSdR= PSIc(4) - PSIc(2)
ADD2= PSI(i-2)*W(i-2)*dSdR
OVR1= OVR1 + ADD1
OVR2= OVR2 + ADD2
gtk= gtk + PSI(i-2)*PSIc(3)
AI1(NL,i-2)= OVR1
AI2(NL,i-2)= OVR2
AIgtk(NL,i-2)= gtk
IF(TMFVAR(2*NL-2,ifs).GT.0) THEN
dIda2= dIda2 + ADD1*W(i-2)
dIda4= dIda4 + ADD2*W(i-2)
ENDIF
IF(TMFVAR(2*NL-1,ifs).GT.0) THEN
dIdRc1= dIdRc1 + ADD1/RR(i-2)
dIdRc2= dIdRc2 + ADD1*RR(i-2)*W(i-2)
dIdRc3= dIdRc3 + ADD2*RR(i-2)*W(i-2)
ENDIF
ENDIF
c-----------------------------------------------------------------------
c If wavefuntion too large in forbidden region, renormalize it ...
c Also renormalize overlap integrals etc. here
c-----------------------------------------------------------------------
IF((PSIc(5).GE.1.D32).OR.(i.EQ.TURNPT)) THEN
NFACT= 1.D0/PSIc(5)
PSIc(5)= 1.D0
DO j= 1,4
PSIc(j)= PSIc(j)*NFACT
ENDDO
IF(PSIc0.GT.1.D-30) PSIc0= PSIc0*NFACT
OVR1= OVR1*NFACT
OVR2= OVR2*NFACT
gtk= gtk*NFACT
DO j= MESH1,i-2
AI1(NL,j)= AI1(NL,j)*NFACT
AI2(NL,j)= AI2(NL,j)*NFACT
AIgtk(NL,j)= AIgtk(NL,j)*NFACT
ENDDO
Y1= Y1*NFACT
Y2= Y2*NFACT
Y3= Y3*NFACT
IF(TMFVAR(2*NL-2,ifs).GT.0) THEN
dIda2= dIda2*NFACT
dIda4= dIda4*NFACT
ENDIF
IF(TMFVAR(2*NL-1,ifs).GT.0) THEN
dIdRc1= dIdRc1*NFACT
dIdRc2= dIdRc2*NFACT
dIdRc3= dIdRc3*NFACT
ENDIF
ENDIF
DO j= 1,4
PSIc(j)= PSIc(j+1)
ENDDO
16 CONTINUE
IF((IWR.NE.0).AND.(PSIc0/PSIc(5).GT.1.D-8))
1 WRITE(6,602)JP,EFN,MESH1,PSIc0/PSIc(5),TURNPT
c-----------------------------------------------------------------------
c If turning point NOT past end of range for bound state wavefx., then
c integrate from turning point to end of bound-state wave function
c NOTE that summations will cease at mesh NEND-2 because of the 2-step
c lag in the calculation. This should have essentially no effect on
c integration total
c-----------------------------------------------------------------------
IF(TURNPT.LT.NEND) THEN
DO i= TURNPT+1,NEND
EDIFF(5)= VJ(i)-ER
PSIc(5)= Y3/(1.D0-XIIth*EDIFF(5))
Y3= Y2 + Y2 - Y1 + EDIFF(5)*PSIc(5)
Y1= Y2
Y2= Y3
c-----------------------------------------------------------------------
c NOTE that the derivative term is lagging two steps behind the counter
c-----------------------------------------------------------------------
ADD1= PSI(i-2)*RR(i-2)*W(i-2)*W(i-2)*PSIc(3)
dSdR= PSIc(1) + 8.d0*(PSIc(4) - PSIc(2)) - PSIc(5)
c3pt dSdR= PSIc(4) - PSIc(2)
ADD2= PSI(i-2)*W(i-2)*dSdR
OVR1= OVR1 + ADD1
OVR2= OVR2 + ADD2
gtk= gtk + PSI(i-2)*PSIc(3)
AI1(NL,i-2)= OVR1
AI2(NL,i-2)= OVR2
AIgtk(NL,i-2)= gtk
IF(TMFVAR(2*NL-2,ifs).GT.0) THEN
dIda2= dIda2 + ADD1*W(i-2)
dIda4= dIda4 + ADD2*W(i-2)
ENDIF
IF(TMFVAR(2*NL-1,ifs).GT.0) THEN
dIdRc1= dIdRc1 + ADD1/RR(i-2)
dIdRc2= dIdRc2 + ADD1*RR(i-2)*W(i-2)
dIdRc3= dIdRc3 + ADD2*RR(i-2)*W(i-2)
ENDIF
DO j= 1,4
PSIc(j)= PSIc(j+1)
ENDDO
ENDDO
ENDIF
c-----------------------------------------------------------------------
c Continue wave function propagation until amplitude converges, no
c longer integrating since past the end of bound state range
c-----------------------------------------------------------------------
NAMP= 0
DO i= NEND+1,mxfsp
EDIFF(4)= EDIFF(5)
EDIFF(5)= VJ(i)-ER
PSIc(5)= Y3/(1.D0-XIIth*EDIFF(5))
Y3= Y2 + Y2 - Y1 + EDIFF(5)*PSIc(5)
Y1= Y2
Y2= Y3
IF((PSIc(5).LT.PSIc(4)).AND.(PSIc(3).LT.PSIc(4))) THEN
c-----------------------------------------------------------------------
c At successive maxima, fit solution to W.K.B. form to determine
c apparent asymptotic amplitude.
c-----------------------------------------------------------------------
SG1= DSQRT(-EDIFF(4))
SG2= DSQRT(-EDIFF(5))
HARG= HALF*(SG1+SG2)
SNARG= 1.D0/DSQRT(1.D0+((DSQRT(SG1/SG2)*PSIc(4)/PSIc(5) -
1 DCOS(HARG))/DSIN(HARG))**2)
NAMP= NAMP+1
AMP4= AMP3
AMP3= AMP2
AMP2= AMP1
AMP1= PSIc(5)*DSQRT(SG2/SQKINF)/SNARG
XX= RMIN + (i-1)*RH
IF(IWR.GT.1) WRITE(6,604) JP,EFN,XX,AMP1
last= i
c-----------------------------------------------------------------------
c Test successive amplitudes for convergence
c-----------------------------------------------------------------------
ZTST= OVRCRT*AMP1
IF((DABS(AMP1-AMP2).LT.ZTST).AND.
1 (DABS(AMP2-AMP3).LT.ZTST)) GOTO 35
ENDIF
DO j= 1,4
PSIc(j)= PSIc(j+1)
ENDDO
ENDDO
IF(IWR.NE.0) WRITE(6,603) JP,EFN,AMP1,AMP2,AMP3,AMP4
35 FACT1= 2.D0*RH*RH*RH/(AVAL(NL)*BFCT)
FACT2= -SIXTH*RH*RH/BFCT
c3pt FACT2= -*RH*RH/BFCT
OVR1= OVR1*FACT1
OVR2= OVR2*FACT2
gtkfact= 1.d0
gtk= gtk*gtkfact
DO i= 1,NEND
AI1(NL,i)= AI1(NL,i)*FACT1/AMP1
AI2(NL,i)= AI2(NL,i)*FACT2/AMP1
AIgtk(NL,i)= AIgtk(NL,i)*gtkfact/AMP1
ENDDO
OVRLAP(NL)= (OVR1 + OVR2)/AMP1
gtkLAP(NL)= gtk/AMP1
IF(TMFVAR(2*NL-2,ifs).GT.0) THEN
dIda1= OVR1/AVAL(NL)
dIda2= -16.d0*FACT1*dIda2
dIda3= OVR2/AVAL(NL)
dIda4= -8.d0*FACT2*dIda4
DA(NL)= dIda1 + dIda2 + dIda3 + dIda4
ENDIF
IF(TMFVAR(2*NL-1,ifs).GT.0) THEN
dIdRc1= -FACT1*dIdRc1
dIdRc2= 4.d0*FACT1*dIdRc2/AVAL(NL)
dIdRc3= 2.d0*FACT2*dIdRc3/AVAL(NL)
DRc(NL)= dIdRc1 + dIdRc2 + dIdRc3
ENDIF
c-----------------------------------------------------------------------
c note that total intensity is the square of the overlap integral
c and for total derivative need 2*(overlap integral)*(dI/dp).
c-----------------------------------------------------------------------
100 CONTINUE
OVR= 0.d0
OVRgtk= 0.d0
DO i= 1,NEND
ACCUM1(i)= 0.d0
ACCUM2(i)= 0.d0
ACCUMgtk(i)= 0.d0
ENDDO
DO NL= 1,NLORZ
OVR= OVR + OVRLAP(NL)
OVRgtk= OVRgtk + gtkLAP(NL)
DO i= 1,NEND-2
ACCUM1(i)= ACCUM1(i) + AI1(NL,i)
ACCUM2(i)= ACCUM2(i) + AI2(NL,i)
ACCUMgtk(i)= ACCUMgtk(i) + AIgtk(NL,i)
ENDDO
ENDDO
IF(IWR.GE.1) WRITE(6,605) JP,EFN,last,XX,OVR
IF(IWR.GE.2) WRITE(6,606) PSIc0,AMP1,AMP2,AMP3,AMP4
NL= 1
DO m= 0,OTMF-1,2
DER(m)= 2.d0*OVR*DA(NL)
DER(m+1)= 2.d0*OVR*DRc(NL)
NL= NL+1
ENDDO
OVR= OVR*OVR
OVRgtk= OVRgtk*OVRgtk
IF(LPTMF.GT.0) THEN
WRITE(10,1000)
DO i= 1,NEND-2,LPTMF
TOT= ACCUM1(i) + ACCUM2(i)
WRITE(10,1001) RAD(i),ACCUM1(i),ACCUM2(i),TOT,ACCUMgtk(i)
ENDDO
ENDIF
RETURN
c-----------------------------------------------------------------------
601 FORMAT(' *** OVRLAP BOMBed *** '/ 'For J = ',I3,' EFN = ',
1 F10.2,' never got to first turning point')
602 FORMAT(' ** WARNING ** For J = ', I3 ,' EFN = ',F10.2,
1 ' starting wavefunction is PSI(',I4,') = ',D10.3,' and I(turn.p
2t.) = ',I4)
603 FORMAT(' ** WARNING ** For J= ',I3,' EFN= ',F9.2,' amplitude not',
1 ' converged by end of range'/3x,'Last four values are ',
2 4(1PD14.6))
604 FORMAT(' At J =',I3,' EFN = ',F10.2,' R = ',F7.4,
1 ', apparent asymptotic amplitude is',G15.8)
605 FORMAT(/' At JP=',I3,' EFN= ',F9.2,' Range to R(',I4,')=',
1 F7.4/' OVRPD gives overlap integral= ',F12.8)
606 FORMAT(5x,'where PSIc(initial)= ',D10.3,' & last 4 amplitudes',
1 ' are',1P4D15.7)
607 FORMAT(' *** ERROR *** At J = ',I3,' EFN = ',F10.2,
1 ' have V .GT. E everywhere.' )
608 FORMAT(' *** Caution *** For J = ',I3,' (EFN= ',F10.2,
1 ') .GE. (V = ',F10.2,') at I = ',I4,' ,so initialize with a n
2ode.')
cgtk0 FORMAT(' Accumulated Integral Lorentzian type TMF'//
cgtk 1 ' RAD dW/dR term dPSIc/dR term TOTAL')
1000 FORMAT(' Accumulated Integral Lorentzian type TMF'//
1 ' RAD dW/dR term dPSIc/dR term TOTAL PSIb*PSIc')
cgtk0 FORMAT((F7.3,3(1PD14.6)))
1001 FORMAT((F7.3,4(1PD14.6)))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE HONL(HLFACT,JPP,JP,OMEGA,PQR,ifs)
c=======================================================================
c Routine to calculate Honl-London factors (HLFACT)
c Last modified 9 April 2007 to take account of Hansson & Watson(2005)
c=======================================================================
ccc INCLUDE 'arrsizes.h'
c-----------------------------------------------------------------------
c Utility routine to summarize dimensioning of arrays
c-----------------------------------------------------------------------
INTEGER mxdata,mxisp,mxfsp,mxnj,mxnp,mxntp,mxprm,mxv,mxfs,mxisot,
1 mxsets,mxfreq
REAL*8 CCM,PI
c-----------------------------------------------------------------------
c mxdata - maximum number of input data points
c mxisp - maximum number of points for initial state potential array
c (also used for number of points in transition moment array)
c mxnj - maxiumum value of j quantum number allowed
c mxfsp - maximum number of points for final state potential array
c mxnp - maximum number of parameters total
c mxntp - maximum number of turning points to be read in
c mxprm - maximum number of parameters for final state pot'l or TMF
c mxv - largest value for the v quantum number
c mxfs - maximum number of final states allowed
c mxisot - maximum number of isotopomers allowed
c mxsets - maximum number of data sets allowed
c mxfreq - maximum number of data points allowed in a given set
c-----------------------------------------------------------------------
PARAMETER (mxisp=16001)
PARAMETER (mxnj=20)
PARAMETER (mxfsp=16001)
PARAMETER (mxntp=9999)
PARAMETER (mxprm=6)
PARAMETER (mxv=200)
PARAMETER (mxfs=5)
PARAMETER (mxisot=3)
PARAMETER (mxsets=11)
PARAMETER (mxfreq=501)
PARAMETER (PI=3.141592653589793238d0)
PARAMETER (mxnp=2*mxprm*mxfs+mxsets-1)
PARAMETER (mxdata=mxfreq*mxsets)
PARAMETER (CCM= 299792458d2)
c=======================================================================
INTEGER DOMEGA,ifs,JPP,JP,OMEGA(0:mxfs),PQR
REAL*8 HLFACT,J,L
c
HLFACT= 1.d0
IF(PQR.LE.0) GOTO 100
HLFACT= 0.d0
IF(JP.LT.0) GOTO 100
IF((JP.EQ.JPP).AND.(JP.EQ.0)) GOTO 100
J= DBLE(JPP)
L= DBLE(OMEGA(0))
DOMEGA= OMEGA(ifs) - OMEGA(0)
IF(DOMEGA.EQ.0) THEN
IF(JP.EQ.JPP+1) HLFACT= (J+1.d0+L)*(J+1.d0-L)/(J+1.d0)
IF(JP.EQ.JPP) HLFACT= (2.d0*J+1.d0)*L*L/(J*(J+1.d0))
IF(JP.EQ.JPP-1) HLFACT= (J+L)*(J-L)/J
ELSEIF(DOMEGA.EQ.1) THEN
IF(JP.EQ.JPP+1) HLFACT= (J+2.d0+L)*(J+1.d0+L)/(2.d0*(J+1.d0))
IF(JP.EQ.JPP) HLFACT= (J+1.d0+L)*(J-L)*(2.d0*J+1.d0)/
1 (2.d0*J*(J+1.d0))
IF(JP.EQ.JPP-1) HLFACT= (J-1.d0-L)*(J-L)/(2.d0*J)
IF(MIN(OMEGA(0),OMEGA(ifs)).EQ.0) HLFACT= HLFACT + HLFACT
ELSEIF(DOMEGA.EQ.-1) THEN
IF(JP.EQ.JPP+1) HLFACT= (J+2.d0-L)*(J+1.d0-L)/(2.d0*(J+1.d0))
IF(JP.EQ.JPP) HLFACT= (J+1.d0-L)*(J+L)*(2.d0*J+1.d0)/
1 (2.d0*J*(J+1.d0))
IF(JP.EQ.JPP-1) HLFACT= (J-1.d0+L)*(J+L)/(2.d0*J)
IF(MIN(OMEGA(0),OMEGA(ifs)).EQ.0) HLFACT= HLFACT + HLFACT
ENDIF
c-----------------------------------------------------------------------
c output HLFACT divided by (2J+1) of its actual value in order to keep
c proper population cutoff intact (see POPF in forward.f)
c-----------------------------------------------------------------------
HLFACT= HLFACT/(2.d0*J+1.d0)
100 RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE JAVGE(KV,NJ,JM,BV,TCM)
c=======================================================================
c This subroutine calculates JM(M), the average J for each of the NJ
c equally weighted segments of the rotational population for
c vibrational level whose rotational constant is Bv, all at
c temperature TCM (in cm-1).
c
c JM(NJ,M)=-0.5+FJ1(M)*(8*DSQRT(K*T/Bv)+DSQRT(Bv/K*T))-FJ2(M)* ...
c
c Taken from Eq.(21) of Le Roy et al. (J.Chem.Phys. 65, 1485 (1976))
c----------------- Last updated 23 February 2001 ---------------------
c=======================================================================
INTEGER I,IFIRST,JM(20),KV,M,NJ,NJ1
REAL*8 A1,A2,BV,DERF,E1,E2,F1,F2,FJ1(20),FJ2(20),TCM,TWR,X,ZN
DATA IFIRST/-1/
SAVE FJ2,FJ1,IFIRST
DERF(X) = 1.D0 - (1.D0 + X*(.278393D0 + X*(.230389D0 + X*(.972D-3
1 + X*.078108D0))))**(-4)
c=======================================================================
IF (NJ.NE.IFIRST) THEN
IF (NJ.LE.0) THEN
FJ1(1) = 0.d0
FJ2(1) = 0.d0
IFIRST= NJ
cc WRITE(6,600)
GOTO 100
ENDIF
ZN = NJ
F1 = ZN*0.2215567314D0
A1 = 0.D0
E1 = 0.D0
IF (NJ.GT.1) THEN
NJ1 = NJ - 1
DO M=1,NJ1
A2 = A1
A1 = DSQRT(DLOG(ZN/DFLOAT(NJ-M)))
E2 = E1
E1 = DERF(A1)
FJ2(M) = -(NJ-M)*A1+(NJ-M+1)*A2
FJ1(M) = F1*(E1-E2)
ENDDO
ENDIF
A2 = A1
E2 = E1
FJ2(NJ) = A2
FJ1(NJ) = F1*(1.D0-E2)
cc WRITE(6,601) NJ,(I,FJ1(I),I,FJ2(I),I=1,NJ)
IFIRST= NJ
ENDIF
100 IF (TCM.LE. 0.D0) NJ = 0
IF (NJ.GT.0) THEN
F2 = DSQRT(TCM/BV)
F1 = 4.D0*F2+1.D0/F2
DO M=1,NJ
JM(M)=F1*FJ1(M)+F2*FJ2(M)
ENDDO
TWR = TCM/.6950387d0
cc WRITE(6,603) KV,BV,TWR,NJ,(JM(I),I=1,NJ)
ELSE
JM(1) = 0
ENDIF
RETURN
c-----------------------------------------------------------------------
cc600 FORMAT(/' Fix J=0 rather than sum over a rotational distribution')
cc601 FORMAT(/' Divide rotational distbn for each vib. level into',I3,
cc 1 ' equally weighted segments.'/
cc 2 (2(4x:'FJ1(',I2,')=',F8.5,' FJ2(',I2,')=',F8.5)))
cc603 FORMAT(/' For v =',I2,' with Bv =',F9.6,' at T =',
cc 1 F7.1,' the',I3,' equally weighted J-s are'/(16I5))
c-----------------------------------------------------------------------
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE MASSES(IAN,IMN,NAME,GELGS,GNS,MASS,ABUND)
c***********************************************************************
c** For isotope with (input) atomic number IAN and mass number IMN,
c return (output): (i) as the right-adjusted 2-character variable NAME
c the alphabetic symbol for that element, (ii) the ground state
c electronic degeneracy GELGS, (iii) the nuclear spin degeneracy GNS,
c (iv) the atomic mass MASS [amu], and (v) the natural isotopic
c abundance ABUND [in percent]. GELGS values based on atomic states
c in Moore's "Atomic Energy Level" tables, the isotope masses are taken
c from the 2003 mass table [Audi, Wapstra & Thibault, Nucl.Phys. A729,
c 337-676 (2003)] and other quantities from Tables 6.2 and 6.3 of
c "Quantities, Units and Symbols in Physical Chemistry", by Mills et
c al. (Blackwell, 2'nd Edition, Oxford, 1993).
c** If the input value of IMN does not equal one of the tabulated values
c for atomic species IAN, return the abundance-averaged standard atomic
c weight of that atom and set GNS=-1 and ABUND=-1.
c COPYRIGHT 2005
c** By R.J. Le Roy (with assistance from G.T. Kraemer & J.Y. Seto).
c Last modified 1 June 2005
c***********************************************************************
REAL*8 zm(123,0:10),mass,ab(123,10),abund
INTEGER i,ian,imn,gel(123),nmn(123),mn(123,10),ns2(123,10),
1 gelgs, gns
CHARACTER*2 NAME,AT(123)
c
DATA at(1),gel(1),nmn(1),(mn(1,i),i=1,3)/' H',2,3,1,2,3/
DATA (zm(1,i),i=0,3)/1.00794d0, 1.00782503207d0, 2.0141017778d0,
1 3.0160492777d0/
DATA (ns2(1,i),i=1,3)/1,2,1/
DATA (ab(1,i),i=1,3)/99.985d0,0.015d0,0.d0/
c
DATA at(2),gel(2),nmn(2),(mn(2,i),i=1,2)/'He',1,2,3,4/
DATA (zm(2,i),i=0,2)/4.002602d0, 3.0160293191d0, 4.00260325415d0/
DATA (ns2(2,i),i=1,2)/1,0/
DATA (ab(2,i),i=1,2)/0.000137d0,99.999863d0/
c
DATA at(3),gel(3),nmn(3),(mn(3,i),i=1,2)/'Li',2,2,6,7/
DATA (zm(3,i),i=0,2)/6.941d0, 6.015122795d0, 7.01600455d0/
DATA (ns2(3,i),i=1,2)/2,3/
DATA (ab(3,i),i=1,2)/7.5d0,92.5d0/
c
DATA at(4),gel(4),nmn(4),(mn(4,i),i=1,1)/'Be',1,1,9/
DATA (zm(4,i),i=0,1)/9.012182d0, 9.0121822d0/
DATA (ns2(4,i),i=1,1)/3/
DATA (ab(4,i),i=1,1)/100.d0/
c
DATA at(5),gel(5),nmn(5),(mn(5,i),i=1,2)/' B',2,2,10,11/
DATA (zm(5,i),i=0,2)/10.811d0, 10.0129370d0, 11.0093054d0/
DATA (ns2(5,i),i=1,2)/6,3/
DATA (ab(5,i),i=1,2)/19.9d0,80.1d0/
c
DATA at(6),gel(6),nmn(6),(mn(6,i),i=1,3)/' C',1,3,12,13,14/
DATA (zm(6,i),i=0,3)/12.011d0, 12.d0, 13.0033548378d0,
1 14.003241989d0/
DATA (ns2(6,i),i=1,3)/0,1,0/
DATA (ab(6,i),i=1,3)/98.90d0,1.10d0, 0.d0/
c
DATA at(7),gel(7),nmn(7),(mn(7,i),i=1,2)/' N',4,2,14,15/
DATA (zm(7,i),i=0,2)/14.00674d0, 14.0030740048d0, 15.0001088982d0/
DATA (ns2(7,i),i=1,2)/2,1/
DATA (ab(7,i),i=1,2)/99.634d0,0.366d0/
c
DATA at(8),gel(8),nmn(8),(mn(8,i),i=1,3)/' O',5,3,16,17,18/
DATA (zm(8,i),i=0,3)/15.9994d0, 15.99491461956d0, 16.99913170d0,
1 17.9991610d0/
DATA (ns2(8,i),i=1,3)/0,5,0/
DATA (ab(8,i),i=1,3)/99.762d0, 0.038d0, 0.200d0/
c
DATA at(9),gel(9),nmn(9),(mn(9,i),i=1,1)/' F',4,1,19/
DATA (zm(9,i),i=0,1)/18.9984032d0, 18.99840322d0/
DATA (ns2(9,i),i=1,1)/1/
DATA (ab(9,i),i=1,1)/100.d0/
c
DATA at(10),gel(10),nmn(10),(mn(10,i),i=1,3)/'Ne',1,3,20,21,22/
DATA (zm(10,i),i=0,3)/20.1797d0, 19.9924401754d0, 20.99384668d0,
1 21.991385114d0/
DATA (ns2(10,i),i=1,3)/0,3,0/
DATA (ab(10,i),i=1,3)/90.48d0, 0.27d0, 9.25d0/
c
DATA at(11),gel(11),nmn(11),(mn(11,i),i=1,1)/'Na',2,1,23/
DATA (zm(11,i),i=0,1)/22.989768d0, 22.9897692809d0/
DATA (ns2(11,i),i=1,1)/3/
DATA (ab(11,i),i=1,1)/100.d0/
c
DATA at(12),gel(12),nmn(12),(mn(12,i),i=1,3)/'Mg',1,3,24,25,26/
DATA (zm(12,i),i=0,3)/24.3050d0, 23.985041700d0, 24.98583692d0,
1 25.982592929d0/
DATA (ns2(12,i),i=1,3)/0,5,0/
DATA (ab(12,i),i=1,3)/78.99d0, 10.00d0, 11.01d0/
c
DATA at(13),gel(13),nmn(13),(mn(13,i),i=1,1)/'Al',2,1,27/
DATA (zm(13,i),i=0,1)/26.981539d0, 26.98153863d0/
DATA (ns2(13,i),i=1,1)/5/
DATA (ab(13,i),i=1,1)/100.d0/
c
DATA at(14),gel(14),nmn(14),(mn(14,i),i=1,3)/'Si',1,3,28,29,30/
DATA (zm(14,i),i=0,3)/28.0855d0, 27.9769265325d0, 28.976494700d0,
1 29.97377017d0/
DATA (ns2(14,i),i=1,3)/0,1,0/
DATA (ab(14,i),i=1,3)/92.23d0, 4.67d0, 3.10d0/
DATA at(15),gel(15),nmn(15),(mn(15,i),i=1,1)/' P',4,1,31/
DATA (zm(15,i),i=0,1)/30.973762d0, 30.97376163d0/
DATA (ns2(15,i),i=1,1)/1/
DATA (ab(15,i),i=1,1)/100.d0/
c
DATA at(16),gel(16),nmn(16),(mn(16,i),i=1,4)/' S',5,4,32,33,34,36/
DATA (zm(16,i),i=0,4)/32.066d0, 31.97207100d0, 32.97145876d0,
1 33.96786690d0, 35.96708076d0/
DATA (ns2(16,i),i=1,4)/0,3,0,0/
DATA (ab(16,i),i=1,4)/95.02d0, 0.75d0, 4.21d0, 0.02d0/
c
DATA at(17),gel(17),nmn(17),(mn(17,i),i=1,2)/'Cl',4,2,35,37/
DATA (zm(17,i),i=0,2)/35.4527d0, 34.96885268d0, 36.96590259d0/
DATA (ns2(17,i),i=1,2)/3,3/
DATA (ab(17,i),i=1,2)/75.77d0, 24.23d0/
c
DATA at(18),gel(18),nmn(18),(mn(18,i),i=1,3)/'Ar',1,3,36,38,40/
DATA (zm(18,i),i=0,3)/39.948d0, 35.967545106d0, 37.9627324d0,
1 39.9623831225d0/
DATA (ns2(18,i),i=1,3)/0,0,0/
DATA (ab(18,i),i=1,3)/0.337d0, 0.063d0, 99.600d0/
c
DATA at(19),gel(19),nmn(19),(mn(19,i),i=1,3)/' K',2,3,39,40,41/
DATA (zm(19,i),i=0,3)/39.0983d0, 38.96370668d0, 39.96399848d0,
1 40.96182576d0/
DATA (ns2(19,i),i=1,3)/3,8,3/
DATA (ab(19,i),i=1,3)/93.2581d0, 0.0117d0, 6.7302d0/
DATA at(20),gel(20),nmn(20),(mn(20,i),i=1,6)/'Ca',1,6,40,42,43,44,
1 46,48/
DATA (zm(20,i),i=0,6)/40.078d0, 39.96259098d0, 41.95861801d0,
1 42.9587666d0, 43.9554818d0, 45.9536926d0, 47.952534d0/
DATA (ns2(20,i),i=1,6)/0,0,7,0,0,0/
DATA (ab(20,i),i=1,6)/96.941d0, 0.647d0, 0.135d0, 2.086d0,
1 0.004d0, 0.187d0/
c
DATA at(21),gel(21),nmn(21),(mn(21,i),i=1,1)/'Sc',4,1,45/
DATA (zm(21,i),i=0,1)/44.955910d0, 44.9559119d0/
DATA (ns2(21,i),i=1,1)/7/
DATA (ab(21,i),i=1,1)/100.d0/
c
DATA at(22),gel(22),nmn(22),(mn(22,i),i=1,5)/'Ti',5,5,46,47,48,49,
1 50/
DATA (zm(22,i),i=0,5)/47.88d0, 45.9526316d0, 46.9517631d0,
1 47.9479463d0, 48.9478700d0, 49.9447912d0/
DATA (ns2(22,i),i=1,5)/0,5,0,7,0/
DATA (ab(22,i),i=1,5)/8.0d0, 7.3d0, 73.8d0, 5.5d0, 5.4d0/
c
DATA at(23),gel(23),nmn(23),(mn(23,i),i=1,2)/' V',4,2,50,51/
DATA (zm(23,i),i=0,2)/50.9415d0, 49.9471585d0, 50.9439595d0/
DATA (ns2(23,i),i=1,2)/12,7/
DATA (ab(23,i),i=1,2)/0.250d0, 99.750d0/
c
DATA at(24),gel(24),nmn(24),(mn(24,i),i=1,4)/'Cr',7,4,50,52,53,54/
DATA (zm(24,i),i=0,4)/51.9961d0, 49.9460442d0, 51.9405075d0,
1 52.9406494d0, 53.9388804d0/
DATA (ns2(24,i),i=1,4)/0,0,3,0/
DATA (ab(24,i),i=1,4)/4.345d0, 83.789d0, 9.501d0, 2.365d0/
c
DATA at(25),gel(25),nmn(25),(mn(25,i),i=1,1)/'Mn',6,1,55/
DATA (zm(25,i),i=0,1)/54.93805d0, 54.9380451d0/
DATA (ns2(25,i),i=1,1)/5/
DATA (ab(25,i),i=1,1)/100.d0/
c
DATA at(26),gel(26),nmn(26),(mn(26,i),i=1,4)/'Fe',9,4,54,56,57,58/
DATA (zm(26,i),i=0,4)/55.847d0, 53.9396105d0, 55.9349375d0,
1 56.9353940d0, 57.9332756d0/
DATA (ns2(26,i),i=1,4)/0,0,1,0/
DATA (ab(26,i),i=1,4)/5.8d0, 91.72d0, 2.2d0, 0.28d0/
c
DATA at(27),gel(27),nmn(27),(mn(27,i),i=1,1)/'Co',10,1,59/
DATA (zm(27,i),i=0,1)/58.93320d0, 58.9331950d0/
DATA (ns2(27,i),i=1,1)/7/
DATA (ab(27,i),i=1,1)/100.d0/
c
DATA at(28),gel(28),nmn(28),(mn(28,i),i=1,5)/'Ni',9,5,58,60,61,62,
1 64/
DATA (zm(28,i),i=0,5)/58.69d0, 57.9353429d0, 59.9307864d0,
1 60.9310560d0, 61.9283451d0, 63.9279660d0/
DATA (ns2(28,i),i=1,5)/0,0,3,0,0/
DATA (ab(28,i),i=1,5)/68.077d0,26.223d0,1.140d0,3.634d0,0.926d0/
c
DATA at(29),gel(29),nmn(29),(mn(29,i),i=1,2)/'Cu',2,2,63,65/
DATA (zm(29,i),i=0,2)/63.546d0, 62.9295975d0,64.9277895d0/
DATA (ns2(29,i),i=1,2)/3,3/
DATA (ab(29,i),i=1,2)/69.17d0, 30.83d0/
c
DATA at(30),gel(30),nmn(30),(mn(30,i),i=1,5)/'Zn',1,5,64,66,67,68,
1 70/
DATA (zm(30,i),i=0,5)/65.40d0, 63.9291422d0, 65.9260334d0,
1 66.9271273d0, 67.9248442d0, 69.9253193d0/
DATA (ns2(30,i),i=1,5)/0,0,5,0,0/
DATA (ab(30,i),i=1,5)/48.6d0, 27.9d0, 4.1d0, 18.8d0, 0.6d0/
c
DATA at(31),gel(31),nmn(31),(mn(31,i),i=1,2)/'Ga',2,2,69,71/
DATA (zm(31,i),i=0,2)/69.723d0, 68.9255736d0, 70.9247013d0/
DATA (ns2(31,i),i=1,2)/3,3/
DATA (ab(31,i),i=1,2)/60.108d0, 39.892d0/
c
DATA at(32),gel(32),nmn(32),(mn(32,i),i=1,5)/'Ge',1,5,70,72,73,74,
1 76/
DATA (zm(32,i),i=0,5)/72.61d0, 69.9242474d0, 71.9220758d0,
1 72.9234589d0, 73.9211778d0, 75.9214026d0/
DATA (ns2(32,i),i=1,5)/0,0,9,0,0/
DATA (ab(32,i),i=1,5)/21.23d0, 27.66d0, 7.73d0, 35.94d0, 7.44d0/
c
DATA at(33),gel(33),nmn(33),(mn(33,i),i=1,1)/'As',4,1,75/
DATA (zm(33,i),i=0,1)/74.92159d0, 74.9215965d0/
DATA (ns2(33,i),i=1,1)/3/
DATA (ab(33,i),i=1,1)/100.d0/
c
DATA at(34),gel(34),nmn(34),(mn(34,i),i=1,6)/'Se',5,6,74,76,77,78,
1 80,82/
DATA (zm(34,i),i=0,6)/78.96d0, 73.9224764d0, 75.9192136d0,
1 76.9199140d0, 77.9173091d0, 79.9165213d0, 81.9166994d0/
DATA (ns2(34,i),i=1,6)/0,0,1,0,0,0/
DATA (ab(34,i),i=1,6)/0.89d0, 9.36d0, 7.63d0, 23.78d0, 49.61d0,
1 8.73d0/
c
DATA at(35),gel(35),nmn(35),(mn(35,i),i=1,2)/'Br',4,2,79,81/
DATA (zm(35,i),i=0,2)/79.904d0, 78.9183371d0, 80.9162906d0/
DATA (ns2(35,i),i=1,2)/3,3/
DATA (ab(35,i),i=1,2)/50.69d0, 49.31d0/
c
DATA at(36),gel(36),nmn(36),(mn(36,i),i=1,6)/'Kr',1,6,78,80,82,83,
1 84,86/
DATA (zm(36,i),i=0,6)/83.80d0, 77.9203648d0, 79.9163790d0,
1 81.9134836d0, 82.914136d0, 83.911507d0, 85.91061073d0/
DATA (ns2(36,i),i=1,6)/0,0,0,9,0,0/
DATA (ab(36,i),i=1,6)/0.35d0, 2.25d0, 11.6d0, 11.5d0, 57.0d0,
1 17.3d0/
c
DATA at(37),gel(37),nmn(37),(mn(37,i),i=1,2)/'Rb',2,2,85,87/
DATA (zm(37,i),i=0,2)/85.4678d0, 84.911789738d0, 86.909180527d0/
DATA (ns2(37,i),i=1,2)/5,3/
DATA (ab(37,i),i=1,2)/72.165d0, 27.835d0/
c
DATA at(38),gel(38),nmn(38),(mn(38,i),i=1,4)/'Sr',1,4,84,86,87,88/
DATA (zm(38,i),i=0,4)/87.62d0, 83.913425d0, 85.9092602d0,
1 86.9088771d0, 87.9056121d0/
DATA (ns2(38,i),i=1,4)/0,0,9,0/
DATA (ab(38,i),i=1,4)/0.56d0, 9.86d0, 7.00d0, 82.58d0/
c
DATA at(39),gel(39),nmn(39),(mn(39,i),i=1,1)/' Y',4,1,89/
DATA (zm(39,i),i=0,1)/88.90585d0, 88.9058483d0/
DATA (ns2(39,i),i=1,1)/1/
DATA (ab(39,i),i=1,1)/100.d0/
c
DATA at(40),gel(40),nmn(40),(mn(40,i),i=1,5)/'Zr',5,5,90,91,92,94,
1 96/
DATA (zm(40,i),i=0,5)/91.224d0, 89.9047044d0, 90.9056458d0,
1 91.9050408d0, 93.9063152d0, 95.9082734d0/
DATA (ns2(40,i),i=1,5)/0,5,0,0,0/
DATA (ab(40,i),i=1,5)/51.45d0, 11.22d0, 17.15d0, 17.38d0, 2.80d0/
c
DATA at(41),gel(41),nmn(41),(mn(41,i),i=1,1)/'Nb',2,1,93/
DATA (zm(41,i),i=0,1)/92.90638d0, 92.9063781d0/
DATA (ns2(41,i),i=1,1)/9/
DATA (ab(41,i),i=1,1)/100.d0/
c
DATA at(42),gel(42),nmn(42),(mn(42,i),i=1,7)/'Mo',7,7,92,94,95,96,
1 97,98,100/
DATA (zm(42,i),i=0,7)/95.94d0, 91.906811d0, 93.9050883d0,
1 94.9058421d0, 95.9046795d0, 96.9060215d0, 97.9054082d0,
2 99.907477d0/
DATA (ns2(42,i),i=1,7)/0,0,5,0,5,0,0/
DATA (ab(42,i),i=1,7)/14.84d0, 9.25d0, 15.92d0, 16.68d0, 9.55d0,
1 24.13d0, 9.63d0/
c
DATA at(43),gel(43),nmn(43),(mn(43,i),i=1,1)/'Tc',6,1,98/
DATA (zm(43,i),i=0,1)/97.907215d0, 97.907216d0/
DATA (ns2(43,i),i=1,1)/12/
DATA (ab(43,i),i=1,1)/100.d0/
c
DATA at(44),gel(44),nmn(44),(mn(44,i),i=1,7)/'Ru',11,7,96,98,99,
1 100,101,102,104/
DATA (zm(44,i),i=0,7)/101.07d0, 95.907598d0, 97.905287d0,
1 98.9059393d0, 99.9042195d0, 100.9055821d0, 101.9043493d0,
2 103.905433d0/
DATA (ns2(44,i),i=1,7)/0,0,5,0,5,0,0/
DATA (ab(44,i),i=1,7)/5.52d0, 1.88d0, 12.7d0, 12.6d0, 17.0d0,
1 31.6d0, 18.7d0/
c
DATA at(45),gel(45),nmn(45),(mn(45,i),i=1,1)/'Rh',10,1,103/
DATA (zm(45,i),i=0,1)/102.90550d0, 102.905504d0/
DATA (ns2(45,i),i=1,1)/1/
DATA (ab(45,i),i=1,1)/100.d0/
c
DATA at(46),gel(46),nmn(46),(mn(46,i),i=1,6)/'Pd',1,6,102,104,105,
1 106,108,110/
DATA (zm(46,i),i=0,6)/106.42d0, 101.905609d0, 103.904036d0,
1 104.905085d0, 105.903486d0, 107.903892d0, 109.905153d0/
DATA (ns2(46,i),i=1,6)/0,0,5,0,0,0/
DATA (ab(46,i),i=1,6)/1.02d0, 11.14d0, 22.33d0, 27.33d0, 26.46d0,
1 11.72d0/
c
DATA at(47),gel(47),nmn(47),(mn(47,i),i=1,2)/'Ag',2,2,107,109/
DATA (zm(47,i),i=0,2)/107.8682d0, 106.905097d0, 108.904752d0/
DATA (ns2(47,i),i=1,2)/1,1/
DATA (ab(47,i),i=1,2)/51.839d0, 48.161d0/
c
DATA at(48),gel(48),nmn(48),(mn(48,i),i=1,8)/'Cd',1,8,106,108,110,
1 111,112,113,114,116/
DATA (zm(48,i),i=0,8)/112.411d0, 105.906459d0, 107.904184d0,
1 109.9030021d0, 110.9041781d0, 111.9027578d0, 112.9044017d0,
2 113.9033585d0, 115.904756d0/
DATA (ns2(48,i),i=1,8)/0,0,0,1,0,1,0,0/
DATA (ab(48,i),i=1,8)/1.25d0, 0.89d0, 12.49d0, 12.80d0, 24.13d0,
1 12.22d0, 28.73d0, 7.49d0/
c
DATA at(49),gel(49),nmn(49),(mn(49,i),i=1,2)/'In',2,2,113,115/
DATA (zm(49,i),i=0,2)/114.818d0, 112.904058d0, 114.903878d0/
DATA (ns2(49,i),i=1,2)/9,9/
DATA (ab(49,i),i=1,2)/4.3d0, 95.7d0/
c
DATA at(50),gel(50),nmn(50),(mn(50,i),i=1,10)/'Sn',1,10,112,114,
1 115,116,117,118,119,120,122,124/
DATA (zm(50,i),i=0,10)/118.710d0, 111.904818d0, 113.902779d0,
1 114.903342d0, 115.901741d0, 116.902952d0, 117.901603d0,
2 118.903308d0, 119.9021947d0, 121.9034390d0, 123.9052739d0/
DATA (ns2(50,i),i=1,10)/0,0,1,0,1,0,1,0,0,0/
DATA (ab(50,i),i=1,10)/0.97d0, 0.65d0, 0.34d0, 14.53d0, 7.68d0,
1 24.23d0, 8.59d0, 32.59d0, 4.63d0, 5.79d0/
c
DATA at(51),gel(51),nmn(51),(mn(51,i),i=1,2)/'Sb',4,2,121,123/
DATA (zm(51,i),i=0,2)/121.757d0, 120.9038157d0, 122.9042140d0/
DATA (ns2(51,i),i=1,2)/5,7/
DATA (ab(51,i),i=1,2)/57.36d0, 42.64d0/
c
DATA at(52),gel(52),nmn(52),(mn(52,i),i=1,8)/'Te',5,8,120,122,123,
1 124,125,126,128,130/
DATA (zm(52,i),i=0,8)/127.60d0, 119.904020d0, 121.9030439d0,
1 122.9042700d0, 123.9028179d0, 124.9044307d0, 125.9033117d0,
2 127.9044631d0, 129.9062244d0/
DATA (ns2(52,i),i=1,8)/0,0,1,0,1,0,0,0/
DATA (ab(52,i),i=1,8)/0.096d0, 2.603d0, 0.908d0, 4.816d0,
1 7.139d0, 18.95d0, 31.69d0, 33.80d0/
c
DATA at(53),gel(53),nmn(53),(mn(53,i),i=1,2)/' I',4,2,127,129/
DATA (zm(53,i),i=0,2)/126.90447d0, 126.904473d0, 128.904988d0/
DATA (ns2(53,i),i=1,2)/5,7/
DATA (ab(53,i),i=1,2)/100.d0,0.d0/
c
DATA at(54),gel(54),nmn(54),(mn(54,i),i=1,9)/'Xe',1,9,124,126,128,
1 129,130,131,132,134,136/
DATA (zm(54,i),i=0,9)/131.29d0, 123.9058930d0, 125.904274d0,
1 127.9035313d0, 128.9047794d0, 129.9035080d0, 130.9050824d0,
2 131.9041535d0, 133.9053945d0, 135.907219d0/
DATA (ns2(54,i),i=1,9)/0,0,0,1,0,3,0,0,0/
DATA (ab(54,i),i=1,9)/0.10d0, 0.09d0, 1.91d0, 26.4d0, 4.1d0,
1 21.2d0, 26.9d0, 10.4d0, 8.9d0/
c
DATA at(55),gel(55),nmn(55),(mn(55,i),i=1,1)/'Cs',2,1,133/
DATA (zm(55,i),i=0,1)/132.90543d0, 132.905451933d0/
DATA (ns2(55,i),i=1,1)/7/
DATA (ab(55,i),i=1,1)/100.d0/
c
DATA at(56),gel(56),nmn(56),(mn(56,i),i=1,7)/'Ba',1,7,130,132,134,
1 135,136,137,138/
DATA (zm(56,i),i=0,7)/137.327d0, 129.9063208d0, 131.9050613d0,
1 133.9045084d0, 134.9056886d0, 135.9045759d0, 136.9058274d0,
2 137.9052472d0/
DATA (ns2(56,i),i=1,7)/0,0,0,3,0,3,0/
DATA (ab(56,i),i=1,7)/0.106d0, 0.101d0, 2.417d0, 6.592d0,
1 7.854d0, 11.23d0, 71.70d0/
c
DATA at(57),gel(57),nmn(57),(mn(57,i),i=1,2)/'La',4,2,138,139/
DATA (zm(57,i),i=0,2)/138.9055d0, 137.907112d0, 138.9063533d0/
DATA (ns2(57,i),i=1,2)/10,7/
DATA (ab(57,i),i=1,2)/0.0902d0, 99.9098d0/
c
DATA at(58),gel(58),nmn(58),(mn(58,i),i=1,4)/'Ce',9,4,136,138,140,
1 142/
DATA (zm(58,i),i=0,4)/140.115d0, 135.907172d0, 137.905991d0,
1 139.9054387d0, 141.909244d0/
DATA (ns2(58,i),i=1,4)/0,0,0,0/
DATA (ab(58,i),i=1,4)/0.19d0, 0.25d0, 88.48d0, 11.08d0/
c
DATA at(59),gel(59),nmn(59),(mn(59,i),i=1,1)/'Pr',10,1,141/
DATA (zm(59,i),i=0,1)/140.90765d0, 140.9076528d0/
DATA (ns2(59,i),i=1,1)/5/
DATA (ab(59,i),i=1,1)/100.d0/
c
DATA at(60),gel(60),nmn(60),(mn(60,i),i=1,7)/'Nd',9,7,142,143,144,
1 145,146,148,150/
DATA (zm(60,i),i=0,7)/144.24d0, 141.9077233d0, 142.9098143d0,
1 143.9100873d0, 144.9125736d0, 145.9131169d0, 147.916893d0,
2 149.920891d0/
DATA (ns2(60,i),i=1,7)/0,7,0,7,0,0,0/
DATA (ab(60,i),i=1,7)/27.13d0, 12.18d0, 23.80d0, 8.30d0, 17.19d0,
1 5.76d0, 5.64d0/
c
DATA at(61),gel(61),nmn(61),(mn(61,i),i=1,1)/'Pm',6,1,145/
DATA (zm(61,i),i=0,1)/144.912743d0, 144.912749d0/
DATA (ns2(61,i),i=1,1)/5/
DATA (ab(61,i),i=1,1)/100.d0/
c
DATA at(62),gel(62),nmn(62),(mn(62,i),i=1,7)/'Sm',1,7,144,147,148,
1 149,150,152,154/
DATA (zm(62,i),i=0,7)/150.36d0, 143.911999d0, 146.9148979d0,
1 147.9148227d0, 148.9171847d0, 149.9172755d0, 151.9197324d0,
2 153.9222093d0/
DATA (ns2(62,i),i=1,7)/0,7,0,7,0,0,0/
DATA (ab(62,i),i=1,7)/3.1d0, 15.0d0, 11.3d0, 13.8d0, 7.4d0,
1 26.7d0, 22.7d0/
c
DATA at(63),gel(63),nmn(63),(mn(63,i),i=1,2)/'Eu',8,2,151,153/
DATA (zm(63,i),i=0,2)/151.965d0, 150.9198502d0, 152.9212303d0/
DATA (ns2(63,i),i=1,2)/5,5/
DATA (ab(63,i),i=1,2)/47.8d0, 52.2d0/
c
DATA at(64),gel(64),nmn(64),(mn(64,i),i=1,7)/'Gd',5,7,152,154,155,
1 156,157,158,160/
DATA (zm(64,i),i=0,7)/157.25d0, 151.9197910d0, 153.92086560,
1 154.9226220d0, 155.9221227d0, 156.9239601d0, 157.9241039d0,
2 159.9270541d0/
DATA (ns2(64,i),i=1,7)/0,0,3,0,3,0,0/
DATA (ab(64,i),i=1,7)/0.20d0, 2.18d0, 14.80d0, 20.47d0, 15.65d0,
1 24.84d0, 21.86d0/
c
DATA at(65),gel(65),nmn(65),(mn(65,i),i=1,1)/'Tb',16,1,159/
DATA (zm(65,i),i=0,1)/158.92534d0, 158.9253468d0/
DATA (ns2(65,i),i=1,1)/3/
DATA (ab(65,i),i=1,1)/100.d0/
c
DATA at(66),gel(66),nmn(66),(mn(66,i),i=1,7)/'Dy',17,7,156,158,
1 160,161,162,163,164/
DATA (zm(66,i),i=0,7)/162.50d0, 155.924283d0, 157.924409d0,
1 159.9251975d0, 160.9269334d0, 161.9267984d0, 162.9287312d0,
2 163.9291748d0/
DATA (ns2(66,i),i=1,7)/0,0,0,5,0,5,0/
DATA (ab(66,i),i=1,7)/0.06d0, 0.10d0, 2.34d0, 18.9d0, 25.5d0,
1 24.9d0, 28.2d0/
c
DATA at(67),gel(67),nmn(67),(mn(67,i),i=1,1)/'Ho',16,1,165/
DATA (zm(67,i),i=0,1)/164.93032d0, 164.9303221d0/
DATA (ns2(67,i),i=1,1)/7/
DATA (ab(67,i),i=1,1)/100.d0/
DATA at(68),gel(68),nmn(68),(mn(68,i),i=1,6)/'Er',13,6,162,164,
1 166,167,168,170/
DATA (zm(68,i),i=0,6)/167.26d0, 161.928778d0, 163.929200d0,
1 165.9302931d0, 166.9320482d0, 167.9323702d0, 169.9354643d0/
DATA (ns2(68,i),i=1,6)/0,0,0,7,0,0/
DATA (ab(68,i),i=1,6)/0.14d0, 1.61d0, 33.6d0, 22.95d0, 26.8d0,
1 14.9d0/
c
DATA at(69),gel(69),nmn(69),(mn(69,i),i=1,1)/'Tm',8,1,169/
DATA (zm(69,i),i=0,1)/168.93421d0, 168.9342133d0/
DATA (ns2(69,i),i=1,1)/1/
DATA (ab(69,i),i=1,1)/100.d0/
c
DATA at(70),gel(70),nmn(70),(mn(70,i),i=1,7)/'Yb',1,7,168,170,171,
1 172,173,174,176/
DATA (zm(70,i),i=0,7)/173.04d0, 167.933897d0, 169.9347618d0,
1 170.936323580, 171.9363815d0, 172.9382108d0, 173.9388621d0,
2 175.9425717d0/
DATA (ns2(70,i),i=1,7)/0,0,1,0,5,0,0/
DATA (ab(70,i),i=1,7)/0.13d0, 3.05d0, 14.3d0, 21.9d0, 16.12d0,
1 31.8d0, 12.7d0/
c
DATA at(71),gel(71),nmn(71),(mn(71,i),i=1,2)/'Lu',4,2,175,176/
DATA (zm(71,i),i=0,2)/174.967d0, 174.9407718d0, 175.9426863d0/
DATA (ns2(71,i),i=1,2)/7,14/
DATA (ab(71,i),i=1,2)/97.41d0, 2.59d0/
c
DATA at(72),gel(72),nmn(72),(mn(72,i),i=1,6)/'Hf',5,6,174,176,177,
1 178,179,180/
DATA (zm(72,i),i=0,6)/178.49d0, 173.940046d0, 175.9414086d0,
1 176.9432207d0, 177.9436988d0, 178.9458161d0, 179.9465500d0/
DATA (ns2(72,i),i=1,6)/0,0,7,0,9,0/
DATA (ab(72,i),i=1,6)/0.162d0, 5.206d0, 18.606d0, 27.297d0,
1 13.629d0, 35.100d0/
c
DATA at(73),gel(73),nmn(73),(mn(73,i),i=1,2)/'Ta',4,2,180,181/
DATA (zm(73,i),i=0,2)/180.9479d0, 179.9474648d0, 180.9479958d0/
DATA (ns2(73,i),i=1,2)/16,7/
DATA (ab(73,i),i=1,2)/0.012d0, 99.988d0/
c
DATA at(74),gel(74),nmn(74),(mn(74,i),i=1,5)/' W',1,5,180,182,183,
1 184,186/
DATA (zm(74,i),i=0,5)/183.84d0, 179.946704d0, 181.9482042d0,
1 182.9502230d0, 183.9509312d0, 185.9543641d0/
DATA (ns2(74,i),i=1,5)/0,0,1,0,0/
DATA (ab(74,i),i=1,5)/0.13d0, 26.3d0, 14.3d0, 30.67d0, 28.6d0/
c
DATA at(75),gel(75),nmn(75),(mn(75,i),i=1,2)/'Re',6,2,185,187/
DATA (zm(75,i),i=0,2)/186.207d0, 184.9529550d0, 186.9557531d0/
DATA (ns2(75,i),i=1,2)/5,5/
DATA (ab(75,i),i=1,2)/37.40d0, 62.60d0/
c
DATA at(76),gel(76),nmn(76),(mn(76,i),i=1,7)/'Os',9,7,184,186,187,
1 188,189,190,192/
DATA (zm(76,i),i=0,7)/190.23d0, 183.9524891d0, 185.9538382d0,
1 186.9557505d0, 187.9558382d0, 188.9581475d0, 189.9584470d0,
2 191.9614807d0/
DATA (ns2(76,i),i=1,7)/0,0,1,0,3,0,0/
DATA (ab(76,i),i=1,7)/0.02d0, 1.58d0, 1.6d0, 13.3d0, 16.1d0,
1 26.4d0, 41.0d0/
c
DATA at(77),gel(77),nmn(77),(mn(77,i),i=1,2)/'Ir',10,2,191,193/
DATA (zm(77,i),i=0,2)/192.22d0, 190.9605940d0, 192.9629264d0/
DATA (ns2(77,i),i=1,2)/3,3/
DATA (ab(77,i),i=1,2)/37.3d0, 62.7d0/
c
c
DATA at(78),gel(78),nmn(78),(mn(78,i),i=1,6)/'Pt',7,6,190,192,194,
1 195,196,198/
DATA (zm(78,i),i=0,6)/195.08d0, 189.959932d0, 191.9610380d0,
1 193.9626803d0, 194.9647911d0, 195.9649515d0, 197.967893d0/
DATA (ns2(78,i),i=1,6)/0,0,0,1,0,0/
DATA (ab(78,i),i=1,6)/0.01d0,0.79d0,32.9d0,33.8d0,25.3d0,7.2d0/
c
DATA at(79),gel(79),nmn(79),(mn(79,i),i=1,1)/'Au',2,1,197/
DATA (zm(79,i),i=0,1)/196.96654d0, 196.9665687d0/
DATA (ns2(79,i),i=1,1)/3/
DATA (ab(79,i),i=1,1)/100.d0/
c
DATA at(80),gel(80),nmn(80),(mn(80,i),i=1,7)/'Hg',1,7,196,198,199,
1 200,201,202,204/
DATA (zm(80,i),i=0,7)/200.59d0, 195.965833d0, 197.9667690d0,
1 198.9682799d0, 199.9683260d0, 200.9703023d0, 201.9706430d0,
2 203.9734939d0/
DATA (ns2(80,i),i=1,7)/0,0,1,0,3,0,0/
DATA (ab(80,i),i=1,7)/0.15d0, 9.97d0, 16.87d0, 23.10d0, 13.18d0,
1 29.86d0, 6.87d0/
c
DATA at(81),gel(81),nmn(81),(mn(81,i),i=1,2)/'Tl',2,2,203,205/
DATA (zm(81,i),i=0,2)/204.3833d0, 202.9723442d0, 204.9744275d0/
DATA (ns2(81,i),i=1,2)/1,1/
DATA (ab(81,i),i=1,2)/29.524d0, 70.476d0/
c
DATA at(82),gel(82),nmn(82),(mn(82,i),i=1,4)/'Pb',1,4,204,206,207,
1 208/
DATA (zm(82,i),i=0,4)/207.2d0, 203.9730436d0, 205.9744653d0,
1 206.9758969d0, 207.9766521d0/
DATA (ns2(82,i),i=1,4)/0,0,1,0/
DATA (ab(82,i),i=1,4)/1.4d0, 24.1d0, 22.1d0, 52.4d0/
c
DATA at(83),gel(83),nmn(83),(mn(83,i),i=1,1)/'Bi',4,1,209/
DATA (zm(83,i),i=0,1)/208.98037d0, 208.9803987d0/
DATA (ns2(83,i),i=1,1)/9/
DATA (ab(83,i),i=1,1)/100.d0/
c
DATA at(84),gel(84),nmn(84),(mn(84,i),i=1,1)/'Po',5,1,209/
DATA (zm(84,i),i=0,1)/208.982404d0, 208.9824304d0/
DATA (ns2(84,i),i=1,1)/1/
DATA (ab(84,i),i=1,1)/100.d0/
c
DATA at(85),gel(85),nmn(85),(mn(85,i),i=1,1)/'At',-1,1,210/
DATA (zm(85,i),i=0,1)/209.987126d0, 209.987148d0/
DATA (ns2(85,i),i=1,1)/10/
DATA (ab(85,i),i=1,1)/100.d0/
c
DATA at(86),gel(86),nmn(86),(mn(86,i),i=1,1)/'Rn',1,1,222/
DATA (zm(86,i),i=0,1)/222.017571d0, 222.0175777d0/
DATA (ns2(86,i),i=1,1)/0/
DATA (ab(86,i),i=1,1)/100.d0/
c
DATA at(87),gel(87),nmn(87),(mn(87,i),i=1,1)/'Fr',-1,1,223/
DATA (zm(87,i),i=0,1)/223.019733d0, 223.0197359d0/
DATA (ns2(87,i),i=1,1)/3/
DATA (ab(87,i),i=1,1)/100.d0/
c
DATA at(88),gel(88),nmn(88),(mn(88,i),i=1,1)/'Ra',1,1,226/
DATA (zm(88,i),i=0,1)/226.025403d0, 226.0254098d0/
DATA (ns2(88,i),i=1,1)/0/
DATA (ab(88,i),i=1,1)/100.d0/
c
DATA at(89),gel(89),nmn(89),(mn(89,i),i=1,1)/'Ac',4,1,227/
DATA (zm(89,i),i=0,1)/227.027750d0, 227.0277521d0/
DATA (ns2(89,i),i=1,1)/3/
DATA (ab(89,i),i=1,1)/100.d0/
c
DATA at(90),gel(90),nmn(90),(mn(90,i),i=1,1)/'Th',-1,1,232/
DATA (zm(90,i),i=0,1)/232.038d0, 232.0380553d0/
DATA (ns2(90,i),i=1,1)/0/
DATA (ab(90,i),i=1,1)/100.d0/
c
DATA at(91),gel(91),nmn(91),(mn(91,i),i=1,1)/'Pa',-1,1,231/
DATA (zm(91,i),i=0,1)/231.03588d0, 231.0358840d0/
DATA (ns2(91,i),i=1,1)/3/
DATA (ab(91,i),i=1,1)/100.d0/
c
DATA at(92),gel(92),nmn(92),(mn(92,i),i=1,4)/' U',-1,4,233,234,
1 235,238/
DATA (zm(92,i),i=0,4)/238.0289d0, 233.0396352d0, 234.0409521d0,
1 235.0439299d0, 238.0507882d0/
DATA (ns2(92,i),i=1,4)/5,0,7,0/
DATA (ab(92,i),i=1,4)/0.d0, 0.0055d0, 0.7200d0, 99.2745d0/
c
DATA at(93),gel(93),nmn(93),(mn(93,i),i=1,1)/'Np',-1,1,237/
DATA (zm(93,i),i=0,1)/237.0481678d0, 237.0481734d0/
DATA (ns2(93,i),i=1,1)/5/
DATA (ab(93,i),i=1,1)/100.d0/
c
DATA at(94),gel(94),nmn(94),(mn(94,i),i=1,1)/'Pu',-1,1,244/
DATA (zm(94,i),i=0,1)/244.064199d0, 244.064204d0/
DATA (ns2(94,i),i=1,1)/0/
DATA (ab(94,i),i=1,1)/100.d0/
c
DATA at(95),gel(95),nmn(95),(mn(95,i),i=1,1)/'Am',-1,1,243/
DATA (zm(95,i),i=0,1)/243.061375d0, 243.0613811d0/
DATA (ns2(95,i),i=1,1)/5/
DATA (ab(95,i),i=1,1)/100.d0/
c
DATA at(96),gel(96),nmn(96),(mn(96,i),i=1,1)/'Cm',-1,1,247/
DATA (zm(96,i),i=0,1)/247.070347d0, 247.070354d0/
DATA (ns2(96,i),i=1,1)/9/
DATA (ab(96,i),i=1,1)/100.d0/
c
DATA at(97),gel(97),nmn(97),(mn(97,i),i=1,1)/'Bk',-1,1,247/
DATA (zm(97,i),i=0,1)/247.070300d0, 247.070307d0/
DATA (ns2(97,i),i=1,1)/3/
DATA (ab(97,i),i=1,1)/100.d0/
c
DATA at(98),gel(98),nmn(98),(mn(98,i),i=1,1)/'Cf',-1,1,251/
DATA (zm(98,i),i=0,1)/251.079580d0, 251.079587d0/
DATA (ns2(98,i),i=1,1)/1/
DATA (ab(98,i),i=1,1)/100.d0/
c
DATA at(99),gel(99),nmn(99),(mn(99,i),i=1,1)/'Es',-1,1,252/
DATA (zm(99,i),i=0,1)/252.082944d0, 252.082980d0/
DATA (ns2(99,i),i=1,1)/10/
DATA (ab(99,i),i=1,1)/100.d0/
c
DATA at(100),gel(100),nmn(100),(mn(100,i),i=1,1)/'Fm',-1,1,257/
DATA (zm(100,i),i=0,1)/257.095099d0, 257.095105d0/
DATA (ns2(100,i),i=1,1)/9/
DATA (ab(100,i),i=1,1)/100.d0/
c
DATA at(101),gel(101),nmn(101),(mn(101,i),i=1,1)/'Md',-1,1,258/
DATA (zm(101,i),i=0,1)/258.09857d0, 258.098431d0/
DATA (ns2(101,i),i=1,1)/16/
DATA (ab(101,i),i=1,1)/100.d0/
c
DATA at(102),gel(102),nmn(102),(mn(102,i),i=1,1)/'No',-1,1,259/
DATA (zm(102,i),i=0,1)/259.100931d0, 259.101030d0/
DATA (ns2(102,i),i=1,1)/9/
DATA (ab(102,i),i=1,1)/100.d0/
c
DATA at(103),gel(103),nmn(103),(mn(103,i),i=1,1)/'Lr',-1,1,260/
DATA (zm(103,i),i=0,1)/260.105320d0, 260.105500d0/
DATA (ns2(103,i),i=1,1)/-1/
DATA (ab(103,i),i=1,1)/100.d0/
c
DATA at(104),gel(104),nmn(104),(mn(104,i),i=1,1)/'Rf',-1,1,261/
DATA (zm(104,i),i=0,1)/261.10869d0, 261.108770d0/
DATA (ns2(104,i),i=1,1)/-1/
DATA (ab(104,i),i=1,1)/100.d0/
c
DATA at(105),gel(105),nmn(105),(mn(105,i),i=1,1)/'Db',-1,1,262/
DATA (zm(105,i),i=0,1)/262.11376d0, 262.114080d0/
DATA (ns2(105,i),i=1,1)/-1/
DATA (ab(105,i),i=1,1)/100.d0/
c
DATA at(106),gel(106),nmn(106),(mn(106,i),i=1,1)/'Sg',-1,1,263/
DATA (zm(106,i),i=0,1)/263.11822d0, 263.118320d0/
DATA (ns2(106,i),i=1,1)/-1/
DATA (ab(106,i),i=1,1)/100.d0/
c
DATA at(107),gel(107),nmn(107),(mn(107,i),i=1,1)/'Bh',-1,1,262/
DATA (zm(107,i),i=0,1)/262.12293d0, 262.122890d0/
DATA (ns2(107,i),i=1,1)/-1/
DATA (ab(107,i),i=1,1)/100.d0/
c
DATA at(108),gel(108),nmn(108),(mn(108,i),i=1,1)/'Hs',-1,1,265/
DATA (zm(108,i),i=0,1)/265.13016d0, 265.130090d0/
DATA (ns2(108,i),i=1,1)/-1/
DATA (ab(108,i),i=1,1)/100.d0/
c
DATA at(109),gel(109),nmn(109),(mn(109,i),i=1,1)/'Mt',-1,1,266/
DATA (zm(109,i),i=0,1)/266.13764d0, 266.137300d0/
DATA (ns2(109,i),i=1,1)/-1/
DATA (ab(109,i),i=1,1)/100.d0/
c
IF((IAN.LE.0).OR.(IAN.GT.109)) THEN
MASS= 0.d0
NAME= 'XX'
IMN= 0
WRITE(6,601) IAN
RETURN
ELSE
NAME= AT(IAN)
ENDIF
IF((IAN.EQ.1).AND.(IMN.NE.1)) THEN
c** Special case: insert common name for deuterium or tritium
IF(IMN.EQ.2) NAME=' D'
IF(IMN.EQ.3) NAME=' T'
ENDIF
GELGS= GEL(IAN)
MASS= -1.d0
GNS= -1
ABUND = -1.d0
DO I= 1,NMN(IAN)
if(i.gt.10) write(6,606) ian,imn,nmn(ian)
606 format(3i9)
IF(IMN.EQ.MN(IAN,I)) THEN
MASS= ZM(IAN,I)
GNS= NS2(IAN,I)+1
ABUND = AB(IAN,I)
ENDIF
ENDDO
IF(MASS.LT.0.d0) THEN
MASS= ZM(IAN,0)
IF(IMN.NE.0) WRITE(6,602) AT(IAN),IMN
IMN= 0
ENDIF
RETURN
601 FORMAT(' *** MASSES Data base does not include Atomic Number=',i4)
602 FORMAT(' *** MASSES Data base does not include ',A2,'(',i3,
1 '), so use average atomic mass.')
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE PREPOT(LNPT,IAN1,IAN2,IMN1,IMN2,NPP,OMEGA,RR,RM2,VLIM,
1 VV,NCN)
c** Driver subroutine of package to read parameters and/or generate
c values of a potential V(I) at the NPP input distances RR(I).
c=================== Version of 9 February 2004 =======================
c**** Subroutine Input:
c----------------------
c LNPT is an integer specifying the operational mode:
c * LNPT > 0 : for a new case for which all potential-defining
c parameters are read in & a description printed
c * LNPT.le.0 : if potential points are to be generated in exactly
c the same manner as on preceding call, but at
c different distances RR(I) (no reads or writes)
c IAN1 & IAN2 are the atomic numbers and IMN1 & IMN2 the mass numbers
c of atoms #1 & 2, used (if needed) to specify isotope masses for
c calculating adiabatic and/or non-adiabatic B-O-B correction fx.
c NPP (integer) is the number of input distances RR(i) (in Angstroms)
c at which potential values VV(i) (in cm-1) are to be generated
c RR (real array) is set of NPP distances where potential calculated
c RM2 (real array) on input is the (centrifugal) array of 1/RR(i)**2
c----------------------
c**** Subroutine Output:
c----------------------
c OMEGA the (integer) elelectronic angular momentum projection q.no.
c VLIM (cm-1) is the absolute energy at the potential asymptote
c VV (real array) is the set of function values generated (in cm-1)
c RM2 values returned may (if appropriate) be modified to include B-O-B
c corrections to the (centrifugal) potential 1/RR(i)**2
c NCN is an integer power defining the asymptotically-dominant
c inverse-power long-range potential tail: CNN/R**NCN
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+ Calls GENINT (which calls PLYINTRP, SPLINT & SPLINE) , or POTGEN ++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Set maximum array dimension for the input function values to be
c interpolated over & extrapolated beyong
INTEGER NTPMX
PARAMETER (NTPMX= 1600)
INTEGER I,J,IAN1,IAN2,IMN1,IMN2,INPTS,ILR,IR2,JWR,LNPT,LPPOT,LWR,
1 NCN,NLIN,NPP,NROW,NTP,NUSE,NPRS,NPRF, OMEGA
REAL*8 RFACT,EFACT,RH,RMIN,VLIM,VSHIFT,VV(NPP),RR(NPP),RM2(NPP),
1 XI(NTPMX),YI(NTPMX),RWR(20),VWR(20),VWRB(3),D1V(3),D1VB(3),
2 D2V(3),CNN
c
c** Save variables needed for 'subsequent' LNPT.le.0 calls
SAVE ILR,IR2,LPPOT,NTP,NUSE
SAVE CNN,VSHIFT,XI,YI
c
DATA VWRB/3*0.D0/,D1VB/3*0.D0/
LPPOT= 0
NPRS= 1
NPRF= NPP
c
IF(LNPT.GT.0) THEN
c** If NTP > 0 : define potential by interpolation over & extrapolation
c beyond the NTP read-in turning points using subroutine GENINT.
c If NTP.le.0 : generate a (fully analytic) potential in POTGEN.
c** If LPPOT > 0 : at every |LPPOT|-th point, print potential and
c derivatives-by-differences. *** If LPPOT < 0 write potential
c at every |LPPOT|-th point to channel-8 in a compact format **
c OMEGA the (integer) total elextronic angular momentum projection
c quantum number (required for proper rotational intensities)
c** VLIM (cm-1) is the energy associated with the potential asymptote.
c-----------------------------------------------------------------------
READ(5,*) NTP, LPPOT, OMEGA, VLIM
c-----------------------------------------------------------------------
WRITE(6,600) OMEGA,VLIM
IF(NTP.GT.0) THEN
c** For a pointwise potential (NTP > 0), now read points & parameters
c controlling how the interpolation/extrapolation is to be done.
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** NTP (read above) is number of turning points (XI,YI) to be read in.
c** If NUSE > 0 interpolate with NUSE-point piecewise polynomials
c (usually choose NUSE even, say, = 6, 8 or 10). *** If(NUSE.LE.0)
c interpolate with cubic spline instead of local polynomials.
c** If IR2 > 0 , interpolate over YI*XI**2 ; otherwise on YI itself
c This may help if interpolation has trouble on steep repulsive wall.
c** ILR specifies how to extrapolate beyond largest input distance XI(i)
c If ILR < 0 , fit last 3 points to: VLIM - A*exp(-b*(R-R0)**2)
c If ILR = 0 , fit last 3 points to: VLIM - A*R**p *exp(-b*R)
c If ILR = 1 : fit last two points to: VLIM - A/R**B .
c** If(ILR > 1) fit last turning points to: VLIM - sum{of ILR
c inverse-power terms beginning with 1/R**NCN}. *** If CNN.ne.0 ,
c leading coefficient fixed at CNN ; otherwise get it from points too.
c* Assume read-in CNN value has units: [(cm-1)(Angstroms)**'NCN'].
c* If ILR = 2 or 3 , successive higher power terms differ by 1/R**2
c* If ILR > 3 : successive higher power terms differ by factor 1/R
c-----------------------------------------------------------------------
READ(5,*) NUSE, IR2, ILR, NCN, CNN
c-----------------------------------------------------------------------
IF(NTP.GT.NTPMX) THEN
WRITE(6,602) NTP,NTPMX
STOP
ENDIF
IF(NUSE.GT.0) WRITE(6,604) NUSE,NTP
IF(NUSE.LE.0) WRITE(6,606) NTP
IF(IR2.GT.0) WRITE(6,608)
IF((ILR.GT.1).AND.(DABS(CNN).GT.0.D0))WRITE(6,610)CNN,NCN
c** Read in turning points to be interpolated over
c** RFACT & EFACT are factors required to convert units of input turning
c points (XI,YI) to Angstroms & cm-1, respectively (may = 1.d0)
c** Turning points (XI,YI) must be ordered with increasing XI(I)
c** Energy VSHIFT (cm-1) is added to the input potential points to
c make their absolute energy consistent with VLIM (often VSHIFT=Te).
c-----------------------------------------------------------------------
READ(5,*) RFACT, EFACT, VSHIFT
READ(5,*) (XI(I), YI(I), I= 1,NTP)
c-----------------------------------------------------------------------
WRITE(6,612) VSHIFT, RFACT, EFACT
NROW= (NTP+2)/3
DO J= 1,NROW
IF(EFACT.LE.10.D0) THEN
WRITE(6,614) (XI(I),YI(I),I= J,NTP,NROW)
ELSE
WRITE(6,616) (XI(I),YI(I),I= J,NTP,NROW)
ENDIF
ENDDO
WRITE(6,624)
DO I= 1,NTP
YI(I)= YI(I)*EFACT+ VSHIFT
XI(I)= XI(I)*RFACT
ENDDO
IF(IR2.GT.0) THEN
DO I= 1,NTP
YI(I)= YI(I)*XI(I)**2
ENDDO
ENDIF
ENDIF
ENDIF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
IF(NTP.GT.0) THEN
CALL GENINT(LNPT,NPP,RR,VV,NUSE,IR2,NTP,XI,YI,VLIM,ILR,
1 NCN,CNN,NPRS,NPRF)
ELSE
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Generate a fully analytic potential in subroutine POTGEN ***********
c* Potentials generated in cm-1 with potential asymptote at energy VLIM
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** IPOTL specifies the type of potential function to be generated.
c** MPAR & NPAR are integers for specifying potential types.
c** NVARB is number of (real*8) potential parameters read in.
c** IBOB specifies whether (if > 0) or not (if .le. 0) atomic mass
c dependent Born-Oppenheimer breakdown corrections will be included
c** For all functions considered, well depth and equilibrium distance
c are read as DSCM (cm-1) and REQ (Angstroms), respectively.
c* [Most read-in parameters are dimensionless (scaled by DSCM & REQ).]
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c** If IPOTL=1 generate an L.J.(MPAR,NPAR) potential.
c** If IPOTL=2 generate an MLJ(NPAR) potential [JCP 112, 3949 (2000)]
c If MPAR > 0 exponent parameter is polynomial of order (NVARB-1)
c in y_{MPAR}= (R**MPAR - Re**MPAR)/(R**MPAR + Re**MPAR),
c with the NVARB coefficients PARM(j)
c If MPAR.le.0 exponent polynomial in y_{1} of order (NVARB-4) with
c coefficients PARM(i) (i= 1,NVARB-3), & includes a switching
c function with exponent coefficient ALPHA= PARM(NVARB) and
c RSW= PARM(NVARB-1), defined to yield limiting inverse-power
c potential coefficient Cn= PARM(NVARB-2).
c** If IPOTL=3 generate a Morse or Extended Morse Oscillator potential
c with exponent factor "beta" defined as a power series of order
c (NVARB-1) in y_{MPAR}= (R**MPAR - Re**MPAR)/(R**MPAR + Re**MPAR)
c with NVARB coefficients PARM(i). [!! MPAR .ge.1 !!]
c * For conventional "simple" Morse potential, NVARB=1 & MPAR dummy
c* Special option #1: set MPAR= -1 to produce Wei Hua's 4-parameter
c modified Morse function with b= PARM(1) and C= PARM(2).
c* Special option #2: set MPAR= -2 to produce Coxon's "Generalized
c Morse Oscillator" potential with exponent expansion in (R-Re)]
c ... otherwise, set MPAR.ge.0
c** If IPOTL=4 use Seto's modification of Surkus' GPEF expansion in
c z = [R^NPAR - Re^NPAR]/[a*R^NPAR + b*Re^NPAR] where
c a=PARM(NVARB-1) & b=PARM(NVARB), which incorporates Dunham, SPF,
c O-T and other forms: V(z) = c_0 z^2 [1 + c_1 z + c_2 z^2 + ...]
c where c_0 [cm-1] is read in as DSCM, and the first (NVARB-2)
c PARM(i)'s are the c_i (i > 0). [MPAR is dummy parameter here]
c * For Dunham case: NPAR=1, PARM(NVARB-1)= 0.0, PARM(NVARB)= 1.0
c * For SPF case: NPAR=1, PARM(NVARB-1)= 1.0, PARM(NVARB)= 0.0
c * For Ogilvie-Tipping: NPAR=1, PARM(NVARB-1)= 0.5 = PARM(NVARB)
c * NOTE that for Surkus NPAR < 0 case: z(NPAR,a,b)= z(|NPAR|,-b,-a)
c Generate & return the D_e value implied by these coefficients.
c * NPAR= 0 generates potential as power series of order-NVARB in R
c with constant term = (read-in VLIM) & NVARB read-in coefficients
c** If IPOTL=5 generate generalized HFD(NPAR,6,8,10,12,14) potential.
c PARM(1-3) are the parameters defining the HFD damping function
c D(x)=exp[-pparm(1)*(PARM(2)/x - 1)**PARM(3)] {for x < PARM(2)}
c PARM(4) the quadratic coefficient in the exponent, and
c PARM(5) is the power of x=R/Req multiplying the repulsive term
c AREP*x**PARM(5) *exp[-beta*x - PARM(4)*x**2] ;
c PARM(6-11) are the reduced C_NPAR, C_6, C_8, C_10, C_12 and C14
c parameters (NPAR < 6), while AREP and beta are defined
c by having the potential minimum at x=1. For NVARB < 11, higher
c C_m coefficients automatically zero; necessarily NVARB.ge.7 .
c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c** IBOB > 0, add atomic-mass-dependent Born-Openheimer breakdown
c correction functions to rotationless and/or centrifugal potential(s).
c Both expressed as power series in z= (R-Re)/(R+Re) starting with the
c constant term, using the mass shift convention of Le Roy [J.Mol.Spec.
c 194, 189 (1999)]. Adiabatic B-O-B potential correction fx. defined
c by polynomials of order NC1 with (NC1+1) coefficients {CA1(i)} for
c atom-1 and order NC2 with (NC2+1) coefficients {CA2(i)} for atom-2,
c while centrifugal correction fx. defined polynomial of order NG1 with
c (NG1+1) coefficients {GA1(i)} for atom-1 and order NG2 with (NG2+1)
c coefficients {GA2(i)} for atom-2.
c** Input parameters IANi & IMNi are the atomic & mass number of atom-i
c (i=1,2), while integers RMN1 & RMN2 read here are the mass numbers of
c the reference isotopes defining the B-O-B correction functions.
c** NC1 & NC2 are orders of polynomials DELTA(V,atom-i) defining
c 'adiabatic' corrections to the rotationless potential for atoms 1 & 2
c DELTA(V)= (1-M1ref/M1)*DELTA(V,atom-1) + (1-M2ref/M2)*DELTA(V,atom-2)
c** NG1 & NG2 are orders of polynomials q1(z) & q2(z) defining B-O-B
c correction to the centrifugal potential:
c V(centrifugal)= [1 + (M1ref/M1)*q1(z) + (M2ref/M2)*q2(z)]/R**2
c ... to omit a particular correction set associated NCi or NGi .lt.0
c** RX > 0.0 invokes Coxon's (older) expansions in (R-Re) for potential
c correction and in [(R-Rx)**j - (Re-Rx)**j] for centrifugal corrn.
c ... OTHERWISE (to use Le Roy B-O-B formalism) set RX.le.0.d0 !!
c-----------------------------------------------------------------------
c** Read inside subroutine POTGEN
c IF(LNPT.GT.0) THEN
c READ(5,*) IPOTL, MPAR, NPAR, NVARB, IBOB, DSCM, REQ
c IF(NVARB.GT.0) READ(5,*) (PARM(I), I=1,NVARB)
c IF(IBOB.GT.0) THEN
c READ(5,*) RMN1, RMN2, NC1, NC2, NG1, NG2, RX
c IF(NC1.GE.0) READ(5,*) (CA1(I), I=0,NC1)
c IF(NC2.GE.0) READ(5,*) (CA2(I), I=0,NC2)
c IF(NG1.GE.0) READ(5,*) (GA1(I), I=0,NG1)
c IF(NG2.GE.0) READ(5,*) (GA2(I), I=0,NG2)
c ENDIF
c ENDIF
c-----------------------------------------------------------------------
NCN= 99
CALL POTGEN(LNPT,NPP,IAN1,IAN2,IMN1,IMN2,VLIM,RR,RM2,VV,
1 NCN,CNN)
ENDIF
IF(LPPOT.NE.0) THEN
c** If desired, on the first pass (i.e. if LNPT > 0) print the potential
RH= RR(2)-RR(1)
INPTS= IABS(LPPOT)
IF(LPPOT.LT.0) THEN
c** Option to write resulting function compactly to channel-8.
RMIN= RR(1)
NLIN= NPP/INPTS+ 1
WRITE(8,800) NLIN,VLIM
WRITE(8,802) (RR(I),VV(I),I= 1,NPP,INPTS)
ELSE
c** Option to print potential & its 1-st three derivatives, the latter
c calculated by differences, assuming equally spaced RR(I) values.
WRITE(6,620)
NPRS= MAX(1,(NPRS- 15*INPTS))
NPRF= MIN(NPP,(NPRF+ 15*INPTS))
NLIN= (NPRF-NPRS+1)/(2*INPTS)+1
RH= INPTS*RH
DO I= 1,NLIN
LWR= NPRS+INPTS*(I-1)
DO J= 1,2
JWR= LWR+(J-1)*NLIN*INPTS
IF(JWR.LE.NPP) THEN
RWR(J)= RR(JWR)
VWR(J)= VV(JWR)
D1V(J)= (VWR(J)-VWRB(J))/RH
VWRB(J)= VWR(J)
D2V(J)= (D1V(J)-D1VB(J))/RH
D1VB(J)= D1V(J)
ELSE
RWR(J)= 0.d0
VWR(J)= 0.d0
ENDIF
IF(I.LE.2) THEN
D2V(J)= 0.d0
IF(I.EQ.1) D1V(J)= 0.d0
ENDIF
ENDDO
WRITE(6,622) (RWR(J),VWR(J),D1V(J),D2V(J),J= 1,2)
ENDDO
ENDIF
ENDIF
IF(LNPT.GT.0) WRITE(6,624)
RETURN
600 FORMAT(' State has OMEGA=',i2, ' and energy asymptote: Y(lim)
1=',F12.4,'(cm-1)')
602 FORMAT(/' **** ERROR in dimensioning of arrays required'
1 ,' by GENINT; No. input points ',I5,' > NTPMX =',I4)
604 FORMAT('- Perform',I3,'-point piecewise polynomial interpolation o
1ver',I5,' input points' )
606 FORMAT('- Perform cubic spline interpolation over the',I5,
1 ' input points' )
608 FORMAT('- Interpolation actually performed over modified input arr
1ay: Y(I) * R(I)**2')
610 FORMAT('- Beyond read-in points extrapolate to limiting asymptotic
1 behaviour:'/20x,'Y(R) = Y(lim) - (',D16.7,')/R**',I2)
612 FORMAT('- To make input points Y(i) consistent with Y(lim), add'
1 ,' Y(shift)=',F12.4/'- Scale input points: (distance)*',
2 1PD16.9,' & (energy)*',D16.9/13x,'to get required internal unit
3s [Angstroms & cm-1 for potentials]'/
4 3(' R(i) Y(i) ')/3(3X,11('--')))
614 FORMAT((3(F13.8,F12.4)))
616 FORMAT((3(F12.6,F13.8)))
620 FORMAT(/' Function and first 2 derivatives by differences'/
1 2(' R Y(R) d1Y/dR1 d2Y/dR2')/2(2X,19('--')))
622 FORMAT(2(0PF8.3,F11.3,1PD11.3,D10.2))
624 FORMAT(1x,38('--'))
800 FORMAT(I7,' function values with asymptotic value:',F14.6)
802 FORMAT((1X,3(F12.8,F14.6)))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE GENINT(LNPT,NPP,XX,YY,NUSE,IR2,NTP,XI,YI,VLIM,ILR,
1 NCN,CNN,NPRS,NPRF)
c** GENINT produces a smooth function YY(i) at the NPP input distances
c XX(i) by performing numerical interpolation over the range of the
c NTP input function values YI(j) at the distances XI(j), and using
c analytic functions to extrapolate beyond their range to with an
c exponential at short range and a form specified by ILR, NCN & CNN
c** ILR specifies how to extrapolate beyond largest given turning pts
c If ILR < 0 , fit last 3 points to: VLIM - A*exp(-b*(R-R0)**2)
c If ILR = 0 , fit last 3 points to: VLIM - A*R**p *exp(-b*R)
c If ILR = 1 : fit last two points to: VLIM - A/R**B .
c* If(ILR.ge.2) fit last turning points to: VLIM - sum(of ILR
c inverse-power terms beginning with 1/R**NCN). *** If CNN.ne.0 ,
c leading coefficient fixed at CNN ; otherwise get it from points too.
c* Assume read-in CNN value has units: ((cm-1)(Angstroms)**'NCN').
c If ILR = 2 or 3 , successive higher power terms differ by 1/R**2
c If ILR > 3 : this factor is 1/R .
c=== Calls subroutines PLYINTRP, SPLINT & SPLINE ==================
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
INTEGER I,J,IFXCN,IDER,IR2,ILR,ISR,LNPT,MBEG,MFIN,MINNER,
1 NN,NPP,NUSE,NUST,NORD,NCN,NCN2,NCN4,NPRS,NPRF,NTP,
2 IMX1,NMX,JR2,JMAX,MI(10),MF(10)
REAL*8 ASR,BSR,CSR,ALR,BLR,CLR,DCSR,ADCSR,PDCSR,VRAT,
1 DX1,DX2,DX3,EX1,EX2,EX3,CNN,VLIM,X1,X2,X3,Y1,Y2,Y3,
1 XX(NPP),YY(NPP),XI(NTP),YI(NTP),XJ(20),YJ(20),DUMM(20)
c
SAVE ASR,BSR,CSR,ISR,ALR,BLR,CLR,IMX1,NMX,JR2,JMAX
c
NUST= NUSE/2
IF(NUSE.LE.0) NUST= 2
IDER= 0
NPRS= 1
NPRF= NPP
c** Determine if/where need to begin extrapolation beyond input data
c XX(MI(J)) is the 1-st mesh point past turning point XI(J) .
c XX(MF(J)) is the last mesh point before turning point XI(NTP+1-J)
DO 6 J = 1,NUST
MI(J)= 1
MF(J)= 0
DO I= 1,NPP
IF(XX(I).LE.XI(J)) MI(J)= I+ 1
IF(XX(I).GE.XI(NTP+1-J)) GO TO 6
MF(J)= I
ENDDO
6 CONTINUE
IF(NUST.LT.2) THEN
MFIN= MI(1)-1
ELSE
MFIN= MI(2)-1
ENDIF
IF(LNPT.GT.0) THEN
c-----------------------------------------------------------------------
c** For a new case determine analytic functions for extrapolating beyond
c the range of the input points (if necessary) on this or later calls.
c** Try to fit three innermost turning points to V(R)=A+B*DEXP(-C*R).
c** If unsatisfactory, extrapolate inward with inverse power function
IF(IR2.LE.0) THEN
DO I= 1,4
YJ(I)= YI(I)
ENDDO
ELSE
DO I= 1,4
YJ(I)= YI(I)/XI(I)**2
ENDDO
ENDIF
X1= XI(1)
X2= XI(2)
X3= XI(3)
Y1= YJ(1)
Y2= YJ(2)
Y3= YJ(3)
IF((Y1-Y2)*(Y2-Y3).LE.0.d0) THEN
c** If 3 innermost points not monotonic, use A+B/X inward extrapoln.
ISR= 0
WRITE(6,600)
ELSE
c** Use cubic through innermost points to get initial trial exponent
c from ratio of derivatives, Y''/Y'
IDER= 2
ISR= 4
CALL PLYINTRP(XI,YJ,ISR,X2,XJ,ISR,IDER)
CSR= XJ(3)/XJ(2)
DCSR= DABS(CSR*X2)
IF(DCSR.GT.1.5D+2) THEN
c** If exponential causes overflows, use inverse power inward extrapoln.
ISR= 0
WRITE(6,602) CSR
GO TO 20
ENDIF
c** Prepare parameters for inward exponential extrapolation
VRAT= (Y3- Y2)/(Y1- Y2)
DX1= X1- X2
DX3= X3- X2
EX2= 1.D0
ADCSR= 1.d99
c** Now iterate (with actual point) to get exact exponent coefficient
DO J= 1,15
PDCSR= ADCSR
EX1= DEXP( CSR*DX1)
EX3= DEXP( CSR*DX3)
DCSR= (VRAT- (EX3- EX2)/(EX1- EX2)) /
1 ((X3*EX3- X2 - (X1*EX1- X2)*(EX3-EX2)/(EX1- EX2))/(EX1- EX2))
ADCSR= ABS(DCSR)
IF((ADCSR.GT.PDCSR).AND.(ADCSR.LT.1.d-8)) GO TO 12
IF(ADCSR.LT.1.d-12) GO TO 12
CSR= CSR+ DCSR
ENDDO
WRITE(6,604) DCSR
12 BSR= (Y1-Y2)/(EX1-EX2)
ASR= Y2-BSR*EX2
BSR= BSR*DEXP(-CSR*X2)
WRITE(6,606) X2,ASR,BSR,CSR
ENDIF
20 IF(ISR.LE.0) THEN
IF((X1*X2).LE.0.d0) THEN
c** If 1'st two mesh points of opposite sign, extrapolate linearly
ISR= -1
ASR= Y2
BSR= (Y2- Y1)/(X2- X1)
CSR= X2
WRITE(6,608) X2,ASR,BSR,CSR
ELSE
c** For inward extrapolation as inverse power through 1'st two points ..
BSR= (Y1-Y2)* X1*X2/(X2- X1)
ASR= Y1-BSR/X1
CSR= X2
WRITE(6,610) X2,ASR,BSR
ENDIF
ENDIF
ENDIF
600 FORMAT(' ** CAUTION ** Exponential inward extrapolation fails'/
1 16x,'since first 3 points not monotonic, ... so ...')
602 FORMAT(' *** CAUTION ** inward extrapolation exponent coefficient
1 C=',D12.4/10x,'could cause overflows, ... so ...')
604 FORMAT(' *** CAUTION ** after 15 tries inward extrap. exponent coe
1fft change is',1PD9.1)
606 FORMAT(' Extrapolate to X .le.',F7.4,' with'/' Y=',F13.3,
1 SP,1PD15.6,' * exp(',SS,D13.6,'*X)')
608 FORMAT(' Extrapolate to X .le.',F8.4,' with'/' Y=',F13.3,
1 SP,1PD16.7,' * [X - (',SS,F8.4,')]')
610 FORMAT(' Extrapolate to X .le.',F8.4,' with Y=',F12.3,
1 SP,1PD15.6,')/X**1')
c
IF(MFIN.GT.0) THEN
c** If needed, calculate function in inner extrapolation region
IF(ISR.GT.0) THEN
c ... either as an exponential
DO I= 1,MFIN
EX1= CSR*XX(I)
IF(DABS(EX1).GT.1.D+2) EX1= 1.D+2*DSIGN(1.d0,EX1)
YY(I)= ASR+BSR*DEXP(EX1)
ENDDO
ELSEIF(ISR.EQ.0) THEN
c ... or if that fails, as an inverse power
DO I= 1,MFIN
YY(I)= ASR+BSR/XX(I)
ENDDO
ELSEIF(ISR.LT.0) THEN
c ... or if X changes sign, extrapolate inward linearly
DO I= 1,MFIN
YY(I)= ASR+ BSR*(XX(I)- CSR)
ENDDO
ENDIF
ENDIF
c** End of inward extrapolation procedure
c-----------------------------------------------------------------------
MINNER= MFIN
IF(NUST.GT.2) THEN
c** If(NUSE.gt.5) minimize spurious behaviour by interpolating with
c order less than NUSE on intervals near inner end of range
DO J= 3,NUST
NORD= 2*(J-1)
MBEG= MI(J-1)
MFIN= MI(J)-1
IF(MFIN.GE.MBEG) THEN
DO I= MBEG,MFIN
CALL PLYINTRP(XI,YI,NTP,XX(I),DUMM,NORD,IDER)
YY(I)= DUMM(1)
ENDDO
ENDIF
ENDDO
ENDIF
c** Main interpolation step begins here
c=======================================================================
MBEG= MI(NUST)
MFIN= MF(NUST)
IF(MFIN.GE.MBEG) THEN
IF(NUSE.LE.0) THEN
c** Either ... use cubic spline for main interpolation step
CALL SPLINT(LNPT,NTP,XI,YI,MBEG,MFIN,XX,YY)
ELSE
c ... or use piecewise polynomials for main interpolation step
DO I= MBEG,MFIN
CALL PLYINTRP(XI,YI,NTP,XX(I),DUMM,NUSE,IDER)
YY(I)= DUMM(1)
ENDDO
ENDIF
ENDIF
IF(MFIN.LT.NPP) THEN
IF(NUST.LE.2) THEN
c** If(NUSE.gt.5) minimize spurious behaviour by interpolating with
c order less than NUSE on intervals near outer end of range
MBEG= MF(NUST)+1
ELSE
NN= NUST-2
DO J= 1,NN
NORD= 2*(NUST-J)
MBEG= MF(NUST-J+1)+1
MFIN= MF(NUST-J)
IF(MFIN.GE.MBEG) THEN
DO I= MBEG,MFIN
CALL PLYINTRP(XI,YI,NTP,XX(I),DUMM,NORD,IDER)
YY(I)= DUMM(1)
ENDDO
END IF
ENDDO
ENDIF
ENDIF
MBEG= MFIN+1
IF((MFIN.GT.MINNER).AND.(IR2.GT.0)) THEN
c** In (IR2.gt.0) option, now remove X**2 from the interpolated function
DO I= MINNER+1,MFIN
YY(I)= YY(I)/XX(I)**2
ENDDO
ENDIF
c** Print test of smoothness at join with analytic inward extrapolation
c IF(LNPT.GT.0) THEN
c MST= MAX0(MINNER-4,1)
c NPRS= MST
c MFN= MST+8
c IF(MFN.GT.NPP) MFN= NPP
c IF(MFN.GT.MFIN) MFN= MFIN
c IF(MINNER.GT.0) WRITE(6,611) X2,((XX(I),YY(I),I= J,MFN,3),
c 1 J= MST,MST+2)
c 611 FORMAT(' Verify smoothness of inner join at X=',F9.5/
c 1 (3X,3(F10.5,G15.7)))
c ENDIF
c-----------------------------------------------------------------------
c** To extrapolate potential beyond range of given turning points ...
IF(LNPT.GT.0) THEN
c** On first entry, calculate things needed for extrapolation constants
Y1= YI(NTP)
Y2= YI(NTP-1)
Y3= YI(NTP-2)
X1= XI(NTP)
X2= XI(NTP-1)
X3= XI(NTP-2)
IF(IR2.GT.0) THEN
Y1= Y1/X1**2
Y2= Y2/X2**2
Y3= Y3/X3**2
ENDIF
ENDIF
c** Check inverse-power tail power ...
IF(NCN.LE.0) NCN= 6
IF(ILR.LT.0) THEN
IF(LNPT.GT.0) THEN
C** For ILR.lt.0 use Y = VLIM - ALR * exp[-CLR*(X - BLR)**2]
EX1= DLOG((VLIM-Y1)/(VLIM-Y2))/(X1-X2)
EX2= DLOG((VLIM-Y2)/(VLIM-Y3))/(X2-X3)
BLR= (X1+X2 - (X2+X3)*EX1/EX2)/(2.d0- 2.d0*EX1/EX2)
CLR= -EX1/(X1+X2-2.d0*BLR)
ALR= (VLIM-Y1)*DEXP(CLR*(X1-BLR)**2)
WRITE(6,614) X2,VLIM,ALR,CLR,BLR
IF(CLR.LT.0.d0) THEN
c ... but replace it by an inverse power of exponent constant negative
WRITE(6,612)
ILR= 1
GO TO 50
ENDIF
ENDIF
IF(MBEG.LE.NPP) THEN
DO I= MBEG,NPP
YY(I)= VLIM- ALR*DEXP(-CLR*(XX(I) - BLR)**2)
ENDDO
ENDIF
GO TO 90
ENDIF
IF(ILR.EQ.0) THEN
c** For ILR.le.0 use Y = VLIM - ALR * X**p * exp(-CLR*X)
IF(LNPT.GT.0) THEN
EX1= DLOG((VLIM-Y1)/(VLIM-Y2))/(X1-X2)
EX2= DLOG((VLIM-Y2)/(VLIM-Y3))/(X2-X3)
DX1= DLOG(X1/X2)/(X1-X2)
DX2= DLOG(X2/X3)/(X2-X3)
BLR= (EX1-EX2)/(DX1-DX2)
CLR= BLR*DX1- EX1
ALR= (VLIM-Y1)* DEXP(CLR*X1)/X1**BLR
WRITE(6,616) X2,VLIM,ALR,BLR,CLR
IF(CLR.LT.0.d0) THEN
c ... but replace it by an inverse power of exponent constant negative
WRITE(6,612)
ILR= 1
GO TO 50
ENDIF
ENDIF
IF(MBEG.LE.NPP) THEN
DO I= MBEG,NPP
YY(I)= VLIM- ALR*XX(I)**BLR *DEXP(-CLR*XX(I))
ENDDO
ENDIF
GO TO 90
ENDIF
50 IF(ILR.EQ.1) THEN
c** For ILR=1 , use Y = VLIM + ALR/X**BLR
IF(LNPT.GT.0) THEN
BLR= DLOG((VLIM-Y2)/(VLIM-Y1))/DLOG(X1/X2)
ALR= (Y1- VLIM)*X1**BLR
NCN= BLR
WRITE(6,618) X2,VLIM,ALR,BLR,NCN
ENDIF
IF(MBEG.LE.NPP) THEN
DO I= MBEG,NPP
YY(I)= VLIM+ ALR/XX(I)**BLR
ENDDO
ENDIF
GO TO 90
ENDIF
c** Set constants for long-range extrapolation
IFXCN= 0
IF((CNN.GT.0.d0).OR.(CNN.LT.0.d0)) IFXCN= 1
NCN2= NCN+2
IF(ILR.EQ.2) THEN
c** For ILR=2 , use Y = VLIM - CNN/X**NCN - BSR/X**(NCN+2)
c* If CNN held fixed need ILR > 2 to prevent discontinuity
IF(LNPT.GT.0) THEN
IF(IFXCN.LE.0) THEN
CNN= ((VLIM-Y1)*X1**NCN2 -
1 (VLIM-Y2)*X2**NCN2)/(X1**2-X2**2)
ENDIF
ALR= CNN
BLR= (VLIM-Y1)*X1**NCN2 - CNN*X1**2
WRITE(6,620) X2,VLIM,CNN,NCN,BLR,NCN2
ENDIF
IF(MBEG.LE.NPP) THEN
DO I= MBEG,NPP
YY(I)= VLIM-(ALR+BLR/XX(I)**2)/XX(I)**NCN
ENDDO
ENDIF
GO TO 90
ENDIF
IF(ILR.EQ.3) THEN
c** For ILR=3 , use Y = VLIM - (CN + CN2/X**2 + CN4/X**4)/X**NCN
IF(LNPT.GT.0) THEN
NCN4= NCN+4
IF(IFXCN.GT.0) THEN
ALR= CNN
BLR= (((VLIM-Y1)*X1**NCN-ALR)*X1**4-((VLIM-Y2)
1 *X2**NCN-ALR)*X2**4)/(X1**2-X2**2)
CLR= ((VLIM-Y1)*X1**NCN-ALR-BLR/X1**2)*X1**4
ELSE
EX1= X1**2
EX2= X2**2
EX3= X3**2
DX1= (VLIM-Y1)*X1**NCN4
DX2= (VLIM-Y2)*X2**NCN4
DX3= (VLIM-Y3)*X3**NCN4
BLR= (DX1-DX2)/(EX1-EX2)
ALR= (BLR-(DX2-DX3)/(EX2-EX3))/(EX1-EX3)
BLR= BLR-ALR*(EX1+EX2)
CLR= DX1-(ALR*EX1+BLR)*EX1
ENDIF
WRITE(6,622) X2,VLIM,ALR,NCN,BLR,NCN2,CLR,NCN4
ENDIF
IF(MBEG.LE.NPP) THEN
DO I= MBEG,NPP
EX2= 1.d0/XX(I)**2
YY(I)= VLIM-(ALR+EX2*(BLR+EX2*CLR))/XX(I)**NCN
ENDDO
ENDIF
GO TO 90
ENDIF
IF(ILR.GE.4) THEN
c** For ILR.ge.4, Y = VLIM-SUM(BB(K)/X**K) , (K=NCN,NMX=NCN+ILR-1)
IF(LNPT.GT.0) THEN
IF(NCN.LE.0) NCN= 1
IMX1= ILR-1
NMX= NCN+IMX1
JR2= 0
IF(IR2.GT.0) JR2= 2
IDER= 0
JMAX= ILR
IF(IFXCN.GT.0) JMAX= IMX1
WRITE(6,624) X2,ILR,NCN,VLIM
IF(IFXCN.GT.0) WRITE(6,626) NCN,CNN
ENDIF
c** Actually extrapolate with polynomial fitted to the last JMAX
c values of (VLIM - YI(I))*XI(I)**NMX , & then convert back to YY(I).
IF(MBEG.LE.NPP) THEN
J= NTP- JMAX
DO I= 1,JMAX
J= J+1
XJ(I)= XI(J)
YJ(I)= (VLIM-YI(J)/XI(J)**JR2)*XI(J)**NMX
IF(IFXCN.GT.0) YJ(I)= YJ(I)- CNN*XI(J)**IMX1
ENDDO
DO I= MBEG,NPP
CALL PLYINTRP(XJ,YJ,JMAX,XX(I),DUMM,JMAX,IDER)
YY(I)= DUMM(1)
IF(IFXCN.GT.0) YY(I)= YY(I)+ CNN*XX(I)**IMX1
YY(I)= VLIM-YY(I)/XX(I)**NMX
ENDDO
ENDIF
ENDIF
c** Finished extrapolation section.
90 CONTINUE
c** Test smoothness at outer join to analytic extrapolation function
c IF((LNPT.GT.0).AND.(MBEG.LE.NPP)) THEN
c MST= MBEG-5
c IF(MST.LT.1) MST= 1
c MFN= MST+8
c IF(MFN.GT.NPP) MFN= NPP
c WRITE(6,627) X2,((XX(I),YY(I),I= J,MFN,3),J= MST,MST+2)
c NPRF= MFN
c ENDIF
c 627 FORMAT(' Verify smoothness of outer join at X=',F9.5/
c 1 (3X,3(F10.5,G15.7)))
RETURN
612 FORMAT(' *** BUT *** since exponent has positive coefficient, swi
1tch form ...')
614 FORMAT(' Function for X .GE.',F8.4,' generated as'/' Y=',
1 F12.4,' - (',1PD13.6,') * exp{-',0PF10.6,' * (R -',F9.6,')**2}')
616 FORMAT(' Function for X .GE.',F8.4,' generated as'/' Y=',
1 F12.4,' - (',1PD13.6,') * R**',0PF10.6,' * exp{-(',F11.6,'*R)}')
618 FORMAT(' Extrapolate to X .GE.',F8.4,' using'/' Y=',
1 F12.4,SP,1PD15.6,'/X**(',SS,D13.6,')] , yielding NCN=',I3)
620 FORMAT(' Extrapolate to X .GE.',F8.4,' using'/' Y=',
1 F12.4,' - [',1PD13.6,'/X**',I1,SP,D14.6,'/X**',SS,I1,']')
622 FORMAT(' Extrapolate to X .GE.',F8.4,' using'/
1 ' Y=',F12.4,' - [',1PD13.6,'/X**',I1,SP,D14.6,'/X**',
2 SS,I1,SP,D14.6,'/X**',SS,I2,']')
624 FORMAT(' Function for X .GE.',F7.3,' generated by',I3,
1 '-point inverse-power interpolation'/' with leading term 1/R**
2',I1,' relative to dissociation limit YLIM=',F11.3)
626 FORMAT(' and (dimensionless) leading coefficient fixed as C',
1 I1,'=',G15.8)
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE PLYINTRP(XI,YI,NPT,RR,C,NCFT,IDER)
c* From the NPT known mesh points (XI,YI) ,given in order of increasing
c or decreasing XI(I), select the NCFT points (XJ,YJ) surrounding the
c given point RR, and by fitting an (NCFT-1)-th degree polynomial through
c them, interpolate to find the function CC(1) and its first IDER
c derivatives (CC(I+1),I=1,IDER) evaluated at RR.
c* Adapted by R.J. Le Roy from algorithm #416,Comm.A.C.M.; 27/02/1988
c=======================================================================
INTEGER I,J,K,I1,I2,IFC,IM,IDER,J1,NH,NPT,NCFT
REAL*8 RR,XX,XI(NPT),YI(NPT),C(NCFT),XJ(20),YJ(20)
c
IF((NCFT.GT.20).OR.(NCFT.GT.NPT)) GO TO 101
NH= NCFT/2
c** First locate the known mesh points (XJ,YJ) bracketing RR
I1= 1
I2= NCFT
IF(NCFT.NE.NPT) THEN
IF(XI(NPT).LE.XI(1)) THEN
DO I= 1,NPT
IM= I
IF(XI(I).LT.RR) GO TO 20
ENDDO
ELSE
DO I= 1,NPT
IM= I
IF(XI(I).GT.RR) GO TO 20
ENDDO
ENDIF
20 I1= IM-NH
IF(I1.LE.0) I1= 1
I2= I1+NCFT-1
IF(I2.GT.NPT) THEN
I2= NPT
I1= I2-NCFT+1
ENDIF
ENDIF
J= 0
DO I= I1,I2
J= J+1
XJ(J)= XI(I)-RR
YJ(J)= YI(I)
ENDDO
c** Now determine polynomial coefficients C(I).
DO I= 2,NCFT
I1= I-1
K= I1+1
DO J= 1,I1
K= K-1
YJ(K)= (YJ(K+1)-YJ(K))/(XJ(I)-XJ(K))
ENDDO
ENDDO
C(1)= YJ(1)
DO I= 2,NCFT
XX= XJ(I)
C(I)= C(I-1)
IF(I.NE.2) THEN
I1= I-1
K= I1+1
DO J= 2,I1
K= K-1
C(K)= -XX*C(K)+C(K-1)
ENDDO
ENDIF
C(1)= YJ(I)-XX*C(1)
ENDDO
c** Finally, convert polynomial coefficients to derivatives at RR.
IFC= 1
IF(IDER.GE.NCFT) IDER= NCFT-1
IF(IDER.LE.1) GO TO 99
DO I= 2,IDER
J= I+1
IFC= IFC*I
C(J)= C(J)*IFC
ENDDO
IF(J.LT.NCFT) THEN
J1= J+1
DO I= J1,NCFT
C(I)= 0.D+0
ENDDO
ENDIF
99 RETURN
101 WRITE(6,601) NCFT,NCFT,NPT
STOP
601 FORMAT(/' *** Dimensioning ERROR in PLYINTRP : either (NCFT=',
1 I2,' .GT. 20) or (NCFT=',I2,' .GT. NPT=',I3,')')
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c**********************************************************************
SUBROUTINE SPLINT(LNPT,NTP,R1,V1,MBEG,MEND,XX,YY)
c** Subroutine to generate (if LNPT.ge.0) 4*NTP coefficients CSP(J)
c of a cubic spline passing through the NTP points (R1(J),V1(J))
c and to then calculate values of the resulting function YY(I) at the
c entering abscissae values XX(I) for I=MBEG to MEND.
c** If LNPT < 0 , generate function values at the given XX(I) using
c the coefficients CSP(J) obtained and SAVEd on a preceding call.
c** Assumes both R1(J) & XX(I) are monotonic increasing.
c+++++ Calls only subroutine SPLINE +++++++++++++++++++++++++++++++++++
c======================================================================
INTEGER MAXSP
PARAMETER (MAXSP=6400)
INTEGER I,IER,I1ST,IDER,JK,K,KK,LNPT,N2,N3,NIPT,NTP,MBEG,MEND
REAL*8 EPS,R2,RI,RRR,TTMP,R1(NTP),V1(NTP),CSP(MAXSP),
1 YY(MEND),XX(MEND)
SAVE CSP
c
IF(4*NTP.GT.MAXSP) THEN
WRITE(6,602) MAXSP,NTP
STOP
ENDIF
EPS= 1.D-6*(R1(2)-R1(1))
N2= 2*NTP
N3= 3*NTP
IF(LNPT.GT.0) THEN
c** On first pass for a given data set, generate spline function
c coefficients in subroutine SPLINE
c** Start by using a cubic polynomial at each end of the range to get
c the first derivative at each end for use in defining the spline.
IDER= 1
NIPT= 4
I1ST= NTP-3
CALL PLYINTRP(R1(I1ST),V1(I1ST),NIPT,R1(NTP),CSP,NIPT,IDER)
TTMP= CSP(2)
CALL PLYINTRP(R1,V1,NIPT,R1(1),CSP,NIPT,IDER)
CSP(1)= CSP(2)
CSP(2)= TTMP
c** Now call routine to actually generate spline coefficients
CALL SPLINE(R1,V1,NTP,3,CSP,MAXSP,IER)
IF(IER .NE. 0) THEN
WRITE(6,604)
STOP
ENDIF
ENDIF
IF(MEND.LT.MBEG) GO TO 99
c** Now, use spline to generate function at desired points XX(I)
DO I= MBEG,MEND
RI= XX(I)
RRR= RI-EPS
KK= 1
c** For a monotonic increasing distance array XX(I), this statement
c speeds up the search for which set of cubic coefficients to use.
IF(I.GT.MBEG) THEN
IF(XX(I).GT.XX(I-1)) KK= JK
ENDIF
DO K= KK,NTP
JK= K
IF(R1(K).GE.RRR) GO TO 64
ENDDO
64 CONTINUE
JK= JK-1
IF(JK.LT.1) JK= 1
R2= RI-R1(JK)
YY(I)= CSP(JK)+R2*(CSP(NTP+JK)+R2*(CSP(N2+JK)+R2*CSP(N3+JK)))
ENDDO
99 RETURN
602 FORMAT(' *** ERROR in SPLINT *** Array dimension MAXSP=',I4,
1 ' cannot contain spline coefficients for NTP=',I4)
604 FORMAT(' *** ERROR in generating spline coefficients in SPLINE')
END
c**********************************************************************
SUBROUTINE SPLINE(X,Y,N,IOPT,C,N4,IER)
c** Subroutine for generating cubic spline coefficients
c C(J), (J=1,N4=4*N) through the N points X(I), Y(I).
c** C(I+M*N), M=0-3 are the coefficients of order 0-3 of cubic
c polynomial expanded about X(I) so as to describe the interval:
c - X(I) to X(I+1) , if X(I) in increasing order
c - X(I-1) to X(I) , if X(I) in decreasing order.
c** IOPT indicates boundary conditions used in creating the spline .
c* If (IOPT=0) second derivatives = zero at both ends of range.
c* If (IOPT=1) 1st derivative at first point X(1) fixed at C(1),
c and 2nd derivative at X(N) = zero.
c* If (IOPT=2) 1st derivative at last point X(N) fixed at C(2),
c and 2nd derivative at X(1) = zero.
c* If (IOPT=3) constrain first derivatives at end points to have
c (read in) values C(1) at X(1) & C(2) at X(N)
c** IER is the error flag. IER=0 on return if routine successful.
c-----------------------------------------------------------------------
INTEGER I,II,IER,IOH,IOL,IOPT,J,J1,J2,J3,NER,N,N4,JMP
REAL*8 A,H,R,DY2,DYA,DYB,XB,XC,YA,YB, X(N),Y(N),C(N4)
c
JMP= 1
NER= 1000
IF(N.LE.1) GO TO 250
c** Initialization
XC= X(1)
YB= Y(1)
H= 0.D0
A= 0.D0
R= 0.D0
DYB= 0.D0
NER= 2000
c
c IOL=0 - given derivative at firstpoint
c IOH=0 - given derivative at last point
c
IOL= IOPT-1
IOH= IOPT-2
IF(IOH.EQ.1) THEN
IOL= 0
IOH= 0
ENDIF
DY2= C(2)
c
c Form the system of linear equations
c and eliminate subsequentially
c
J= 1
DO I= 1,N
J2= N+I
J3= J2+N
A= H*(2.D0-A)
DYA= DYB+H*R
IF(I.GE.N) THEN
c
c set derivative dy2 at last point
c
DYB= DY2
H= 0.D0
IF(IOH.EQ.0) GOTO 200
DYB= DYA
GOTO 220
ENDIF
J= J+JMP
XB= XC
XC= X(J)
H= XC-XB
c
c II= 0 - increasing abscissae
c II= 1 - decreasing abscissae
c
II= 0
IF(H.LT.0) II= 1
IF(H.EQ.0) GO TO 250
YA= YB
YB= Y(J)
DYB= (YB-YA)/H
IF(I.LE.1) THEN
J1= II
IF(IOL.NE.0) GO TO 220
DYA= C(1)
ENDIF
200 IF(J1.NE.II) GO TO 250
A= 1.D0/(H+H+A)
220 R= A*(DYB-DYA)
C(J3)= R
A= H*A
C(J2)= A
C(I)= DYB
ENDDO
c
c back substitution of the system of linear equations
c and computation of the other coefficients
c
A= 1.D0
J1= J3+N+II-II*N
I= N
DO IOL= 1,N
XB= X(J)
H= XC-XB
XC= XB
A= A+H
YB= R
R= C(J3)-R*C(J2)
YA= R+R
C(J3)= YA+R
C(J2)= C(I)-H*(YA+YB)
C(J1)= (YB-R)/A
C(I)= Y(J)
A= 0.D0
J= J-JMP
I= I-1
J2= J2-1
J3= J3-1
J1= J3+N+II
ENDDO
IER= 0
RETURN
250 IER= NER
RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE POTGEN(LNPT,NPP,IAN1,IAN2,IMN1,IMN2,VLIM,XO,RM2,VV,
1 NCN,CNN)
c** Generate analytic potential VV(i) as specified by the choice
c of parameter IPOTL (see comments in PREPOT (& in main program))
c** All potentials generated in units cm-1 with absolute asymptote at
c (input) energy VLIM for distance array X0(i) Angstroms.
c** Return with NCN equal to power of asymptotically dominant inverse
c power term in long range part of potential
c** Born-Oppenheimer correction functions in IPOTL=3 option may have up
c to NBOB+1 terms.
c-----------------------------------------------------------------------
INTEGER NBOB
PARAMETER (NBOB=20)
INTEGER I,J,M,IBOB,IAN1,IAN2,IMN1,IMN2,RMN1,RMN2,IORD,IPOTL,
1 NC1,NC2,NG1,NG2,NCMAX,NPAR,MPAR,NVARB,NPP,LNPT,NCN,GNS,GEL
CHARACTER*2 NAME1,NAME2
REAL*8 A0,A1,A2,A3,ALFA,BETA,BINF,B1,B2,CSAV,
1 ABUND,CNN,DSCM,DX,DX1,FCT,
2 FC1,FC2,MASS1,MASS2,RMASS1,RMASS2,RC6,RC8,RC10,RC12,RC14,
3 RCNPAR,RD,RDIF,REQ,RPOW,RX,SC1,SC2,SG1,SG2,VLIM,VMIN,
4 XDF,X1,XM,XN,XM2C,XP1,ZZ,ZP, CA1(0:NBOB),CA2(0:NBOB),
5 GA1(0:NBOB),GA2(0:NBOB),PARM(20),XO(NPP),VV(NPP),RM2(NPP)
c
SAVE IBOB,IPOTL,IORD,MPAR,NPAR,NVARB,DSCM,REQ,PARM,CA1,CA2,GA1,
1 GA2,RX,CSAV
c
IF(LNPT.GT.0) THEN
c** Parameter definitions listed preceeding CALL in subroutine PREPOT
c-----------------------------------------------------------------------
READ(5,*) IPOTL, MPAR, NPAR, NVARB, IBOB, DSCM, REQ
IF(IPOTL.EQ.1) NVARB= 0
IF((IPOTL.EQ.3).AND.(NPAR.EQ.-1)) NVARB= 2
IF(NVARB.GT.0) READ(5,*) (PARM(I), I=1,NVARB)
IF(IBOB.GT.0) THEN
READ(5,*) RMN1, RMN2, NC1, NC2, NG1, NG2, RX
c-----------------------------------------------------------------------
NCMAX= MAX0(NC1,NC2,NG1,NG2)
IF(NCMAX.LT.0) THEN
IBOB= 0
ELSE
c** If appropriate, read parameters & prepare to add mass-dep. BOB corrn
CALL MASSES(IAN1,IMN1,NAME1,GEL,GNS,MASS1,ABUND)
CALL MASSES(IAN1,RMN1,NAME1,GEL,GNS,RMASS1,ABUND)
CALL MASSES(IAN2,IMN2,NAME2,GEL,GNS,MASS2,ABUND)
CALL MASSES(IAN2,RMN2,NAME2,GEL,GNS,RMASS2,ABUND)
WRITE(6,628)
c For simplicity, first zero out all correction function coefficients
DO I=0,NCMAX
CA1(I)= 0.d0
CA2(I)= 0.d0
GA1(I)= 0.d0
GA2(I)= 0.d0
ENDDO
FC1= 0.d0
FC2= 0.d0
c=======================================================================
c** Read actual B-O-B polynomial expansion coefficients
c=======================================================================
IF(NC1.GE.0) THEN
c-----------------------------------------------------------------------
READ(5,*) (CA1(I), I=0,NC1)
c-----------------------------------------------------------------------
IF(RX.LE.0.d0) THEN
WRITE(6,630) 1,MASS1,NC1,NAME1,RMN1,NAME1,
1 IMN1,NC1+1,(CA1(I),I= 0,NC1)
FC1= 1.d0 - RMASS1/MASS1
ELSE
WRITE(6,632) 1,MASS1,NC1,NAME1,IMN1,NC1+1,
1 (CA1(I),I= 0,NC1)
FC1= 1.d0/MASS1
ENDIF
ENDIF
IF(NC2.GE.0) THEN
c-----------------------------------------------------------------------
READ(5,*) (CA2(I), I=0,NC2)
c-----------------------------------------------------------------------
IF(RX.LE.0.d0) THEN
WRITE(6,630) 2,MASS2,NC2,NAME2,RMN2,NAME2,
1 IMN2,NC2+1,(CA2(I),I= 0,NC2)
FC2= 1.d0 - RMASS2/MASS2
ELSE
WRITE(6,632) 2,MASS2,NC2,NAME2,IMN2,NC2+1,
1 (CA2(I),I=0,NC2)
FC2= 1.d0/MASS2
ENDIF
ENDIF
IF(NG1.GE.0) THEN
c-----------------------------------------------------------------------
READ(5,*) (GA1(I), I=0,NG1)
c-----------------------------------------------------------------------
IF(RX.LE.0.d0) THEN
WRITE(6,634) 1,MASS1,NG1,NAME1,RMN1,NAME1,
1 IMN1,NG1+1,(GA1(I),I= 0,NG1)
ELSE
WRITE(6,636) 1,MASS1,NG1,NAME1,IMN1,RX,
1 NG1+1,(GA1(I),I= 0,NG1)
ENDIF
ENDIF
IF(NG2.GE.0) THEN
c-----------------------------------------------------------------------
READ(5,*) (GA2(I), I=0,NG2)
c-----------------------------------------------------------------------
IF(RX.LE.0.d0) THEN
WRITE(6,634) 2,MASS2,NG2,NAME2,RMN2,NAME2,
1 IMN2,NG2+1,(GA2(I),I= 0,NG2)
ELSE
WRITE(6,636) 2,MASS2,NG2,NAME2,IMN2,RX,
1 NG2+1,(GA2(I),I= 0,NG2)
ENDIF
ENDIF
DO I=0,NCMAX
CA1(I)= CA1(I)*FC1
CA2(I)= CA2(I)*FC2
IF(RX.LE.0.d0) THEN
GA1(I)= GA1(I)*(1.d0-FC1)
GA2(I)= GA2(I)*(1.d0-FC2)
ELSE
GA1(I)= GA1(I)*FC1
GA2(I)= GA2(I)*FC2
ENDIF
ENDDO
ENDIF
ENDIF
ENDIF
IF(IPOTL.EQ.1) THEN
c=======================================================================
c** Generate a Lennard-Jones(MPAR,NPAR) potential here.
c=======================================================================
XM= MPAR
XN= NPAR
XDF= DSCM/(XM-XN)
IF(LNPT.GE.0) WRITE(6,600) MPAR,NPAR,DSCM,REQ
NCN= NPAR
CNN= XM*XDF*REQ**NPAR
DO I= 1,NPP
VV(I)= (XN*(REQ/XO(I))**MPAR - XM*(REQ/XO(I))**NPAR)*XDF
1 +VLIM
ENDDO
ENDIF
IF(IPOTL.EQ.2) THEN
c=======================================================================
c** Generate an MLJ potential [as per JCP 112, 3949 (2000)] here ...
c=======================================================================
NCN= NPAR
IORD= NVARB-1
IF(MPAR.LE.0) THEN
c If appropriate, prepare to calculate switching function
IORD= IORD- 3
CNN= PARM(NVARB-2)
BINF= DLOG(2.d0*DSCM*REQ**NPAR/CNN)
ALFA= PARM(NVARB- 1)
RX= PARM(NVARB)
ELSE
c Generate limiting Cn value for non-switching case from BINF
BINF= 0.D0
DO I= 1,NVARB
BINF= BINF+ PARM(I)
ENDDO
CNN= 2.d0*DSCM*REQ**NPAR *DEXP(-BINF)
ENDIF
IF(LNPT.GT.0) THEN
WRITE(6,602) DSCM,REQ
IF(MPAR.GT.0) WRITE(6,603) IORD,MPAR,MPAR,MPAR,MPAR,
1 IORD+1,(PARM(J),J= 1,IORD+1)
IF(MPAR.LE.0) WRITE(6,603) IORD,1,1,1,1,
1 IORD+1,(PARM(J),J= 1,IORD+1)
IF(MPAR.LE.0) WRITE(6,604) NPAR,NPAR,NPAR,PARM(NVARB-2),
1 PARM(NVARB-1),PARM(NVARB)
ENDIF
NCN= NPAR
c Loop over distance array XO(I)
DO I= 1,NPP
ZZ= (XO(I)- REQ)/(XO(I)+ REQ)
IF(MPAR.GT.1) ZZ= (XO(i)**MPAR - REQ**MPAR)/
1 (XO(i)**MPAR + REQ**MPAR)
BETA= 0.d0
DO J= IORD,0,-1
BETA= BETA*ZZ+ PARM(J+1)
ENDDO
c Calculate and apply switching function to MLJ exponent coefficient
IF(MPAR.LE.0) BETA= BINF+ (BETA- BINF)/
1 (1.d0+ DEXP(ALFA*(XO(I) - RX)))
VV(I)= DSCM*(1.d0 - (REQ/XO(I))**NPAR *DEXP(-BETA*ZZ))**2
1 - DSCM+ VLIM
ENDDO
ENDIF
IF(IPOTL.EQ.3) THEN
c=======================================================================
c** Generate a simple Morse, or Extended (EMO) Morse potential, or as
c special cases, Coxon's GMO or Wei Hua's generalized Morse
c=======================================================================
BETA= PARM(1)
NCN= 99
IF(LNPT.GE.0) THEN
IF(MPAR.EQ.-1) THEN
c** Option to generate Wei Hua's extended 4-parameter Morse-type potl.
CSAV= PARM(2)
WRITE(6,605) DSCM,REQ,CSAV,BETA
ELSE
IF(NVARB.LE.1) WRITE(6,606) DSCM,REQ,BETA
IF(NVARB.GT.1) THEN
IF(MPAR.GT.0) WRITE(6,608) DSCM,REQ,NVARB-1,
1 MPAR,MPAR,MPAR,MPAR,NVARB,(PARM(i),i= 1,NVARB)
IF(MPAR.EQ.-2) WRITE(6,610) DSCM,REQ,NVARB-1,
1 (PARM(i),i= 1,NVARB)
ENDIF
ENDIF
ENDIF
c Loop over distance array XO(I)
DO I= 1,NPP
c ... for Wei Hua's extended Morse function ...
IF(MPAR.EQ.-1) THEN
VV(I)= DSCM*((1.d0 - DEXP(-BETA*(XO(I)-REQ)))/(1.d0
1 - CSAV*DEXP(-BETA*(XO(I)-REQ))))**2 - DSCM+ VLIM
ELSE
IF(NVARB.GT.1) THEN
ZZ= (XO(I)- REQ)/(XO(I)+ REQ)
IF(MPAR.GT.1) ZZ= (XO(i)**MPAR - REQ**MPAR)/
1 (XO(i)**MPAR + REQ**MPAR)
c ... for Coxon-Hajigeorgiou "GMO" potential
IF(MPAR.EQ.-2) ZZ= (XO(I)- REQ)
BETA= 0.d0
DO J= NVARB,1,-1
BETA= BETA*ZZ+ PARM(J)
ENDDO
ENDIF
VV(I)= DSCM*(1.d0 - DEXP(-BETA*(XO(I)-REQ)))**2
1 - DSCM+ VLIM
ENDIF
ENDDO
ENDIF
IF(IPOTL.EQ.4) THEN
c=======================================================================
c** Generate Seto-modified form of Surkus' GPEF function which includes
c Dunham, SPF and OT forms as special cases.
c=======================================================================
VMIN= VLIM
VLIM= 1.d9
A0= DSCM
IORD= NVARB-2
X1= 1.d0
FCT= PARM(NVARB-1)
IF((NPAR.NE.0).AND.(DABS(FCT).GT.0.d0)) THEN
FCT= 1.d0/PARM(NVARB-1)
DO J=1,IORD
X1= X1+ PARM(J)*FCT**J
ENDDO
DSCM= DSCM*X1*FCT**2 + VMIN
ENDIF
IF(NPAR.EQ.1) THEN
c Cases with power =1 (including Dunham, SPF & O-T expansions).
IF(DABS(PARM(NVARB-1)).LE.0.d0) THEN
c ... print for Dunham expansion ...
WRITE(6,612) PARM(NVARB),REQ,VMIN,A0,NVARB-2,
1 (PARM(I),I= 1,NVARB-2)
NCN= -99
CNN= 0.d0
ENDIF
IF(DABS(PARM(NVARB)).LE.0.d0) THEN
c ... print for Simons-Parr-Finlan expansion ...
WRITE(6,614) PARM(NVARB-1),REQ,DSCM,A0,NVARB-2,
1 (PARM(I),I= 1,NVARB-2)
NCN= 1
ENDIF
IF(DABS(PARM(NVARB)-PARM(NVARB-1)).LE.0.d0) THEN
c ... print for Ogilvie-Tipping expansion ...
WRITE(6,616) PARM(NVARB),REQ,DSCM,A0,NVARB-2,
1 (PARM(I),I= 1,NVARB-2)
NCN= 1
ENDIF
ENDIF
IF((NPAR.NE.0).AND.((NPAR.NE.1).OR.
1 ((DABS(PARM(NVARB)-PARM(NVARB-1)).GT.0.d0).AND.
2 (DABS(PARM(NVARB)*PARM(NVARB-1)).GT.0.d0)))) THEN
c ... print for general GPEF expansion variable ...
IF(NPAR.LT.0) THEN
c ... for negative NPAR, convert to equivalent positive NPAR case
NPAR= -NPAR
A1= PARM(NVARB)
PARM(NVARB)= -PARM(NVARB-1)
PARM(NVARB-1)= -A1
ENDIF
WRITE(6,618) NPAR,NPAR,PARM(NVARB-1),NPAR,PARM(NVARB),
1 NPAR,REQ,DSCM,A0,NVARB-2,(PARM(I),I= 1,NVARB-2)
NCN= NPAR
ENDIF
IF(NPAR.EQ.0) THEN
c** For case of simple power series in R itself
WRITE(6,620) NVARB,(PARM(I),I= 1,NVARB)
DO I= 1, NPP
ZP= 1.d0
A1= 0.d0
DO J= 1,NVARB
A1= A1+ PARM(J)*ZP
ZP= ZP*XO(I)
ENDDO
VV(I)= A1+ VMIN
ENDDO
VLIM= VV(NPP)
RETURN
ENDIF
c ... otherwise - generate potential as a GPEF-type expansion
DO I= 1, NPP
ZZ= (XO(I)**NPAR - REQ**NPAR)/(PARM(NVARB-1)*XO(I)**NPAR
1 + PARM(NVARB)*REQ**NPAR)
A1= 1.d0
ZP= 1.d0
DO J=1, NVARB-2
ZP= ZP*ZZ
A1= A1+ PARM(J)*ZP
ENDDO
VV(I)= A0*ZZ*ZZ*A1 + VMIN
ENDDO
ENDIF
IF(IPOTL.EQ.5) THEN
c=======================================================================
c** For generalized H.F.D.(NPAR,6,8,10,12,14) potential with reduced
c form VBAR = ALFA*x**PARM(5) * exp[-BETR*x - PARM(4)*x**2] - D(x)*
c [PARM(6)/x**NPAR + PARM(7)/x**6 + PARM(8)/x**8 + PARM(9)/x**10
c + PARM(10)/X**12 + PARM(11)/X**14] where x=r/R_e ,
c VBAR= V/epsilon and D(x)= exp[-PARM(1)*(PARM(2)/x - 1)**PARM(3)]
c for x < PARM(2)
c=======================================================================
A1= PARM(1)
A2= PARM(2)
A3= PARM(3)
B2= PARM(4)
RC8= 0.d0
RC10= 0.d0
RC12= 0.d0
RC14= 0.d0
RCNPAR= PARM(6)
NCN= 6
IF(RCNPAR.GT.0.d0) NCN= NPAR
RC6= PARM(7)
IF(NVARB.ge.8) RC8= PARM(8)
IF(NVARB.ge.9) RC10= PARM(9)
IF(NVARB.ge.10) RC12= PARM(10)
IF(NVARB.ge.11) RC14= PARM(11)
DX= 1.d0
DX1= 0.d0
IF(A2.GT.1.d0) THEN
DX= DEXP(-A1*(A2- 1.d0)**A3)
DX1= A1*A2*A3*DX*(A2- 1.d0)**(A3- 1.d0)
ENDIF
ALFA= -1.D0+ (RCNPAR+ RC6+ RC8+ RC10+ RC12+ RC14)*DX
IF(ALFA.LE.0.d0) THEN
WRITE(6,622) RCNPAR,RC6,RC8,RC10,RC12,RC14,ALFA
STOP
ENDIF
B1= ((NPAR*RCNPAR+6.D0*RC6+8.D0*RC8+10.D0*RC10+12.d0*RC12+
1 14.d0*RC14)*DX - (RCNPAR+RC6+RC8+RC10+RC12+RC14)*DX1)/ALFA
2 + PARM(5) - 2.D0*B2
ALFA= ALFA*DEXP(B1+B2)
IF(LNPT.GE.0) WRITE(6,624) NPAR,PARM(5),B1,B2,ALFA*DSCM,
1 RCNPAR,RC6,RC8,RC10,RC12,RC14,A1,A2,A3,DSCM,REQ
DO I= 1,NPP
X1= XO(I)/REQ
XP1= 0.0D0
IF((B1*X1+ B2*X1**2).LT.170.D0) XP1= DEXP(-X1*(B1+ B2*X1))
XP1= XP1*X1**PARM(5)
FC1= 1.D0
IF(A2.GT.X1) FC1= DEXP(-A1*(A2/X1- 1.d0)**A3)
XM2C= (REQ/XO(I))**2
VV(I)= DSCM*(ALFA*XP1- FC1*(((((RC14*XM2C+RC12)*XM2C+RC10)
1 *XM2C+ RC8)*XM2C+ RC6)*XM2C**3 + RCNPAR/X1**NPAR)) + VLIM
ENDDO
ENDIF
IF(IBOB.GT.0) THEN
c=======================================================================
c** If appropriate, generate Born-Oppenheimer breakdown correction
c functions to rotationless and/or centrifugal potential(s).
c [Special "Coxon" option: if RX > 0.0, expand as per older Coxon work]
c=======================================================================
IF(RX.GE.0.D0) RDIF= REQ-RX
DO I=1,NPP
IF(RX.LE.0.d0) THEN
ZZ= (XO(I)-REQ)/(XO(I)+REQ)
ELSE
ZZ= XO(I)- REQ
RD= XO(I)- RX
ENDIF
SC1= 0.d0
SC2= 0.d0
SG1= 0.d0
SG2= 0.d0
RPOW= 1.d0
DO J= 0,NCMAX
SC1= SC1+ RPOW*CA1(J)
SC2= SC2+ RPOW*CA2(J)
IF(RX.LE.0.d0) THEN
SG1= SG1+ RPOW*GA1(J)
SG2= SG2+ RPOW*GA2(J)
ELSE
M= J-1
SG1= SG1+ (RD**J -RDIF**J)*GA1(J)
SG2= SG2+ (RD**J -RDIF**J)*GA2(J)
ENDIF
RPOW= RPOW*ZZ
ENDDO
RM2(I)= (1.d0+ SG1+ SG2)/XO(i)**2
VV(I)= VV(I) + SC1 + SC2
ENDDO
ENDIF
RETURN
600 FORMAT(/' Lennard-Jones(',I2,',',I2,') potential with De=',
1 F10.3,'(cm-1) Re =',F10.6,'(A)')
602 FORMAT(/' Use an MLJ potential with De =',F10.3,
1 '(cm-1) Re =',F12.8,'(A)')
603 FORMAT(3x,'with parameter BETA an order-',i2,' polynomial in y =
1 (R^',i1,' - Re^',i1,')/(R^',i1,' + Re^',i1,')'/' with',i3,
2 ' coefficients:',1PD16.8,2D16.8:/(8x,4D16.8:))
604 FORMAT(' & exponent switching function yielding limiting C',i1,
1 '/R^',i1,' with C_',i1,'=',1PD13.6/10x,'defined by ALPHA_s=',
2 0Pf9.6,' R_s=',f10.6)
605 FORMAT(/' Potential is a Hua-Wei 4-parameter Morse type function w
1ith De =',F11.4/11x,'Re =',F12.9,' C=',f7.4,' & beta=',
1 F13.10,' [1/Angstroms]')
606 FORMAT(/' Potential is a simple Morse function with De =',F11.4,
1 ' Re =',F12.9/39x,'and beta =',F13.10,' [1/Angstroms]')
608 FORMAT(/' Potential is Extended Morse Oscillator with De=',
1 F11.4,' Re=',F12.9/3x,'Exponent factor "beta" is order-',i2,
2 ' power series in y=(R^',i1,' -Re^',i1,')/(R^',i1,' +Re^',i1,')'
3 /' with',I3,' coefficients:',1x,1PD18.9,2D18.9:/(7X,4D18.9:))
610 FORMAT(/' Potential is Generalized Morse Oscillator with De=',
1 F10.3,' Re=',F11.8/4x,'Exponent factor "beta" is',i3,' order po
2wer series in (R-Re) with coefficients:'/4x,1PD18.9,3D18.9:/
3 (4X,4D18.9:))
612 FORMAT(/' Potential is a Dunham expansion in (R-Re)/(',f5.2,
1 ' * Re) with Re=',f12.9/' V(Re)=',f12.4,' a0=',1PD16.9,
2 ' and',i3,' a_i coefficients:'/(5D16.8))
614 FORMAT(/' Potential is an SPF expansion in (R-Re)/(',F5.2,
1 '* R) with Re=',f12.9/5x,'De=',g18.10,' b0=',
2 1PD16.9,' and',i3,' b_i coefficients:'/(5D16.8))
616 FORMAT(/' Potential is an O-T expansion in (R-Re)/[',f5.2,
1 '*(R+Re)] with Re=',f12.9/5x,'De=',G18.10,
2 ' c0=',1PD16.9,' and',i3,' c_i coefficients:'/(5D16.8))
618 FORMAT(/' Potential is a general GPEF expansion in (R^',i1,
1 ' - Re^',i1,')/(',SP,F5.2,'*R^',SS,i1,SP,F6.2,'*Re^',SS,i1,')'/
2 5x,'with Re=',f12.9,' De=',g18.10,' g0=',1PD16.9/
3 5x,'and',i3,' g_i coefficients: ',3D16.8/(5D16.8:))
620 FORMAT(/' Potential is an',i3,'-term power series in R with coef
1ficients (starting from power=0):'/(5D16.8))
622 FORMAT(/' *** ERROR in generating HFD potential *** C',i1,
1 ', C6, C8, C10, C12, C14 =',6G15.7/10X,'yield ALFA =',G15.7)
624 FORMAT(/' Potential is Generalized HFD(',i1,',6,8,10,12,14) with',
1 ' gamma=',f9.6/' beta1=',f12.8,' beta2=',f9.6,' A=',
2 1PD16.9/" reduced {Cn's}:",3D14.6/19x,3D14.6/' Damping func
3tion D(R)= exp[ -',0Pf6.4,'*(',f7.4,'/X -1.0)**',f5.2,']' /
4 ' & DSCM=',f10.4,'[cm-1] Re=',f9.6,'[Angst.]')
628 FORMAT(' ')
630 FORMAT(' B-O-B correction to rotationless potential for atom-',
1 I1,' of mass ',f14.10/5x,'is [order-',I2,' polynomial in {(R-R
2e)/(R+Re)}] * [1- MASS(',A2,i3,')/MASS(',A2,I3,')]'/5x,'with',i3,
3 ' coefficients:',3G18.10:/(8x,4G18.10:))
632 FORMAT(' B-O-B correction to rotationless potential for atom-',
1 I1,' of mass ',f14.10/5x,'is [order-',I2,' polynomial in (R-Re)
2]/[MASS(',A2,I3,')] with',i3,' coefficients:'/(5x,4G18.10:))
634 FORMAT(' B-O-Breakdown correction to centrifugal term for atom-',
1 I1,' of mass ',f14.10/5x,'is [order-',I2,' polynomial in {(R-Re
2/(R+Re)}] * [MASS(',A2,I3,')/MASS(',A2,I3,')]'/5x,'with',i3,' coef
3ficients:',3G18.10:/(8x,4G18.10:))
636 FORMAT(' B-O-Breakdown correction to centrifugal term for atom-',
1 I1,' of mass ',f14.10/5x,'is [order-',I2,' polynomial in {(R-Rx
2)**i - (Re-Rx)**i}] / [MASS(',A2,I3,')]'/5x,'with Rx=',f6.3,
3 ' &',i3,' coefficients: ',1PD18.9,D18.9:/(5x,4D18.9:))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
c** Version 0.9s dated Mar 7, 2000.
c***********************************************************************
SUBROUTINE ALF(NDP,RMIN,RH,V,SWF,VLIM,KVMAX,AFLAG,ZMU,EPS,NCN,GV,
1 INNR,IWR)
c***********************************************************************
c** The subroutine ALF (Automatic vibrational Level Finder) will
c automatically generate the eigenvalues from the first vibrational
c level (v=0) to a user specified level (v=KVMAX) or the highest
c allowed vibrational level of a given smooth single (or double)
c minimum potential (V). These energies are stored and returned to the
c calling program in the molecular constants array GV(v=0-KVMAX).
c** For any errors that cannot be resolved within the subroutine, ALF
c returns AFLAG with a value that defines which error had occured.
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++ COPYRIGHT 1998 - 1999 by Jenning Seto and Robert J. Le Roy +++
c Dept. of Chemistry, Univ. of Waterloo, Waterloo, Ontario, Canada +
c This software may not be sold or any other commercial use made +
c of it without the express written permission of the authors. +
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+ Please inform me of any bugs, by phone at: (519)888-4567, ext. 4099 +
c++++++++ by e-mail to: jyseto@uwaterloo.ca , or write me at: ++++++++++
c+++ Dept. of Chemistry, Univ. Waterloo, Waterloo, Ontario N2L 3G1 ++++
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Based on the automatic level finding routine found in LEVEL 6.0
c written by Robert J. Le Roy
c** Uses the Schrodinger solver subroutine SCHRQ.
c
c** On entry:
c NDP is the number of datapoints used for the potential.
c RMIN is the inner radial distance of the potential (ang).
c RH is the meshvalue (ang).
c NDP, RMIN, and RH define the radial range over which the
c potential is defined.
c V(i) is the scaled input potential (cm-1).
c The scaling factor BFCT is (2*mu/hbar^2)*RH^2.
c VLIM is the potential asymptote (cm-1).
c KVMAX is the maximum vibrational level for which we wish to find.
c AFLAG is the rotational state of the potential.
c ZMU is the reduced mass of the diatom (amu).
c EPS is the energy convergence criterion (cm-1).
c NCN is the near dissociation limit radial exponential.
c IWR specifies the level of printing inside SCHRQ
c <> 0 : print error & warning descriptions.
c >= 1 : also print final eigenvalues & node count.
c >= 2 : also show end-of-range wave function amplitudes.
c >= 3 : print also intermediate trial eigenvalues, etc.
c
c** On exit:
c KVMAX returns the highest allowed vibrational quantum number if
c less than the inputed KVMAX.
c AFLAG returns calculation outcome to calling program.
c >= 0 : Subroutine has functioned normally.
c = -1 : KVMAX larger than number of allowed levels.
c = -2 : Initial trial energy is unusable.
c = -3 : Calculated trial energy is unusable.
c = -4 : Cannot find first vibrational level.
c = -5 : Calculated trial energy too low.
c = -6 : Calculated trial energy too high.
c = -7 : An impossible situation occured.
c = -8 : Potential found to have a second minimum.
c GV(v) contains the vibrational energy level spacings and
c rotational constants in cm-1 for each level.
c INNR(v) labels each level as belonging to the inner (INNR = 1) or
c outer (INNR = 0) well.
c
c** Flags: Modify only when debugging.
c AWO specifies the level of printing inside ALF
c <> 0 : print error & warning descriptions.
c > 0 : also print intermediate ALF messages.
c MCO specifies the level of printing of molecular constants.
c > 0 : print out vibrational energies to channel-21.
c INNER specifies wave function matching (& initiation) conditions.
c = 0 : Match inward & outward solutions at outermost wave
c function maximum
c <>0 : Match at inner edge of classically allowed region.
c < 0 : uses zero slope inner boundary condition.
c For most normal cases set INNER = 0, but ......
c To find "inner-well-dominated" solutions of an asymmetric
c double minimum potential, set INNER > 0.
c To find symmetric eigenfunctions of a symmetric potential,
c set INNER < 0 & start integration (set RMIN) at potential
c mid point.
c LPRWF specifies option of printing out generated wavefunction
c > 0 : print wave function every LPRWF-th point.
c < 0 : compactly write to channel-7 every |LPRWF|-th wave
c function value.
c A lead "card" identifies the level, gives the position of
c 1-st point and radial mesh, & states No. of points.
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** The dimensioning parameters must be consistant with the sizes of the
c arrays used in the calling program.
c
c NVIBMX is the maximum number of vibrational levels considered.
c Note: NVIBMX should be larger than KVMAX.
c
INTEGER NVIBMX
PARAMETER (NVIBMX = 400)
c
c** NF counts levels found in automatic search option
c
c** OWL holds the vibrational levels that are contained in the outer
c well.
c** IWL holds the vibrational levels that are contained in the inner
c well (if present).
c
INTEGER NDP,KVMAX,NCN,KV,AFLAG,NF,NBEG,NEND,INNR(0:KVMAX),IWR,
1 I,IZPE,IVDIF,IVCOR,IQT,IEG,LTRY,AWO,MCO,INNER,LPRWF,JROT,
2 NPMIN, NPMAX, NIWL,IWL(0:NVIBMX),NOWL,OWL(0:NVIBMX)
c
REAL*8 RMIN,RMAX,RH,V(NDP),SWF(NDP),VLIM,EO,ZMU,EPS,
1 GV(0:KVMAX),BV(0:NVIBMX),BVDOUT,BVDIN,AO,VD,
2 BZ,BFCT,PW,PWI,GAMA,VMIN,VMAX,RE,PMAX,VDMV,VDL,VDU,
3 VPMIN(10), RPMIN(10), VPMAX(10), RPMAX(10),
3 ZQ, ZH, Z1, Z2
c
DATA AWO/0/,MCO/0/,LPRWF/0/
c
DATA ZQ/0.25D0/,ZH/0.5D0/,Z1/1.D0/,Z2/2.D0/
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Check if the dimensions are adequate.
c
IF (KVMAX.GT.NVIBMX) THEN
WRITE(6,610)
WRITE(6,613) KVMAX, NVIBMX
STOP
ENDIF
c
c** Initialize level counters for each well.
c
DO I = 0,KVMAX
INNR(I) = 0
IWL(I) = 0
OWL(I) = 0
END DO
c
c** Initialize the remaining variables and flags.
c
NF = 0
NIWL = 0
NOWL = 0
KV = 0
INNER = 0
LTRY = 0
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c
c** Store rotational quantum number.
c
JROT = AFLAG
c
c** Numerical factor 16.85762908 based on 1998 physical constants.
c
BZ = ZMU/16.85762908d0
BFCT = BZ*RH*RH
c
c** RMAX is the outer radial distance over which the potential is
c defined.
c
RMAX = RMIN + DBLE(NDP-1)*RH
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Locate the potential minima.
c
NPMIN = 0
DO I = 2,NDP-1
IF ((V(I).LT.V(I-1)).AND.(V(I).LT.V(I+1))) THEN
NPMIN = NPMIN + 1
RPMIN(NPMIN) = RMIN + DBLE(I-1)*RH
VPMIN(NPMIN) = V(I) / BFCT
IF (NPMIN.EQ.10) GOTO 100
END IF
END DO
c
c** If a minimum cannot be found, then print a warning and exit.
c
100 IF (NPMIN.EQ.0) THEN
WRITE(6,610)
WRITE(6,614)
STOP
END IF
c
c** If more than two minima are found, then print a warning and exit.
c
IF (NPMIN.GT.2) THEN
WRITE(6,605)
WRITE(6,615) NPMIN, 'minima'
* STOP
END IF
c
c** Locate the potential maxima (if it exists).
c
NPMAX = 0
DO I = 2,NDP-1
IF ((V(I).GT.V(I-1)).AND.(V(I).GT.V(I+1))) THEN
NPMAX = NPMAX + 1
RPMAX(NPMAX) = RMIN + DBLE(I-1)*RH
VPMAX(NPMAX) = V(I) / BFCT
IF (NPMAX.EQ.10) GOTO 150
END IF
END DO
c
c** If no maxima were found, then set the maximum to be the value at the
c end of the range.
c
150 IF (NPMAX.EQ.0) THEN
NPMAX = 1
RPMAX(NPMAX) = RMAX
VPMAX(NPMAX) = V(NDP) / BFCT
END IF
c
c** If more than three maxima are found, then print a warning and exit.
c
IF (NPMAX.GT.3) THEN
WRITE(6,605)
WRITE(6,615) NPMAX, 'maxima'
* STOP
END IF
c
c** If there is no rotationless barrier to assiciation, then set the
c final VPMAX to be the value at the end of the range.
c
IF (RPMAX(NPMAX).LT.RPMIN(NPMIN)) THEN
NPMAX = NPMAX + 1
RPMAX(NPMAX) = RMAX
VPMAX(NPMAX) = V(NDP) / BFCT
END IF
c
c** If a maxima occurs before a minima, then the potential turns over in
c short range region and should not be used. Print a warning and exit.
c
IF (RPMAX(1).LT.RPMIN(1)) THEN
WRITE(6,610)
WRITE(6,616) RPMAX(1)
* STOP
END IF
c
c** Now find the absolute potential minimum.
c
VMIN = VPMIN(1)
RE = RPMIN(1)
DO I = 2,NPMIN
IF (VMIN.GT.VPMIN(I)) THEN
VMIN = VPMIN(I)
RE = RPMIN(I)
END IF
END DO
c
c** Now find the absolute potential minimum.
c
VMAX = VPMAX(1)
DO I = 2,NPMAX
IF (VMAX.LT.VPMAX(I)) VMAX = VPMAX(I)
END DO
c
c** If the absolute potential maximum is lower than the absolute
c potential minimum, then print out an error statement and quit.
c
IF (VMAX.LE.VMIN) THEN
WRITE(6,610)
WRITE(6,617)
STOP
END IF
c
c** Otherwise, print out the results if desired.
c
IF (AWO.GT.0) THEN
WRITE(6,650) NPMIN, VMIN
WRITE(6,651) NPMAX, VMAX
END IF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Calculate 2*NCN/(NCN - 2) for use when calculating trial energies.
c
PW = 20.0d0
IF ((NCN.GT.0).AND.(NCN.NE.2)) PW = Z2*DBLE(NCN)/(DBLE(NCN)-Z2)
IF (VMAX.GT.VLIM) PW = Z2
PWI = Z1/PW
c
c** Use Lennard-Jones estimation of zero point energy to determine the
c initial trial energy.
c _____________________________
c vD + 0.5 = ao \/ZMU * De * Re^2 / 16.85762908
c
c De = A (vD - v)^3 = A (vD + 0.5)^3
c
c E(v=0) = VMIN + A [(vD + 0.5)^3 - vD^3]
c
c** Choose AO to have a value of 0.25.
c
AO = ZQ
VD = AO * DSQRT(BZ*(VMAX-VMIN)) * RE - ZH
AO = (VMAX-VMIN)*(Z1 - (VD/(VD+ZH))**3)
EO = VMIN + AO
c
c** If desired, write out energy level information.
c
IF (MCO.GE.1) THEN
WRITE(21,2100)
WRITE(21,2110) RMIN, RMAX, RH, BZ, ZMU
WRITE(21,2111) EPS
WRITE(21,2112)
WRITE(21,2101)
END IF
c=========== Begin Actual Eigenvalue Calculation Loop Here =============
c** Compute eigenvalues ... etc up to the KVMAXth vibrational level.
c** When attempts to find the next eigenvalue fails, then perhaps the
c next level is located in a second (inner) well. If so, then the
c subroutine will set INNER = 1, and attempt to find that level.
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Call subroutine SCHRQ to find eigenvalue EO and eigenfunction SWF(I).
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
10 IF (AWO.GT.0) THEN
WRITE(6,601)
IF (INNER.EQ.0) WRITE(6,602)
IF (INNER.EQ.1) WRITE(6,603)
END IF
CALL SCHRQ(KV,JROT,EO,GAMA,PMAX,VLIM,V,SWF,BFCT,EPS,RMIN,RH,NDP,
1 NBEG,NEND,INNER,IWR,LPRWF)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** The SCHRQ error condition is KV < 0.
c There are three possible situations to consider:
c EO > VMAX : Trial energy greater than potential maximum
c NF = 0 : Looking for the first vibrational level (v = 0)
c NF > 0 : Looking for the other vibrational levels (v > 0)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** For the case when the next trial energy is higher than the potential
c maximum, try one last ditch attempt to find the highest bound level
c (quasi or otherwise) in the potential.
c
IF ((KV.LT.0).AND.(EO.GT.VMAX)) THEN
IF (LTRY.LT.1) THEN
LTRY = 1
KV = 999
EO = VMAX - 1.0d-2
c
c** If unsucessful, then print out a warning and exit.
c
ELSE
IF (AWO.NE.0) THEN
WRITE(6,605)
WRITE(6,606) NF, EO, VMAX
END IF
AFLAG = -1
GOTO 200
END IF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** If trying to find the first vibrational level (v=0), then double the
c zero point energy estimation (AO).
c
c E(v=0) = VMIN + IQT*AO
c
ELSEIF ((KV.LT.0).AND.(NF.EQ.0)) THEN
IF (IQT.GT.1) THEN
IF (AWO.NE.0) THEN
WRITE(6,610)
WRITE(6,611)
WRITE(6,620) IQT, EO
END IF
c
c** If this fails, then try changing the wavefunction matching
c condition (INNER) to see if a possible second minimum contains the
c zero point level.
c
IF (INNER.EQ.0) THEN
INNER = 1
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c
c** If both attempts fail, then print out warning message and exit the
c subroutine.
c
ELSE
AFLAG = -2
GOTO 200
END IF
END IF
IQT = IQT + 1
EO = VMIN + DBLE(IQT)*AO
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** If trying to find other vibrational levels (v > 0) then switch to
c use of differences for estimating spacing.
c
ELSEIF ((KV.LT.0).AND.(NF.GT.0)) THEN
IF (IVDIF.GT.0) THEN
IF (AWO.NE.0) THEN
WRITE(6,610)
WRITE(6,612)
WRITE(6,621) NF,IVDIF
END IF
c
c** If differences fails, then try changing the wavefunction matching
c condition (INNER) to see if a possible second minimum contains the
c zero point level.
c
IF (INNER.EQ.0) THEN
INNER = 1
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c
c** If both attempts fail, then print out warning message and exit the
c subroutine.
c
ELSE
AFLAG = -3
GOTO 200
END IF
END IF
IVDIF = 1
IF (INNER.EQ.0) THEN
CALL DTENG(IEG,NF,NOWL,OWL,NVIBMX,VMIN,GV,EO)
ELSE
CALL DTENG(IEG,NF,NIWL,IWL,NVIBMX,VMIN,GV,EO)
END IF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** If first level found isn't v=0, try up to 3 times to 'harmonically'
c estimate improved trial ground state energy.
c
c E(v=0) = E(v=KV) - (E(v=KV) - VMIN)/(1 + KV/2)
c
ELSEIF ((KV.GT.0).AND.(NF.EQ.0)) THEN
IF (IZPE.GT.3) THEN
IF (AWO.NE.0) THEN
WRITE(6,610)
WRITE(6,611)
WRITE(6,622) IZPE,GV(0),KV,EO
END IF
c
c** If differences fails, then try changing the wavefunction matching
c condition (INNER) to see if a possible second minimum contains the
c zero point level.
c
IF (INNER.EQ.0) THEN
INNER = 1
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c
c** If both attempts fail, then print out warning message and exit the
c subroutine.
c
ELSE
AFLAG = -4
GOTO 200
END IF
END IF
IZPE = IZPE + 1
EO = EO - (EO-VMIN)/(Z1+ZH/KV)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** For the next three cases, KV >= 0 and NF > 0.
c** If the calculated vibrational level is less than the next expected
c level, then the estimated trial energy is too low.
c** Perhaps the difference in energy between vibrational levels v and
c v-1 is much greater than the energy between levels v-1 and v-2.
c
c E(v) - E(v-1) >> E(v-1) - E (v-2)
c
c In which case (most likely a potential with a shelf), try twice to
c estimate a higher trial energy.
c
c E(v) = E(v-1) + (1+IEG/2) * (2*(E(v-1)-E(v-2)) - (E(v-2)-E(v-3)))
c
ELSEIF (KV.LT.NF) THEN
IF (IEG.GT.1) THEN
IF (AWO.NE.0) THEN
WRITE(6,610)
WRITE(6,612)
WRITE(6,623) NF, KV
END IF
c
c** If this fails, then try changing the wavefunction matching
c condition (INNER) to see if a possible second minimum contains the
c zero point level.
c
IF (INNER.EQ.0) THEN
INNER = 1
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c
c** If both attempts fail, then print out warning message and exit the
c subroutine.
c
ELSE
AFLAG = -5
GOTO 200
END IF
END IF
IEG = IEG + 1
c
c** If a second minimum is present, then the next vibrational level may
c be in the inner well. If so, use the inner well vibrational levels
c to estimate the next trial energy.
c
IF (INNER.EQ.0) THEN
CALL DTENG(IEG,NF,NOWL,OWL,NVIBMX,VMIN,GV,EO)
ELSE
CALL DTENG(IEG,NF,NIWL,IWL,NVIBMX,VMIN,GV,EO)
END IF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** If the calculated vibrational level is the next expected level, then
c continue.
c
ELSEIF (KV.EQ.NF) THEN
NF = NF + 1
GV(KV) = EO
INNR(KV) = INNER
LTRY = 0
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c-----------------------------------------------------------------------
c** To ease confusion when using a potential with a second minimum, keep
c track of levels that are in the outer well seperate from the levels
c in the inner well.
c** First, calculate the rotational constant for this level (Bv).
c
BV(KV) = ZH*((SWF(NBEG)/(RMIN+DBLE(NBEG-1)*RH))**2
1 + (SWF(NEND)/(RMIN+DBLE(NEND-1)*RH))**2)
DO I = NBEG+1,NEND-1
BV(KV) = BV(KV) + (SWF(I)/(RMIN+DBLE(I-1)*RH))**2
END DO
BV(KV) = BV(KV)*RH/BZ
c
c** Double check that the calculated level is in fact located in the
c correct well. This can be done (for v <> 0) by comparing the Bv
c value of the new level and with the Bv values in each well. If the
c difference is greater than 1.5 times the difference in the other
c well, then the calculated level is probably in the wrong well.
c
IF (NOWL.GT.0) THEN
BVDOUT = DABS(BV(KV) - BV(OWL(NOWL-1)))
ELSE
BVDOUT = 9999.9d0
END IF
IF (NIWL.GT.0) THEN
BVDIN = DABS(BV(KV) - BV(IWL(NIWL-1)))
ELSE
BVDIN = 9999.9d0
END IF
IF (INNER.EQ.0) THEN
IF ((NOWL.GT.0).AND.(BVDOUT.GT.(1.5d0*BVDIN))) THEN
IF (MCO.GE.1) THEN
WRITE(21,2113) KV,'Inner',NIWL,GV(KV)-VMIN,BV(KV)
END IF
IWL(NIWL) = KV
NIWL = NIWL + 1
ELSE
IF (MCO.GE.1) THEN
WRITE(21,2113) KV,'Outer',NOWL,GV(KV)-VMIN,BV(KV)
END IF
OWL(NOWL) = KV
NOWL = NOWL + 1
END IF
ELSE
IF ((NIWL.GT.0).AND.(BVDIN.GT.(1.5d0*BVDOUT))) THEN
IF (MCO.GE.1) THEN
WRITE(21,2113) KV,'Outer',NOWL,GV(KV)-VMIN,BV(KV)
END IF
OWL(NOWL) = KV
NOWL = NOWL + 1
ELSE
IF (MCO.GE.1) THEN
WRITE(21,2113) KV,'Inner',NIWL,GV(KV)-VMIN,BV(KV)
END IF
IWL(NIWL) = KV
NIWL = NIWL + 1
END IF
INNER = 0
END IF
c-----------------------------------------------------------------------
c** Now estimate trial energy for next higher vibrational energy level
c by using the Near-Dissociation Theory result that:
c
c (binding energy)**((NCN-2)/(2*NCN))
c
c is (at least locally) linear in vibrational quantum number.
c
IF (NF.EQ.1) THEN
VDMV = ZH/(((VMAX-VMIN)/(VMAX-GV(0)))**PWI - Z1)
ELSE
VDMV = Z1/(((VMAX-GV(NF-2))/(VMAX-GV(NF-1)))**PWI - Z1)
END IF
c
c** If unable to calculate the next trial energy, see if all of the
c desired levels have been calculated. If not then turn on the warning
c flag and quit, otherwise print out success message and quit.
c
IF ((VDMV.LT.Z1).AND.(NCN.GT.2)) THEN
IF (NF.LE.KVMAX) THEN
AFLAG = -1
WRITE(6,640) JROT, KV + VDMV
ELSEIF (AWO.GT.0) THEN
WRITE(6,630) KVMAX
END IF
GOTO 200
END IF
c
c** Now calculate the next trial energy.
c
EO = VMAX - (VMAX-GV(NF-1))*(Z1-Z1/VDMV)**PW
c
c** However, if the level is above the dissociation limit (for
c potentials with barriers) then use differences to calculate the
c next trial energy.
c
IF (EO.GT.VMAX) CALL DTENG(IEG,NF,NOWL,OWL,NVIBMX,VMIN,GV,EO)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** If the calculated vibrational level is higher then the next expected
c level, then try thrice to interpolate harmonically for the missed
c level.
c
c E(v) = E(v-1) + (E(KV) - E(v-1)) / 2
c
ELSEIF (KV.GT.NF) THEN
IF (IVCOR.GT.2) THEN
IF (AWO.NE.0) THEN
WRITE(6,610)
WRITE(6,612)
WRITE(6,624) IVCOR,KV,EO,(NF-1),GV(NF-1)
END IF
c
c** If interpolation fails, then try changing the wavefunction matching
c condition (INNER) to see if a possible second minimum contains the
c missing level.
c
IF (INNER.EQ.0) THEN
INNER = 1
CALL INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c
c** If both attempts fail, then print out warning message and exit the
c subroutine.
c
ELSE
AFLAG = -6
GOTO 200
END IF
END IF
IVCOR = IVCOR + 1
c
c** Use NDE theory to determine the missing level.
c
IF (NPMIN.EQ.1) THEN
VDU = (VPMAX(1)-EO)**PWI
VDL = (VPMAX(1)-GV(OWL(NOWL-1)))**PWI
EO = VPMAX(1) - (VDL + (VDU - VDL) / DBLE(KV - NF + 1))**PW
ELSEIF (((INNER.EQ.1).AND.(NIWL.GT.0)).OR.
1 ((INNER.EQ.0).AND.(NOWL.EQ.0))) THEN
VDU = (VPMAX(1)-EO)**PWI
VDL = (VPMAX(1)-GV(IWL(NIWL-1)))**PWI
EO = VPMAX(1) - (VDL + (VDU - VDL) / DBLE(KV - NF + 1))**PW
ELSEIF (((INNER.EQ.0).AND.(NOWL.GT.0)).OR.
1 ((INNER.EQ.1).AND.(NIWL.EQ.0))) THEN
VDU = (VPMAX(2)-EO)**PWI
VDL = (VPMAX(2)-GV(OWL(NOWL-1)))**PWI
EO = VPMAX(2) - (VDL + (VDU - VDL) / DBLE(KV - NF + 1))**PW
END IF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** If an unknown case occurs (quite impossible but don't quote me on
c it) then write out an error message and exit.
c
ELSE
IF (AWO.NE.0) THEN
WRITE(6,610)
WRITE(6,666) KV,NF
END IF
AFLAG = -7
GOTO 200
END IF
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Set KV to the next vibrational level to be found unless looking for
c the highest vibrational level.
c
IF (KV.NE.999) KV = NF
c
c** If still haven't found all of the vibrational levels then
c look for the next vibrational level.
c
IF ((KV.LE.KVMAX).OR.(KV.EQ.999)) GOTO 10
c
c** Otherwise, print out a message saying that all is well.
c
IF ((KV.GT.KVMAX).AND.(AWO.GT.0)) WRITE(6,630) KVMAX
c
c** If the potential has levels in a second minimum, then print out a
c list of those levels to channel-21 if desired.
c
IF ((NIWL.GT.0).AND.(NOWL.GT.0)) THEN
IF (MCO.GE.1) WRITE(21,2114) NIWL, NOWL
IF (AWO.NE.0) THEN
WRITE(6,605)
WRITE(6,607)
END IF
AFLAG = -8
END IF
c
c** If an error has occured, then set KVMAX to the quantum number of the
c highest vibrational level found and print out that quantum number
c and the energy of that level.
c
200 IF (AFLAG.LT.0) THEN
KVMAX = NF - 1
IF (AWO.NE.0) WRITE(6,626) KVMAX, GV(KVMAX)
END IF
IF (MCO.GE.1) WRITE(21,2100)
RETURN
c-----------------------------------------------------------------------
601 FORMAT(/' Solve by matching inward and outward solutions at')
602 FORMAT(' the outermost wave function maximum, S(max), where R = R
1R(M)')
603 FORMAT(' the innermost turning point R1 = R(M)')
605 FORMAT(/' *** ALF WARNING ***')
606 FORMAT(4X,'Next estimated trial energy E(v=',I3,') =',G15.8/4X,
1'is greater than the potential maximum VMAX =',G15.8)
607 FORMAT(4X,'Potential found to have a second minimum.')
610 FORMAT(/' *** ALF ERROR ***')
611 FORMAT(4X,'Attempt to find zero point level fails!')
612 FORMAT(4X,'Attempt to find next higher vibrational level fails!')
613 FORMAT(4X,'Number of vib levels requested=',i4,' exceeds internal
1ALF array dimension NVIBMX=',i4)
614 FORMAT(4X,'Unable to find a potential minimum.')
615 FORMAT(4X,'There are',I3,' potential ',A6,' in this potential.')
616 FORMAT(4X,'The potential turns over in the short range region at R
1 = ',G15.8)
617 FORMAT(4X,'VMAX =',G15.8,' found to be less than VMIN =',G15.8)
620 FORMAT(4X,'Use of energy ',I1,'0% up the potential well (E =',
1G15.8,')'/4X,' fails to produce a viable vibrational eigenstate.')
621 FORMAT(4X,'Use of differences to estimate the energy for the next'
1/4X,' vibrational level (v=',I3,') failed after',I3,' attempt.')
622 FORMAT(4X,'After',I3,' tries to harmonically estimate the zero-poi
1nt energy,'/4X,' initial trial energy',G15.8,' had yielded E(v
2=',I3,') =',G15.8)
623 FORMAT(4X,'Expecting to find level (v=',I3,') but found level (v='
1,I3,')')
624 FORMAT(4X,'After',I3,' tries, failed to interpolate trial energy b
1etween'/4X,'E(v=',I3,') =',G15.8,' and E(v=',I3,') =',G15.8)
626 FORMAT(4X,'The highest calculated level is E(v=',I3,') =',G15.8)
630 FORMAT(/' ALF successfully finds all vibrational levels up to KVMA
1X=',I3)
640 FORMAT(/' ALF finds all J=',i3,' vib. levels below vD=',F7.3,
1 ' estimated by N-D theory')
650 FORMAT(/' There were',I3,' potential minima found with the absolu
1te minimum'/4X,'VMIN =',G15.8,' cm-1.')
651 FORMAT(/' There were',I3,' potential maxima found with the absolu
1te maximum'/4X,'VMAX =',G15.8,' cm-1.')
666 FORMAT(4X,'Undefined case for automatic search.'/,4X,'Values of KV
1 =',I3,' and NF =',I3)
2100 FORMAT(/1X,39('=='))
2101 FORMAT(/1X,39('--'))
2110 FORMAT(/' Limits and increment of integration (in Angstroms):'
1 /' RMIN =',F6.3,' RMAX =',F7.3,' RH =',F9.6,
2 //' Generate BZ =',G19.12,' ((1/cm-1)(1/Angstroms**2))'
3 /' from ZMU:',F15.11,' (amu)')
2111 FORMAT(/' Eigenvalue convergence criterion is EPS =',G11.4,'(cm-
11)')
2112 FORMAT(/' Calculating properties of the potential described above.
1 '/' Use Airy function at 3-rd turning point as outer boundary'
2 /' condition for quasibound levels.')
2113 FORMAT(' v=',I3,4X,'v(',A5,')=',I3,4X,'Gv=',F16.9,4X,'Bv=',F16.12)
2114 FORMAT(/' Found',I4,' level(s) in the inner well and',I4,' level(s
1) in the outer well.')
END
c***********************************************************************
SUBROUTINE INITVAL(IQT,IVDIF,IZPE,IEG,IVCOR)
c***********************************************************************
c** This subroutine reinitializes the condition flags when considering a
c new case (found next vibrational level or finding level in inner
c well - INNER = 1).
c
c** On entry and exit:
c IQT Case when KV < 0 and NF = 0
c determines the value used for the initial trial energy.
c IVDIF Case when KV < 0 and NF > 0
c is the flag denoting the use of differences to calculate
c trial energies.
c IZPE Case when KV > 0 and NF = 0
c is the number of times the zero point energy (v = 0) has
c been estimated harmonically.
c IEG Case when KV < NF and NF > 0
c are the number of times that a larger trial energy is used
c to find the next level.
c IVCOR Case when KV > NF and NF > 0
c are the number of times that a smaller trial energy is used
c to find the next level.
c
INTEGER IZPE,IVDIF,IVCOR,IQT,IEG
c
IQT = 1
IVDIF = 0
IZPE = 0
IEG = 0
IVCOR = 0
RETURN
END
c***********************************************************************
SUBROUTINE DTENG(IEG,NF,NVEL,VEL,NVIBMX,VMIN,GV,EO)
c***********************************************************************
c** This subroutine calculates the next trial energy using differences.
c
c** On entry:
c IEG factor by which a larger trial energy should be calculated:
c NVEL = 2 : Increase correction by increments of 25%
c NVEL > 2 : Increase correction by increments of 50%
c NF is the highest calculated vibrational level.
c NVEL is the number of levels found in the potential well.
c VEL(v) keeps track of all levels in the potential well.
c NVIBMX is the maximum number of vibrational levels (dimension).
c VMIN is the absolute value of the potential minimum (cm-1).
c GV(v) contains the vibrational energy level spacings
c and rotational constants for each level (cm-1).
c
c** On exit:
c EO is the calculated trial energy.
c
INTEGER IEG,NF,NVEL,NVIBMX,VEL(0:NVIBMX)
c
REAL*8 VMIN,GV(0:NVIBMX),EO,ZQ,ZH,Z1,Z2
c
DATA ZQ/0.25D0/,ZH/0.5D0/,Z1/1.D0/,Z2/2.D0/
c
c** If determining the first (non-zero point energy) level in the well,
c then use the last determined level in the other well plus a larger
c than harmonic correction that becomes smaller with each new
c itteration.
c
c E(v=0) = E(v=NF-1) + (E(v=NF-1)-VMIN)/(NF-1+IEG/4)
c
IF (NVEL.EQ.0) THEN
EO = GV(NF-1) + (GV(NF-1) - VMIN)/(NF - 1 + ZQ*DBLE(IEG))
c
c** Try to get v = 1 using smaller-than-harmonic spacing.
c
c E(v=1) = E(v=0) + 1.3*(E(v=0)-VMIN)
c
ELSEIF (NVEL.EQ.1) THEN
EO = GV(VEL(0)) + 1.3d0*(GV(VEL(0))-VMIN)
c
c** Try to get v = 2 using a sequentially increasing correction.
c
c E(v=2) = E(v=1) + (0.8+IEG/4)*(E(v=1)-E(v=0))
c
ELSEIF (NVEL.EQ.2) THEN
EO = GV(VEL(1)) + (0.8d0+DBLE(IEG)*ZQ)*(GV(VEL(1))-GV(VEL(0)))
c
c** Try to get v > 2 using a sequentially increasing correction.
c
c E(v) = E(v-1) + (1.0+IEG/2)*(2.0*E(v-1)-3.0*E(v-2)+E(v-3))
c
ELSE
EO = GV(VEL(NVEL-1)) + (Z1+DBLE(IEG)*ZH)
1 *(Z2*GV(VEL(NVEL-1))-3.0d0*GV(VEL(NVEL-2))+GV(VEL(NVEL-3)))
END IF
RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
c****** R.J. Le Roy subroutine SCHRQ, last updated 16 May 2000 *******
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c COPYRIGHT 2000 by Robert J. Le Roy +
c Dept. of Chemistry, Univ. of Waterloo, Waterloo, Ontario, Canada +
c This software may not be sold or any other commercial use made +
c of it without the express written permission of the author. +
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** SCHRQ solves radial Schrodinger equation in dimensionless form
c d2WF/dR2 = - (E-V(R))*WF(R) , where WF(I) is the wave function.
c** Integrate by Numerov method over N mesh points with increment
c H=RH across range beginning at RMIN .
c** Input trial energy EO, eigenvalue convergence criterion EEPS
c potential asymptote VLIM, and all returned energies (EO, GAMA & VMAX)
c have units (cm-1).
c** On entry, the input potential V(I) must include the centrifugal
c term and the factor: 'BFCT'=2*mu*(2*pi*RH/hPLANCK)**2 (1/cm-1) ,
c which is also internally incorporated into EO, VLIM & EEPS.
c* Note that these reduced quantities (& the internal eigenvalue E)
c contain a factor of the squared integration increment RH**2 .
c This saves arithmetic work in the innermost loop of the algorithm.
c** For energy in (cm-1), BFCT=ZMU(u)*H(Angst)**2/16.85762908 (1/cm-1)
c** INNER specifies wave function matching (& initiation) condition *
c* For INNER = 0 , match inward & outward solutions at outermost
c wave function maximum; otherwise match at inner edge of classically
c allowed region. ** INNER<0 uses zero slope inner boundary condition.
c** For most normal cases set INNER=0 , but ......
c* to find "inner-well-dominated" solutions of an asymmetric double
c minimum potential, set INNER > 0 .
c* To find symmetric eigenfunctions of a symmetric potential, set
c INNER < 0 & start integration (set RMIN) at potential mid point.
c----------------------------------------------------------------------
SUBROUTINE SCHRQ(KV,JROT,EO,GAMA,VMAX,VLIM,V,WF,BFCT,EEPS,RMIN,
1 RH,N,NBEG,NEND,INNER,IWR,LPRWF)
c----------------------------------------------------------------------
c** Output vibrational quantum number KV, eigenvalue EO, normalized
c wave function WF(I), and range, NBEG .le. I .le. NEND over
c which WF(I) is defined. *** Have set WF(I)=0 outside this range.
c* (NBEG,NEND), defined by requiring abs(WF(I)) < RATST=1.D-9 outside.
c** If(LPRWF.gt.0) print wavefunction WF(I) every LPRWF-th point.
c* If(LPRWF.lt.0) "punch" (i.e., WRITE(10,XXX)) every |LPRWF|-th point
c of the wave function on disk starting at R(NBEG) with step size
c of IPSIQ=|LPRWF|*RH.
c** For energies above the potential asymptote VLIM, locate quasibound
c levels using Airy function boundary condition and return the level
c width GAMA and barrier height VMAX, as well as EO.
c** ERROR condition on return is KV < 0 ; usually KV=-1, but return
c KV=-2 if error appears to arise from too low trial energy.
c** If(IWR.ne.0) print error & warning descriptions
c If (IWR.gt.0) also print final eigenvalues & node count.
c If (IWR.ge.2) also show end-of-range wave function amplitudes
c If (IWR.ge.3) print also intermediate trial eigenvalues, etc.
c** If input KV.ge.998 , tries to find highest bound level, and
c trial energy should be only slightly less than VLIM.
c** If input KV < -10 , use log-derivative outer boundary condition at
c mesh point |KV| , based on incoming value of wave function WF(|KV|)
c and of the wavefunction derivative at that point, SPNEND, which is
c brought in as WF(|KV|-1). For a hard wall condition at mesh point
c |KV|, set WF(|KV|)=0 and WF(|KV|-1)= -1 before entry.
c----------------------------------------------------------------------
c++ "SCHRQ" calls subroutineas "QBOUND" and "WIDTH", and the latter
c++ calls "LEVQAD" .
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
INTEGER I,IBEGIN,ICOR,IJ,IJK,INNER,IPSID,IQTST,IT,ITER,ITP1,
1 ITP1P,ITP3,IWR,J,JJ,J1,J2,JPSIQ,JQTST,JROT,
2 KKV,KV,KVIN,LPRWF,M,MS,MSAVE,
3 N,NBEG,NBEGB,NBEG2,NDN,NEND,NENDCH,NLINES,NPR
REAL*8 BFCT,DE,DEP,DEPRN,DF,DOLD,DSOC,
2 E,EEPS,EO,EPS,F,FX,GAMA,GI,GN,H,H2,HT,PROD,PPROD,
3 RATIN,RATOUT,RATST,RH,RINC,RMIN,RMINN,RR,RSTT,RWR(20),
4 WF(N),SB,SI,SM,SN,SNEND,SPNEND,SRTGI,SRTGN,SWR(20),
5 V(N),VLIM,VMAX,VMX,VPR,
6 WKBTST,XEND,XPR,XPW,DXPW,Y1,Y2,Y3,YIN,YM,YOUT,
7 Z0,Z1,Z2,ZH
DATA Z0/0.D0/,ZH/0.5D0/,Z1/1.D0/,Z2/2.D0/
DATA RATST/1.D-9/,XPW/20.72d0/
DATA NDN/15/
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DXPW= (XPW+ 2.30d0)/NDN
KVIN= KV
KV= -1
RMINN= RMIN-RH
GAMA= Z0
VMAX= VLIM
VMX= VMAX*BFCT
H= RH
H2= H*H
HT= Z1/12.D+0
E= EO*BFCT
EPS= EEPS*BFCT
DSOC= VLIM*BFCT
DE= Z0
RATIN= Z0
RATOUT= Z0
IF(IWR.GT.2) THEN
IF(KVIN.GE.998) then
WRITE(6,610) EO
ELSE
WRITE(6,601) KVIN,JROT,EO,INNER
ENDIF
WRITE(6,602)
ENDIF
NEND= N
IF(KVIN.LT.-10) THEN
NEND= -KVIN
SNEND= WF(NEND)
SPNEND= WF(NEND-1)
ENDIF
JQTST = 0
c** Start iterative loop; try to converge for up to 15 iterations.
DO 90 IT= 1,15
ITER= IT
IF(INNER.NE.0) GO TO 38
10 IF(KVIN.LT.-10) THEN
c** If desired, (KVIN < -10) outer boundary set at NEND=|KVIN| and
c initialize wavefunction with log-derivative condition based on value
c WF(NEND) & derivative SPNEND at that mesh point (brought in in CALL)
GN= V(NEND)-E
GI= V(NEND-1)-E
SB= SNEND
SI= SB*(Z1+ ZH*GN)- RH*SPNEND
GO TO 24
END IF
IF(E.GE.DSOC) THEN
c** For quasibound levels, initialize wave function in "QBOUND"
CALL QBOUND(KVIN,JROT,E,EO,VMX,DSOC,V,RMIN,H,GN,GI,
1 SB,SI,N,ITP3,IWR,IQTST,BFCT,IT)
NEND= ITP3
VMAX= VMX/BFCT
IF(IQTST.GT.0) GO TO 24
IF(IQTST.LT.0) THEN
JQTST = JQTST+IQTST
IF((JQTST.LE.-2).OR.(VMAX.LT.VLIM)) GO TO 999
c** Try up to once to find level using trial value just below maximum
EO = VMAX-0.1D0
E = EO*BFCT
GO TO 90
ENDIF
GO TO 20
ENDIF
c** For E < DSOC begin inward integration by using JWKB to estimate
c optimum (minimum) inward starting point which will still give
c RATOUT < RATST = exp(-XPW) (ca. 1.d-9) [not needed after 1'st 2 ITER]
IF(ITER.LE.2) THEN
NEND= N
c ... first do rough inward search for outermost turning point
DO M= N,1,-NDN
MS= M
GI= V(M)- E
IF(GI.LE.0.D0) GO TO 12
GN= GI
ENDDO
IF(IWR.NE.0) WRITE(6,611)
GO TO 999
12 IF(MS.GE.N) GO TO 998
FX= GN/(GI-GN)
SM= ZH*(Z1+ FX)*DSQRT(GN)
MS= MS+ 2*NDN
IF(MS.GE.N) GO TO 20
c ... now integrate exponent till JWKB wave fx. would be negligible
DO M= MS,N,NDN
NEND= M
SM= SM+ DSQRT(V(M)- E)
IF(SM.GT.DXPW) GO TO 18
ENDDO
18 IF(NEND.LT.N) NEND= NEND+ NDN
ENDIF
c** For truly bound state initialize wave function as 1-st order WKB
c solution increasing inward
20 GN= V(NEND)- E
GI= V(NEND-1)- E
MS= NEND-1
IF(GI.LT.0.d0) GO TO 998
SRTGN= DSQRT(GN)
SRTGI= DSQRT(GI)
SB= Z1
SI= SB*DSQRT(SRTGN/SRTGI)*DEXP((SRTGN+SRTGI)/Z2)
IF(SB.GT.SI) THEN
c WOOPS - JWKB gives inward DEcreasing solution, so initialize with node
IF(IWR.NE.0) WRITE(6,618) JROT,EO,SB/SI
SI= Z1
SB= Z0
ENDIF
24 M= NEND-1
Y1= (Z1-HT*GN)*SB
Y2= (Z1-HT*GI)*SI
WF(NEND)= SB
WF(NEND-1)= SI
MS= NEND
NENDCH= NEND
IBEGIN= 3
IF(INNER.NE.0) IBEGIN= ITP1+2
c** Actual inward integration loop starts here
DO I= IBEGIN,NEND
M= M-1
Y3= Y2+Y2-Y1+GI*SI
GI= V(M)-E
SB= SI
SI= Y3/(Z1-HT*GI)
WF(M)= SI
IF(DABS(SI).GE.1.D+17) THEN
c** Renormalize to prevent overflow of WF(I) in classically
c forbidden region where (V(I) .gt. E)
SI= Z1/SI
DO J= M,MS
WF(J)= WF(J)*SI
ENDDO
NENDCH= MS
MS= M
Y2= Y2*SI
Y3= Y3*SI
SB= SB*SI
SI= Z1
ENDIF
Y1= Y2
Y2= Y3
c** Test for outermost maximum of wave function.
cc IF((INNER.EQ.0).AND.(SI.LE.SB)) GO TO 32
c** Test for outer well turning point
IF((INNER.EQ.0).AND.(GI.lt.0.d0)) GO TO 32
ENDDO
IF(INNER.EQ.0) THEN
c** Error mode ... find no wave function maximum.
KV= -2
IF(IWR.NE.0) WRITE(6,616) KV,JROT,EO
GO TO 999
ENDIF
c** Scale outer part of wave function before proceding
32 SI= Z1/SI
MSAVE= M
RR= RMINN+MSAVE*H
YIN= Y1*SI
RATOUT= WF(NEND)*SI
NEND= NENDCH
DO J= MSAVE,NEND
WF(J)= WF(J)*SI
ENDDO
IF(INNER.NE.0) GO TO 70
c-------------------------------------------------------------------
c** Set up to prepare for outward integration **********************
38 NBEG= 1
IF(INNER.LT.0) THEN
c** Option to initialize with zero slope at beginning of the range
SB= Z1
GN= V(1)-E
Y1= SB*(Z1-HT*GN)
Y2= Y1+GN*SB/Z2
GI= V(2)-E
SI= Y2/(Z1-HT*GI)
ELSE
c** Initialize outward integration with a node at beginning of range
40 GN= V(NBEG)-E
IF(GN.GT.10.D0) THEN
c** If potential has [V(1)-E] so high that H is (locally) much too
c large, then shift inner starting point outward.
NBEG= NBEG+1
IF(NBEG.LT.N) GO TO 40
IF(IWR.NE.0) WRITE(6,613)
GO TO 999
ENDIF
IF((ITER.LE.1).AND.(IWR.NE.0)) THEN
IF(NBEG.GT.1) WRITE(6,609) JROT,EO,NBEG
IF(GN.LE.Z0) WRITE(6,604) JROT,EO,E,V(NBEG),NBEG
ENDIF
c** Initialize outward wave function with a node: WF(NBEG) = 0.
SB= Z0
SI= Z1
GI= V(NBEG+1)-E
Y1= SB*(Z1-HT*GN)
Y2= SI*(Z1-HT*GI)
ENDIF
c
WF(NBEG)= SB
WF(NBEG+1)= SI
NBEGB= NBEG
NBEG2= NBEG+2
IF(INNER.NE.0) MSAVE= N
c** Actual outward integration loops start here
DO I= NBEG2,MSAVE
Y3= Y2+Y2-Y1+GI*SI
GI= V(I)-E
SI= Y3/(Z1-HT*GI)
WF(I)= SI
IF(DABS(SI).GE.1.D+17) THEN
c** Renormalize to prevent overflow of WF(I) in classically forbidden
c region where V(I) .gt. E
SI= Z1/SI
NBEG= NBEGB
DO J= NBEG,I
WF(J)= WF(J)*SI
ENDDO
NBEGB= I
Y2= Y2*SI
Y3= Y3*SI
SI= Z1
ENDIF
Y1= Y2
Y2= Y3
ITP1= I
c** Exit from this loop at onset of classically allowed region
IF(GI.LE.Z0) GO TO 52
ENDDO
MS= MSAVE
IF((INNER.EQ.0).AND.(GN.LE.Z0)) GO TO 60
IF(IWR.NE.0) WRITE(6,612) KVIN,JROT,EO,MSAVE
GO TO 999
52 ITP1P= ITP1+1
MS= ITP1
IF(INNER.NE.0) GO TO 60
DO I= ITP1P,MSAVE
Y3= Y2+Y2-Y1+GI*SI
GI= V(I)-E
SI= Y3/(Z1-HT*GI)
WF(I)= SI
IF(DABS(SI).GT.1.D+17) THEN
c** Renormalize to prevent overflow of WF(I) , as needed.
SI= Z1/SI
NBEG= NBEGB
DO J= NBEG,I
WF(J)= WF(J)*SI
ENDDO
NBEGB= I
Y2= Y2*SI
Y3= Y3*SI
SI= Z1
ENDIF
Y1= Y2
Y2= Y3
ENDDO
MS= MSAVE
c** Finished outward integration. Normalize w.r.t. WF(MSAVE)
60 SI= Z1/SI
YOUT= Y1*SI
YM= Y2*SI
RATIN= WF(NBEG+1)*SI
DO I= NBEG,MS
WF(I)= WF(I)*SI
ENDDO
IF(INNER.NE.0) GO TO 10
c----- Finished numerical integration ... now correct trial energy
c** DF*H is the integral of (WF(I))**2 dR
70 DF= Z0
DO J= NBEG,NEND
DF= DF+WF(J)**2
ENDDO
c** Add edge correction to DF assuming wave function dies off as simple
c exponential past R(NEND); matters only if WF(NEND) unusually large.
IF((E.LE.DSOC).AND.(WF(NEND).NE.0)) THEN
IF((KVIN.GE.-10).AND.(WF(NEND-1)/WF(NEND).GT.Z1))
1 DF= DF+ WF(NEND)**2/(Z2*DLOG(WF(NEND-1)/WF(NEND)))
ENDIF
F= (-YOUT-YIN+Z2*YM+GI)
DOLD= DE
IF(DABS(F).LE.1.D+30) THEN
DE= F/DF
ELSE
F= 9.9D+30
DF= F
DE= DABS(0.01D+0 *(DSOC-E))
ENDIF
IF(IWR.GT.2) THEN
DEPRN = DE/BFCT
XEND= RMINN+NEND*H
c** RATIN & RATOUT are wave fx. amplitude at inner/outer ends of range
c relative to its value at outermost extremum.
WRITE(6,603) IT,EO,F,DF,DEPRN,MSAVE,RR,RATIN,RATOUT,
1 XEND,NBEG,ITP1
ENDIF
c** Test trial eigenvalue for convergence
IF(DABS(DE).LE.DABS(EPS)) GO TO 100
E= E+DE
c** KV.ge.998 Option ... Search for highest bound level. Adjust new
c trial energy downward if it would have been above dissociation.
IF((KVIN.GE.998).AND.(E.GT.VMX)) E= VMX- 2.d0*(VMX-E+DE)
EO= E/BFCT
IF((IT.GT.4).AND.(DABS(DE).GE.DABS(DOLD)).AND.
1 ((DOLD*DE).LE.Z0)) THEN
c** Adjust energy increment if having convergence difficulties. Not
c usually needed except for some quasibounds extremely near VMAX .
ICOR= ICOR+1
DEP= DE/BFCT
IF(IWR.NE.0) WRITE(6,617) IT,DEP
DE= ZH*DE
E= E-DE
EO= E/BFCT
ENDIF
90 CONTINUE
c** End of iterative loop which searches for eigenvalue ************
c-------------------------------------------------------------------*
c** Convergence fails, so return in error condition
E= E-DE
EO= E/BFCT
DEPRN= DE/BFCT
IF(IWR.NE.0) WRITE(6,620) KVIN,JROT,ITER,DEPRN
GO TO 999
100 IF(IWR.NE.0) THEN
IF(IWR.GE.3) WRITE(6,619)
IF((DABS(RATIN).GT.RATST).AND.(INNER.GE.0))
1 WRITE(6,614) JROT,EO,RATIN
IF((E.LT.DSOC).AND.(DABS(RATOUT).GT.RATST)) THEN
WKBTST= ZH*DABS(V(NEND)-V(NEND-1))/DSQRT((V(NEND)-E)**3)
IF(WKBTST.GT.1.d-3)WRITE(6,615)JROT,EO,RATOUT,RATST,WKBTST
ENDIF
ENDIF
KKV = 0
c** Perform node count on converged solution
PROD= WF(ITP1)*WF(ITP1-1)
J1= ITP1+1
J2= NEND-1
DO J= J1, J2
PPROD= PROD
PROD= WF(J)*WF(J-1)
IF((PPROD.LE.Z0).AND.(PROD.GT.Z0)) KKV= KKV+1
ENDDO
KV = KKV
c** Normalize & find interval (NBEG,NEND) where WF(I) is non-negligible
SN= Z1/DSQRT(H*DF)
DO I= NBEG,NEND
WF(I)= WF(I)*SN
ENDDO
IF(ITP1.LE.1) GO TO 122
J= ITP1P
DO I= 1,ITP1
J= J-1
IF(DABS(WF(J)).LT.RATST) GO TO 119
ENDDO
119 NBEG= J
IF(NBEG.LE.1) GO TO 122
J= J-1
DO I= 1,J
WF(I)= Z0
ENDDO
122 IF(KVIN.GE.-10) THEN
c** For "non-wall" cases, move NEND inward to where wavefunction
c "non-negligible"
J= NEND-1
DO I= NBEG,NEND
IF(DABS(WF(J)).GT.RATST) GO TO 126
J= J-1
ENDDO
126 NEND= J+1
END IF
IF(NEND.LT.N) THEN
c** Zero out wavefunction array at distances past NEND
DO I= NEND+1,N
WF(I)= Z0
ENDDO
ENDIF
IF(LPRWF.LT.0) THEN
c** If desired, write every |LPRWF|-th point of the wave function
c to a file on channel-10, starting at the NBEG-th mesh point.
JPSIQ= -LPRWF
NPR= 1+(NEND-NBEG)/JPSIQ
RINC= RH*JPSIQ
RSTT= RMINN+NBEG*RH
c** Write every JPSIQ-th point of the wave function for level v=KV
c J=JROT , beginning at mesh point NBEG & distance RSTT where
c the NPR values written separated by mesh step RINC=JPSIQ*RH
WRITE(10,701) KV,JROT,EO,NPR,RSTT,RINC,NBEG,JPSIQ
WRITE(10,702) (RMINN+I*RH,WF(I),I=NBEG,NEND,JPSIQ)
GO TO 140
ENDIF
c** Print solutions every LPRWF-th point, 6 to a line, in columns.
IF(LPRWF.GT.0) THEN
NLINES= ((1+(NEND-NBEG)/LPRWF)+3)/4
IPSID= LPRWF*NLINES
WRITE(6,605) KV,JROT,EO
DO J= 1,NLINES
JJ= NBEG+(J-1)*LPRWF
IJK= 0
DO IJ= JJ,NEND,IPSID
IJK= IJK+1
RWR(IJK)= RMINN+IJ*H
SWR(IJK)= WF(IJ)
ENDDO
WRITE(6,606) (RWR(I),SWR(I),I= 1,IJK)
ENDDO
ENDIF
140 IF(IWR.EQ.1) WRITE(6,607) KV,JROT,EO
cc
cc IF(IWR.NE.0) WRITE(6,699) rminn+itp1*rh,eO,rminn+msave*rh,eo
cc699 format(' & turning points:',2(f8.5,f11.4))
cc
IF(IWR.GE.2) WRITE(6,607) KV,JROT,EO,ITER,RR,RATIN,RATOUT
c** For quasibound levels, calculate width in subroutine "WIDTH"
IF((E.GT.DSOC).AND.(KVIN.GT.-10)) CALL WIDTH(KV,JROT,E,EO,DSOC,
1 V,WF,VMX,RMIN,H,BFCT,IWR,ITP1,ITP3,INNER,N,GAMA)
RETURN
c** ERROR condition if E.gt.V(R) at outer end of integration range.
998 XPR= RMINN+MS*H
VPR= V(MS)/BFCT
IF(IWR.NE.0) WRITE(6,608) EO,MS,VPR,XPR,IT
c** Return in error mode
999 KV= -1
RETURN
601 FORMAT(/' Solve for v=',I3,' J=',I3,' ETRIAL=',1PD15.7,
1 ' INNER=',i2,' WF(1st) WF(NEND)' )
602 FORMAT(' ITER ETRIAL',8X,'F(E) DF(E) D(E)',
1 5X,'M R(M) /WF(M) /WF(M) R(NEND) NBEG ITP1'/
2 1X,96('-'))
603 FORMAT(I4,1PD15.7,3D10.2,I5,0PF7.3,1P2D9.1,0PF8.2,I4,I5)
604 FORMAT(' NOTE: for J =',I3,' EO =',F12.4,' E=',D13.6,
1 ' .ge. V(R)=',D13.6,' at initial mesh point',I6)
605 FORMAT(/' Solution of radial Schr. equation for E(v=',I3,',J=',
1 I3,') =',F15.7/2x,4(' R(I) WF(I) ')/2X,38('--') )
606 FORMAT(2X,4(F8.3,F11.7))
607 FORMAT('E(v=',I3,',J=',I3,')=',F11.4,1x,I3,' Iterations',
1 ' R(M)=',F6.3,' WF(NBEG)/WF(M)=',1PD8.1/
2 57x,'WF(NEND)/WF(M)=',D8.1)
608 FORMAT(' *** SCHRQ Error: E=',F9.2,' > V(',I5,')=',F9.2,
1 ' at Rmax=',F6.2,' for IT=',I2)
609 FORMAT(' *** For J=',I3,' E=',1PD15.7," integration can't",
1 ' start till past mesh'/37x,'point',I5,', so RMIN smaller than n
2eeded')
610 FORMAT(/' Attempt to find the highest bound level starting from',
1 ' ETRIAL =',1PD9.2)
611 FORMAT(' *** SCHRQ Error: inward search at E=',f9.2,
1 ' finds no classical region')
612 FORMAT(/' *** ERROR *** for v =',I3,' J =',I3,' E =',
1 F12.4,' Innermost turning point not found by M = MSAVE =',I5)
613 FORMAT(/' *** ERROR in potential array ... V(I) everywhere',
1 ' too big to integrate with given increment')
614 FORMAT(' *** CAUTION *** For J=',I3,' E=',G15.8/16x,
1 'WF(first)/WF(Max)=',D9.2,' suggests RMIN may be too large')
615 FORMAT(' ** CAUTION ** For J=',I3,' E=',1PD13.6,
1 ' WF(NEND)/WF(Max)=',D8.1,' >',D8.1/4X,'& initialization ',
2 'quality test ',1PD8.1,' > 1.D-3 so RMAX may be too small')
616 FORMAT(' ** WARNING *** For v=',I2,', J=',I3,' at E=',
1 G14.7,' WF always has negative slope ... Energy too low or poten
2tial too weak' )
617 FORMAT(' *** SCHRQ has a convergence problem, so for IT=',I2,
1 ' cut DE=',1PD10.2,' in HALF' )
618 FORMAT(' *** For J=',I3,' E=',F9.2,' JWKB start gives SB/SI=',
1 1PD10.3,' so use a node.')
619 FORMAT(1X,96('-'))
620 FORMAT(' *** CAUTION for v=',I3,' J=',I3," SCHRQ doesn't conver
1ge by ITER=",I2,' DE=',1PD9.2)
701 FORMAT(/2x,'Level v=',I3,' J=',I3,' E=',F12.4,' , wave funct
1ion at',I6,' points.'/7x,'R(1-st)=',F12.8,' mesh=',F12.8,
2 ' NBEG=',I4,' |LPRWF|=',I3)
702 FORMAT((1X,4(f9.4,f10.6)))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c*******************************************************************
SUBROUTINE QBOUND(KV,JROT,E,EO,VMX,DSOC,V,RMIN,H,GB,GI,SB,SI,N,
1 ITP3,IWR,IQTST,BFCT,IT)
c*******************************************************************
c** Subroutine to initialize quasibound level wave function as Airy
c function at third turning point (if possible). For the relevant
c theory see: Le Roy & Bernstein, J.Chem.Phys. 54, 5114 (1971) and
c Le Roy & Liu, J.Chem.Phys.69,3622-31 (1978).
c----------------------------------------------------------------------
c** IQTST is error flag. *** If (IQTST.lt.0) initialization fails
c so eigenvalue calculation aborts *** (IQTST.gt.0) for successful
c Airy function initialization. *** (IQTST=0) if Airy function
c initialization prevented because 3-rd turning point beyond
c range, so that WKB initialization is used.
c----------------------------------------------------------------------
INTEGER I,II,IQTST,IT,ITP3,IWR,J,JROT,K,KV,N
REAL*8 A1,A2,A13,A23,BFCT,
1 C1A,C2A,DF,DSOC,E,EO,FBA,FIA,FJ,GB,GBA,GI,GIA,H,
2 RMIN,RMINN,SB,SI,SL,V(N),VMX,VMXPR,XJ1, Z1,Z3,Z6
DATA Z1/1.D0/,Z3/3.D0/
1 Z6/6.D0/,C1A/0.355028053887817D0/,C2A/0.258819403792807D0/
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
IQTST=1
RMINN=RMIN-H
c** Start by searching for third turning point.
J=N
IF(V(N).GT.E) GO TO 22
DO I=2,N
J=J-1
IF(V(J).GT.E) GO TO 10
ENDDO
GO TO 14
c** Check that there is a classically allowed region inside this point
c and determine height of barrier maximum.
10 II=J
VMX=DSOC
DO I=2,J
II=II-1
IF(V(II).LE.E) GO TO 16
IF(V(II).GT.VMX) VMX=V(II)
ENDDO
c** Energy too high ... find no more than one turning point.
14 XJ1=RMINN+J*H
c ... Search outward for barrier height to facilitate energy correction
IF(J.EQ.1) J= 2
K=J-1
DO I=J,N
IF(V(I).GT.V(K)) GO TO 120
K=I
ENDDO
VMX=V(K)
GO TO 130
120 K=K+2
J=K-1
DO I=K,N
IF(V(I).LT.V(J)) GO TO 126
J=I
ENDDO
126 VMX=V(J)
130 VMXPR=VMX/BFCT
IF(IWR.NE.0) WRITE(6,608) JROT,EO,VMXPR,XJ1
ITP3= J
IQTST=-1
GO TO 100
16 ITP3= J+1
c** ITP3 is the first mesh point outside classically forbidden region
GB=V(ITP3)-E
GI=V(ITP3-1)-E
FJ=GI/(GI-GB)
c** Treat quasibound levels as bound using outer boundary condition
c of Airy function at third turning point ... as discussed by
c R.J.Le Roy and R.B.Bernstein in J.Chem.Phys. 54,5114(1971).
SL=(GI-GB)**(Z1/Z3)/H
IF((SL*H).LT.Z1) THEN
A1=GI/(SL*H)**2
A2=GB/(SL*H)**2
A13=A1*A1*A1
A23=A2*A2*A2
FIA=Z1+A13*(A13*(A13+72.D0)+2160.D0)/12960.D0
GIA=A1+A1*A13*(A13*(A13+90.D0)+3780.D0)/45360.D0
FBA=Z1+A23*(A23*(A23+72.D0)+2160.D0)/12960.D0
GBA=A2+A2*A23*(A23*(A23+90.D0)+3780.D0)/45360.D0
c** Airy function Bi(X) at points straddling 3-rd turning point
SI=C1A*FIA+C2A*GIA
SB=C1A*FBA+C2A*GBA
GO TO 100
ENDIF
c** If Airy function expansion unreliable, use zero slope at third
c turning point as quasibound outer boundary condition.
DF=GI-GB
SI=Z1+DF*FJ**3/Z6
SB=Z1-DF*(Z1-FJ)**3/Z6
IF(IWR.NE.0) WRITE(6,606) KV,JROT,EO,IT
GO TO 100
c** If 3-rd turning point beyond range start with WKB wave function
c at end of range.
22 IF(IWR.NE.0) WRITE(6,607) JROT,EO
ITP3= N
IQTST=0
GB=V(ITP3)-E
GI=V(ITP3-1)-E
VMX=V(ITP3)
II=ITP3
DO I=2,ITP3
II=II-1
IF(V(II).LT.VMX) GO TO 100
VMX=V(II)
ENDDO
IF(IWR.NE.0) WRITE(6,604)
c** End of quasibound level initialization schemes.
IQTST=-9
100 RETURN
604 FORMAT(" **** QBOUND doesn't work ... no classically allowed regio
1n accessible at this energy.")
606 FORMAT(' *** CAUTION *** v=',I3,' J=',I3,' E=',1PD13.6,
1 ' IT=',I2/5x,'Airy initialization unstable so use zero slope',
2 'at R(3-rd)' )
607 FORMAT(' *** For J=',I3,' E=',F9.2,
1 ' R(3-rd) > RMAX & E < V(N) so try WKB B.C. @ RMAX')
608 FORMAT(' For J=',I3,' ETRY=',F11.4,' > VMAX=',F11.4,
1 ' find onee turn point: R=',F6.2)
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
c** Subroutine to calculates quasibound level tunneling lifetime/width
c** For relevant theory see Le Roy & Liu [J.Chem.Phys.69,3622-31(1978)]
c and Connor & Smith [Mol.Phys. 43, 397 (1981)].
c** Final level width calculation from Eq.(4.5) of Connor & Smith.
c-----------------------------------------------------------------------
SUBROUTINE WIDTH(KV,JROT,E,EO,DSOC,V,S,VMX,RMIN,H,BFCT,IWR,ITP1,
1 ITP3,INNER,N,GAMA)
c++ "WIDTH" calls subroutine "LEVQAD" ++++++++++++++++++++++++++++++++++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
INTEGER I,IMM,INNER,IRM,ITP1,ITP1P,ITP1P1,ITP2,ITP2M,ITP2M2,
1 ITP2P1,ITP2P2,ITP3,IWR,JROT,KV,KVI,KVO,
2 M,M2,N,NN,NST
REAL*8 AA,ANS1,ANS2,ARG,BFCT,COR,
1 D1,D2,D3,DFI,DSGB,DSGN,DSOC,DWEB,OMEGJC,
2 E,EO,EMSC,EMV,FJNLC,G1,G2,G3,GA,GAMA,GAMALG,
3 H,H2,HBW,HBWB,PI,PMX,RMIN,RMINN,RMX,RT,RT1,RT2,
4 S(N),SM,TAU,TAULG,TI,TUN0,TNUM,U1,U2,V(N),VMAX,VMX,
7 XJ,XX,Z0,Z1,Z2,Z4,ZH
CHARACTER*5 LWELL(2)
DATA Z0/0.D0/,ZH/0.5D0/,Z1/1.D0/,Z2/2.D0/,Z4/4.D0/,
1 PI/3.141592653589793D0/
DATA LWELL/'INNER','OUTER'/
RMINN=RMIN-H
H2=H*H
c** ITP1 is first mesh point to right of innermost turning point.
40 ITP1P=ITP1+1
ITP1P1=ITP1P+1
IRM=ITP1-1
c** Calculate JWKB tunneling probability from quadrature over barrier
c** First must locate 2-nd turning point.
DO I=ITP1P1,ITP3
ITP2=I
IF(V(I).GT.E) GO TO 202
ENDDO
GAMA=Z0
GO TO 250
202 ITP2P1=ITP2+1
ITP2P2=ITP2+2
c** ITP2M is the last mesh point before the 2-nd turning point.
ITP2M=ITP2-1
ITP2M2=ITP2-2
G1=V(ITP2M)-E
G2=V(ITP2)-E
GA=V(ITP2P1)-E
c** Quadrature over barrier starts here.
CALL LEVQAD(G1,G2,GA,H,RT,ANS1,ANS2)
SM=ANS2/H
IF(GA.LT.Z0) GO TO 218
SM=SM+ZH*DSQRT(GA)
PMX=VMX
M2=ITP2P2
204 DO I=M2,ITP3
M=I
GA=V(I)-E
IF(V(I).GT.PMX) PMX=V(I)
IF(GA.LT.Z0) GO TO 210
SM=SM+DSQRT(GA)
ENDDO
IF(V(M).GT.V(M-1)) THEN
IF(IWR.NE.0) WRITE(6,602) KV,JROT
GO TO 250
ENDIF
RMX=RMINN+M*H
U1=DSQRT(GA/(V(M)-DSOC))
U2=DSQRT((E-DSOC)/(V(M)-DSOC))
SM=SM-ZH*DSQRT(GA) + (DLOG((Z1+U1)/U2)-U1)*RMX*DSQRT(V(M)-DSOC)/H
XJ=(DSQRT(Z1+Z4*(V(M)-DSOC)*(RMX/H)**2)-Z1)/Z2
IF(IWR.NE.0) WRITE(6,603) JROT,EO,XJ,RMX
GO TO 218
210 IF(M.LT.ITP3) THEN
c** If encounter a double-humped barrier, take care here.
IF(IWR.NE.0) WRITE(6,609) KV,JROT,EO,M
KVO=0
DSGN=DSIGN(Z1,S(M-1))
c** Find the effective quantum number for the outer well
DO I=M,ITP3
DSGB=DSGN
DSGN=DSIGN(Z1,S(I))
IF((DSGN*DSGB).LT.Z0) KVO=KVO+1
ENDDO
KVI=KV-KVO
IF(INNER.EQ.0) THEN
c** For levels of outer well, get correct width by changing ITP1
ITP1=M
IF(IWR.GT.0) WRITE(6,610) KVO,LWELL(2)
GO TO 40
ENDIF
IF(IWR.GT.0) WRITE(6,610) KVI,LWELL(1)
c** For "inner-well" levels, locate outer barrier
DO I=M,ITP3
M2=I
GA=V(I)-E
IF(GA.GE.Z0) GO TO 204
ENDDO
GO TO 218
ENDIF
G3=V(M-2)-E
G2=V(M-1)-E
CALL LEVQAD(GA,G2,G3,H,RT,ANS1,ANS2)
SM= SM- ZH*DSQRT(G3)-DSQRT(G2) + ANS2/H
218 EMSC= -SM/PI
IF(INNER.NE.0) VMX= PMX
VMAX= VMX/BFCT
c** Tunneling factors calculated here ** TUN0 is simple WKB result
c as in Child's eqs.(57c) & (59).
TUN0= Z0
IF(DABS(EMSC).LT.25.D0) TUN0= ZH*DEXP(Z2*PI*EMSC)
c ... for permeability calculate Connor-Smith's Eq.(3.7) \omega=OMEGJC
FJNLC= DSQRT(Z1+ Z2*TUN0)
OMEGJC= FJNLC- Z1
IF(TUN0.LT.1.D-6) OMEGJC= TUN0
OMEGJC= OMEGJC/(FJNLC+ 1.d0)
c** Quadrature for JWKB calculation of vibrational spacing in well HBW
D1=E-V(IRM)
D2=E-V(ITP1)
D3=E-V(ITP1P)
CALL LEVQAD(D1,D2,D3,H,RT,ANS1,ANS2)
RT1=RT
SM=ANS1/H
IF(D3.LT.Z0) GO TO 228
SM=SM+ZH/DSQRT(D3)
DO I=ITP1P1,ITP2M2
IMM=I
EMV=E-V(I)
IF(EMV.LT.Z0) GO TO 222
SM=SM+Z1/DSQRT(EMV)
ENDDO
D3=E-V(ITP2M2)
D2=E-V(ITP2M)
D1=E-V(ITP2)
GO TO 226
c** If encounter a double-minimum well, take care here.
222 D1=EMV
D2=E-V(IMM-1)
D3=E-V(IMM-2)
IF(IWR.NE.0) WRITE(6,605) KV,JROT,EO
226 CALL LEVQAD(D1,D2,D3,H,RT,ANS1,ANS2)
RT2=RT
SM=SM-ZH/DSQRT(D3) + ANS1/H
c** Get HBW in same energy units (1/cm) associated with BFCT
228 HBW=Z2*PI/(BFCT*SM)
c** HBW fix up suggested by Child uses his eqs.(48)&(62) for HBW
AA= DLOG(DABS(EMSC))
TNUM= Z1/EMSC
c** Derivative of complex gamma function argument calculated as
c per eq.(6.1.27) in Abramowitz and Stegun.
ARG= Z2/((ZH/EMSC)**2+Z1)
NST= DABS(EMSC)*1.D2
NST= MAX0(NST,4)
DO I= 1,NST
NN= I
XX= (ZH+NN)/EMSC
TI= TNUM/(XX*(XX**2+Z1))
ARG= ARG+TI
IF(DABS(TI).LT.1.D-10) GO TO 233
ENDDO
233 COR= ZH*(EMSC/(NN+Z1))**2
ARG= ARG+COR-COR**2
DWEB= (EO-VMAX)*BFCT/(H2*EMSC)
DFI= (AA + 1.96351002602134D0-ARG)*BFCT/(H2*DWEB)
HBWB= Z1/(Z1/HBW + DFI/(Z2*PI))
c** Width from formula (4.5) of Connor & Smith, Mol.Phys.43,397(1981)
c [neglect time delay integral past barrier in their Eq.(4.16)].
IF(EMSC.GT.-25.D0) THEN
GAMA = (HBWB/(Z2*PI))*Z4*OMEGJC
TAU= 0.D0
IF(GAMA.GT.1.D-60) TAU= 5.308837457D-12/GAMA
c** GAM0 = TUN0*HBW/PI is the simple WKB width GAMMA(0) discussed by
c Le Roy & Liu in J.C.P.69,3622(1978).
IF(IWR.GT.0) WRITE(6,601) TAU,GAMA,HBWB,VMAX
GO TO 250
ENDIF
GAMALG= DLOG10(HBWB/(Z2*PI))+Z2*PI*EMSC/2.302585093D0
TAULG= DLOG10(5.308837457D-12)-GAMALG
IF(IWR.GT.0) WRITE(6,611) TAULG,GAMALG,HBWB,VMAX
250 RETURN
601 FORMAT(' Lifetime=',1PD10.3,'(s) Width=',D10.3,' dG/dv=',
1 0PF7.2,' V(max)=',F9.2)
602 FORMAT(' *** WARNING *** For v =',I3,' J =',I3,' cannot cal
1culate width since barrier maximum beyond range')
603 FORMAT(' *** For J=',I3,' E=',F9.2,' R(3-rd) beyond range so tu
1nneling calculation uses'/8X,'pure centrifugal potential with J(a
2pp)=',F7.2,' for R > R(max)=',F7.2)
605 FORMAT(' **** CAUTION *** Width estimate only qualitative, as have
1 a double-minimum well for E(v=',I3,', J=',I3,')=',F15.7/15X,
2 'a more stable result may be obtained by searching for the quasib
3ound levels using option: INNER > 0 .')
609 FORMAT(' *** CAUTION - Permeability estimate not exact as have a d
1ouble-humped barrier: E(v=',I3,', J=',I3,') =',G15.8,I6)
610 FORMAT(16X,'(NOTE: this has the node count of a v=',I3,2X,A5,
1 '-well level')
611 FORMAT(12X,'Log10(lifetime/sec)=',F10.5,' ; Log10(width/cm-1)=',
1 F10.5,' Spacing=',G12.5,' V(max)=',G14.7,'(cm-1)')
END
c**********************************************************************
SUBROUTINE LEVQAD(Y1,Y2,Y3,H,RT,ANS1,ANS2)
c** Subroutine "LEVQAD" fits quadratic Y = A + B*X + C*X**2 through
c function values Y1, Y2, Y3 at equally spaced points separated by
c distance H, where Y1 < 0 and (Y2,Y3 .ge.0), locates the function
c zero (at RT, relative to X1 < X2 = 0) between points X1 & X2, and
c evaluates the integral from RT to R3 of 1/sqrt(Y) , called
c ANS1, and the integral (same range) of sqrt(Y) , which is ANS2
c** Alternately, if Y1 & Y3 both < 0 and only the middle point
c Y2.ge.0 , fit the points to: Y = A - B*(X-X0)**2 , locate the
c turning points between which Y(X) > 0 and evaluate these integrals
c on this interval. *************************************************
c----------------------------------------------------------------------
REAL*8 A,ANS1,ANS2,B,C,CQ,H,HPI,R1,R2,RCQ,RR,RT,SL3,SLT,
1 X0,Y1,Y2,Y3,Z0,Z1,Z2,Z4,ZT
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
IF((Y1.GE.0).OR.(Y2.LT.0)) GO TO 99
DATA Z0/0.D0/,Z1/1.D0/,Z2/2.D0/,Z4/4.D0/,HPI/1.570796326794896D0/
IF(Y3.LT.Z0) GO TO 50
c** Here treat case where both 'Y2' & 'Y3' are positive
IF(DABS((Y2-Y1)/(Y3-Y2) -1.D0).LT.1.d-10) THEN
c ... special case of true (to 1/10^10) linearity ...
RT= -H*Y2/(Y2-Y1)
ANS1= 2.d0*(H-RT)/DSQRT(Y3)
ANS2= ANS1*Y3/3.D0
RETURN
ENDIF
C=(Y3-Z2*Y2+Y1)/(Z2*H*H)
B=(Y3-Y2)/H-C*H
A=Y2
CQ=B**2-Z4*A*C
RCQ=DSQRT(CQ)
R1=(-B-RCQ)/(Z2*C)
R2=R1+RCQ/C
IF((R2.LE.Z0).AND.(R2.GE.-H)) RT=R2
IF((R1.LE.Z0).AND.(R1.GE.-H)) RT=R1
SL3=Z2*C*H+B
SLT=Z2*C*RT+B
IF(C.LT.Z0) GO TO 10
ANS1=DLOG((Z2*DSQRT(C*Y3)+SL3)/SLT)/DSQRT(C)
GO TO 20
10 ANS1=-(DASIN(SL3/RCQ)-DSIGN(HPI,SLT))/DSQRT(-C)
20 ANS2=(SL3*DSQRT(Y3)-CQ*ANS1/Z2)/(Z4*C)
IF(RT.GE.H) WRITE(6,601) H,R1,R2
601 FORMAT(' *** CAUTION *** in LEVQAD, turning point not between poin
1ts 1 & 2. H =',F9.6,' R1 =',F9.6,' R2 =',F9.6)
RETURN
c** Here treat case when only 'Y2' is non-negative
50 RR=(Y2-Y1)/(Y2-Y3)
X0=H*(RR-Z1)/((RR+Z1)*Z2)
B=(Y2-Y1)/(H*(Z2*X0+H))
A=Y2+B*X0**2
ZT=DSQRT(A/B)
RT=X0-ZT
ANS1=Z2*HPI/DSQRT(B)
ANS2=ANS1*A/Z2
RETURN
99 WRITE(6,602) Y1,Y2
602 FORMAT(' *** ERROR in LEVQAD *** No turning point between 1-st two
1 points as Y1=',D10.3,' Y2=',D10.3)
ANS1=Z0
ANS2=Z0
RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE CDJOEL(EO,NBEG,NEND,BvWN,RH,WARN,V,WF0,RM2,RCNST)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Subroutine solving the linear inhomogeneous differential equations
c formulated by J.M. Hutson [J.Phys.B14, 851 (1982)] for treating
c centrifugal distortion as a perturbation, to determine centrifugal
c distortion constants of a diatomic molecule. Uses the algorithm of
c J. Tellinghuisen [J.Mol.Spectrosc. 122, 455 (1987)]. The current
c version calculates Bv, Dv, Hv, Lv, Mv, Nv and Ov and writes them out,
c but does not return values to the calling program.
c
c** On entry: EO is the eigenvalue (in units [cm-1])
c NBEG & NEND the mesh point range over which the input
c wavefunction WF0 (in units 1/sqrt(Ang)) has non-negligible values
c BvWn is the numerical factor (hbar^2/2mu) [cm-1 Ang^2]
c RH is the integration stepsize (in units [Ang])
c WARN is an integer flag: > 0 print internal warnings,
c V(i) is the effective potential (including centrifugal
c term if calculation performed at J > 0) in
c 'internal' units, including the factor RH**2/BvWN
c RM2(i) is the array 1/(distance**2) in units [1/Ang**2]
c** On exit: RCNST(i) is the set of 7 rotational constants: Bv, -Dv,
c Hv, Lv, Mv, Nv & Ov
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c COPYRIGHT 1994 by Robert J. Le Roy +
c Dept. of Chemistry, Univ. of Waterloo, Waterloo, Ontario, Canada +
c This software may not be sold or any other commercial use made +
c of it without the express written permission of the author. +
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Authors: R.J. Le Roy & J. Tellinghuisen Version of 30/09/1999
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Dimension: potential arrays and vib. level arrays.
INTEGER NDMINT
PARAMETER (NDMINT= 40001)
INTEGER I,M,IPASS,M1,M2,NBEG,NEND,WARN
REAL*8 V(NEND),WF0(NEND),RM2(NEND),P(NDMINT),WF1(NDMINT),
1 WF2(NDMINT),RCNST(7)
REAL*8 BvWN,DV,DVV,HVV,HV2,LVV,LV2,MVV,MV2,NVV,OVV,EO,E,RH,RHSQ,
1 ZTW,AR,R2IN,G2,G3,P0,P1,P2,P3,PI,PIF,PRS,PRT,V1,V2,V3,Y1,Y2,Y3,
2 TSTHv,TSTLv,TSTMv,AMB,AMB1,AMB2,
3 OV,OV01,OV02,OV03,OV11,OV12,OV13,OV22,OV23,OV33,
4 PER01,PER02,PER03,PER11,PER12,PER13,PER22,PER23,PER33
c
IF(NEND.GT.NDMINT) THEN
WRITE(6,602) NEND,NDMINT
RETURN
ENDIF
ZTW= 1.D0/12.d0
RHSQ = RH*RH
DV = RHSQ/12.D0
E= EO*RHSQ/BvWN
IPASS = 1
OV01 = 0.D0
OV02 = 0.D0
OV03 = 0.D0
OV11 = 0.D0
OV22 = 0.D0
OV12 = 0.D0
OV33 = 0.D0
OV23 = 0.D0
OV13 = 0.D0
PER01 = 0.D0
PER02 = 0.D0
PER03 = 0.D0
PER11 = 0.D0
PER12 = 0.D0
PER13 = 0.D0
PER22 = 0.D0
PER23 = 0.D0
PER33 = 0.D0
c** First, calculate the expectation value of 1/r**2 and hence Bv
R2IN= 0.5D0*(RM2(NBEG)*WF0(NBEG)**2 + RM2(NEND)*WF0(NEND)**2)
DO I= NBEG+1, NEND-1
R2IN= R2IN+ RM2(I)*WF0(I)**2
ENDDO
R2IN = R2IN*RH
RCNST(1)= R2IN*BvWN
c
c** On First pass IPASS=1 and calculate first-order wavefx., Dv & Hv
c On second pass IPASS=2 and calculate second-order wavefx., Lv & Mv
c On third pass IPASS=3 and calculate third-order wavefx., Nv & Ov
c
10 P1= 0.D0
P2= 0.D0
c
c P1= WF0(NEND)
c P2= WF0(NEND-1)
c
P(NEND) = P1
P(NEND-1) = P2
V1 = V(NEND) - E
V2 = V(NEND-1) - E
IF(IPASS.EQ.1) THEN
Y1 = P1*(1.D0 - ZTW*V1) - DV*(RM2(NEND) - R2IN)*WF0(NEND)
G2 = (RM2(NEND-1) - R2IN)*WF0(NEND-1)
ELSEIF(IPASS.EQ.2) THEN
Y1 = P1*(1.D0 - ZTW*V1) - DV*((RM2(NEND) - R2IN)*WF1(NEND)
1 - DVV*WF0(NEND))
G2 = (RM2(NEND-1) - R2IN)*WF1(NEND-1) - DVV*WF0(NEND-1)
ELSEIF(IPASS.EQ.3) THEN
Y1 = P1*(1.D0 - ZTW*V1) - DV*((RM2(NEND) - R2IN)*WF2(NEND)
1 - DVV*WF1(NEND) - HVV*WF0(NEND))
G2 = (RM2(NEND-1) - R2IN)*WF2(NEND-1) - DVV*WF1(NEND-1)
1 - HVV*WF0(NEND-1)
ENDIF
Y2 = P2*(1.D0 - ZTW*V2) - DV*G2
M= NEND-1
c** Now - integrate inward from outer end of range
DO I = NBEG+2,NEND
M = M-1
Y3 = Y2 + Y2 - Y1 + RHSQ*G2 + V2*P2
IF(IPASS.EQ.1) G3 = (RM2(M) - R2IN)*WF0(M)
IF(IPASS.EQ.2) G3 = (RM2(M) - R2IN)*WF1(M) - DVV*WF0(M)
IF(IPASS.EQ.3) G3 = (RM2(M) - R2IN)*WF2(M) - DVV*WF1(M)
1 - HVV*WF0(M)
V3 = V(M) - E
P3 = (Y3 + DV*G3)/(1.D0 - ZTW*V3)
IF(V3.LT.0.D0) GO TO 32
P(M) = P3
Y1 = Y2
Y2 = Y3
V2 = V3
P2 = P3
G2 = G3
ENDDO
GO TO 90
c** Escaped loop at outer turning point: initialize outward integration
32 PRS = P3
PRT = P(M+1)
P1 = 0.D0
P2 = 0.D0
c
c P1 = WF0(NBEG)
c P2 = WF0(NBEG+1)
c
P(NBEG) = P1
P(NBEG+1) = P2
V1 = V(NBEG) - E
V2 = V(NBEG+1) - E
IF(IPASS.EQ.1) THEN
Y1 = P1*(1.D0 - ZTW*V1) - DV*(RM2(NBEG) - R2IN)*WF0(NBEG)
G2 = (RM2(NBEG+1) - R2IN)*WF0(NBEG+1)
ELSEIF(IPASS.EQ.2) THEN
Y1 = P1*(1.D0 - ZTW*V1) - DV*((RM2(NBEG) - R2IN)*WF1(NBEG)
1 - DVV*WF0(NEND))
G2 = (RM2(NBEG+1) - R2IN)*WF1(NBEG+1) - DVV*WF0(NBEG+1)
ELSEIF(IPASS.EQ.3) THEN
Y1 = P1*(1.D0 - ZTW*V1) - DV*((RM2(NBEG) - R2IN)*WF2(NBEG)
1 - DVV*WF1(NEND) - HVV*WF0(NEND))
G2 = (RM2(NBEG+1) - R2IN)*WF2(NBEG+1) - DVV*WF1(NBEG+1)
2 - HVV*WF0(NBEG+1)
ENDIF
Y2 = P2*(1.D0 - ZTW*V2) - DV*G2
AR = 0.D0
M1 = M+1
c** Now ... integrate outward from inner end of range
DO I = NBEG+2,M1
Y3 = Y2 + Y2 - Y1 + RHSQ*G2 + V2*P2
P0 = WF0(I)
IF(IPASS.EQ.1) G3 = (RM2(I) - R2IN)*P0
IF(IPASS.EQ.2) G3 = (RM2(I)-R2IN)*WF1(I) - DVV*P0
IF(IPASS.EQ.3) G3 = (RM2(I)-R2IN)*WF2(I) - DVV*WF1(I) - HVV*P0
V3 = V(I) - E
P3 = (Y3 + DV*G3)/(1.D0 - ZTW*V3)
P(I) = P3
Y1 = Y2
Y2 = Y3
V2 = V3
P2 = P3
G2 = G3
AR = AR + P0*P3
ENDDO
c** Average for 2 adjacent mesh points to get Joel's "(a-b)"
AMB2 = (P3-PRT)/P0
AMB1 = (P(M)-PRS)/WF0(M)
AMB = (AMB1+AMB2)*0.5D0
M2 = M+2
c** Find the rest of the overlap with zero-th order solution ...
DO I = M2,NEND
P0 = WF0(I)
PI = P(I) + AMB*P0
P(I) = PI
AR = AR + PI*P0
ENDDO
OV = AR*RH
DO I = NBEG,NEND
P0 = WF0(I)
c ... and project out contribution of zero'th-order part of solution
PI = P(I) - OV*P0
PIF = PI*RM2(I)
IF(IPASS.EQ.1) THEN
c** Now - on first pass accumulate integrals for Dv and Hv
WF1(I) = PI
OV01 = OV01 + PI*P0
OV11 = OV11 + PI*PI
PER01 = PER01 + PIF*P0
PER11 = PER11 + PI*PIF
ELSEIF(IPASS.EQ.2) THEN
c ... and on next pass, accumulate integrals for Lv and Mv
WF2(I) = PI
P1 = WF1(I)
OV02 = OV02 + PI*P0
OV12 = OV12 + PI*P1
OV22 = OV22 + PI*PI
PER02 = PER02 + PIF*P0
PER12 = PER12 + PIF*P1
PER22 = PER22 + PI*PIF
ELSEIF(IPASS.EQ.3) THEN
c ... and on next pass, accumulate integrals for Nv and Ov
P1 = WF1(I)
P2 = WF2(I)
OV03 = OV03 + PI*P0
OV13 = OV13 + PI*P1
OV23 = OV23 + PI*P2
OV33 = OV33 + PI*PI
PER03 = PER03 + PIF*P0
PER13 = PER13 + PIF*P1
PER23 = PER23 + PIF*P2
PER33 = PER33 + PIF*PI
ENDIF
ENDDO
IF(IPASS.EQ.1) THEN
DVV = RH*PER01
HVV = RH*(PER11 - R2IN*OV11)
IPASS = 2
RCNST(2) = DVV*BvWN
RCNST(3) = HVV*BvWn
GO TO 10
ELSEIF(IPASS.EQ.2) THEN
HV2 = RH*PER02*BvWN
LVV = RH*(PER12 - R2IN*OV12 - DVV*OV11)
MVV = RH*(PER22 - R2IN*OV22 - 2.D0*DVV*OV12 - HVV*OV11)
IPASS = 3
RCNST(4) = LVV*BvWN
RCNST(5) = MVV*BvWN
GO TO 10
ELSEIF(IPASS.EQ.3) THEN
LV2 = RH*PER03*BvWN
MV2 = RH*(PER13 - R2IN*OV13 - DVV*OV12 - HVV*OV11)*BvWN
NVV = RH*(PER23 - R2IN*OV23 - DVV*(OV13 + OV22)
1 - 2.D0*HVV*OV12 - LVV*OV11)
OVV = RH*(PER33 - R2IN*OV33 - 2.D0*DVV*OV23
1 - HVV*(2.D0*OV13+ OV22) - 2.D0*LVV*OV12 - MVV*OV11)
RCNST(6) = NVV*BvWN
RCNST(7) = OVV*BvWN
ENDIF
IF(WARN.GT.0) THEN
IF(DMAX1(DABS(OV01),DABS(OV02),DABS(OV01)).GT.1.D-9)
1 WRITE(6,604) OV01,OV02,OV03
TSTHV= dabs(RCNST(3)/HV2-1.D0)
TSTLV= dabs(RCNST(4)/LV2-1.D0)
TSTMV= dabs(RCNST(5)/MV2-1.D0)
IF(DMAX1(TSTHV,TSTLV,TSTMV).GT.1.d-5)
1 WRITE(6,603) TSTHV,TSTLV,TSTMV
ENDIF
RETURN
90 WRITE(6,601) EO
RETURN
601 FORMAT(' *** ERROR in CDJOEL *** for input energy E =',f12.4,
1 ' never reach outer turning point')
602 FORMAT(/' *** Dimensioning PROBLEM in CDJOEL *** NEND=',i6,
1 ' > NDMINT=',i6)
603 FORMAT(' ** CAUTION ** Comparison tests for Hv, Lv & Mv give:',
1 3(1Pd9.1))
604 FORMAT(' ** CAUTION ** CDJOEL orthogonality tests OV01,OV02 & OV03
1:',3(1Pd9.1))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE NLLSSRR(NDATA,NPTOT,NPMAX,IROUND,NGPRND,LPRINT,YO,YU,
1 YD,PV,PU,PS,CM,TSTPS,TSTPU,DSE)
c** Program for performing linear or non-linear least-squares fits and
c (if desired) automatically using sequential rounding and refitting
c to minimize the numbers of parameter digits which must be quoted [see
c R.J. Le Roy, J.Mol.Spectrosc. 191, 223-231 (1998)]. 16/11/00
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c COPYRIGHT 1998-2000 by Robert J. Le Roy +
c Dept. of Chemistry, Univ. of Waterloo, Waterloo, Ontario, Canada +
c This software may not be sold or any other commercial use made +
c of it without the express written permission of the author. +
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c** Program uses orthogonal decomposition of the "design" (partial
c derivative) matrix for the core locally linear (steepest descent)
c step, following a method introduced (to me) by Dr. Michael Dulick.
c** If no parameters are free (NPTOT=0), simply return RMS(residuals) as
c calculated from the input parameter values {PV(j)}.
c** A user MUST SUPPLY subroutine DYIDPJ to generate the predicted
c value of each datum and the partial derivatives of each datum w.r.t.
c each parameter (see below) from the current trial parameters.
c
c** On entry:
c NDATA is the number of data to be fitted
c NPTOT the number of parameters to be varied (.le.NPMAX).
c If NPTOT.le.0 , assume YD(i)=YO(i) and calculate the (RMS
c dimensionless deviation)=DSE from them & YU(i)
c NPMAX is the maximum number of free parameters allowed by current
c external array sizes. Should set internal NPINTMX = NPMAX
c (may be freely changed by the user).
c IROUND .ne. 0 causes Sequential Rounding & Refitting to be
c performed, with each parameter being rounded at the
c |IROUND|'th sig. digit of its local incertainty.
c > 0 rounding selects in turn remaining parameter with largest
c relative uncertainy
c < 0 round parameters sequentially from last to first
c = 0 simply stops after full convergence (without rounding).
c NGPRND in the unusual case when one has MANY parameters and wants
c to round a number off all at once, setting NGPRDN > 1 causes
c the last NGPRND parameters to be rounded in the initial step.
c Use only if necessary: should NORMALLY set NGPRND.le.1 .
c LPRINT specifies the level of printing inside NLLSSRR
c if: = 0, no print except for failed convergence.
c < 0 only converged, unrounded parameters, PU & PS's
c >= 1 print converged parameters, PU & PS's
c >= 2 also print parameter change each rounding step
c >= 3 also indicate nature of convergence
c >= 4 also print convergence tests on each cycle
c >= 5 also parameters changes & uncertainties, each cycle
c >= 6 also print correlation matrix on each cycle
c YO(i) are the NDATA 'observed' data to be fitted
c YU(i) are the uncertainties in these YO(i) values
c PV(j) are initial trial parameter values (for non-linear fits);
c should be set at zero for initially undefined parameters.
c
c** On Exit:
c YD(i) is the array of differences [Ycalc(i) - YO(i)]
c PV(j) are the final converged parameter values
c PU(j) are 95% confidence limit uncertainties in the PV(j)'s
c PS(j) are 'parameter sensitivities' for the PV(j)'s, defined such
c that the RMS displacement of predicted data due to rounding
c off parameter-j by PS(j) is .le. DSE/10*NPTOT
c CM(j,k) is the correlation matrix obtained by normalizing variance
c /covariance matrix: CM(j,k) = CM(j,k)/SQRT[CM(j,j)*CM(k,k)]
c TSTPS = max{|delta[PV(j)]/PS(j)|} is the parameter sensitivity
c convergence test: delta[PV(j)] is last change in parameter-j
c TSTPU = max{|delta[PV(j)]/PU(j)|} is the parameter uncertainty
c convergence test: delta[PV(j)] is last change in parameter-j
c DSE is the predicted (dimensionless) standard error of the fit
c
c NOTE that the squared 95% confidence limit uncertainty in a property
c F({PV(j)}) defined in terms of the fitted parameters {PV(j)} (where
c the L.H.S. involves [row]*[matrix]*[column] multiplication) is:
c [D(F)]^2 = [PU(1)*dF/dPV(1), PU(2)*dF/dPV(2), ...]*[CM(j,k)]*
c [PU(2)*dF/dPV(1), PU(2)*dF/dPV(2), ...]
c
c** Externally dimension: YO, YU and YD .ge. NDATA
c PV, PU and PS .ge. NPTOT (say as NPMAX),
c CM as a square matrix with column & row length NPMAX
c***********************************************************************
INTEGER NPINTMX
PARAMETER (NPINTMX=2000)
INTEGER I,J,K,L,IDF,ITER,NITER,IROUND,JROUND,LPRINT,NDATA,
1 NGPRND,NPTOT,NPARM,NPMAX,QUIT,KFIX,JFIX,IFXP(NPINTMX)
REAL*8 YO(NDATA), YU(NDATA), YD(NDATA), PV(NPTOT), PU(NPTOT),
1 PS(NPTOT),PSS(NPINTMX),PC(NPINTMX),PX(NPINTMX),PY(NPINTMX),
2 CM(NPMAX,NPMAX), F95(10),
3 RMSR, RMSRB, DSE, TSTPS, TSTPSB, TSTPU, TFACT, S, UU
DATA F95/12.7062D0,4.3027D0,3.1824D0,2.7764D0,2.5706D0,2.4469D0,
1 2.3646D0,2.3060D0,2.2622D0,2.2281D0/
c
IF((NPTOT.GT.NPMAX).OR.(NPTOT.GT.NPINTMX)
1 .OR.(NPTOT.GT.NDATA)) THEN
c** If array dimensioning inadequate, print warning & then STOP
WRITE(6,602) NPTOT,NPINTMX,NPMAX,NDATA
STOP
ENDIF
NPARM= NPTOT
TSTPS= 0.d0
RMSR= 0.d0
NITER= 0
QUIT= 0
DO J= 1,NPTOT
PS(J)= 0.d0
IFXP(J)= 0
ENDDO
JROUND= IABS(IROUND)
c=======================================================================
c** Beginning of loop to perform rounding (if desired). NOTE that in
c sequential rounding, NPARM is the current (iteratively shrinking)
c number of free parameters.
6 IF(NPARM.GT.0) TSTPS= 9.d99
c** TFACT is 95% student t-value for (NDATA-NPARM) degrees of freedom.
c [Approximate expression for (NDATA-NPARM).GT.10 accurate to ca. 0.002]
TFACT= 0.D0
IF(NDATA.GT.NPARM) THEN
IDF= NDATA-NPARM
IF(IDF.GT.10) TFACT= 1.960D0*DEXP(1.265D0/DFLOAT(IDF))
IF(IDF.LE.10) TFACT= F95(IDF)
ELSE
TFACT= 0.D0
ENDIF
c======================================================================
c** Begin iterative convergence loop: try for up to 20 cycles
DO 50 ITER= 1,20
NITER= NITER+ 1
DSE= 0.d0
TSTPSB= TSTPS
RMSRB= RMSR
c** Zero out various arrays
IF(NPARM.GT.0) THEN
DO I = 1,NPARM
c** PSS is the array of Saved Parameter Sensitivities from previous run
c to be carried into dyidpj subroutine - used in predicting increment
c for derivatives by differences.
PSS(I)= PS(I)
PS(I) = 0.D0
PU(I) = 0.D0
PX(I) = 0.D0
PY(I) = 0.D0
DO J = 1,NPARM
CM(I,J) = 0.D0
ENDDO
ENDDO
ENDIF
c
c========Beginning of core linear least-squares step====================
c
c** Begin by forming the Jacobian Matrix from partial derivative matrix
DO I = 1,NDATA
c** User-supplied subroutine DYIDPJ uses current (trial) parameter
c values {PV} to generate predicted datum # I [y(calc;I)=UU] and its
c partial derivatives w.r.t. each of the parameters, returning the
c latter in 1-D array PC. See dummy sample version at end of listing.
c* [NOTE: if desired, could write DYIDPJ such that the y(calc) values
c and derivatives for all data are prepared at the same time (when
c I=1), but only returned here one datum at a time (for I > 1).
c However, this would be inappropriate for very large data sets.]
CALL DYIDPJ(I,NDATA,NPTOT,UU,PV,PC,PSS,RMSR)
IF((NPARM.LT.NPTOT).AND.(IROUND.GT.0)) THEN
c** For sequential rounding, collapse partial derivative array here
DO J= NPTOT,1,-1
IF((IFXP(J).GT.0).AND.(J.LT.NPTOT)) THEN
DO K= J,NPTOT-1
PC(K)= PC(K+1)
ENDDO
PC(NPTOT)= 0.d0
ENDIF
ENDDO
ENDIF
S = 1.D0 / YU(I)
YD(I)= UU - YO(I)
UU = - YD(I) * S
DSE= DSE+ UU*UU
IF(NPARM.GT.0) THEN
DO J = 1,NPARM
PC(J) = PC(J)*S
PS(J) = PS(J)+ PC(J)**2
ENDDO
CALL QROD(NPARM,NPMAX,NPMAX,CM,PC,PU,UU,PX,PY)
ENDIF
ENDDO
RMSR= DSQRT(DSE/NDATA)
IF(NPARM.LE.0) GO TO 60
c
c** Compute the inverse of CM
CM(1,1) = 1.D0 / CM(1,1)
DO I = 2,NPARM
L = I - 1
DO J = 1,L
S = 0.D0
DO K = J,L
S = S + CM(K,I) * CM(J,K)
ENDDO
CM(J,I) = -S / CM(I,I)
ENDDO
CM(I,I) = 1.D0 / CM(I,I)
ENDDO
c
c** Solve for parameter changes PC(j)
DO 26 I = 1,NPARM
J = NPARM - I + 1
PC(J) = 0.D0
DO 24 K = J,NPARM
24 PC(J) = PC(J) + CM(J,K) * PU(K)
26 CONTINUE
c
c** Get (upper triangular) "dispersion Matrix" [variance-covarience
c matrix without the sigma^2 factor].
DO 30 I = 1,NPARM
DO 30 J = I,NPARM
UU = 0.D0
DO 28 K = J,NPARM
28 UU = UU + CM(I,K) * CM(J,K)
30 CM(I,J) = UU
c** Generate core of Parameter Uncertainties PU(j) and (symmetric)
c correlation matrix CM
DO 36 J = 1,NPARM
PU(J) = DSQRT(CM(J,J))
DO 32 K= J,NPARM
32 CM(J,K)= CM(J,K)/PU(J)
DO 34 K= 1,J
CM(K,J)= CM(K,J)/PU(J)
34 CM(J,K)= CM(K,J)
36 CONTINUE
c** Option to print correlation matrix on first cycle ...
IF((ITER.EQ.1).AND.(LPRINT.GE.6)) THEN
WRITE(6,693) CM(1,1)
DO i= 2,NPTOT
WRITE(6,694) i,(CM(i,k),k= 1,i)
ENDDO
ENDIF
c
c** Generate standard error DSE = sigma^2, and prepare to calculate
c Parameter Sensitivities PS
IF(NDATA.GT.NPARM) THEN
DSE= DSQRT(DSE/(NDATA-NPARM))
ELSE
DSE= 0.d0
ENDIF
c** Use DSE to get final (95% confid. limit) parameter uncertainties PU
c** Calculate 'parameter sensitivities', changes in PV(j) which would
c change predictions of input data by an RMS average of DSE*0.1/NPARM
UU= DSE*0.1d0/DFLOAT(NPARM)
S= DSE*TFACT
DO 40 J = 1,NPARM
PU(J)= S* PU(J)
40 PS(J)= UU*DSQRT(NDATA/PS(J))
c========End of core linear least-squares step==========================
c ... early exit if Rounding cycle finished ...
IF(QUIT.GT.0) GO TO 60
c
c** Next test for convergence
TSTPS= 0.D0
TSTPU= 0.D0
DO J= 1,NPARM
TSTPS= MAX(TSTPS,DABS(PC(J)/PS(J)))
TSTPU= MAX(TSTPU,DABS(PC(J)/PU(J)))
ENDDO
IF(LPRINT.GE.4) WRITE(6,604) ITER,RMSR,TSTPS,TSTPU
c** Now ... update parameters (careful about rounding)
DO J= 1,NPTOT
IF(IFXP(J).GT.0) THEN
c** If parameter held fixed (by rounding process), shift values of
c change, sensitivity & uncertainty to correct label.
DO I= NPTOT,J+1,-1
PC(I)= PC(I-1)
PS(I)= PS(I-1)
PU(I)= PU(I-1)
ENDDO
PC(J)= 0.d0
PS(J)= 0.d0
PU(J)= 0.d0
ELSE
PV(J)= PV(J)+ PC(J)
ENDIF
ENDDO
IF(LPRINT.GE.5) WRITE(6,612) (J,PV(J),PU(J),PS(J),PC(J),
1 J=1,NPTOT)
IF(NITER.GT.1) THEN
c** Test for convergence: for every parameter desire:
c |parameter change| < |parameter sensitivity| But STOP iterating
c if Max{|change/sens.|} increases AND Max{|change/unc.|} < 0.01
IF(TSTPS.GT.1.d0) THEN
IF((RMSR.GT.RMSRB).AND.(ITER.GT.5)) THEN
IF((TSTPU.LT.1.d-2).OR.((TSTPU.LT.0.5d0).AND.
1 (ITER.GT.10))) THEN
IF(LPRINT.GE.3) WRITE(6,606) ITER,TSTPU,RMSR
GO TO 54
ENDIF
ENDIF
ELSE
IF(LPRINT.GE.3) WRITE(6,608) ITER,TSTPS,RMSR
GO TO 54
ENDIF
ENDIF
ccc CALL FLUSH(6)
50 CONTINUE
WRITE(6,610) NPARM,NDATA,ITER,RMSR,TSTPS,TSTPU
c** End of iterative convergence loop for (in general) non-linear case.
c======================================================================
c
54 IF(NPARM.EQ.NPTOT) THEN
IF(LPRINT.NE.0) THEN
c** If desired, print unrounded parameters and fit properties
WRITE(6,616) NDATA,NPARM,RMSR
WRITE(6,612) (J,PV(J),PU(J),PS(J),PC(J),J=1,NPARM)
ENDIF
IF(IROUND.EQ.0) RETURN
IF(NGPRND.GT.1) THEN
c** For special case when wish to round off the last NGPRND parameters
c in a single step ... (sometimes feasible for linear parameters)
IF(NGPRND.GE.NPTOT) NGPRND= NPTOT-1
CALL GPROUND(JROUND+1,NPTOT,NPARM,NPMAX,NGPRND,LPRINT,
1 IFXP,PV,PU)
GO TO 6
ENDIF
ENDIF
c** Automated 'Sequential Rounding and Refitting' section: round
c current last parameter, fix it, and return (above) to repeat fit.
IF(IROUND.LT.0) THEN
c ... if IROUND < 0, sequentially round off 'last' remaining parameter
JFIX= NPARM
ELSE
c ... if IROUND > 0, sequentially round off remaining parameter with
c largest relative uncertainty.
c ... First, select parameter with the largest relative uncertainty
K= 0
TSTPS= 0.d0
DO J= 1,NPTOT
IF(IFXP(J).LE.0) THEN
K= K+1
TSTPSB= DABS(PU(J)/PV(J))
IF(TSTPSB.GT.TSTPS) THEN
JFIX= J
KFIX= K
TSTPS= TSTPSB
ENDIF
ENDIF
ENDDO
c** Now redistribute correlation matrix elements for use by ROUND
DO J= 1,NPTOT
IF(IFXP(J).GT.0) THEN
DO I= NPTOT,J+1,-1
CM(KFIX,I)= CM(KFIX,I-1)
ENDDO
ENDIF
ENDDO
ENDIF
UU= PV(JFIX)
CALL ROUND(JROUND,NPMAX,NPARM,NPTOT,JFIX,PV,PU,PS,CM)
IFXP(JFIX)= 1
IF(LPRINT.GE.2)
1 WRITE(6,614) JFIX,UU,PU(JFIX),PS(JFIX),PV(JFIX),RMSR
NPARM= NPARM-1
IF(NPARM.EQ.0) THEN
c** After rounding complete, make one more pass with all parameters free
c to get full correct corelation matrix, uncertainties & sensitivities
NPARM= NPTOT
QUIT= 1
DO J= 1,NPTOT
IFXP(J)= 0
ENDDO
c ... reinitialize for derivative-by-differences calculation
RMSR= 0.d0
ENDIF
GO TO 6
c
c** If no parameters varied or sequential rounding completed - simply
c calculate DSE from RMS residuals and return.
60 DSE= 0.d0
IF(NDATA.GT.NPTOT) THEN
DSE= RMSR*DSQRT(DFLOAT(NDATA)/DFLOAT(NDATA-NPTOT))
ELSE
DSE= 0.d0
ENDIF
IF(NPTOT.GT.0) THEN
IF(LPRINT.GT.0) THEN
c** Print final rounded parameters with original Uncert. & Sensitivities
WRITE(6,616) NDATA,NPTOT,RMSR
WRITE(6,612) (J,PV(J),PU(J),PS(J),PC(J),J=1,NPTOT)
ENDIF
ENDIF
RETURN
c
602 FORMAT(/' *** NLLSSRR problem: [NPTOT=',i4,'] > min{NPINTMX=',
1 i4,' NPMAX=',i4,', NDATA=',i6,'}')
604 FORMAT(' After Cycle #',i2,': RMSR=',1PD10.3,' test(PS)=',
1 1PD8.1,' test(PU)=',D8.1)
606 FORMAT(' Effective',i3,'-cycle Cgce: MAX{|change/unc.|}=',1PD8.1,
1 ' < 0.01 RMSR=',D10.3)
608 FORMAT(' Full',i3,'- cycle convergence: Max{|change/sens.|}=',
1 1PD8.1,' < 1 RMSR=',D10.2)
610 FORMAT(' !! CAUTION !! fit of',i4,' parameters to',I6,' data not c
1onverged after',i3,' Cycles'/5x,'RMS(residuals)=',1PD10.3,
2 ' test(PS) =',D9.2,' test(PU) =',D9.2/1x,30('**'))
612 FORMAT((4x,'PV(',i4,') =',1PD22.14,' (+/-',D8.1,') PS=',d8.1,
1 ' PC=',d8.1))
614 FORMAT(' =',39('==')/' Round Off PV(',i3,')=',1PD21.13,' (+/-',
1 D9.2,') PS=',d9.2/11x,'fix it as ',D21.13,' & refit: RMS(res
2iduals)=',D10.3)
616 FORMAT(/' Fit of',i6,' data to',i5,' parameters yields RMS(resid
1uals)=',G11.4)
693 FORMAT(/14x,'Correlation Matrix'/' 1',f7.3,4x,9('--'))
694 FORMAT(i3,20(f7.3))
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE QROD(N,NR,NC,A,R,F,B,GC,GS)
C** Performs ORTHOGONAL DECOMPOSITION OF THE LINEAR LEAST-SQUARES
C EQUATION J * X = F TO A * X = B(TRANSPOSE) * F WHERE
C J IS THE JACOBIAN IN WHICH THE FIRST N ROWS AND COLUMNS
C ARE TRANSFORMED TO THE UPPER TRIANGULAR MATRIX A
C (J = B * A), X IS THE INDEPENDENT VARIABLE VECTOR, AND
C F IS THE DEPENDENT VARIABLE VECTOR. THE TRANSFORMATION
C IS APPLIED TO ONE ROW OF THE JACOBIAN MATRIX AT A TIME.
C PARAMETERS :
C N - (INTEGER) DIMENSION OF A TO BE TRANSFORMED.
C NR - (INTEGER) ROW DIMENSION OF A DECLARED IN CALLING PROGRAM.
C NC - (INTEGER) Column DIMENSION OF F DECLARED IN CALLING PROGRAM.
C A - (REAL*8 ARRAY OF DIMENSIONS .GE. N*N) UPPER TRIANGULAR
C TRANSFORMATION MATRIX.
C R - (REAL*8 LINEAR ARRAY OF DIMENSION .GE. N) ROW OF
C JACOBIAN TO BE ADDED.
C F - (REAL*8 LINEAR ARRAY .GE. TO THE ROW DIMENSION OF THE
C JACOBIAN) TRANSFORMED DEPENDENT VARIABLE MATRIX.
C B - (REAL*8) VALUE OF F THAT CORRESPONDS TO THE ADDED
C JACOBIAN ROW.
C GC - (REAL*8 LINEAR ARRAY .GE. N) GIVENS COSINE TRANSFORMATIONS.
C GS - (REAL*8 LINEAR ARRAY .GE. N) GIVENS SINE TRANSFORMATIONS.
C--------------------------------------------------------------------
C AUTHOR : MICHAEL DULICK, Department of Chemistry,
C UNIVERSITY OF WATERLOO, WATERLOO, ONTARIO N2L 3G1
C--------------------------------------------------------------------
INTEGER I,J,K,N,NC,NR
REAL*8 A(NR,NC), R(N), F(NR), GC(N), GS(N), B, Z(2)
DO 10 I = 1,N
Z(1) = R(I)
J = I - 1
DO K = 1,J
Z(2) = GC(K) * A(K,I) + GS(K) * Z(1)
Z(1) = GC(K) * Z(1) - GS(K) * A(K,I)
A(K,I) = Z(2)
ENDDO
GC(I) = 1.D0
GS(I) = 0.D0
IF(Z(1) .EQ. 0.D0) GOTO 10
IF(DABS(A(I,I)) .LT. DABS(Z(1))) THEN
Z(2) = A(I,I) / Z(1)
GS(I) = 1.D0 / DSQRT(1.D0 + Z(2) * Z(2))
GC(I) = Z(2) * GS(I)
ELSE
Z(2) = Z(1) / A(I,I)
GC(I) = 1.D0 / DSQRT(1.D0 + Z(2) * Z(2))
GS(I) = Z(2) * GC(I)
ENDIF
A(I,I) = GC(I) * A(I,I) + GS(I) * Z(1)
Z(2) = GC(I) * F(I) + GS(I) * B
B = GC(I) * B - GS(I) * F(I)
F(I) = Z(2)
10 CONTINUE
RETURN
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE ROUND(IROUND,NPMAX,NPARM,NPTOT,IPAR,PV,PU,PS,CM)
c** Subroutine to round off parameter # IPAR with value PV(IPAR) at the
c |IROUND|'th significant digit of: [its uncertainty PU(IPAR)] .
c** On return, the rounded value replaced the initial value PV(IPAR).
c** Then ... use the correlation matrix CM and the uncertainties PU(I)
c in the other (NPTOT-1) [or (NPARM-1) free] parameters to calculate
c the optimum compensating changes PV(I) in their values.
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c COPYRIGHT 1998 by Robert J. Le Roy +
c Dept. of Chemistry, Univ. of Waterloo, Waterloo, Ontario, Canada +
c This software may not be sold or any other commercial use made +
c of it without the express written permission of the author. +
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
INTEGER IROUND,NPMAX,NPARM,NPTOT,IPAR,I,IRND,KRND
REAL*8 PU(NPMAX),PS(NPMAX),PV(NPMAX),CM(NPMAX,NPMAX),CNST,
1 CRND,XRND,FCT,Z0
DATA Z0/0.d0/
CNST= PV(IPAR)
XRND= DLOG10(PU(IPAR))
c** If appropriate, base last rounding step on sensitivity (not uncert.)
IF((NPARM.EQ.1).AND.(PS(IPAR).LT.PU(IPAR))) XRND= DLOG10(PS(IPAR))
c** First ... fiddle with log's to perform the rounding
IRND= INT(XRND)
IF(XRND.GT.0) IRND=IRND+1
IRND= IRND- IROUND
FCT= 10.D0**IRND
CRND= PV(IPAR)/FCT
XRND= Z0
c ... if rounding goes past REAL*8 precision, retain unrounded constant
IF(DABS(CRND).GE.1.D+16) THEN
WRITE(6,601) IROUND,IPAR
RETURN
ENDIF
IF(DABS(CRND).GE.1.D+8) THEN
c ... to avoid problems from overflow of I*4 integers ...
KRND= NINT(CRND/1.D+8)
XRND= KRND*1.D+8
CRND= CRND-XRND
XRND= XRND*FCT
END IF
IRND= NINT(CRND)
CNST= IRND*FCT+ XRND
c** Now ... combine rounding change in parameter # IPAR, together with
c correlation matrix CM and parameter uncertainties PU to predict
c changes in other parameters to optimally compensate for rounding off
c of parameter-IPAR. Method pointed out by Mary Thompson (Dept. of
c Statistics, UW),
IF(IPAR.GT.1) THEN
XRND= (CNST-PV(IPAR))/PU(IPAR)
DO I= 1,NPTOT
IF(I.NE.IPAR) THEN
PV(I)= PV(I)+ CM(IPAR,I)*PU(I)*XRND
ENDIF
ENDDO
ENDIF
PV(IPAR)= CNST
RETURN
601 FORMAT(' =',39('==')/' Caution:',i3,'-digit rounding of parameter-
1',i2,' would exceed (assumed) REAL*8'/' ******** precision overf
2low at 1.D+16, so keep unrounded constant')
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
SUBROUTINE GPROUND(IROUND,NPTOT,NPARM,NPMAX,NGPRND,LPRINT,
1 IFXP,PV,PU)
c** Subroutine to round off the last NGPRND of the NPTOT parameters
c PV(i) at the |IROUND|'th significant digit of the smallest of their
c uncertainties min{U(i)}. This procedure does NOT attempt to correct
c the remaining parameters to compensate for these changes (as ROUND
c does) and so is not appropriate for nonlinear parameters.
c** On return, the rounded values replaces the initial values of PV(i).
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c COPYRIGHT 2000 by Robert J. Le Roy +
c Dept. of Chemistry, Univ. of Waterloo, Waterloo, Ontario, Canada +
c This software may not be sold or any other commercial use made +
c of it without the express written permission of the author. +
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
INTEGER I,IROUND,NGPRND,NPMAX,NPTOT,NPARM,IPAR,IRND,KRND,LPRINT
INTEGER IFXP(NPTOT)
REAL*8 PU(NPMAX),PV(NPMAX),CNST,CRND,XRND,FCT,XX,YY
c
c** Now, loop over & round off the last NGPRDN parameters,
IF(LPRINT.GE.2) WRITE(6,602) NGPRND,NPTOT
NPARM= NPTOT+ 1
DO I= 1,NGPRND
NPARM= NPARM- 1
c** First ... fiddle with log's to perform the rounding
XRND= DLOG10(PU(NPARM))
IRND= INT(XRND)
IF(XRND.GT.0) IRND=IRND+1
IRND= IRND- IROUND
FCT= 10.D0**IRND
CNST= PV(NPARM)
YY= CNST
CRND= PV(NPARM)/FCT
XRND= 0.d0
c ... if rounding goes past REAL*8 precision, retain unrounded constant
IF(DABS(CRND).GE.1.D+16) THEN
WRITE(6,600) IROUND,IPAR
RETURN
ENDIF
IF(DABS(CRND).GE.1.D+8) THEN
c ... to avoid problems from overflow of I*4 integers ...
KRND= NINT(CRND/1.D+8)
XRND= KRND*1.D+8
CRND= CRND-XRND
XRND= XRND*FCT
END IF
IRND= NINT(CRND)
CNST= IRND*FCT+ XRND
PV(NPARM) = CNST
IFXP(NPARM)= 1
IF(LPRINT.GE.2) WRITE(6,604) NPARM,YY,PV(NPARM)
604 FORMAT(5x,'Round parameter #',i4,' from',G20.12,' to',G20.12)
ENDDO
NPARM= NPARM- 1
RETURN
600 FORMAT(' =',39('==')/' Caution:',i3,'-digit rounding of parameter-
1',i2,' would exceed (assumed) REAL*8'/' ******** precision overf
2low at 1.D+16, so keep unrounded constant')
602 FORMAT(' Rounding off the last',i5,' of',i5,' parameters:')
END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c***********************************************************************
c SUBROUTINE DYIDPJ(I,NDATA,NPTOT,UU,PV,PC,PS,RMSR)
c** Illustrative dummy version of DYIDPJ for the case of a fit to a
c power series of order (NPTOT-1) in X(i). *** For datum number-i,
c calculate and return PD(j)=[partial derivatives of datum-i] w.r.t.
c each of the free polynomial coefficients varied in the fit
c (for j=1 to NPTOT). **
c* NOTE that NDATA, PS and RMSR are useful for cases in which
c derivatives-by-differences are generated (as for BCONT).
c=====================================================================
c** Use COMMON block(s) to bring in values of the independent variable
c [here XX(i)] and any other parameters or variables needeed to
c calculate YC and the partial derivatives.
c=====================================================================
c INTEGER I,J,NDATA,NPTOT,MXDATA
c PARAMETER (MXDATA= 501)
c REAL*8 RMSR,YC,PV(NPTOT),PD(NPTOT),PS(NPTOT),POWER,XX(MXDATA)
c COMMON /DATABLK/XX
c=====================================================================
c** NOTE BENE(!!) for non-linear fits, need to be sure that the
c calculations of YC and PD(j) are based on the current UPDATED PV(j)
c values. If other (than PV) parameter labels are used internally
c in the calculations, UPDATE them whenever (say) I = 1 .
c=====================================================================
c POWER= 1.D0
c YC= PV(1)
c PD(1)= POWER
c DO 10 J= 2,NPTOT
c POWER= POWER*XX(I)
c YC= YC+ PV(J)*POWER
c PD(J)= POWER
c 10 CONTINUE
c RETURN
c END
c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12