c*********************************************************************** PROGRAM dPotFit16 c*********************************************************************** c** Program "D(iatomic)Pot(ential)Fit" (dPotFit) for performing least- c squares fits of diatomic spectral data to molecular potential c energy functions for one or multiple electronic states. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++++++++++ COPYRIGHT 2006-2016 by R.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++ Uses least-squares subroutine NLLSSRR written by Le Roy & Dulick +++ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** This program can perform the following types of calculations: c (i) From a set of read-in constants, make predictions for any chosen c input data set consisting of diatomic singlet-singlet transitions, c and calculate deviations [calc.-obs.] c (ii) Fit a data set made up of any combination of MW, IR or c electronic vibrational bands, and/or fluorescence series, involving c one or more electronic states and one or more isotopologues, to c parameters defining the observed levels of each state. c======================================================================= c** Dimensioning parameters intrinsic to the program are input through c 'arrsizes.h' c** Parameters characterizing the problem and governing the fits are c read on channel-5 while the raw data are read on channel-4 . c Principle output goes to channel-6 while higher channel numbers c are used for secondary or more detailed/voluminous output. c*********************************************************************** cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c----------------------------------------------------------------------- c** Common block for partial derivatives of potential at the one distance RDIST c and HPP derivatives for uncertainties REAL*8 dVdPk(HPARMX),dDe(0:NbetaMX),dDedRe COMMON /dVdPkBLK/dVdPk,dDe,dDedRe c======================================================================= CHARACTER*40 DATAFILE,MAKEPRED CHARACTER*24 WRITFILE,TVNAME(NPARMX) CHARACTER*27 FN4,FN6,FN7,FN8,FN10,FN11,FN12,FN13,FN14,FN15,FN16, 1 FN17,FN20,FN22,FN30 cc 1 ,FN32 INTEGER*4 lnblnk INTEGER I,J,ISTATE,ISOT,CHARGE,hCHARGE1,hCHARGE2,CHARGE3,IPV, 1 MKPRED,PRINP,PASok(NSTATEMX),NDAT(0:NVIBMX,NISTPMX,NSTATEMX), 2 NTVSTATE,NTVSSTAT,NTVSTOT,VMAXIN(NSTATEMX) REAL*8 UCUTOFF,ZMASE,HZMASE,DECM(NSTATEMX) c INTEGER NOWIDTHS COMMON /WIDTHBLK/NOWIDTHS c c** Parameters required for NLLSSRR. c INTEGER NPTOT,CYCMAX,IROUND,ROBUST,LPRINT,SIROUND,NFPAR,uBv, 1 IFXPV(NPARMX),SIFXPV(NPARMX) REAL*8 PV(NPARMX),PU(NPARMX),PS(NPARMX),CM(NPARMX,NPARMX), 1 PUSAV(NPARMX),PSSAV(NPARMX),TSTPS,TSTPU,DSE c----------------------------------------------------------------------- c** Set type statements for (unused) MASSES variables. c CHARACTER*2 CATOM INTEGER GELGS(2,NISTPMX),GNS(2,NISTPMX) REAL*8 zIP,ABUND c------------------------------------------------------------------------ c------------------------------------------------------------------------ c*** Common Block info for fununc calculations *********************** REAL*8 Rsr(NPNTMX,NSTATEMX),Vsr(NPNTMX,NSTATEMX), 1 Bsr(NPNTMX,NSTATEMX) INTEGER nPointSR(NSTATEMX) COMMON /VsrBLK/Rsr,Vsr,Bsr,nPointSR c REAL*8 Rlr(NPNTMX,NSTATEMX),Plr(NPNTMX,NSTATEMX), 1 Blr(NPNTMX,NSTATEMX) INTEGER nPointLR(NSTATEMX) COMMON /PlrBLK/Rlr,Plr,Blr,nPointLR c----------------------------------------------------------------------- c************************** misc. other variables ********************** REAL*8 RDIST,VDIST,BETADIST,RMAXT,RHT,RHL INTEGER NCNN,NBCTOT DATA ZMASE /5.4857990946D-04/ !! 2010 physical constants d:mohr12 DATA MAKEPRED/'MAKEPRED'/ c======================================================================= HZMASE= 0.5d0*ZMASE SLABL(-6)= ' ' !! data type not yet defined SLABL(-5)='VAC' !! Accoustic Virial Coefficient SLABL(-4)='VIR' !! Pressure Virial Coefficients SLABL(-3)='VVV' !! potential function values SLABL(-2)='WID' !! tunneling level widths SLABL(-1)='PAS' !! Photo-Association binding energies SLABL(0)='FLS' !! fluorescence series c** uncertainties for data involving Quasibound level increased c by Fqb*width to DSQRT{u(_i;exp)**2 + (Fqb*width)**2} Fqb= 0.20d0 c======================================================================= c** FSsame > 0 checks all FS to find those with a common (v',J',isot) c and the fit will use a single upper-state energy, instead of a c separate one for each series. c!!! REMOVE THIS OPTION - for such cases invoke a fake electronic state ! FSsame= 0 c%% FSsame= 1 NFS1= 0 DO I=1,NPARMX TVALUE(I)= 0.d0 PV(I)= 0.0d0 PU(I)= 0.0d0 PS(I)= 0.0d0 IFXPV(I)= 1 ENDDO SIROUND= 0 c======================================================================= c** Start by reading parameters describing the overall nature of the c case and placing chosen restrictions on the data set to be used. c c AN(1) & AN(2) are atomic numbers identifying the atoms forming the c molecule. c c CHARGE (+/- integer) is the charge on the molecule (=0 for neutral). c If(CHARGE.ne.0) use Watson's(JMS 1980) charge-modified reduced mass c (default case), OR assign gained/lost electrons masses (in units of c {m_e/2}) to one particle or the other using integers hCHARGE1 & hCHARGE2 c c NISTP is the number of isotopologues to be simultaneously considered. c c NSTATES is the number of electronic states associated with the data c set to be analysed: NSTATES = 1 for fits to IR/MW and/or c fluorescence data for a single electronic state, while c NSTATES > 1 for multi-state fits. c Upper states of fluorescence series NOT included in this count. c c LPRINT specifies the level of printing inside NLLSSRR if: 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 c PRINP > 0 causes a summary of the input data to be printed before c the fitting starts. Normally set =0 unless troubleshooting c c** IF |PRINP|=2 READ title BANDNAME(IBAND) for each Band/Series on 1'st c line of input for that series and print it at the end of 'summary' c file for that series in the Channels 6 & 8 output. c c** For |CHARGE|.ne. 0: option to distribute missing/added e^- mass(es) c Read # half-electron-masses to be added to/subtracted from standard c atomic masses to create standard 2-body reduced mass m1*m2/(m1+m2) c For Watson's charge-adjusted reduced mass, set hCHARGE1= hCHARGE2= 0 c DATAFILE is the (character variable) name of the file containing the c experimental data to be used in the fit. If it is not located in c the current directory, the name 'DATAFILE' must include the c relative path. The valiable name may (currently) consist of up to c 40 characters. READ ON A SEPARATE LINE! c c !! To make predictions using a completely specified set of parameters, c the input value of parameter DATAFILE must be 'MAKEPRED' c c WRITFILE is the (character variable) name of the file to which the c output will be written. Channel-6 outut goes to WRITFILE.6, c channel-7 output to WRITFILE.7, channel-8 to WRITFILE.8, ... etc. c If not in the current directory, the name 'WRITFILE' must include the c relative path. The valiable name may (currently) consist of up to c 40 characters, enclosed in single quotes, with no leading spaces. c======================================================================= READ(5,*) AN(1), AN(2), CHARGE, NISTP, NSTATES, LPRINT, PRINP IF(IABS(CHARGE).NE.0) READ(5,*) hCHARGE1, hCHARGE2 READ(5,*) DATAFILE READ(5,*) WRITFILE c======================================================================= c** Now construct and define the names of output files associated with c WRITE's to channels 6, 7, 8, 20, 22 & 30 used by the program. WRITE(FN6,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.6' WRITE(FN7,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.7' WRITE(FN8,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.8' WRITE(FN20,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.20' WRITE(FN22,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.22' WRITE(FN30,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.30' OPEN(UNIT=6,FILE=FN6) OPEN(UNIT=7,FILE=FN7) OPEN(UNIT=8,FILE=FN8) OPEN(UNIT=20,FILE=FN20) OPEN(UNIT=22,FILE=FN22) OPEN(UNIT=30,FILE=FN30) c for a molecular ion, printout re. placement of +/- e^- mass(es) CHARGE3= 0 IF(CHARGE.NE.0) THEN CHARGE3= hCHARGE1 + hCHARGE2 IF((hCHARGE1.NE.0).OR.(hCHARGE2.NE.0)) THEN c** If wish to add/subtract e- mass(es) to atomic mass of ions ..... IF(CHARGE3.NE.2*CHARGE) THEN c,,, if adding particle charges don't give total charge ... ERROR & STOP WRITE(6,605) hCHARGE1,hCHARGE2,CHARGE STOP ENDIF WRITE(6,606) hCHARGE1,hCHARGE2,hCHARGE1,hCHARGE2 ELSE WRITE(6,607) ENDIF ENDIF WRITE(6,601) NISTP 606 FORMAT(' Reduced masses below are based on atoms 1 & 2 with charg 1es (',SP,I2,'/2) and (',I2,'/2),'/8x,'respectively, with subtracti 2on/addition of',SS,I2,' and',I2,' half-electron masses.'/) 605 FORMAT(' *** ERROR *** atomic charges',SP,I3,'/2 and',I3,"/2 do 1n't add up to total CHARGE=",I3/10x,' !!! so STOP !!!!') 607 FORMAT(" Reduced masses are Watson's charge-modified reduced mass 1 for diatomic ions"/) c DO ISOT= 1,NISTP c** Loop to read the mass numbers of the atoms in each of the isotopologues c MN(i,ISOT) is the mass number for atom with atomic number AN(i) c [NOTE: be sure order of MN values consistent with that of AN's]. c Choosing it .ne. value for some known isotope if that species c causes the average atomic mass to be used. c======================================================================= READ(5,*) MN(1,ISOT), MN(2,ISOT) c======================================================================= I= MIN(I,MN(1,ISOT),MN(2,ISOT)) CALL MASSES(AN(1),MN(1,ISOT),CATOM,GELGS(1,ISOT), 1 GNS(1,ISOT),ZMASS(1,ISOT),ABUND) IF(ISOT.EQ.1) NAME(1)= CATOM CALL MASSES(AN(2),MN(2,ISOT),CATOM,GELGS(2,ISOT), 1 GNS(2,ISOT),ZMASS(2,ISOT),ABUND) IF(ISOT.EQ.1) NAME(2)= CATOM IF(CHARGE3.EQ.0) THEN !! Watson charge modified mass ZMASS(3,ISOT)= (ZMASS(1,ISOT)*ZMASS(2,ISOT))/ 1 (ZMASS(1,ISOT)+ZMASS(2,ISOT)-CHARGE*ZMASE) ELSE !! standard 2-body mass IF(CHARGE.NE.0) THEN !! adjust masses for ion ZMASS(1,ISOT)= ZMASS(1,ISOT) - hCHARGE1*HZMASE ZMASS(2,ISOT)= ZMASS(2,ISOT) - hCHARGE2*HZMASE ENDIF ZMASS(3,ISOT)= ZMASS(1,ISOT)*ZMASS(2,ISOT)/ 2 (ZMASS(1,ISOT) + ZMASS(2,ISOT)) ENDIF WRITE(6,602) NAME(1),MN(1,ISOT),NAME(2),MN(2,ISOT), 1 (ZMASS(J,ISOT),J=1,3) IF(I.EQ.0) WRITE(6,603) RSQMU(ISOT)= DSQRT(ZMASS(3,1)/ZMASS(3,ISOT)) ENDDO c... end of loop over isotopologues .................................... ccc IF(CHARGE.NE.0) WRITE(6,597) CHARGE WRITE(6,599) DATAFILE,Fqb IF(AN(1).EQ.AN(2)) WRITE(6,604) 599 FORMAT(/' Use experimental data input file: ',a30/' Uncertainties 1 for transitions involving quasibound levels modified to:'/20x, 2 'SQRT{(u(i;exp)**2 + (',f5.2,'*width)**2}') cc597 FORMAT(1x,67('-')/' Since this is an ion with charge',SP,i3, cc 1 ", use Watson's charge-modified reduced mass.") 601 FORMAT(2X,'Input data for',I3,' isotopologues(s)'/2X,16('**')/2X, 1 ' Isotopologues Mass of atom-1 Mass of atom-2 Reduced 2 mass'/ 2X,'----------------- ',3(' --------------')) 602 FORMAT(2X,A2,'(',I3,') - ',A2,'(',I3,')',3(3X,F14.9)) 603 FORMAT(' Note that (Mass Number) = 0 causes the average atomi 1c mass to be used.') 604 FORMAT(' For electrically homonuclear molecules, BO correction fun 1ctions are the same'/5x,'for both atoms, so only the first sets of 2 correction coefficients'/5x,'UA(s) and TA(s) are used, and the ma 3ss scaling factors are sums over'/5x,'the two individual atoms.') c MKPRED= 0 IF(DATAFILE.EQ.MAKEPRED) THEN MKPRED= 1 ENDIF c----------------------------------------------------------------------- c UCUTOFF Neglect any input data with uncertainties > UCUTOFF (cm-1) c c NOWIDTHS > 0 causes the program to ignore any tunneling widths in c the data set and omit calculating partial derivatives c of predissociation level widths w.r.t. potential param. c <= 0 causes the program to fit to tunneling widths c < 0 use simple version of dWdP, ignoring the partial c derivative of t_vib which involves k = 1 phase integral c IROUND specifies the level of rounding inside NLLSSRR if: c > 0 : requires that Sequential Rounding & Refitting be c performed, with each parameter being rounded at the c IROUND'th sig. digit of its local uncertainty. c <=0 : simply stops after full convergence (without rounding). c c ROBUST > 0 (integer) causes "Robust" least-squares weighting (as per c Watson [J.Mol.Spectrosc. 219, 326 (2003)]) to be used c = 0 uses normal data weights 1/[uncertainty(i)]**2 c c c CYCMAX sets an upper bound on the number of cycles to allowed in the c least-squares fit subroutine NLLSSRR c c uBv defines whether (uBv > 0) or nor (uBv.LE.0) to compute the c uncertainties in the calculated Gv & Bv values due to the fit c uncertainties and write them to channel 17. c======================================================================= READ(5,*) UCUTOFF, NOWIDTHS, IROUND, ROBUST, CYCMAX, uBv c======================================================================= IF(IROUND.NE.0) WRITE(6,685) IABS(IROUND) IF(IROUND.GT.0) WRITE(6,686) IF(IROUND.LT.0) WRITE(6,687) IF(ROBUST.GT.0) THEN ROBUST= 2 WRITE(6,596) ELSE WRITE(6,598) ENDIF WRITE(6,595) CYCMAX 596 FORMAT( " Fit uses Watson's",' "Robust" data weighting [J.Mol/Spec 1trosc. 219, 326 (2003)] '/20x,'1/[{unc(i)}^2 + {calc.-obs.}^2/3]') 595 FORMAT(' Non-linear fits are allowed a maximum of CYCMAX=', I4,' 1cycles') 598 FORMAT( ' Fit uses standard 1/[uncertainty(i)]**2 data weighting 1') 685 FORMAT(/' Apply "Sequential Rounding & Refitting" at digit-', 1 i1,' of the (local) parameter') 686 FORMAT(4x,'uncertainty, selecting remaining parameter with largest 1 relative uncertainty') 687 FORMAT(4x,'uncertainty, proceeding sequentially from the LAST para 1meter to the FIRST.') c DO ISTATE= 1,NSTATES c----------------------------------------------------------------------- c** Read parameters to characterize state & possibly restrict data used c SLABL(s) is a 3-character alphameric label enclosed in single quotes c to identify the electronic state; e.g., 'XSG', 'A1P', ... etc. c IOMEG(s) .GE.0 is electronic angular momentum of singlet state with c projection quantum number Lambda= IOMEG c IOMEG(s) .EQ. -1 if it indicates a doublet SIGMA electronic state c [other spin multiplets not yet coded] c IOMEG(s) .EQ. -2 indicated that the centrifugal potential strength c factor is [J(J+1) + 2] (special Li2 case) c V(MIN/MAX)(s) Neglect data for electronic state vibrational levels c outside the range VMIN to VMAX. c JTRUNC(s) data with J > JTRUNC are not included in the fit. c EFSEL(s) allows a user to consider data for: c * ONLY the e-parity levels of this state, if EFSEL > 0 c * ONLY the f-parity levels of this state, if EFSEL < 0 c * BOTH e- and f-parity levels of this state, if EFSEL = 0 c======================================================================= READ(5,*) SLABL(ISTATE), IOMEG(ISTATE), VMIN(ISTATE,1), 1 VMAX(ISTATE,1), JTRUNC(ISTATE), EFSEL(ISTATE) c====================================================================== IF(NISTP.GT.1) THEN DO ISOT= 2, NISTP VMIN(ISTATE,ISOT)= VMIN(ISTATE,1) VMAX(ISTATE,ISOT)= INT((VMAX(ISTATE,1)+1.0d0)/ 1 RSQMU(ISOT)-0.5d0) ENDDO VMAXIN(ISTATE)= 1 IF(VMAX(ISTATE,1).LT.0) THEN VMAXIN(ISTATE)= VMAX(ISTATE,1) c** If desired, read separate upper bound level for each isotopologue c======================================================================= READ(5,*) (VMAX(ISTATE,ISOT), ISOT= 1, NISTP) c======================================================================= ENDIF ENDIF c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL READPOT(ISTATE,SLABL) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** These statements construct and define the names of output files c associated with WRITE's to channels 10-16 used by the program. IF(OSEL(ISTATE).NE.0) THEN WRITE(FN10,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.10' OPEN(UNIT=10,FILE=FN10) cc WRITE(FN11,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.11' cc OPEN(UNIT=11,FILE=FN11) IF(OSEL(ISTATE).LT.0) THEN IF(NUA(ISTATE).GE.0) THEN WRITE(FN12,'(2A)') WRITFILE(1:lnblnk(WRITFILE)), 1 '.12' OPEN(UNIT=12, FILE=FN12) ENDIF IF(NUB(ISTATE).GE.0) THEN WRITE(FN13,'(2A)') WRITFILE(1:lnblnk(WRITFILE)), 1 '.13' OPEN(UNIT=13,FILE=FN13) ENDIF IF(NTA(ISTATE).GE.0) THEN WRITE(FN14,'(2A)') WRITFILE(1:lnblnk(WRITFILE)), 1 '.14' OPEN(UNIT=14,FILE=FN14) ENDIF IF(NTB(ISTATE).GE.0) THEN WRITE(FN15,'(2A)') WRITFILE(1:lnblnk(WRITFILE)), 1 '.15' OPEN(UNIT=15,FILE=FN15) ENDIF IF(NwCFT(ISTATE).GE.0) THEN WRITE(FN16,'(2A)') WRITFILE(1:lnblnk(WRITFILE)), 1 '.16' OPEN(UNIT=16,FILE=FN16) ENDIF ENDIF ENDIF PASok(ISTATE)= 1 IF(PSEL(ISTATE).EQ.6) PASok(ISTATE)= 0 c** Call VGEN to generate betaINF value for output in WRITEPOT IF(PSEL(ISTATE).EQ.2) THEN POTPARI(ISTATE)= 1 CALL VGEN(ISTATE,1.0d0,VDIST,BETADIST,0) ENDIF ENDDO IF(uBv.GT.0) THEN c** If uBv > 0, define the name of the output file for Bv & Gv uncert WRITE(FN17,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.17' OPEN(UNIT=17,FILE=FN17) ENDIF c** Now write summary of the initial potential parameters for each state CALL WRITEPOT(1,SLABL,NAME,DECM,PV,PU,PS,CM,VMAXIN) c c** Now ... count potential parameters of various types for each state c======================================================================= c** Counters for numbers of potential parameters of different types for c each state c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF, c 1 UBPARI,UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF c======================================================================= TOTPOTPAR= 0 NBCTOT= 0 IPV= 0 DO 90 ISTATE= 1,NSTATES IF((PSEL(ISTATE).EQ.0).OR.(PSEL(ISTATE).EQ.-2)) GOTO 90 IF(PSEL(ISTATE).EQ.-1) THEN c... When using band constants for this state ... count them and label c first and last for each level of each isotopologue ... DO ISOT= 1, NISTP DO I= VMIN(ISTATE,ISOT),VMAX(ISTATE,ISOT) IF(NBC(I,ISOT,ISTATE).GT.0) THEN BCPARI(I,ISOT,ISTATE)= IPV+1 DO J= 1,NBC(I,ISOT,ISTATE) IPV= IPV+1 IFXPV(IPV)= 0 PV(IPV)= 0.d0 PU(IPV)= 0.d0 ENDDO NBCTOT= NBCTOT + NBC(I,ISOT,ISTATE) BCPARF(I,ISOT,ISTATE)= IPV ENDIF IF(NQC(I,ISOT,ISTATE).GT.0) THEN QCPARI(I,ISOT,ISTATE)= IPV+1 DO J= 1,NQC(I,ISOT,ISTATE) IPV= IPV+1 IFXPV(IPV)= 0 PV(IPV)= 0.d0 PU(IPV)= 0.d0 ENDDO NBCTOT= NBCTOT + NQC(I,ISOT,ISTATE) QCPARF(I,ISOT,ISTATE)= IPV ENDIF ENDDO ENDDO cc TOTPOTPAR= IPV !! ?? save BC for GPROUND GOTO 90 ENDIF POTPARI(ISTATE)= IPV+1 UAPARI(ISTATE)= 0 UAPARF(ISTATE)= 0 UBPARI(ISTATE)= 0 UBPARF(ISTATE)= 0 TAPARI(ISTATE)= 0 TAPARF(ISTATE)= 0 TBPARI(ISTATE)= 0 TBPARF(ISTATE)= 0 LDPARI(ISTATE)= 0 LDPARF(ISTATE)= 0 HPARF(ISTATE)= 0 c... For all fitted potentials except GPEF count De IF((PSEL(ISTATE).LT.4)) THEN IPV= IPV+ 1 IFXPV(IPV)= IFXDe(ISTATE) ENDIF c... For all fitted potentials count Re IF((PSEL(ISTATE).LE.4)) THEN IPV= IPV+1 IF(PSEL(ISTATE).EQ.4) POTPARI(ISTATE)= IPV IFXPV(IPV)= IFXRe(ISTATE) ENDIF IF((PSEL(ISTATE).EQ.2).OR.(PSEL(ISTATE).EQ.3)) THEN c... For MLR and DELR, forms, count long-range parameters: count Cm's DO J= 1,NCMM(ISTATE) c... additional Aubert-Frecon{3,6,6,8,8} parameters included in this count IPV= IPV+ 1 POTPARF(ISTATE)= IPV IFXPV(IPV)= IFXCm(J,ISTATE) IF(IFXPV(IPV).GT.1) THEN c!!! If constraining one or more Cm to be fixed at same value as for c an earlier (smaller ISTATE) state .... WRITE(6,610) IPV,IFXPV(IPV) 610 FORMAT('** Constrain PV(',i3,') = PV(',I3,') in the fits') ENDIF ENDDO ENDIF c... Now count [exponent] \beta_i expansion coefficients J=0 c** For Pashov-exponent SE-MLR, or TT or HDF parameter count starts with 1 IF((APSE(ISTATE).GT.0).OR.(PSEL(ISTATE).GE.6)) J=1 DO I= J,Nbeta(ISTATE) IPV= IPV+ 1 POTPARF(ISTATE)= IPV IFXPV(IPV)= IFXBETA(I,ISTATE) ENDDO IF(NUA(ISTATE).GE.0) THEN c... Count adiabatic parameters for atom A (if appropriate) UAPARI(ISTATE)= IPV + 1 DO J= 0,NUA(ISTATE) IPV= IPV+ 1 UAPARF(ISTATE)= IPV IFXPV(IPV)= IFXUA(J,ISTATE) ENDDO ENDIF IF(NUB(ISTATE).GE.0) THEN c... Count adiabatic parameters for atom B (if appropriate) UBPARI(ISTATE)= IPV + 1 DO J= 0,NUB(ISTATE) IPV= IPV+ 1 UBPARF(ISTATE)= IPV IFXPV(IPV)= IFXUB(J,ISTATE) ENDDO ENDIF IF(NTA(ISTATE).GE.0) THEN c... Count centrifugal BOB parameters for atom A (if appropriate) TAPARI(ISTATE)= IPV + 1 DO J= 0,NTA(ISTATE) IPV= IPV+ 1 TAPARF(ISTATE)= IPV IFXPV(IPV)= IFXTA(J,ISTATE) ENDDO ENDIF IF(NTB(ISTATE).GE.0) THEN c... Count centrifugal BOB parameters for atom B (if appropriate) TBPARI(ISTATE)= IPV + 1 DO J= 0,NTB(ISTATE) IPV= IPV+ 1 TBPARF(ISTATE)= IPV IFXPV(IPV)= IFXTB(J,ISTATE) ENDDO ENDIF IF(NwCFT(ISTATE).GE.0) THEN c... Count Lambda/doublet-sigma doubling parameters (if appropriate) LDPARI(ISTATE)= IPV + 1 DO J= 0,NwCFT(ISTATE) IPV= IPV+ 1 LDPARF(ISTATE)= IPV IFXPV(IPV)= IFXwCFT(J,ISTATE) ENDDO ENDIF HPARF(ISTATE)= IPV TOTPOTPAR= IPV c..... end of parameter count/label loop! 90 CONTINUE cc IF(TOTPOTPAR.EQ.0) TOTPOTPAR= IPV !! ?? spurious - unneeded ? IF(TOTPOTPAR.GT.HPARMX) THEN WRITE(6,626) TOTPOTPAR,HPARMX STOP ENDIF NPTOT= IPV NFPAR= 0 c** Count total free Hamiltonian fitting parameters DO IPV= 1, TOTPOTPAR IF(IFXPV(IPV).LE.0) NFPAR= NFPAR+ 1 ENDDO c------------ Finished counting Hamiltonian Parameters------------------ 626 FORMAT(/' *** Dimension Error *** [(total No. Hamiltonian parmaete 1rs)=',i4,'] > HPARMX=',i4) 638 FORMAT(' State ',A3,' Energy Convergence criterion EPS is', 1 1PD8.1,' cm-1') c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine to input experimental data in specified band-by-band c format, and do bookkeeping to characterize amounts of data of each c type. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(MKPRED.LE.0) OPEN(UNIT= 4, STATUS= 'OLD', FILE= DATAFILE) c** when COMMON blocks check out ... introduce MKPRED option ...... IF(MKPRED.GT.0) THEN WRITE(FN4,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.4' OPEN(UNIT= 4, FILE= FN4) IF(UCUTOFF.LT.1.d0) UCUTOFF= 1.d0 CALL MKPREDICT(NSTATES,NDAT) REWIND(4) ENDIF CALL READATA(PASok,UCUTOFF,NDAT,NOWIDTHS,PRINP) NTVALL(0)= 0 NTVSTOT= 0 DO ISTATE= 1,NSTATES IF(PSEL(ISTATE).EQ.-2) THEN c... If this state to be represented by term values, determine the number c and add them to the parameter count NTVI(ISTATE)= NPTOT+ 1 !! note: TVSORT updates NPTOT CALL TVSORT(ISTATE,NPTOT,VMAX,NTVALL,NTVSSTAT,TVNAME) NTVALL(0)= NTVALL(0) + NTVALL(ISTATE) IF(NTVALL(ISTATE).GT.0) THEN NTVF(ISTATE)= NPTOT ENDIF IF(NTVSSTAT.GT.0) NTVSTOT= NTVSTOT+ NTVSSTAT ENDIF ENDDO c** Add number of fluorescence series origins to total parameter count c and set initial values of any fluorescence series origins to zero. IF(NFSTOT.GT.0) THEN NFS1= NPTOT+ 1 NPTOT= NPTOT+ NFSTOT ENDIF c** Set the energy convergence criterion to be 1/100th of the smallest c experimental uncertainty. [UCUTOFF reset by READATA to that min. unc.] DO ISTATE=1,NSTATES EPS(ISTATE)= DMIN1(UCUTOFF/100.0d0,1.D-06) cc EPS(ISTATE)= MIN(UCUTOFF/10.0d0,1.d-06) WRITE(6,638) SLABL(ISTATE), EPS(ISTATE) c** Initialize the dissociation energy ???? DECM(ISTATE)= 0.0d0 ENDDO flush(6) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Now Generate internal NLLSSRR variables {PV} from the external ones CALL MAPPAR(NISTP,PV,0) SIROUND= IROUND IROUND= 0 IF((NFSTOT.GT.0).OR.(NTVALL(0).GT.0).OR.(NBCTOT.GT.0)) THEN c** If HAVE fluorescence series and/or fitted term values and/or band c constants ... first fix ALL potential parameters and fit to determine c estimates of the series origins and/or term values, and only THEN c free potential parameters too. c** Start by saving read-in values of 'IF(fix)' parameters DO I= 1,TOTPOTPAR SIFXPV(I)= IFXPV(I) IFXPV(I)= 1 ENDDO DO I= TOTPOTPAR+1,NPTOT IFXPV(I)= 0 PV(I)= 0.d0 cc IF(IFXFS(I-TOTPOTPAR).GT.0) IFXPV(I)= 1 !!????? cc IF(IFXFS(I-TOTPOTPAR+NBCTOT).GT.0) IFXPV(I)= 1 ENDDO c** First, fit ONLY to Fluorescence series origins and/or free Term c Value and/or band constants c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL NLLSSRR(COUNTOT,NPTOT,NPARMX,CYCMAX,IROUND,ROBUST,LPRINT, 1 IFXPV,FREQ,UFREQ,DFREQ,PV,PU,PS,CM,TSTPS,TSTPU,DSE) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c... Now reset "IFX(fix)" parameters to read-in values ... & proceed .. DO I= 1,TOTPOTPAR IFXPV(I)= SIFXPV(I) ENDDO c** Now, set TVALUE values & reset parameter array for global fit DO I= TOTPOTPAR+1,NPTOT TVALUE(I-TOTPOTPAR)= PV(I) IFXPV(I)= 0 IF(IFXFS(I-TOTPOTPAR).GT.0) THEN write(6,888) I-TOTPOTPAR,TVALUE(I-TOTPOTPAR), 1 IFXFS(I-TOTPOTPAR),TVALUE(IFXFS(I-TOTPOTPAR)) 888 format(/' Following FS fit, reset T(',i3,')=',f12.4, 1 ' equal T(',I3,')=', F12.4) TVALUE(I-TOTPOTPAR)= TVALUE(IFXFS(I-TOTPOTPAR)) IFXPV(I)= 1 ENDIF ENDDO NFPAR= NFPAR+ NFSTOT+ NTVALL(0)+ NBCTOT CALL MAPPAR(NISTP,PV,0) ENDIF c--- End of section to determine preliminary values of any fluorescence c series origins, aterm Values or Band Constants c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine NLLSSRR to calculate converged parameters from trial c values and spectroscopic data. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL NLLSSRR(COUNTOT,NPTOT,NPARMX,CYCMAX,IROUND,ROBUST,LPRINT, 1 IFXPV,FREQ,UFREQ,DFREQ,PV,PU,PS,CM,TSTPS,TSTPU,DSE) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(SIROUND.NE.0) THEN c** If SRR rounding is to be performed, first save global uncertainties DO I= 1, NPTOT PUSAV(I)= PU(I) PSSAV(I)= PS(I) ENDDO c** Perform group rounding of all band constants and/or term values, c and/or fluorescence series origins in a single step IF((NFSTOT.GT.0).OR.(NTVALL(0).GT.0).OR.(NBCTOT.GT.0)) THEN IROUND= IABS(SIROUND) + 2 CALL GPROUND(IROUND,NPTOT,NPARMX,TOTPOTPAR+1,NPTOT, 1 LPRINT,IFXPV,PV,PU) ENDIF c ... and then call NLLSSRR again to sequentially round remaining parm. IROUND= SIROUND CALL NLLSSRR(COUNTOT,NPTOT,NPARMX,CYCMAX,IROUND,ROBUST,LPRINT, 1 IFXPV,FREQ,UFREQ,DFREQ,PV,PU,PS,CM,TSTPS,TSTPU,DSE) c ... finally, reset all parameter uncertainties at pre-rounding values DO I= 1, NPTOT PU(I)= PUSAV(I) PS(I)= PSSAV(I) ENDDO ENDIF c** Writing out the general information of the fit. c----------------------------------------------------------------------- WRITE(6,691) NFPAR,COUNTOT,DSE c----------------------------------------------------------------------- c** Writing out the fluorescence band results. c----------------------------------------------------------------------- IF(NFSTOT.GT.0) THEN WRITE(6,692) NFSTOT J= NPTOT - NFSTOT DO I= 1,NFSTOT WRITE(6,694) VP(FSBAND(I)),VPP(FSBAND(I)), 1 EFP(IFIRST(FSBAND(I))),ISTP(FSBAND(I)),TVALUE(J+I), 2 PU(J+I),PS(J+I) ENDDO ENDIF DO ISTATE= 1, NSTATES IF(PSEL(ISTATE).EQ.-2) THEN c** For states represented by independent term values for each level ... WRITE(6,696) SLABL(ISTATE),NTVALL(ISTATE) WRITE(6,698) (TVNAME(I),PV(I),PU(I),PS(I),I= 1 NTVI(ISTATE),NTVF(ISTATE)) ELSEIF(PSEL(ISTATE).GT.0) THEN c** Calculation of the uncertainties for Te for each potential require c elements from the correlation matrix. IF((IFXDE(1).LE.0).AND.(IFXDE(ISTATE).LE.0)) THEN DECM(ISTATE)= CM(1,POTPARI(ISTATE)) ELSE DECM(ISTATE)= 0.0d0 ENDIF ENDIF ENDDO 691 FORMAT(/,1X,36('==')/' Fitting',I5,' free parameters to',I6, 1 ' transitions yields DSE=',G15.8/1X,36('==')) 692 FORMAT(/1X,33('==')/' The following',I5,' Fluorescence Series Ori 1gins were determined'/1x,30('--')/" ( v', J', p'; ISTP)",4x, 2 'T(value)',4x, 'Uncertainty Sensitivity'/1x,30('--')) cc694 FORMAT(3X,'(',I3,',',I3,',',SP,I3,SS,';',I2,')',1X,1PD19.10, 694 FORMAT(2X,'(',I4,',',I3,',',SP,I3,SS,';',I2,')',1X,F15.6, 1 1PD11.1,D12.1) 696 FORMAT(/1X,33('==')/' State ',A3,' represented by the',I5,' indiv 1idual term values:'/1x,33('--')/" T(es: v', J', p';IS) #dat",4x, 2 'T(value)',4x,'Uncertainty Sensitivity'/1x,33('--')) 698 FORMAT(2X,A24,1PD19.10,D11.1,D12.1) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine MAPPAR to convert internal NLLSSRR parameter array c back into external (logical) variable system. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL MAPPAR(NISTP,PV,1) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine VGEN to generate the potential function from the c final calculated converged parameters. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DO ISTATE= 1,NSTATES IF(PSEL(ISTATE).GT.0) THEN RMAXT= RD(NDATPT(ISTATE),ISTATE) RHT= RD(2,ISTATE) - RD(1,ISTATE) nPointSR(ISTATE)= RD(1,ISTATE)/RHT IF(nPointSR(ISTATE).GT.NPNTMX) nPointSR(ISTATE)= NPNTMX IF(OSEL(ISTATE).NE. 0) THEN IF(RMAXT .GT. 100.0) THEN nPointLR(ISTATE)= 0 ELSE RHL= RHT*OSEL(ISTATE) nPointLR(ISTATE)= (100.0-RMAXT)/RHL IF(nPointLR(ISTATE).GT.NPNTMX) THEN RHL= RHL*DFLOAT(nPointLR(ISTATE))/NPNTMX nPointLR(ISTATE)= NPNTMX ENDIF ENDIF ENDIF CALL VGEN(ISTATE,-1.0d0,VDIST,BETADIST,1) IB(NDATAMX)= NPARMX ! omits centrifugal bits from VGEN IF(OSEL(ISTATE).GT.0) THEN J= MAX1(1.,OSEL(ISTATE)/10.) DO I= 1,nPointSR(ISTATE), J c ... generate potential & exponent values in inner extrapolation region RDIST= RHT*DBLE(I) Rsr(I,ISTATE)= RDIST CALL VGEN(ISTATE,RDIST,VDIST,BETADIST,-1) Vsr(I,ISTATE)= VDIST Bsr(I,ISTATE)= BETADIST ENDDO DO I= 1,nPointLR(ISTATE) c ... generate potential & exponent values in outer extrapolation region RDIST= RMAXT + RHL*DBLE(I) Rlr(I,ISTATE)= RDIST CALL VGEN(ISTATE,RDIST,VDIST,BETADIST,-1) Plr(I,ISTATE)= VDIST Blr(I,ISTATE)= BETADIST ENDDO ENDIF ENDIF ENDDO c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine to print out a summary of the converged and fixed c values to standard output (channel-6). c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL WRITEPOT(2,SLABL,NAME,DECM,PV,PU,PS,CM,VMAXIN) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** If chosen, output file(s) will be created for the export of the c generated functions: V, BETAFX, UAR/UBR, or TAR/TBR and their c respective uncertainties. DO ISTATE= 1, NSTATES IF(OSEL(ISTATE).NE.0) THEN IF(PSEL(ISTATE).GT.0) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine to print out the generated functions and their c respective uncertainties. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL FUNUNC(ISTATE,WRITFILE,PU,CM) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ELSE DO I= 1,NDATPT(NSTATES),IABS(OSEL(ISTATE)) WRITE(18,900) RD(I,ISTATE),VPOT(I,NSTATES) ENDDO ENDIF ENDIF ENDDO c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine to print out summary of dimensionless standard c errors on a band-by-band basis, and (if desired) print [obs.-calc.] c values to channel-8. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL DIFFSTATS(NSTATES,NFPAR,ROBUST,MKPRED,NPTOT,NTVSTOT,PRINP) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(uBv.GT.0) THEN c** If desired, calculate Bv uncertainties CALL UNCBV(NPTOT,PV,PU,CM) ENDIF STOP 900 FORMAT(5X,G18.8,5X,G18.8) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE MASSES(IAN,IMN,NAME,GELGS,DGNS,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 DGNS, 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 2012 mass table [Wang, Audi, Wapstra, Kondev, MacCormick, Xu c & Pfeiffer, Chin.Phys.C 36, 1603-2014 (2012)] ,the proton, deuteron, c and triton masses are taken from the 2010 fundamental constants table c [Mohr, Taylor, & Newell, Rev. Mod. Phys. 84, 1587-1591 (2012)] and other c quantities from Tables 6.2 and 6.3 of "Quantities, Units and Symbols in c Physical Chemistry", by Mills et 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 DGNS=-1 and ABUND=-1. c** For Atomic number IAN=0 and isotope mass numbers IMN=1-3, return the c masses of the proton, deuteron, and triton, p,d & t, respectively c Masses and properties of selected Halo nuclei an unstable nuclei included c COPYRIGHT 2005-2015 : last updated 10 January 2016 c** By R.J. Le Roy, with assistance from c G.T. Kraemer, J.Y. Seto and K.V. Slaughter. c*********************************************************************** REAL*8 zm(0:123,0:15),mass,ab(0:123,15),abund INTEGER i,ian,imn,gel(0:123),nmn(0:123),mn(0:123,15), 1 gns(0:123,15),DGNS,gelgs CHARACTER*2 NAME,AT(0:123) cc DATA at(0),gel(0),nmn(0),(mn(0,i),i=1,3)/' p',1,3,1,2,3/ DATA (zm(0,i),i=0,3)/1.008d0,1.007276466812d0,2.013553212712d0, 2 3.0155007134d0/ DATA (gns(0,i),i=1,3)/2,3,2/ DATA (ab(0,i),i=1,3)/0.d0, 0.d0, 0.d0/ 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.00782503223d0, 2.01410177812d0, 1 3.0160492779d0/ DATA (gns(1,i),i=1,3)/2,3,2/ 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,4)/'He',1,4,3,4,6,8/ DATA (zm(2,i),i=0,4)/4.002602d0, 3.0160293201d0, 4.00260325413d0, 1 6.0188891d0, 8.033922d0/ DATA (gns(2,i),i=1,4)/2,1,1,1/ DATA (ab(2,i),i=1,4)/0.000137d0,99.999863d0, 2*0.d0/ c DATA at(3),gel(3),nmn(3),(mn(3,i),i=1,6)/'Li',2,6,6,7,8,9,11,12/ DATA (zm(3,i),i=0,6)/6.941d0, 6.0151228874d0, 7.016003437d0, 1 8.02248736d0,9.0267895d0,11.043798d0,12.05378d0/ DATA (gns(3,i),i=1,6)/3,4,5,4,4,1/ DATA (ab(3,i),i=1,6)/7.5d0, 92.5d0, 4*0.d0/ c DATA at(4),gel(4),nmn(4),(mn(4,i),i=1,8)/'Be',1,8,7,9,10,11,12, 1 14,15,16/ DATA (zm(4,i),i=0,8)/9.012182d0, 7.01692983d0, 9.01218307d0, 1 10.0135338d0, 11.021658d0, 12.026921d0, 14.04289d0, 15.05346d0, 2 16.06192d0/ DATA (gns(4,i),i=1,8)/4,4,3,2,1,1,2,1/ DATA (ab(4,i),i=1,8)/0.d0, 100.d0, 6*0.d0/ c DATA at(5),gel(5),nmn(5),(mn(5,i),i=1,10)/' B',2,10,8,10,11,12, 1 13,14,15,17,18,19/ DATA (zm(5,i),i=0,10)/10.811d0, 8.0246072d0, 10.0129369d0, 1 11.0093054d0, 12.0143521d0, 13.0177802d0, 14.025404d0, 2 15.031103d0, 17.04699d0, 18.05617d0,19.06373d0/ DATA (gns(5,i),i=1,10)/5,7,4,3,4,5,4,4,1,4/ DATA (ab(5,i),i=1,10)/0.d0, 19.9d0,80.1d0, 7*0.d0/ c DATA at(6),gel(6),nmn(6),(mn(6,i),i=1,14)/' C',1,14,9,10,11,12,13, 1 14,15,16,17,18,19,20,21,22/ DATA (zm(6,i),i=0,14)/12.011d0, 9.0310367d0, 10.0168532d0, 1 11.0114336d0, 12.d0, 13.00335483507d0, 14.003241989d0, 1 15.0105993d0, 16.014701d0, 17.022586d0, 18.02676d0, 19.03481d0, 2 20.04032d0, 21.04934d0, 22.05720d0/ DATA (gns(6,i),i=1,14)/4,1,4,1,2,1,2,1,4,1,2,1,2,1/ DATA (ab(6,i),i=1,14)/3*0.d0, 98.90d0,1.10d0, 9*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.00307400443d0,15.0001088989d0/ DATA (gns(7,i),i=1,2)/3,2/ 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.99491461957d0, 16.9991317565d0, 1 17.9991596129d0/ DATA (gns(8,i),i=1,3)/1,6,1/ 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.9984031627d0/ DATA (gns(9,i),i=1,1)/2/ DATA (ab(9,i),i=1,1)/100.d0/ c DATA at(10),gel(10),nmn(10),(mn(10,i),i=1,4)/'Ne',1,4,17,20,21,22/ DATA (zm(10,i),i=0,4)/20.1797d0, 17.017672d0, 19.9924401762d0, 1 20.99384669d0,21.991385115d0/ DATA (gns(10,i),i=1,4)/2,1,4,1/ DATA (ab(10,i),i=1,4)/0.d0, 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.9897692820d0/ DATA (gns(11,i),i=1,1)/4/ 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.985041698d0, 24.98583698d0, 1 25.98259297d0/ DATA (gns(12,i),i=1,3)/1,6,1/ 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.98153853d0/ DATA (gns(13,i),i=1,1)/6/ 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.9769265346d0, 28.9764946649d0, 1 29.973770136d0/ DATA (gns(14,i),i=1,3)/1,2,1/ 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,2)/' P',4,2,26,31/ DATA (zm(15,i),i=0,2)/30.973762d0, 26.01178d0, 30.9737619984d0/ DATA (gns(15,i),i=1,2)/15,2/ DATA (ab(15,i),i=1,2)/0.d0, 100.d0/ c DATA at(16),gel(16),nmn(16),(mn(16,i),i=1,5)/' S',5,5,27,32,33, 1 34,36/ DATA (zm(16,i),i=0,5)/32.066d0, 27.01883d0, 31.9720711744d0, 1 32.9714589098d0,33.96786700d0, 35.96708071d0/ DATA (gns(16,i),i=1,5)/6,1,4,1,1/ DATA (ab(16,i),i=1,5)/0.d0, 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.96590260d0/ DATA (gns(17,i),i=1,2)/4,4/ 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.967545105d0, 37.96273211d0, 1 39.9623831237d0/ DATA (gns(18,i),i=1,3)/1,1,1/ 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.963706486d0, 39.96399817d0, 1 40.961825258d0/ DATA (gns(19,i),i=1,3)/4,9,4/ 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.962590864d0, 41.95861783d0, 1 42.95876644d0, 43.9554816d0, 45.9536890d0, 47.95252277d0/ DATA (gns(20,i),i=1,6)/1,1,8,1,1,1/ 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.9559083d0/ DATA (gns(21,i),i=1,1)/8/ 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.9526277d0, 46.9517588d0, 1 47.9479420d0, 48.9478657d0, 49.9447869d0/ DATA (gns(22,i),i=1,5)/1,6,1,8,1/ 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.9471560d0, 50.9439570d0/ DATA (gns(23,i),i=1,2)/13,8/ 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.9460418d0, 51.9405062d0, 1 52.9406481d0, 53.9388792d0/ DATA (gns(24,i),i=1,4)/1,1,4,1/ 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.938049d0/ DATA (gns(25,i),i=1,1)/6/ 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.9396090d0, 55.9349363d0, 1 56.9353928d0, 57.9332744d0/ DATA (gns(26,i),i=1,4)/1,1,2,1/ 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.9331943d0/ DATA (gns(27,i),i=1,1)/8/ 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.9353424d0, 59.9307859d0, 1 60.9310556d0, 61.9283454d0, 63.9279668d0/ DATA (gns(28,i),i=1,5)/1,1,4,1,1/ 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.9295977d0,64.9277897d0/ DATA (gns(29,i),i=1,2)/4,4/ 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.9291420d0, 65.9260338d0, 1 66.9271277d0, 67.9248446d0, 69.9253192d0/ DATA (gns(30,i),i=1,5)/1,1,6,1,1/ 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.9255735d0, 70.9247026d0/ DATA (gns(31,i),i=1,2)/4,4/ 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.9242488d0, 71.92207583d0, 1 72.92345896d0, 73.921177762d0, 75.921402726d0/ DATA (gns(32,i),i=1,5)/1,1,10,1,1/ 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.9215946d0/ DATA (gns(33,i),i=1,1)/4/ 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.922475935d0, 75.919213704d0, 1 76.91991415d0, 77.91730928d0, 79.9165218d0, 81.9166995d0/ DATA (gns(34,i),i=1,6)/1,1,2,1,1,1/ 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.9183376d0, 80.9162897d0/ DATA (gns(35,i),i=1,2)/4,4/ 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.9203649d0, 79.9163781d0, 1 81.9134827d0, 82.9141272d0, 83.911497728d0, 85.910610627d0/ DATA (gns(36,i),i=1,6)/1,1,1,10,1,1/ 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.909180532d0/ DATA (gns(37,i),i=1,2)/6,4/ 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.9134191d0, 85.9092606d0, 1 86.9088775d0, 87.9056125d0/ DATA (gns(38,i),i=1,4)/1,1,10,1/ 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.9058403d0/ DATA (gns(39,i),i=1,1)/2/ 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.9046977d0, 90.9056396d0, 1 91.9050347d0, 93.9063108d0, 95.9082714d0/ DATA (gns(40,i),i=1,5)/1,6,1,1,1/ 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.9063730d0/ DATA (gns(41,i),i=1,1)/10/ 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.9068080d0, 93.9050849d0, 1 94.9058388d0, 95.9046761d0, 96.9060181d0, 97.9054048d0, 2 99.9074718d0/ DATA (gns(42,i),i=1,7)/1,1,6,1,6,1,1/ 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.907212d0/ DATA (gns(43,i),i=1,1)/13/ 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.9075903d0, 97.905287d0, 1 98.9059341d0, 99.9042143d0, 100.9055769d0, 101.9043441d0, 2 103.9054275d0/ DATA (gns(44,i),i=1,7)/1,1,6,1,6,1,1/ 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.9054980d0/ DATA (gns(45,i),i=1,1)/2/ 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.9056022d0, 103.9040305d0, 1 104.9050796d0, 105.9034804d0, 107.9038916d0, 109.9051722d0/ DATA (gns(46,i),i=1,6)/1,1,6,1,1,1/ 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.9050916d0, 108.9047553d0/ DATA (gns(47,i),i=1,2)/2,2/ 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.9064599d0, 107.9041834d0, 1 109.9030066d0, 110.9041829d0, 111.9027629d0, 112.9044081d0, 2 113.9033651d0, 115.90476315d0/ DATA (gns(48,i),i=1,8)/1,1,1,2,1,2,1,1/ 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.9040618d0, 114.903878776d0/ DATA (gns(49,i),i=1,2)/10,10/ 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.9048239d0, 113.9027827d0, 1 114.903344699d0, 115.90174280d0, 116.9029540d0, 117.9016066d0, 2 118.9033112d0, 119.9022016d0, 121.9034438d0, 123.9052766d0/ DATA (gns(50,i),i=1,10)/1,1,2,1,2,1,2,1,1,1/ 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.903812d0, 122.9042132d0/ DATA (gns(51,i),i=1,2)/6,8/ 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.904059d0, 121.9030435d0, 1 122.9042698d0, 123.9028171d0, 124.9044299d0, 125.9033109d0, 2 127.9044613d0, 129.906222749d0/ DATA (gns(52,i),i=1,8)/1,1,2,1,2,1,1,1/ 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.904472d0, 128.904984d0/ DATA (gns(53,i),i=1,2)/6,8/ 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.9058920d0, 125.904298d0, 1 127.9035310d0, 128.904780861d0,129.903509350d0,130.90508406d0, 2 131.904155086d0, 133.9053947d0, 135.907214484d0/ DATA (gns(54,i),i=1,9)/1,1,1,2,1,4,1,1,1/ 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.905451961d0/ DATA (gns(55,i),i=1,1)/8/ 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.9063207d0, 131.9050611d0, 1 133.90450818d0, 134.90568838d0, 135.90457573d0, 136.9058271d0, 2 137.9052470d0/ DATA (gns(56,i),i=1,7)/1,1,1,4,1,4,1/ 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.907115d0, 138.9063563d0/ DATA (gns(57,i),i=1,2)/11,8/ 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.9071292d0, 137.905991d0, 1 139.9054431d0, 141.9092504d0/ DATA (gns(58,i),i=1,4)/1,1,1,1/ 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.9076576d0/ DATA (gns(59,i),i=1,1)/6/ 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.9077290d0, 142.9098200d0, 1 143.9100930d0, 144.9125793d0, 145.9131226d0, 147.9168993d0, 2 149.9209022d0/ DATA (gns(60,i),i=1,7)/1,8,1,8,1,1,1/ 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.912756d0/ DATA (gns(61,i),i=1,1)/6/ 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.9120065d0, 146.9149044d0, 1 147.9148292d0, 148.9171921d0, 149.9172829d0, 151.9197397d0, 2 153.9222169d0/ DATA (gns(62,i),i=1,7)/1,8,1,8,1,1,1/ 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.9198578d0, 152.9212380d0/ DATA (gns(63,i),i=1,2)/6,6/ 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.9197995d0, 153.9208741d0, 1 154.9226305d0, 155.9221312d0, 156.9239686d0, 157.9241123d0, 2 159.9270624d0/ DATA (gns(64,i),i=1,7)/1,1,4,1,4,1,1/ 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.9253547d0/ DATA (gns(65,i),i=1,1)/4/ 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.9242847d0, 157.924416d0, 1 159.9252046d0, 160.9269405d0, 161.9268056d0, 162.9287383d0, 2 163.9291819d0/ DATA (gns(66,i),i=1,7)/1,1,1,6,1,6,1/ 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.9303288d0/ DATA (gns(67,i),i=1,1)/8/ 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.9287884d0, 163.9292088d0, 1 165.9302995d0, 166.9320546d0, 167.9323767d0, 169.9354702d0/ DATA (gns(68,i),i=1,6)/1,1,1,8,1,1/ 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.9342179d0/ DATA (gns(69,i),i=1,1)/2/ 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.9338896d0, 169.9347664d0, 1 170.9363302d0, 171.9363859d0, 172.9382151d0, 173.9388664d0, 2 175.9425764d0/ DATA (gns(70,i),i=1,7)/1,1,2,1,6,1,1/ 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.9407752d0, 175.9426897d0/ DATA (gns(71,i),i=1,2)/6,15/ 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.9400461d0, 175.9414076d0, 1 176.9432277d0, 177.9437058d0, 178.9458232d0, 179.9465570d0/ DATA (gns(72,i),i=1,6)/1,1,8,1,10,1/ 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 (gns(73,i),i=1,2)/17,8/ 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.9467108d0, 181.9482039d0, 1 182.9502227d0, 183.9509309d0, 185.9543628d0/ DATA (gns(74,i),i=1,5)/1,1,2,1,1/ 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.9529545d0, 186.9557501d0/ DATA (gns(75,i),i=1,2)/6,6/ 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.9524885d0, 185.9538350d0, 1 186.9557474d0, 187.9558352d0, 188.9581442d0, 189.9584437d0, 2 191.9614770d0/ DATA (gns(76,i),i=1,7)/1,1,2,1,4,1,1/ 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.9605893d0, 192.9629216d0/ DATA (gns(77,i),i=1,2)/4,4/ 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.959930d0, 191.961039d0, 1 193.9626809d0, 194.9647917d0, 195.9649521d0, 197.9678949d0/ DATA (gns(78,i),i=1,6)/1,1,1,2,1,1/ 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.9665688d0/ DATA (gns(79,i),i=1,1)/4/ 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.9667686d0, 1 198.9682806d0, 199.9683266d0, 200.9703028d0, 201.9706434d0, 2 203.9734940d0/ DATA (gns(80,i),i=1,7)/1,1,2,1,4,1,1/ 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.9723446d0, 204.9744278d0/ DATA (gns(81,i),i=1,2)/2,2/ 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.9730440d0, 205.9744657d0, 1 206.9758973d0, 207.9766525d0/ DATA (gns(82,i),i=1,4)/1,1,2,1/ 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.9803991d0/ DATA (gns(83,i),i=1,1)/10/ 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.9824308d0/ DATA (gns(84,i),i=1,1)/2/ 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 (gns(85,i),i=1,1)/11/ 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.0175782d0/ DATA (gns(86,i),i=1,1)/1/ 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.0197360d0/ DATA (gns(87,i),i=1,1)/4/ 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.0254103d0/ DATA (gns(88,i),i=1,1)/1/ 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.0277523d0/ DATA (gns(89,i),i=1,1)/4/ 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.0380558d0/ DATA (gns(90,i),i=1,1)/1/ 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.0358842d0/ DATA (gns(91,i),i=1,1)/4/ 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.0396355d0, 234.0409523d0, 1 235.0439301d0, 238.0507884d0/ DATA (gns(92,i),i=1,4)/6,1,8,1/ 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.0481736d0/ DATA (gns(93,i),i=1,1)/6/ 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.064205d0/ DATA (gns(94,i),i=1,1)/1/ 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.0613815d0/ DATA (gns(95,i),i=1,1)/6/ 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 (gns(96,i),i=1,1)/10/ 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 (gns(97,i),i=1,1)/4/ 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.079589d0/ DATA (gns(98,i),i=1,1)/2/ 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 (gns(99,i),i=1,1)/11/ 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.095106d0/ DATA (gns(100,i),i=1,1)/10/ 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 (gns(101,i),i=1,1)/17/ 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 (gns(102,i),i=1,1)/10/ 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.105510d0/ DATA (gns(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 (gns(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.114070d0/ DATA (gns(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.118290d0/ DATA (gns(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.122970d0/ DATA (gns(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.129793d0/ DATA (gns(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.137370d0/ DATA (gns(109,i),i=1,1)/-1/ DATA (ab(109,i),i=1,1)/100.d0/ c IF((IAN.LT.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.GT.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 IF((IAN.EQ.0).AND.(IMN.GT.1)) THEN IF(IMN.EQ.2) NAME=' d' IF(IMN.EQ.3) NAME=' t' ENDIF GELGS= GEL(IAN) MASS= -1.d0 DGNS= -1 ABUND = -1.d0 DO I= 1,NMN(IAN) if(i.gt.15) write(6,606) ian,imn,nmn(ian) IF(IMN.EQ.MN(IAN,I)) THEN MASS= ZM(IAN,I) DGNS= gns(IAN,I) 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.') 606 format(/' *** ERROR *** called MASSES for atom with AN=',I4, 1 ' MN=',I4,'n(MN)=',I4) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE READATA(PASok,UCUTOFF,NDAT,NOWIDTHS,PRINP) c*********************************************************************** c** Subroutine to read, do book-keeping for, and print summary of c experimental data used in fits to spectroscopic data for one or more c electronic states and one or more isotopologues. c ********* Version of 11 July 2015 ********* c last change ... add acoustic virial data type c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++ COPYRIGHT 1997-2015 by Robert J. Le Roy & Dominique R.T. Appadoo + 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** The present program version can treat seven types of experimental c experimental data, for up to NISTPMX isotopologues of a given species. c The data are read in grouped as "bands", as (fluorescence) series, c as binding energies (from photoassociation spectroscopy), as a set c of Bv values for a given electronic state, and [in a potential-fit c aanalysis] as tunneling predissociation level widths. The types are c identified by the values of the 'electronic state label' parameters c IEP & IEPP. They are: c (i) microwave transitions within a given electronic state; c (ii) infrared bands among the vibrational levels a given state; c (iii) fluorescence series from some initial excited state level into c vibration-rotation levels of a given electronic state c (iv) visible (electronic) absorption or emission bands between vib. c levels of two electronic state. c (v) binding energies - as from photoassociation spectroscopy c (vi) "experimental" B_v values for vibrational levels of one of the c electronic states. c (vii) Widths of tunneling predissociation quasibound levels (this c option only meaningful for program DSPotFit). c (ix) 2'nd virial coefficient data (also only for dPotFit applications) c (x) Potential function value from some other source (e.g., ab initio c energy high on the repusive wall. c----------------------------------------------------------------------- c** On Entry: c NSTATES is the number of electronic states involved in the data set c considered (don't count states giving rise to fluorescence series). c PASok indicates how photoassociation data to be treated in analysis: c If(PASok(ISTATE).GE.1) treat it as proper PA binding energy data. c If(PASok(ISTATE).LE.0) treat PAS data as fluorescence series. c Set PASok= 0 if potential model has no explicit Dissoc. Energy c Data cutoffs: for levels of electronic state s , neglect data with: c J(s) > JTRUNC(s), or vibrational levels lying outside the range c VMIN(s,ISOT) to VMAX(s,ISOT), AND NEGLECT any data for which c read-in uncertainty is > UCUTOFF (cm-1). EFSEL(s) > 0 causes c f-parity levels to be neglected, EFSEL(s) < 0 omits e-parity levels c while EFSEL(s) = 0 allows both types of parity to be included. c NOWIDTHS > 0 causes the program to ignore any tunneling widths in c the data set. c PRINP > 0 turns on the printing of a summary description of the data. c** On Return: c UCUTOFF (cm-1) is the smallest uncertainty in the (accepted) data c NDAT(v,i,s) is the number of transitions associated with c vibrational level-v of isotopologue-i of state-s [for NDEGB < 0 case] c** This subroutine reads in the experimental data on channel-4 c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKTYPE.h' c======================================================================= c** Type statements & common blocks for characterizing transitions REAL*8 AVEUFREQ(NPARMX),MAXUFREQ(NPARMX) INTEGER NTRANSFS(NISTPMX,NSTATEMX), 1 NTRANSVIS(NISTPMX,NSTATEMX,NSTATEMX), 1 NBANDEL(NISTPMX,NSTATEMX,NSTATEMX), 2 NTRANSIR(NISTPMX,NSTATEMX),NTRANSMW(NISTPMX,NSTATEMX), 3 NBANDFS(NISTPMX,NSTATEMX),NBANDVIS(NISTPMX,NSTATEMX), 4 NBANDIR(NISTPMX,NSTATEMX),NBANDMW(NISTPMX,NSTATEMX), 5 NVVPP(NISTPMX,NSTATEMX),NWIDTH(NISTPMX,NSTATEMX), 6 NEBPAS(NISTPMX,NSTATEMX),NVIRIAL(NISTPMX,NSTATEMX), 7 NAcVIR(NISTPMX,NSTATEMX),NBANDS(NISTPMX) c COMMON /BLKTYPE/AVEUFREQ,MAXUFREQ,NTRANSFS,NTRANSVIS,NTRANSIR, 1 NTRANSMW,NBANDFS,NBANDEL,NBANDVIS,NBANDIR,NBANDMW,NVVPP,NWIDTH, 2 NEBPAS,NVIRIAL,NAcVIR,NBANDS c======================================================================= c INTEGER I,IBN,COUNT,IBAND, 1 VMX(NSTATEMX),ISOT,NBND,ESP,ESPP,ISTATE,ISTATEE,MN1,MN2,PRINP, 2 FSOMIT,VMAXesp,VMINesp,VMAXespp,VMINespp,JTRUNCesp,JTRUNCespp INTEGER NOWIDTHS,NDAT(0:NVIBMX,NISTPMX,NSTATEMX),PASok(NSTATEMX) REAL*8 UCUTOFF,UMIN,TOTUFREQ CHARACTER*3 NEF(-1:1) CHARACTER*3 LABLP,LABLPP CHARACTER*2 OLDSLABL(-6:0) c----------------------------------------------------------------------- DATA NEF/' f',' ',' e'/ c** maintain compatibility with old labeling method OLDSLABL(-6)=' ' !! awaiting new data type OLDSLABL(-5)='VA' OLDSLABL(-4)='VR' OLDSLABL(-3)='VV' OLDSLABL(-2)='WI' OLDSLABL(-1)='PA' OLDSLABL(0)='FS' c----------------------------------------------------------------------- WRITE(6,603) UCUTOFF DO ISTATE= 1,NSTATES IF(JTRUNC(ISTATE).GE.0) THEN WRITE(6,607) SLABL(ISTATE),JTRUNC(ISTATE) ELSE WRITE(6,605) SLABL(ISTATE),-JTRUNC(ISTATE) ENDIF WRITE(6,611) (VMIN(ISTATE,ISOT),VMAX(ISTATE,ISOT),ISOT, 1 ISOT= 1,NISTP) IF(EFSEL(ISTATE).GT.0) WRITE(6,601) NEF(-1) IF(EFSEL(ISTATE).LT.0) WRITE(6,601) NEF(1) ENDDO UMIN= UCUTOFF c** Initialize counters for book-keeping on input data COUNT= 0 DO ISOT= 1,NISTP DO ISTATE= 1,NSTATES NTRANSFS(ISOT,ISTATE)= 0 NTRANSIR(ISOT,ISTATE)= 0 NTRANSMW(ISOT,ISTATE)= 0 NBANDFS(ISOT,ISTATE)= 0 NBANDVIS(ISOT,ISTATE)= 0 NBANDIR(ISOT,ISTATE)= 0 NBANDMW(ISOT,ISTATE)= 0 NVVPP(ISOT,ISTATE)= 0 NWIDTH(ISOT,ISTATE)= 0 NEBPAS(ISOT,ISTATE)= 0 NVIRIAL(ISOT,ISTATE)= 0 NAcVIR(ISOT,ISTATE)= 0 DO I= 1,NSTATES NTRANSVIS(ISOT,ISTATE,I)= 0 NBANDEL(ISOT,ISTATE,I)= 0 ENDDO ENDDO NBANDS(ISOT)= 0 ENDDO DO ISTATE= 1,NSTATES VMX(ISTATE)= 0 ENDDO NFSTOT= 0 FSOMIT= 0 c======================================================================== c** Begin loop to read in data, band(or series)-by-band(or series). c STOP when run out of bands or when encounter a negative vibrational c quantum number. c** Read all data for each isotopologue at one time. IBAND= 0 10 CONTINUE IBAND= IBAND+1 IF(IBAND.GT.NPARMX) THEN IF(PRINP.GT.0) WRITE(6,609) IBAND,NPARMX IBAND= IBAND-1 GOTO 40 ENDIF c c For each "band", read in: (i) upper/lower vibrational quantum numbers c VP & VPP, (ii) a two-character electronic-state alphameric label c {enclosed in single quotes; e.g., 'X0' or 'A1'} for the upper c (LABLP) and lower (LABLP) state, and (iii) integers NM1 & NM2 are c the mass numbers [corresponding to input atomic numbers AN(1) & c AN(2)] identifying the particular isotopologue. Note that LABLP also c identifies the type of data in the 'band' or data-group (see below). c** LABLP = LABLPP and VP = VPP for a microwave band c LABLP = LABLPP and VP.ne.VPP for an infrared band c LABLP = 'FLS' identifies this data group/band as a fluorescence c series from a single emitting level into vibrational levels c of electronic state LABLPP. In this case: VP is the quantum c number v' for the emitting level, while VPP is actually the c rotational quantum number J' for the emitting level and JP c [see below] the lower state vibrational quantum number v". c LABLP = 'PAS' identifies this data group/band as a set of binding c energies [D-E(v,J,p)] for a given state. Data Labels as for 'FS' c LABLP = 'BV' identifies this data group/band as a set of Bv values c for electronic state LABLPP. In this case, parameters VP c & VPP are dummy variables, as are EFP, JPP and EFPP [see c below], JP is actually the vibrational quantum number v", c FREQ the Bv value & UFREQ its uncertainty c LABLP = 'WID' identifies this data group/band as a set of tunneling c predissociation widths for electronic state LABLPP. In this c case, parameters VP, VPP and EFP are dummy variables, while c the predissociating level is identified as: v"=JP, J"=JPP, c and parity p"=EFPP. c LABLP = 'VVV' to identify this as a set of potential fx. values c e.g., ab initio values for the high repulsive wall. In this c case, parameters VP, VPP are dummy variables. c LABLP = 'VIR' identifies this data group/band as a set of virial c coefficients for electronic state LABLPP. In this case, c parameters VP, VPP are dummy variables. c LABLP = 'VAC' identifies this data group/band as a set of virial c coefficients for electronic state LABLPP. In this case, c parameters VP, VPP are dummy variables. c** STOP reading when run out of bands OR when read-in VPP is negative c----------------------------------------------------------------------- IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN READ(4,*,END=40) VP(IBAND), VPP(IBAND), LABLP, LABLPP, MN1, MN2, 1 BANDNAME(IBAND) ELSE READ(4,*,END=40) VP(IBAND), VPP(IBAND), LABLP, LABLPP, MN1, MN2 ENDIF c----------------------------------------------------------------------- IF(VP(IBAND).LT.0) GO TO 40 IEP(IBAND)= -99 IEPP(IBAND)= -99 DO I= -6, 0 IF(LABLP.EQ.OLDSLABL(I)) LABLP= SLABL(I) IF(LABLPP.EQ.OLDSLABL(I)) LABLPP= SLABL(I) ENDDO DO I= -6, NSTATES IF(LABLP.EQ.SLABL(I)) IEP(IBAND)= I IF(LABLPP.EQ.SLABL(I)) IEPP(IBAND)= I ENDDO c** Check that this isotopologue is one of those chosen to be fitted ... ISOT= 0 DO I= 1,NISTP IF((MN1.EQ.MN(1,I)).AND.(MN2.EQ.MN(2,I))) ISOT= I ENDDO ISTP(IBAND)= ISOT ESP= IEP(IBAND) ESPP= IEPP(IBAND) IF(IEP(IBAND).EQ.-3) THEN c** For case in which the 'data' are potential function value(s) in cm-1 ... COUNT= COUNT+ 1 IFIRST(IBAND)= COUNT c... TEMP(i)= r(i) ; FREQ(i)= V(r(i)) ; UFREQ= unc{V(r(i))} c---------------------------------------------------------------------- 12 READ(4,*) TEMP(COUNT),FREQ(COUNT),UFREQ(COUNT) c---------------------------------------------------------------------- YUNC(COUNT)= UFREQ(COUNT) c ... a negative input distance implies end of potential energy data set IF(TEMP(COUNT).GT.0.d0) THEN c ... if this isotope or state not considered, ignore this datum IF((ISOT.LE.0).OR.(ESPP.LT.-6)) GOTO 12 c ... if no potential used, ignore this datum IF(PSEL(ESPP).LT.0) GOTO 12 IB(COUNT)= IBAND COUNT= COUNT+1 GOTO 12 ELSE GOTO 18 ENDIF ENDIF IF((IEP(IBAND).EQ.-4).OR.(IEP(IBAND).EQ.-5)) THEN c** For case in which the data are virial coefficients COUNT= COUNT+ 1 IFIRST(IBAND)= COUNT c... TEMP(i)= temperature[K], FREQ(i)= Bvir(i), UFREQ(i)= unc{Bvir(i)} c---------------------------------------------------------------------- 14 READ(4,*) TEMP(COUNT),FREQ(COUNT),UFREQ(COUNT) c---------------------------------------------------------------------- YUNC(COUNT)= UFREQ(COUNT) c ... negative input 'temperature' implies end of virial/PE data set IF(TEMP(COUNT).GT.0.d0) THEN c ... if this isotope or state not considered, ignore this datum IF((ISOT.LE.0).OR.(ESPP.LT.-6)) GOTO 14 c ... if no potential used, ignore this datum IF(PSEL(ESPP).LT.0) GOTO 14 IB(COUNT)= IBAND COUNT= COUNT+1 GOTO 14 ELSE !! for 'TEMP'.LE.0 GOTO 18 ENDIF ENDIF c... now ... for the case of spectroscopic data ... TOTUFREQ= 0.D0 MAXUFREQ(IBAND)= 0 JMAX(IBAND)= 0 JMIN(IBAND)= 9999 COUNT= COUNT+1 IF(COUNT.GT.NDATAMX) THEN WRITE(6,640) COUNT,NDATAMX STOP ENDIF NTRANS(IBAND)= 0 IFIRST(IBAND)= COUNT VMAXespp= 0 VMINespp= 0 VMAXesp= 0 VMINesp= 0 IF((ESPP.GT.0).AND.(ISOT.GT.0)) THEN VMAXespp= VMAX(ESPP,ISOT) VMINespp= VMIN(ESPP,ISOT) JTRUNCespp= JTRUNC(ESPP) IF(ISOT.GT.1) THEN VMAXespp= INT((VMAX(ESPP,ISOT)+0.5d0)/RSQMU(ISOT)-0.5d0) !! added VMINespp= INT((VMIN(ESPP,ISOT)+0.5d0)/RSQMU(ISOT)-0.5d0) !! added JTRUNCespp= INT(JTRUNC(ESPP)/RSQMU(ISOT)) ENDIF cc VMAXesp= VMAX(ESPP,ISOT) ?????? Huh ??????/ ENDIF IF((ESP.GT.0).AND.(ISOT.GT.0)) THEN VMAXesp= VMAX(ESP,ISOT) VMINesp= VMIN(ESP,ISOT) JTRUNCesp= JTRUNC(ESP) IF(ISOT.GT.1) THEN JTRUNCesp= INT(JTRUNC(ESP)/RSQMU(ISOT)) ENDIF ENDIF c** For each of the lines in a given band/series, read upper level c rotational quantum number (JP) and e/f parity [EFP= +1 for e, -1 for c f, and 0 if e/f splitting unresolved and to be ignored], and lower c level rotational quantum number (JPP) and parity [EFPP, as above], c the transition frequency FREQ, and its uncertainty UFREQ. c** For PAS or Tunneling Width data, JP(COUNT)=v", JPP(COUNT)=J", c EFPP(COUNT)=p", FREQ is the observable (a positive No.), while c EFP(COUNT), VP(IBAND) & VPP(IBAND) are dummy variables. c** For Bv values, JP(COUNT)=v" while JPP(COUNT), EFP(COUNT) and c EFPP(COUNT) as well as VP(IBAND) & VPP(IBAND) are dummy variables. c----------------------------------------------------------------------- 15 READ(4,*) JP(COUNT), EFP(COUNT), JPP(COUNT), EFPP(COUNT), 1 FREQ(COUNT), UFREQ(COUNT) c----------------------------------------------------------------------- c======================================================================= c Sample IR band data of HF for the '.4' file: c -------------------------------------------- c 1 0 'X0' 'X0' 1 19 % VP VPP LABLP LABLPP MN1 MN2 c 8 1 9 1 266.0131002 0.005 % JP EFP JPP EFPP FREQ UFREQ c 9 1 10 1 265.8885896 0.003 c 10 1 11 1 265.7716591 0.002 c . . . . c . . . . c [end of a band indicated by -ve JP and/or JPP value(s)] c -1 1 -1 1 -1.1 -1.1 c======================================================================= YUNC(COUNT)= UFREQ(COUNT) IF(EFP(COUNT).GT.1) EFP(COUNT)= 1 IF(EFP(COUNT).LT.-1) EFP(COUNT)= -1 IF(EFPP(COUNT).GT.1) EFPP(COUNT)= 1 IF(EFPP(COUNT).LT.-1) EFPP(COUNT)= -1 c** At end of a band, exit from implicit loop IF((JPP(COUNT).LT.0).OR.(JP(COUNT).LT.0)) GOTO 18 c** If this band is not for one of the chosen isotopologues or states c or 'property' datum w. no PEC, omit this datum from the fit IF((ISOT.EQ.0).OR.(ESPP.LT.-6)) GO TO 15 IF((PSEL(ESPP).LT.0).AND.(ESP.LT.0)) GO TO 15 c** If this band involves electronic states other than those chosen to c be treated, omit its data from the fit IF((ESP.EQ.-99).OR.(ESPP.EQ.-99)) GO TO 15 c** If a datum uncertainty of zero is accidentally read in, STOP IF(DABS(UFREQ(COUNT)).LE.0.d0) THEN WRITE(6,600) COUNT,FREQ(COUNT),IBAND STOP ENDIF c** Omit data with uncertainties outside specified limit UCUTOFF IF(UFREQ(COUNT).GT.UCUTOFF) GOTO 15 c** Require that datum lies within specified J & v ranges IF(ESP.GE.-2) THEN IF(((JTRUNCespp.GE.0).AND.(JPP(COUNT).GT.JTRUNCespp)).OR. 1 ((JTRUNCespp.LT.0).AND.(JPP(COUNT).LT.-JTRUNCespp))) 2 GOTO 15 IF((EFPP(COUNT)*EFSEL(ESPP)).LT.0) GOTO 15 ENDIF IF(ESP.GT.0) THEN IF(VPP(IBAND).GT.VMAXespp) GOTO 15 IF(VPP(IBAND).LT.VMINespp) GOTO 15 IF(VP(IBAND).GT.VMAXesp) GOTO 15 IF(VP(IBAND).LT.VMINesp) GOTO 15 IF((JTRUNCesp.GE.0).AND.(JP(COUNT).GT.JTRUNCesp)) GOTO 15 IF((JTRUNCesp.LT.0).AND.(JP(COUNT).LT.-JTRUNCesp)) GOTO 15 IF((EFP(COUNT)*EFSEL(ESP)).LT.0) GOTO 15 ELSE IF(JP(COUNT).GT.VMAXespp) GOTO 15 IF(JP(COUNT).LT.VMINespp) GOTO 15 ENDIF c** If NOWIDTHS > 0 omit any tunneling width data from the fit. IF((ESP.EQ.-2).AND.(NOWIDTHS.GT.0)) GOTO 15 c c** End of tests for datum inclusion. Now count/sort data c======================================================================= c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c%%% Convert MHz to cm-1 c freq(count)=freq(count)/2.99792458d+4 c ufreq(count)=ufreq(count)/2.99792458d+4 c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TVUP(COUNT)= 0 TVLW(COUNT)= 0 c?? RJL What was the purpose of UMIN ? a check on EPS ? IF(ESP.GE.-1) UMIN= MIN(UMIN,UFREQ(COUNT)) c** Determine actual v & J range of data & count data for each v c JMIN & JMAX needed for printout summary & data-count for testing c no. parameters allowed in Band Constant fit. c??? This segment imperfect & needs re-examination ????????????? IF(ESP.GT.0) THEN IF(JPP(COUNT).LT.JMIN(IBAND)) JMIN(IBAND)= JPP(COUNT) IF(JPP(COUNT).GT.JMAX(IBAND)) JMAX(IBAND)= JPP(COUNT) IF(JP(COUNT).LT.JMIN(IBAND)) JMIN(IBAND)= JP(COUNT) IF(JP(COUNT).GT.JMAX(IBAND)) JMAX(IBAND)= JP(COUNT) VMX(ESP)= MAX(VMX(ESP),VP(IBAND)) VMX(ESPP)= MAX(VMX(ESPP),VPP(IBAND)) c c** Accumulate count of data associated with each vibrational level ... NDAT(VPP(IBAND),ISTP(IBAND),ESPP)= 1 NDAT(VPP(IBAND),ISTP(IBAND),ESPP)+ 1 NDAT(VP(IBAND),ISTP(IBAND),ESP)= 1 NDAT(VP(IBAND),ISTP(IBAND),ESP)+ 1 ELSEIF((ESP.LE.0).OR.(ESP.GE.-2)) THEN IF(JP(COUNT).LT.JMIN(IBAND)) JMIN(IBAND)= JP(COUNT) IF(JP(COUNT).GT.JMAX(IBAND)) JMAX(IBAND)= JP(COUNT) VMX(ESPP)= MAX(VMX(ESPP),JP(COUNT)) NDAT(JP(COUNT),ISTP(IBAND),ESPP)= 1 NDAT(JP(COUNT),ISTP(IBAND),ESPP)+ 1 ELSEIF(ESP.LE.-3) THEN c... and for potential function values as data ... IF(TEMP(COUNT).LT.JMIN(IBAND)) JMIN(IBAND)= TEMP(COUNT) IF(TEMP(COUNT).GT.JMAX(IBAND)) JMAX(IBAND)= TEMP(COUNT) NDAT(JPP(COUNT),ISTP(IBAND),ESPP)= 1 NDAT(JPP(COUNT),ISTP(IBAND),ESPP)+ 1 ENDIF DFREQ(COUNT)= 0.d0 IB(COUNT)= IBAND TOTUFREQ= TOTUFREQ+UFREQ(COUNT) IF(UFREQ(COUNT).GT.MAXUFREQ(IBAND)) MAXUFREQ(IBAND)= UFREQ(COUNT) COUNT= COUNT+1 IF(COUNT.GT.NDATAMX) THEN WRITE(6,640) COUNT,NDATAMX STOP ENDIF GOTO 15 c** End of loop reading data for a given band/series c c** Tidy up at end of reading for a given band 18 COUNT= COUNT-1 ILAST(IBAND)= COUNT NTRANS(IBAND)= ILAST(IBAND)-IFIRST(IBAND)+1 IF(NTRANS(IBAND).GT.0) THEN c** Treat PAS data as Fluorescence series unless PASok > 0 IF((IEP(IBAND).EQ.-1).AND.(PASok(IEPP(IBAND)).LE.0)) 1 IEP(IBAND)=0 IF((NTRANS(IBAND).EQ.1).AND.(LABLP.EQ.'FS')) THEN c** Ignore any fluorescence series consisting of only one datum COUNT= COUNT-1 IBAND= IBAND-1 FSOMIT= FSOMIT+1 GOTO 10 ENDIF AVEUFREQ(IBAND)= TOTUFREQ/NTRANS(IBAND) NBANDS(ISTP(IBAND))= NBANDS(ISTP(IBAND))+1 ELSE IBAND= IBAND-1 GOTO 10 ENDIF c======================================================================= c** Accumulate counters for bands/series of different types IF(ESP.EQ.0) THEN c** For Fluorescence Series ... first enumerate the No. of bands & lines NFSTOT= NFSTOT+1 c** Define counters to label which f.s. is associated with band IBAND c ... FSBAND(j) is the absolute band number for the j'th FS c ... NDF(IBAND) if the FS number associated with band IBAND FSBAND(NFSTOT)= IBAND NFS(IBAND)= NFSTOT NBANDFS(ISOT,ESPP)= NBANDFS(ISOT,ESPP)+ 1 NBND= NBANDFS(ISOT,ESPP) NTRANSFS(ISOT,ESPP)= NTRANSFS(ISOT,ESPP)+NTRANS(IBAND) c ... and then set up labels/ranges/properties for each band IBB(ISOT,ESPP,1,NBND)= IBAND IFXFS(NFSTOT)= 0 IF((NFSTOT.GT.1).AND.(FSsame.GT.0)) THEN c** Finally - If desired (FSsame > 0) check to see if this band has the c same upper state as an FS for this isotopologue encountered earlier, c and if so (try) to relabel origin accordingly ... DO I= 1, NFSTOT-1 IF((VP(IBAND).EQ.VP(FSBAND(I))).AND. 1 (VPP(IBAND).EQ.VPP(FSBAND(I))).AND. 2 (ISTP(IBAND).EQ.ISTP(FSBAND(I)))) THEN c ... fix origin for this FS band to be the same as that for FS band I IFXFS(NFSTOT)= I WRITE(6,654) VP(IBAND),VPP(IBAND),ISTP(IBAND), 1 NFSTOT,I 654 FORMAT(" NOTE that FS(v'=",I4,", J'=",I3,", ISOT=",I2,") #",I4, 1 " has same origin as FS #",I4) GOTO 20 ENDIF ENDDO 20 CONTINUE ENDIF ENDIF c IF((ESP.GT.0).AND.(ESP.NE.ESPP)) THEN c** For vibrational band of a normal 2-state electronic transition c ... count bands and transitions in visible (electronic) spectrum NBANDEL(ISOT,ESP,ESPP)= NBANDEL(ISOT,ESP,ESPP)+ 1 NBANDVIS(ISOT,ESPP)= NBANDVIS(ISOT,ESPP)+ 1 NBND= NBANDVIS(ISOT,ESPP) NTRANSVIS(ISOT,ESP,ESPP)= 1 NTRANSVIS(ISOT,ESP,ESPP)+NTRANS(IBAND) c ... and then set up labels/ranges/properties for each of them IBB(ISOT,ESPP,2,NBND)= IBAND ENDIF c IF((ESP.EQ.ESPP).AND.(VP(IBAND).NE.VPP(IBAND))) THEN c** For an Infrared band of electronic state s=ESPP=ESP c** First cumulatively count the number of IR bands & transitions NBANDIR(ISOT,ESPP)= NBANDIR(ISOT,ESPP)+1 NBND= NBANDIR(ISOT,ESPP) NTRANSIR(ISOT,ESPP)= NTRANSIR(ISOT,ESPP)+NTRANS(IBAND) c ... and then set up labels/ranges/properties for each of them IBB(ISOT,ESPP,3,NBND)= IBAND ENDIF c IF((ESP.EQ.ESPP).AND.(VP(IBAND).EQ.VPP(IBAND))) THEN c** For Microwave transitions in electronic state s=ESPP=ESP c** First cumulatively count the number of MW bands & transitions NBANDMW(ISOT,ESPP)= NBANDMW(ISOT,ESPP)+1 NBND= NBANDMW(ISOT,ESPP) NTRANSMW(ISOT,ESPP)= NTRANSMW(ISOT,ESPP)+NTRANS(IBAND) c ... and then set up labels/ranges/properties for each of them IBB(ISOT,ESPP,4,NBND)= IBAND ENDIF c c** NOTE ... in IBB array a last index counts bands of this type for c this isotopologue of this electronic state. Expect to find all c potential fx. values, virial coeficients, Tunneling Widths, PAS c binding energies, virial coeffts, ... etc. in a single group. IF(ESP.EQ.-5) THEN c** Data are Accoustic Virial Coefficients for electronic state IEPP= ESPP NAcVIR(ISOT,ESPP)= NTRANS(IBAND) IBB(ISOT,ESPP,9,1)= IBAND ENDIF c IF(ESP.EQ.-4) THEN c** Data are pressure Virial Coefficients for electronic state IEPP= ESPP NVIRIAL(ISOT,ESPP)= NTRANS(IBAND) IBB(ISOT,ESPP,8,1)= IBAND ENDIF c IF(ESP.EQ.-3) THEN c** Data are not transition energies, but rather values of the potential c function at particular distances for electronic state s=IEPP WRITE(6,612) LABLPP,ISOT NVVPP(ISOT,ESPP)= NTRANS(IBAND) IBB(ISOT,ESPP,5,1)= IBAND ENDIF c IF(ESP.EQ.-2) THEN c** Data are tunneling predissociation linewidths (in cm-1) for levels c of electronic state IEPP=ESPP ccc IF((NWIDTH(ISOT,ESPP).GT.0).AND.(NTRANS(IBAND).GT.0)) THEN WRITE(6,626) ESPP,ISOT ccc STOP ccc ENDIF NWIDTH(ISOT,ESPP)= NTRANS(IBAND) IBB(ISOT,ESPP,6,1)= IBAND ENDIF c IF(ESP.EQ.-1) THEN c** Data are PhotoAssociation Binding Energies (in cm-1) for levels c of electronic state IEPP=ESPP WRITE(6,636) LABLPP,ISOT NEBPAS(ISOT,ESPP)= NTRANS(IBAND) IBB(ISOT,ESPP,7,1)= IBAND ENDIF c c** Now return to read the next band GOTO 10 c======================================================================== c** Now, write a summary of the input data to the output file 40 COUNTOT= COUNT NBANDTOT= 0 DO I= 1,NISTP NBANDTOT= NBANDTOT+ NBANDS(I) ENDDO ISOT= 1 UCUTOFF= UMIN IF(FSOMIT.GT.0) WRITE(6,650) FSOMIT IF(PRINP.LE.0) RETURN c** Write a summary of the data, one isotopologue at a time. 26 WRITE(6,602) NBANDS(ISOT), (NAME(I),MN(I,ISOT),I=1,2) c DO 50 ISTATE= 1,NSTATES c ... For internal use, may wish to update VMAX(ISTATE,ISOT) to actual c highest v in the data set for this state. ** Reactivate as needed. c VMAX(ISTATE,ISOT)= VMX(ISTATE) c ... and separately list data for each (lower) electronic state in turn IF(NTRANSMW(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Micowave data WRITE(6,604) NTRANSMW(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NBANDMW(ISOT,ISTATE) DO I= 1,NBANDMW(ISOT,ISTATE) IBN=IBB(ISOT,ISTATE,4,I) WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN) ENDDO ENDIF c IF(NTRANSIR(ISOT,ISTATE).GT.0)THEN c** Book-keeping for Infrared data WRITE(6,608) NTRANSIR(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NBANDIR(ISOT,ISTATE) DO I= 1,NBANDIR(ISOT,ISTATE) IBN=IBB(ISOT,ISTATE,3,I) WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN) ENDDO ENDIF c c** Book-keeping for electronic vibrational band data DO ISTATEE= 1,NSTATES IF((ISTATEE.NE.ISTATE).AND. 1 (NTRANSVIS(ISOT,ISTATEE,ISTATE).GT.0)) THEN c ... for ISTATEE{upper}-ISTATE{lower} electronic vibrational bands WRITE(6,610) NTRANSVIS(ISOT,ISTATEE,ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),SLABL(ISTATEE),SLABL(ISTATE), 2 NBANDEL(ISOT,ISTATEE,ISTATE) DO I= 1,NBANDVIS(ISOT,ISTATE) IBN=IBB(ISOT,ISTATE,2,I) IF(IEP(IBN).EQ.ISTATEE) THEN WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN) ENDIF ENDDO ENDIF ENDDO IF(NTRANSFS(ISOT,ISTATE).GT.0)THEN c** Book-keeping for Fluorescence data WRITE(6,614) NTRANSFS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NBANDFS(ISOT,ISTATE) DO I= 1,NBANDFS(ISOT,ISTATE) IBN = IBB(ISOT,ISTATE,1,I) WRITE(6,616) VP(IBN),VPP(IBN), 1 NEF(EFP(IFIRST(IBB(ISOT,ISTATE,1,I)))), 2 NTRANS(IBN),JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN) ENDDO ENDIF IF(NVVPP(ISOT,ISTATE).GT.0)THEN c** Book-keeping for potential function values as data .... WRITE(6,618) NVVPP(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2) IBN=IBB(ISOT,ISTATE,5,1) WRITE(6,620) NTRANS(IBN),JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN), 2 MAXUFREQ(IBN) ENDIF IF(NWIDTH(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Tunneling Width data WRITE(6,628) NWIDTH(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2) IBN=IBB(ISOT,ISTATE,6,1) WRITE(6,630) NTRANS(IBN),JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN), 3 MAXUFREQ(IBN) ENDIF IF(NEBPAS(ISOT,ISTATE).GT.0) THEN c** Book-keeping for PAS Binding Energy data WRITE(6,632) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2) IBN=IBB(ISOT,ISTATE,7,1) WRITE(6,630) NTRANS(IBN),JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN), 3 MAXUFREQ(IBN) ENDIF IF(NVIRIAL(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Virial data WRITE(6,642) NVIRIAL(ISOT,ISTATE), SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2) ENDIF IF(NAcVIR(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Accoustic Virial data WRITE(6,644) NAcVIR(ISOT,ISTATE), SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2) ENDIF 50 CONTINUE IF(ISOT.LT.NISTP) THEN c** If NISTP > 1, return to print data summaries for other isotopologues ISOT= ISOT+1 GO TO 26 ENDIF WRITE(6,622) RETURN 600 FORMAT(/' *** INPUT ERROR *** Datum FREQ(',i5,')=',f12.4, 1 ' in IBAND=',i4,' has zero uncertainty!!!') 601 FORMAT(23x,'or with',A3,'-parity.') 603 FORMAT(/' Neglect data with: Uncertainties > UCUTOFF=',1PD10.2, 1 ' (cm-1)') 605 FORMAT(7x,'and State ',A3,' data with J < JTRUNC=',I4) 607 FORMAT(7x,'and State ',A3,' data with J > JTRUNC=',I4) 611 FORMAT(29x,'or v outside range',i3,' to',i4,' for ISOT=', 1 i2:) 602 FORMAT(/1x,20('===')/' *** Input data for',i5,' bands/series of ' 1 ,A2,'(',I3,')-',A2,'(',I3,') ***'/1x,20('===')) 604 FORMAT(1x,28('--')/I5,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') MW transitions in',i4,' sets'/1x,28('--')/" v' ", 1 'v" #data Jmin Jmax Avge.Unc. Max.Unc.'/1x,25('--')) 606 FORMAT(I4,I4,3I7,1x,1P2D10.1) 608 FORMAT(1x,32('--')/I6,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') InfraRed transitions in',I4,' bands'/1x,32('--')/ 2 " v' ",'v" #data Jmin Jmax Avge.Unc. Max.Unc.'/ 3 1x,25('--')) 609 FORMAT(/' *** ERROR *** Dimension allocated for number of bands ex 1ceeded:'/' (IBAND=',i4,') > (NBANDMX=',i4,') so truncate input a 2nd TRY to continue ...') 610 FORMAT(/1x,35('==')/I6,1x,A2,'(',I3,')-',A2,'(',i3,') {State ', 1 A3,'}--{State ',A3,'} Transitions in',i4,' Bands'/1x,35('--')/ 2 " v'",' v" #data Jmin Jmax Avge.Unc. Max.Unc.'/ 3 1x,25('--')) 612 FORMAT(/" NOTE that read-in potential fx. values for ISTATE= ", 1 A3,' ISOT=',i2/32x,' must be input as a single "band" or data 1 group') 614 FORMAT(1x,38('==')/I5,' Fluorescence transitions into State ', 1 A3,2x,A2,'(',I3,')-',A2,'(',I3,') in',i5,' series'/ 2 1x,38('==')/" v' j' p' ",'#data v"min v"max Avge.Unc. Max. 3Unc.'/1x,51('-')) 616 FORMAT(2I4,A3,I6,2I7,1x,1P2D10.1) 618 FORMAT(1x,65('=')/1x,I3,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') potential fx values treated as independent data'/1x,24('--')/ 2 ' #values r(min) r(max) Avge.Unc. Max.Unc.'/1x,24('--')) 620 FORMAT(I7,I9,I8,3x,1P2D11.1) 622 FORMAT(1x,25('===')/1x,25('===')) 626 FORMAT(/" NOTE that all read-in Tunneling Widths for ISTATE=", 1 i2,' ISOT=',i2/10x,' must be in a single "band" or data group') cc626 FORMAT(/" *** STOP INPUT *** and put all read-in Tunneling Widths' cc 1 ' for ISTATE=",i2,' ISOT=',i2/ cc 2 10x,'into one "band" or data group.') 628 FORMAT(1x,61('=')/1x,I3,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') Tunneling Widths included as data'/ 2 1x,61('-')/' #values v(min) v(max) Avge.Unc. Max.Unc.'/ 3 1x,24('--')) 630 FORMAT(I7,I9,I8,2x,1P2D11.1) 632 FORMAT(1x,70('=')/I4,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') PAS Binding Energies included in data set'/ 2 1x,70('-')/' #values v(min) v(max) Avge.Unc. Max.Unc.'/ 3 1x,24('--')) 636 FORMAT(/' NOTE that all read-in PAS Binding Energies for ISTATE= 1 ',a2,' ISOT=',i2/10x,' must be in a single "band" or data group' 2 ) 640 FORMAT(/' *** Input Data Count reaches',i6,' which EXCEEDS ARRAY L 1IMIT of',i6) 642 FORMAT(1x,70('=')/I4,' State ',A3,1x,A2,'(',I3,')-',A2, 1 '(',I3,') Virial coefficients included in data set' ) 644 FORMAT(1x,70('=')/I4,' State ',A3,1x,A2,'(',I3,')-',A2, 1 '(',I3,') Accoustic Virial coefficients included in data set' ) 650 FORMAT(/' Data input IGNORES',i4,' fluorescence series consisting' 1 ,' of only onee line!') END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE TVSORT(ISTATE,NPTOT,VMAX,NTVALL,NTVSSTAT,TVNAME) c*********************************************************************** c** Subroutine to sort through global data file, and for each isotopologue c in state ISTATE: (1) find the number of transitions coupled to each c level (v,J,p), (2) for levels in order (v,J,p), add a free parameter c for each level involved in one or more transitions, and (3) label each c transition involving one of these levels by the index/counter of the c parameter associated with that term value. c ********* Version of 27 August 2004 ********* c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On Entry: c------------ c ISTATE is the electronic state being considered. c NPTOT enters as the cumulative count of parameters prior to entry c TVUP(i) and TVLW(i) in COMMON equal zero for all data c c** On Return: c------------- c NPTOT is updated to include the number of term values for this state c TVUP(i) & TVLW(i): if the upper and/or lower level of transition-i is c to be represented by a term value, TVUP and TVLW (respectively) c is the associated parameter index; otherwise they = 0. c NTVALL is the total number of term value parameters for this state c NTVSSTAT is the total number of term values this state associated c with only a single transition c TVNAME(j) is the alphameric name identifying term value parameter j c c** Internally c------------- c NLV(v,J.p) * initially, counts transitions for level {v,J,p} of a c given isotopologue c * later reset it as the parameter index for that term value c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= c INTEGER I,J,P,IBAND,ISOT,ISTATE,NPTOT,LOWEST, 1 VMAX(NSTATEMX,NISTPMX),NLV(0:NVIBMX,0:NVIBMX,-1:1), 2 NTVS(NSTATEMX,NISTPMX),NTVALL(0:NSTATEMX),NTVSSTAT CHARACTER*24 TVNAME(NPARMX) c======================================================================= WRITE(6,600) SLABL(ISTATE) LOWEST= 1 IF(ISTATE.GT.1) LOWEST= 0 NTVALL(ISTATE)= 0 NTVSSTAT= 0 DO ISOT= 1, NISTP c** First ... zero transition counter array for this isotopologue DO I= 0, VMAX(ISTATE,ISOT) DO J= 0, NVIBMX DO P= -1,1 NLV(I,J,P)= 0 ENDDO ENDDO ENDDO DO IBAND= 1, NBANDTOT c** Then ... search for bands involving isotopologue ISOT in this state IF(((IEP(IBAND).EQ.ISTATE).OR.(IEPP(IBAND).EQ.ISTATE)) 1 .AND.(ISTP(IBAND).EQ.ISOT).AND.(IEP(IBAND).GE.0)) THEN DO I= IFIRST(IBAND), ILAST(IBAND) c ... for each such band, loop over all transitions, and increment NLV c for each {v,J,p} level encountered in a transision IF(IEP(IBAND).EQ.ISTATE) THEN IF(JP(I).GT.NVIBMX) THEN c ... check for array dimension overruns WRITE(6,602) ISTATE,ISOT,JP(I),NVIBMX STOP ENDIF NLV(VP(IBAND),JP(I),EFP(I))= 1 NLV(VP(IBAND),JP(I),EFP(I))+ 1 ENDIF IF(IEPP(IBAND).EQ.ISTATE) THEN IF(JPP(I).GT.NVIBMX) THEN WRITE(6,604) ISTATE,ISOT,JPP(I),NVIBMX STOP ENDIF NLV(VPP(IBAND),JPP(I),EFPP(I)) 1 = NLV(VPP(IBAND),JPP(I),EFPP(I))+ 1 ENDIF ENDDO ENDIF c** Finished scan over all data set for this isotopologue ENDDO c c** Now ... count a free parameter for each level in a transition c** NTV is the total number of term values for case (ISTATE,ISOT) c NTVS is the no. of them involved in only a single transition NTV(ISTATE,ISOT)= 0 NTVS(ISTATE,ISOT)= 0 DO I= 0, VMAX(ISTATE,ISOT) DO J= 0, NVIBMX DO P= -1,1 IF(NLV(I,J,P).GT.0) THEN c!! For ParFit ONLY!! IF(LOWEST.EQ.1) THEN c!! If using term values for `lowest' state (defined as the first state c!!considered), its lowest observed level for isotopologue-1 defines the c!! absolute energy zero c!! WRITE(6,606) I,J,P,ISOT,SLABL(ISTATE) c!! LOWEST= 0 c!! NLV(I,J,P)= 0 c!! GOTO 20 c!! ENDIF NPTOT= NPTOT+ 1 NTV(ISTATE,ISOT)= NTV(ISTATE,ISOT)+ 1 IF(NLV(I,J,P).EQ.1) NTVS(ISTATE,ISOT)= 1 NTVS(ISTATE,ISOT) +1 REWIND(30) WRITE(30,700) SLABL(ISTATE),I,J,P,ISOT, 1 NLV(I,J,P) REWIND(30) READ(30,*) TVNAME(NPTOT) c ... reset NLV(v,J,p) as the parameter index for that term value NLV(I,J,P)= NPTOT ENDIF 20 CONTINUE ENDDO ENDDO ENDDO c** Finally - label each transition with term-value parameter index for c (as appropriate) upper & lower level of each transition DO IBAND= 1, NBANDTOT IF(((IEP(IBAND).EQ.ISTATE).OR.(IEPP(IBAND).EQ.ISTATE)) 1 .AND.(ISTP(IBAND).EQ.ISOT).AND.(IEP(IBAND).GE.0)) THEN c ... for each band involving state ISTATE of this isotopologue, label c each transition with the term value parameter index (which is zero c if the state is not represented by term values!). DO I= IFIRST(IBAND), ILAST(IBAND) IF(IEP(IBAND).EQ.ISTATE) 1 TVUP(I)= NLV(VP(IBAND),JP(I),EFP(I)) IF(IEPP(IBAND).EQ.ISTATE) 1 TVLW(I)= NLV(VPP(IBAND),JPP(I),EFPP(I)) ENDDO ENDIF ENDDO WRITE(6,608) NAME(1),MN(1,ISOT),NAME(2),MN(2,ISOT), 1 NTV(ISTATE,ISOT),NTVS(ISTATE,ISOT) NTVALL(ISTATE)= NTVALL(ISTATE)+ NTV(ISTATE,ISOT) NTVSSTAT= NTVSSTAT+ NTVS(ISTATE,ISOT) ENDDO c RETURN 600 FORMAT(/' For State ',A3,' fit to individual term values for each 1 {v,J,p,isot}'/1x,6('******')) 602 FORMAT(/' *** ARRAY DIMENSION PROBLEM *** JP(ISTATE)=',i2, 1 ',ISOT=',I2,')=',i3,' greater than NVIBMX=',i4) 604 FORMAT(/' *** ARRAY DIMENSION PROBLEM *** JPP(ISTATE)=',i2, 1 ',ISOT=',I2,')=',i3,' greater than NVIBMX=',i4) 606 FORMAT(/' Absolute zero of energy is fixed at level {v=',i3, 1 ', J=',i3,', p=',i2,'}'/1x,12('**'),10x,'of isotopologue ',i2, 2 ' of State ',A3) 608 FORMAT(' For ',A2,'(',i3,')-',A2,'(',I3,') fit to',i5, 1 ' T(v,J,p) term values,'/20x,'of which',i5,' are involved in only 2 one transition') 700 FORMAT("'",'T(',A3,':',i3,',',i3,',',SP,i2,';',SS,i2,')',I4,"'") END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c**********************************************************************N( SUBROUTINE READPOT(ISTATE,SLABL) c********************************************************************** c** This subroutine reads parameters that define the model potential or c parameter representation used for each state in the fit procedure c analytical molecular potentials for the direct Hamiltonian fitting c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Version of 18 November 2012 c (after removal of RREFns, RREFad & RREFw) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c ISTATE is the electronic state being fitted to c SLABL is the three-character label identifying that state c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= c----------------------------------------------------------------------- c** Type statements for input or local variables INTEGER I, I1, ISTATE, IISTP, m, MMN, VTST CHARACTER*3 SLABL(-6:NSTATEMX) REAL*8 ZMASE, RR(NPNTMX), VV(NPNTMX) DATA ZMASE /5.4857990945D-04/ c c** Set some defaults for parameters not common to all models ... IFXDe(ISTATE)= 1 IFXRe(ISTATE)= 1 DO m= 1, NCMMax IFXCm(m,ISTATE)= 1 ENDDO c----------------------------------------------------------------------- c** First choose potential model and select form of BOB representation c PSEL(s) choses the type of analytical potential to be fitted to: c = -2 : represent each distinct observed level of this state as c an independent term value [an alternative to an 'FS' c treatment of transitions involving that state] c = -1 : represent the rotational sublevels for each v of each c isotopologue by Band Constants (!) c = 0 : Use a fixed potential defined by LEVEL's PREPOT routine c = 1 : Use an Expanded Morse Oscillator EMO(p) potential c = 2 : Use a Morse/Long-Range (MLR) Potential. c = 3 : Use a Double-Exponential Long-Range (DELR) Potential. c = 4 : Use a Surkus Generalized Potential Energy Function (GPEF). c = 5 : Use a Tiemann/Hannover-polynomial-potential (HPP) c = 6 : Use a Tang-Toennies type potential c = 7 : Use an Aziz'ian HFD-C type potential c MAXMIN(s)= 1 for a regular single-minimum potential, for which finding c more than one signals a bad model: =2 for a double-minimum case c VLIM(s) is the fixed absolute energy of the potential asymptote c BOBCN is a flag to denote reference & scaling for BOB corrections c = 0 using differences as per RJL [JMS 194,189(1999)] c = 1 use 'clamped nuclei' limit, m_e1/MASS scaling. c OSEL(s) controls printout of radial function arrays to Ch. 10-16. c OSEL > 0: Export to file every OSEL'th point of final function c======================================================================= READ(5,*) PSEL(ISTATE), VLIM(ISTATE), MAXMIN(ISTATE), 1 BOBCN(ISTATE), OSEL(ISTATE) c======================================================================= IF(OSEL(ISTATE).LE.0) OSEL(ISTATE)= 1 IF((PSEL(ISTATE).EQ.-1).OR.(PSEL(ISTATE).EQ. -2)) THEN IF(PSEL(ISTATE).EQ.-2) THEN c** For term value fits ... no further READs needed! WRITE(6,604) SLABL(ISTATE) RETURN ENDIF IF(PSEL(ISTATE).EQ.-1) THEN c** If representing data for this state by fitted band constants, c read in the number of band constants for each vibrational level DO I= VMIN(ISTATE,1),VMAX(ISTATE,1) c** For each isotopologue in each vibrational level, read the number of c band constants to be used (fited to) to represent the data, c======================================================================= READ(5,*) VTST,(NBC(I,IISTP,ISTATE),IISTP= 1,NISTP) IF(IOMEG(ISTATE).GT.0) 1 READ(5,*) (NQC(I,IISTP,ISTATE),IISTP= 1,NISTP) c======================================================================= IF(I.NE.VTST) THEN c... Verify that band constant specification is for the correct vib level WRITE(6,610) I,VTST STOP ENDIF DO IISTP= 1,NISTP !! Check bounds on NBC & NQC IF(NBC(I,IISTP,ISTATE).GT.NBCMX) 1 NBC(I,IISTP,ISTATE)= NBCMX IF(IOMEG(ISTATE).LE.0) NQC(I,IISTP,ISTATE)= -1 IF(NQC(I,IISTP,ISTATE).GT.NBCMX) 1 NQC(I,IISTP,ISTATE)= NBCMX ENDDO ENDDO ENDIF NUA(ISTATE)= -1 NUB(ISTATE)= -1 NTA(ISTATE)= -1 NTB(ISTATE)= -1 RETURN ENDIF c----------------------------------------------------------------------- c** Now to read in the range and mesh for the numerical integration c RMIN/MAX(s) define the range over which this potential is defined. c RH(s) specifies radial mesh for numerical integration for this state c======================================================================= READ(5,*) RMIN(ISTATE), RMAX(ISTATE), RH(ISTATE) c======================================================================= NDATPT(ISTATE)= (RMAX(ISTATE)-RMIN(ISTATE))/RH(ISTATE)+1.0001d0 NDATPT(ISTATE)= MIN(NPNTMX,NDATPT(ISTATE)) RMAX(ISTATE)= RMIN(ISTATE) + RH(ISTATE)*DBLE(NDATPT(ISTATE)-1) DO I= 1, NDATPT(ISTATE) RD(I,ISTATE)= RMIN(ISTATE)+ DBLE(I-1)*RH(ISTATE) ENDDO IF(PSEL(ISTATE).EQ.0) THEN c----------------------------------------------------------------------- c** For case of a fixed potential defined by read-in turning points, c subroutine PREPOTT reads those points & generates potential array c----------------------------------------------------------------------- DO I= 1, NDATPT(ISTATE) RR(I)= RD(I,ISTATE) ENDDO WRITE(6,600)SLABL(ISTATE),RMIN(ISTATE),RMAX(ISTATE),RH(ISTATE) CALL PREPOTT(1,AN(1),AN(2),MN(1,1),MN(2,1),NDATPT(ISTATE), 1 VLIM(ISTATE),RR,VV) DO I= 1, NDATPT(ISTATE) VPOT(I,ISTATE)= VV(I) ENDDO NUA(ISTATE)= -1 NUB(ISTATE)= -1 NTA(ISTATE)= -1 NTB(ISTATE)= -1 NwCFT(ISTATE)= -1 RETURN ENDIF IF((PSEL(ISTATE).GE.2).AND.(PSEL(ISTATE).NE.4)) THEN c----------------------------------------------------------------------- c** For MLR, DELR and HPP, GTT or HFD potentials, read number of terms NCMM c in the {damped} inverse-power long-range tail c uLR(R) = - SUM_{i=1}^{NCMM} Dm(R;MMLR(i) * CmVAL(i)/R**MMLR(i) c** If rhoAB .LE. 0.0 have NO damping functions: all Dm(R)= 1.0 c If rhoAB > 0.0 recommend the molecule-dependent radial scaling c factor of Douketis et al. [JCP 76, 3057 (1982)]: c rhoAB = 2*rhoA*rhoB/(rhoA+rhoB) where rhoA is the ionization c potential ratio (I_p^A/I_p^H)^0{2/3} for atom A c c IVSR specifies damping s.th. Dm(r)/r^m --> r^{IVSR/2} as r->0. c IDSTT > 0 use Douketis et al. damping functions c IDSTT .LE. 0 use Tang-Toennies damping functions c** IFXCm specifies whether this long-range coefficient is to be fitted c freely (when .LE.0), held fixed at the read-in value (when =1) or held c fixed at the value for another state, in which case the parameter value c 'IFXCm(m,ISTATE)' is the no. of the parameter it is constrained to be = to c c** For Alkali dimer (nS + nP) states use Aubert-Frecon [PRA 55, 3458 (1997)] c 2x2 ULR(r) with NCMM= 7 & MMLR= {x, 3, 3, 6, 6, 8, 8} where x=0 for c the A^1\Sigma_u^+ state and x=-1 for the b^3\Pi_u state, and the c read-in C_m's are, DELTAE, C3Sig, C3Pi,C6Sig, C6Pi, C8Sig and C8Pi . c FOR the 3x3 cases NCMM=10 and MMLR= {x, 3, 3, 3, 6, 6, 6, 8, 8, 8} c where x= -2 for the c(1^3\Sigma_g^+) state (the lowest 3x3 root), c while CnVAL= {DELTAE, C3Sig, C3Pi1, C3Pi3, C6Sig, C6Pi1, C6Pi3, c C8Sig, C8Pi1, and C8Pi3 . c For all Cm's assume units units are cm-1*Angst^m c======================================================================= READ(5,*) NCMM(ISTATE), rhoAB(ISTATE), IVSR(ISTATE), 1 IDSTT(ISTATE) DO m= 1,NCMM(ISTATE) READ(5,*) MMLR(m,ISTATE), CmVAL(m,ISTATE), IFXCm(m,ISTATE) ENDDO c======================================================================= ENDIF IF(PSEL(ISTATE).EQ.4) THEN c----------------------------------------------------------------------- c** For GPEF potential, read parameters defining the expansion variable c p p p p c y(R;k,a,b) = (R - Re )/(a*R + b*Re ) c======================================================================= READ(5,*) AGPEF(ISTATE), BGPEF(ISTATE) c======================================================================= RREF(ISTATE)= -1.d0 ENDIF WRITE(6,626) SLABL(ISTATE),RMIN(ISTATE),RMAX(ISTATE),RH(ISTATE) c c** Now to read in the trial dissociation energy and equilibrium c radial distance for the state. c De(s) is the dissociation energy for each state. c Re(s) is the equilibrium radial distance for each state. c IFDe(s) indicates whether the dissociation energy will be: c = 1: held fixed at read-in values. c <= 0: determined from fits. c IFRe(s) indicates whether the equilibrium radial distance will be: c = 1: held fixed at read-in values. c <= 0: determined from fits. c======================================================================= READ(5,*) DE(ISTATE), IFXDE(ISTATE) READ(5,*) RE(ISTATE), IFXRE(ISTATE) c======================================================================= IF(PSEL(ISTATE).GE.4) IFXDE(ISTATE)= 1 IF(PSEL(ISTATE).GE.5) IFXRE(ISTATE)= 1 c======================================================================= c** Read parameters defining the exponent coefficient function \beta(r) c* Nbeta(s) is order of the beta(r) exponent polynomial or # spline points c APSE(s).LE.0 to use {p,q}-type MLR exponent polynomial of order Nbeta(s) c if APSE(s) > 0, \beta(r) is Pashov spline defined by Nbeta(s) points c nQB(s) is the power q for beta(r) exponent expansion variable c nPB(s) is the power p radial and beta(r) switching fx. variables c RREF(s) defines the reference distance in the potential exponent c expansion variable: * for RREF.le.0 , define parameter RREF = Re c * for RREF.gt.0 , fix parameter RREF at its read-in value c======================================================================= READ(5,*) Nbeta(ISTATE), APSE(ISTATE), nQB(ISTATE), nPB(ISTATE), 1 RREF(ISTATE) c======================================================================= IF(Nbeta(ISTATE).GE.NbetaMX) THEN WRITE(6,648) ISTATE,Nbeta(ISTATE),NbetaMX STOP ENDIF IF((PSEL(ISTATE).EQ.2)) THEN !! to test if nPB big enuf for MLR MMN= MMLR(NCMM(ISTATE),ISTATE)- MMLR(1,ISTATE) IF(MMLR(1,ISTATE).le.0) 1 MMN= MMLR(NCMM(ISTATE),ISTATE)- MMLR(2,ISTATE) IF((NCMM(ISTATE).GT.1).AND.(nPB(ISTATE).LE.MMN)) 1 WRITE(6,628) nPB(ISTATE),MMN ENDIF IF((PSEL(ISTATE).EQ.7).AND.((Nbeta(ISTATE).NE.5).AND. 1 (Nbeta(ISTATE).NE.2))) THEN WRITE(6,629) Nbeta(ISTATE) STOP ENDIF IF(PSEL(ISTATE).NE.2) APSE(ISTATE)= 0 IF(APSE(ISTATE).GT.0) THEN DO I= 1, Nbeta(ISTATE) c----------------------------------------------------------------------- c** For SE-MLR exponent is a natural spline function with values BETA c at the yq values yqBETA, and fixed to equal yqINF at yqBETA=1 c======================================================================= READ(5,*)yqBETA(I,ISTATE),BETA(I,ISTATE),IFXBETA(I,ISTATE) c======================================================================= ENDDO IF(yqBETA(Nbeta(ISTATE),ISTATE).LT.1.d0) THEN c** Ensure outer endppoint is at yq= 1.d0 Nbeta(ISTATE)= Nbeta(ISTATE)+1 yqBETA(Nbeta(ISTATE),ISTATE)= 1.d0 IFXBETA(Nbeta(ISTATE),ISTATE)= 1 ENDIF ENDIF c** For non-MLR or the PE-MLR, exponent \beta(yp) is 'conventional' IF((Nbeta(ISTATE).GE.0).AND.(APSE(ISTATE).LE.0)) THEN I1= 0 IF(PSEL(ISTATE).GE.6) I1= 1 !! omit \beta(0) for TT or HFD IF(PSEL(ISTATE).EQ.6) THEN Nbeta(ISTATE)= 9 IDSTT(ISTATE)= 0 IVSR(ISTATE)= +2 ENDIF IF(PSEL(ISTATE).EQ.5) Nbeta(ISTATE)= Nbeta(ISTATE) + 3 DO I= I1, Nbeta(ISTATE) c** Read in trial initial trial parameters for exponent \beta(r) c c BETA(i,s) contains the expansion parameters defining the potential c** for PSEL.LE.3 : read-in values are the {Nbeta+1} beta_i exponent c exponent expansion parameters defining the potential c** for PSEL = 4 : read-in values are leading coefficients in c Surkus' Generalized Potential Energy Function (GPEF). c** for PSEL = 5 : read in the {1+Nbeta} expansion parameters plus c b, RINN, and ROUT of the HPP form c** for PSEL = 6, Nbeta=9 Read in the \\beta_i of Eq.(32) for i=1-9 c** For PSEL=7: >> set Nbeta=4 to use the single global damping function for c HFD-A,B, & C potentials: f_1(x)= beta(0)*exp{-\beta(1)/x)^beta(2)} c while exponent is {\alpha*x + beta(3)*x^2} and \gamma= beta(4). c** >> set Nbeta=3 to combine the overall damping function c f_2(x)= [1 - r^{\beta(0)} exp{-\beta(1)(r}] , and in this case c while exponent is {\alpha*x + beta(2)*x^2} and \gamma= beta(3). c IFXBETA(i,s) indicates whether each potential expansion coefficient c coefficient will be: = 1: held fixed at read-in values. c .LE. 0: determined from fits. c======================================================================= READ(5,*) BETA(I,ISTATE), IFXBETA(I,ISTATE) c======================================================================= IF(PSEL(ISTATE).GE.5) IFXBETA(I,ISTATE)= 1 ENDDO ENDIF c** Note that HPP and (most) HFD potentials assume no damping IF((PSEL(ISTATE).EQ.7).and.(Nbeta(ISTATE).EQ.2)) THEN IVSR(ISTATE)= 0 !! for HFD-D potentials IDSTT(ISTATE)= 1 ENDIF IF((PSEL(ISTATE).EQ.5).OR.((PSEL(ISTATE).EQ.7).and. 1 (Nbeta(ISTATE).EQ.4))) rhoAB(ISTATE)= -1.d0 IF(PSEL(ISTATE).EQ.5) THEN c** Constraints for Tiemann polynomial potential .... nPB(ISTATE)= 1 nQB(ISTATE)= 1 IFXDe(ISTATE)= 1 RREF(ISTATE)= RE(ISTATE) ENDIF c======================================================================= c** Read parameters defining the BOB adiabatic radial functions c* NUA/NUB(s) specifies the order of the polynomial in yp defining c the adiabatic BOB function for atom A/B c if < 0 do not read in any adiabatic BOB function parameters c* pAD(s)/qAD(s) are the powers defining the expansion variables c* LRad(s) determines whether (if > 0) or not (if .LE.0) isotope shift c C_m factors for atoms-A 'dCmA' and atoms B 'dCmB' are to be read in c* UA/UB(a,s) are the adiabatic BOB function expansion coefficients c* IFXU(A/B)(a,s) indicates whether each expansion coefficient is to be c > 0 : held fixed at read-in value, or c .le. 0 : varied in the fit c* UAinf/UBinf is the limiting asymptotic value of uA(r)/uB(r), as per c Theochem paper [internally stored as UA(NUA+1), etc.] c* IFXUAinf/IFXUBinf specifies whether (>0) or not (.le.0) UAinf/UBinf c is to be held fixed at the read-in value c======================================================================= READ(5,*) NUA(ISTATE),NUB(ISTATE),qAD(ISTATE),pAD(ISTATE), 1 LRad(ISTATE) IF(((NUA(ISTATE).GE.0).OR.(NUB(ISTATE).GE.0)) 1 .AND.(PSEL(ISTATE).EQ.1)) pAD(ISTATE)= qAD(ISTATE) c... NOTE never read delta Cm values unless PSEL = 1-3 IF((PSEL(ISTATE).LT.1).OR.(PSEL(ISTATE).GT.3)) LRad(ISTATE)=0 IF(LRad(ISTATE).GT.0) THEN c. if desired, read \delta{Cm} values dCmA & dCmB for atoms-A & B one per line DO m=1,NCMM(ISTATE) READ(5,*) dCmA(m,ISTATE) ENDDO DO m=1,NCMM(ISTATE) READ(5,*) dCmB(m,ISTATE) ENDDO ENDIF IF(NUA(ISTATE).GE.0) THEN c... NOTE that parameters NUA(ISTATE)+1 are UAinf & IFXUAinf ... NUA(ISTATE)= NUA(ISTATE)+ 1 DO I= 0, NUA(ISTATE) READ(5,*) UA(I,ISTATE), IFXUA(I,ISTATE) ENDDO c======================================================================= IF(BOBCN(ISTATE).GT.0) THEN UA(NUA(ISTATE),ISTATE)= 0.d0 IFXUA(NUA(ISTATE),ISTATE)= 1 ENDIF ENDIF c======================================================================= IF(NUB(ISTATE).GE.0) THEN c... NOTE that parameters NUB(ISTATE)+1 are UBinf & IFXUBinf ... NUB(ISTATE)= NUB(ISTATE)+ 1 DO I= 0, NUB(ISTATE) READ(5,*) UB(I,ISTATE), IFXUB(I,ISTATE) ENDDO c======================================================================= IF(BOBCN(ISTATE).GT.0) THEN UB(NUB(ISTATE),ISTATE)= 0.d0 IFXUB(NUB(ISTATE),ISTATE)= 1 ENDIF ENDIF c*********************************************************************** c** Read parameters defining the BOB non-adiabatic centrifugal functions c** If NISTP= 1 , read only one set of non-adiabatic parameters c c NTA/NTB(s) specifies the order of the polynomial in yp defining c the non-adiabatic centrifugal BOB functions for atom A/B c if < 0 do not read in any non-adiabatic BOB parameters c qNA(s) is the power defining the the form of the expansion variable c TA/TB(a,s) are the non-adiabatic centrifugal BOB expansion coeffts c IFXTA/IFXTB(a,s) indicates whether each expansion coefficient is to be c > 0 : held fixed at read-in value, or c .le. 0 : varied in the fit c TAinf/TBinf is the limiting asymptotic value of qA(r)/qB(r), as per c Theochem paper [internally stored as TA(NTA+1), etc.] c IFXTAinf/IFXTBinf specifies whether (>0) or not (.le.0) TAinf/TBinf c is to be held fixed at the read-in value c======================================================================= READ(5,*) NTA(ISTATE), NTB(ISTATE), qNA(ISTATE), pNA(ISTATE) IF(NTA(ISTATE).GE.0) THEN c... NOTE that parameters NTA(ISTATE)+1 are TAinf & IFXTAinf ... NTA(ISTATE)= NTA(ISTATE)+ 1 DO I= 0, NTA(ISTATE) READ(5,*) TA(I,ISTATE), IFXTA(I,ISTATE) ENDDO c======================================================================= IF(BOBCN(ISTATE).GT.0) THEN TA(NTA(ISTATE),ISTATE)= 0.d0 IFXTA(NTA(ISTATE),ISTATE)= 1 ENDIF ENDIF c======================================================================= IF(NTB(ISTATE).GE.0) THEN c... NOTE that parameters NTB(ISTATE)+1 are TBinf & IFXTBinf ... NTB(ISTATE)= NTB(ISTATE)+ 1 DO I= 0, NTB(ISTATE) READ(5,*) TB(I,ISTATE), IFXTB(I,ISTATE) ENDDO c======================================================================= IF(BOBCN(ISTATE).GT.0) THEN TB(NTB(ISTATE),ISTATE)= 0.d0 IFXTB(NTB(ISTATE),ISTATE)= 1 ENDIF ENDIF c NwCFT(ISTATE)= -1 IF((IOMEG(ISTATE).GT.0).OR.(IOMEG(ISTATE).EQ.-1)) THEN c----------------------------------------------------------------------- c** If electronic angular momentum not zero for this state, read Lambda c doubling or doublet Sigma radialfunction parameters. c* NwCFT(s) is order of the polynomial representing the radial fx. c* Pqw(s) defined nature of radial expansion variable: c y_q= [R^{Pqw} - Re^{Pqw}]/[R^{Pqw} + Re^{Pqw}] c* efREF(s) defines reference level for the Lambda doubling splitting c = -1 treats f level as the reference c = 0 treats the mid-point between e and f as reference c = 1 treats e level as the reference c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ READ(5,*) NwCFT(ISTATE), Pqw(ISTATE), efREF(ISTATE) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(IABS(efREF(ISTATE)).GT.1) THEN WRITE(6,646) efREF(ISTATE) STOP ENDIF IF(NwCFT(ISTATE).GE.0) THEN c... NOTE that parameters NwCFT(ISTATE)+1 are wCFTinf & IFXwCFTinf ccc NwCFT(ISTATE)= NwCFT(ISTATE)+ 1 !!! NOT ANY LONGER !!! DO I= 0, NwCFT(ISTATE) READ(5,*) wCFT(I,ISTATE), IFXwCFT(I,ISTATE) ENDDO c======================================================================= IF(IOMEG(ISTATE).GT.0) THEN IF(efREF(ISTATE).EQ.-1) WRITE(6,640) SLABL(ISTATE) IF(efREF(ISTATE).EQ.0) WRITE(6,642) SLABL(ISTATE) IF(efREF(ISTATE).EQ.1) WRITE(6,644) SLABL(ISTATE) ENDIF ENDIF ENDIF c c** Calculate BOB mass scaling factors for the adiabatic (ZMUA, ZMUB) & c non-adiabatic centrifugal (ZMTA, ZMTB) BOB functions DO IISTP= 1, NISTP IF(BOBCN(ISTATE).GE.1) THEN c** For Watson/Coxon/Ogilvie-type clamped-nuclei reference species: ZMUA(IISTP,ISTATE)= ZMASE/ZMASS(1,IISTP) ZMUB(IISTP,ISTATE)= ZMASE/ZMASS(2,IISTP) ZMTA(IISTP,ISTATE)= ZMASE/ZMASS(1,IISTP) ZMTB(IISTP,ISTATE)= ZMASE/ZMASS(2,IISTP) ELSE c** Using RJL's mass differences for adiabatic corrections (ZMUA, ZMUB): ZMUA(IISTP,ISTATE)= 1.0d0 - ZMASS(1,1)/ZMASS(1,IISTP) ZMUB(IISTP,ISTATE)= 1.0d0 - ZMASS(2,1)/ZMASS(2,IISTP) c and mass ratios for the rotational corrections (ZMTA, ZMTB): ZMTA(IISTP,ISTATE)= ZMASS(1,1)/ZMASS(1,IISTP) ZMTB(IISTP,ISTATE)= ZMASS(2,1)/ZMASS(2,IISTP) END IF c c** For homonuclear diatomics, set the first mass scaling term for each c set of correction terms to be the sum of the two original mass c scaling factors, and set the second mass term to zero. c IF(AN(1).EQ.AN(2)) THEN ZMUA(IISTP,ISTATE)= ZMUA(IISTP,ISTATE)+ ZMUB(IISTP,ISTATE) ZMUB(IISTP,ISTATE)= 0.0d0 ZMTA(IISTP,ISTATE)= ZMTA(IISTP,ISTATE)+ ZMTB(IISTP,ISTATE) ZMTB(IISTP,ISTATE)= 0.0d0 END IF ENDDO c----------------------------------------------------------------------- 999 RETURN 600 FORMAT(/'For state ',A3,' use a fixed potential defined by LEVEL s 1ubroutine PREPOT'/4x,'Integrate from RMIN=',f5.2, 1 ' to RMAX=',f6.2,' with mesh RH=',f8.5) 604 FORMAT(/' For state ',A3,' represent level energies by independent 1 term values') 610 FORMAT(' *** Input ERROR *** band constant specification v=',I3, 1 ' .NE.', I3) 626 FORMAT(/' For state ',A3/4x,'integrate from RMIN=',f5.2, 1 ' to RMAX=',f6.2,' with mesh RH=',f8.5) 628 FORMAT(' ***** WARNING p=',i2,' .LE.[MMLR(NCMM)-MMLR(1)]=',i2, 1 ' *****'/" so tail of MLR exponential will 'pollute' u_{LR}(r) 2 behaviour"/(2x,19('****'))) 629 FORMAT(' *** ERROR *** For HFD potentials Nbeta=',I3,' should be 1 5 or 2 !!') 640 FORMAT(/' ', A3,' state energies referenced to f-parity levels') 642 FORMAT(/' ', A3,' state energies referenced to the mid-point betwe 1en e and f-parity levels') 644 FORMAT(/' ', A3,' state energies referenced to e-parity levels') 646 FORMAT(/' *** INPUT ERROR *** |efREF=',i3,'| > 1') 648 FORMAT(/' For ISTATE=',I2,' read-in Nbeta=',I3,' while NbetaMX 1=',I3,' so STOP!!' ) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE WRITEPOT(NPASS,SLABL,NAME,DECM,PV,PU,PS,CM,VMAXIN) c*********************************************************************** c** Subroutine to print out complete description of the potential fx. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++ Version of 16 May 2016 {after generatized TT ipgrade} c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c NPASS is the number of times WRITEPOT was called. c NAME is the name of the molecule. c PU are the parameter uncertainties. c PS are the parameter sensitivities. c---------------------------------------------------- c NSTATES is number of states being considered (in COMMON BLKPARAM) c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c----------------------------------------------------------------------- c** Common block for partial derivatives of potential at the one distance RDIST c and HPP derivatives for uncertainties REAL*8 dVdPk(HPARMX),dDe(0:NbetaMX),dDedRe COMMON /dVdPkBLK/dVdPk,dDe,dDedRe c======================================================================= INTEGER MMAX, VTST, IISTP PARAMETER (MMAX= 20) CHARACTER*2 NAME(2),LAB4(-4:0) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*5 DASH CHARACTER*6 BCNAM(8),QCNAM(8) CHARACTER*7 NAMEDBLE(2) CHARACTER*10 LAB2(7),LAB3(10) INTEGER NPASS, ISTATE,IPV,I,I1,I4,ISOT,J,MMN,m,m1,LSR,MMp2, 1 JSTATE,NUApr,NUBpr,NTApr,NTBpr,MCMM,IPVRe(NSTATEMX), 2 MMLR1D(NCMMAX),VMAXIN(NSTATEMX) REAL*8 DECM(NSTATEMX),BTEMP,UAT,UBT,SAT,BINF,RE3,RE6,RE8,T0,T1, 1 DX,DX1,ULRe,C3VAL,C6adj,C9adj,RET,RETSig,RETPi,RETp,RETm,Tm, 2 VATTRe,dVATTRe,PVSR,ATT,YP,YPP,BT,Rinn,Rout,A1,A2,A3,B5,VX,dVX, 3 uLR,CMMp2,uCMMp2,uDe,XRO,dXRO,dXROdRe,d2XROdRe,fRO,XROpw,ROmp2, 4 dCmp2dRe,dDeROdRe,yqRe,betaRe,yPOW,XRI,AREF,ttVMIN,ttRMIN,RR, 5 bohr,f2,f2p,rhoINT, 5 dCmp2(0:NbetaMX),dULRdCm(NCMMax),DM(MMAX),DMP(MMAX),DMPP(MMAX), 6 bTT(-2:2),cDS(-4:4),bDS(-4:4),CmVAL1D(NCMMAX),CmEFF1D(NCMMAX) DATA QCNAM/' QB(v=','QD(v=',' QH(v=',' QL(v=',' QM(v=', 1 ' QN(v=',' QO(v=',' '/ DATA BCNAM/' Tv(v=',' Bv(v=','-Dv(v=',' Hv(v=',' Lv(v=',' Mv(v=', 1 ' Nv(v=',' Ov(v='/ c** Damping function factors from Table 1 of Mol.Phys. 109, 435 (2011) DATA bTT/2.10d0,2.44d0,2.78d0,3.13d0,3.47d0/ DATA bDS/2.50d0,2.90d0,3.3d0,3.69d0,3.95d0,0.d0,4.53d0,0.d0, 1 4.99d0/ cc DATA cDS/0.468d0,0.446d0,0.423d0,0.405d0,0.390d0,0.d0,0.360d0, DATA cDS/0.468d0,0.446d0,0.423d0,0.400d0,0.390d0,0.d0,0.360d0, 1 0.d0,0.340d0/ DATA DASH/'-----'/ SAVE bTT, bDS, cDS c c** NLLSSRR variables used in output c REAL*8 PV(NPARMX), PU(NPARMX), PS(NPARMX),CM(NPARMX,NPARMX), 1 PT(NPARMX) DATA NAMEDBLE/'wLambda',' wSigma'/ c** labels for matrix cases of MLR: LAB2 for 2x2, LAB3 for 3x3, LAB4 for names DATA LAB2/' DELTAE ',' C3(^1Sig)',' C3(^3Pi)' ,' C6(^1Sig)', 1 ' C6(^3Pi) ',' C8(^1Sig)',' C8(^3Pi) '/ DATA LAB3/'DELTAE ',' C3(^3Sig)',' C3(^1Pi) ',' C3(^3Pi) ', 1 ' C6(^3Sig)',' C6(^1Pi) ',' C6(^3Pi) ', 2 ' C8(^3Sig)',' C8(^1Pi) ',' C8(^3Pi) '/ DATA LAB4/' ?',' B',' c',' b',' A'/ DATA bohr/0.52917721092d0/ !! 2010 physical constants d:mohr12 c----------------------------------------------------------------------- c** Writing out state specific information. c----------------------------------------------------------------------- IPV= 0 DO 90 ISTATE=1,NSTATES VATTRe= 0.d0 dVATTRe= 0.d0 WRITE(6,600) IF(PSEL(ISTATE).EQ.0) THEN WRITE(6,603) SLABL(ISTATE) WRITE(6,636) 'VLIM',VLIM(ISTATE) GOTO 50 ENDIF IF(PSEL(ISTATE).LT.0) THEN c** Write .20 file heading for term-value or band-constant states IF(NPASS.GT.1) THEN WRITE(20,*) WRITE(20,700) SLABL(ISTATE), IOMEG(ISTATE), 1 VMIN(ISTATE,1), VMAX(ISTATE,1),JTRUNC(ISTATE), 2 EFSEL(ISTATE),ISTATE WRITE(20,701) PSEL(ISTATE),VLIM(ISTATE), 1 MAXMIN(ISTATE),BOBCN(ISTATE),OSEL(ISTATE) ENDIF ENDIF IF(PSEL(ISTATE).EQ.-2) THEN WRITE(6,601) SLABL(ISTATE) GO TO 90 ENDIF IF(PSEL(ISTATE).EQ.-1) THEN c** If fitting to band constants for this state .... IF(NPASS.GT.1) WRITE(6,684) SLABL(ISTATE) IF(NPASS.EQ.1) THEN !! in first initialising call WRITE(6,6062) SLABL(ISTATE),(I,I=1,NISTP) WRITE(6,6072) (DASH,I=1,NISTP) DO I= VMIN(ISTATE,1),VMAX(ISTATE,1) DO IISTP= 1,NISTP !! Check bounds on NBC & NQC IF(NBC(I,IISTP,ISTATE).GT.NBCMX) 1 NBC(I,IISTP,ISTATE)= NBCMX IF(NQC(I,IISTP,ISTATE).GT.NBCMX) 1 NQC(I,IISTP,ISTATE)= NBCMX ENDDO WRITE(6,6082) I,(NBC(I,IISTP,ISTATE), 1 IISTP= 1,NISTP) IF(IOMEG(ISTATE).GT.0) WRITE(6,6092) 1 (NQC(I,IISTP,ISTATE),IISTP= 1,NISTP) ENDDO ENDIF IF(NPASS.GT.1) THEN !! in final call after fit is done WRITE(6,690) DO ISOT= 1, NISTP DO I= VMIN(ISTATE,ISOT),VMAX(ISTATE,ISOT) IF(NBC(I,ISOT,ISTATE).GT.0) THEN DO J= 1,NBC(I,ISOT,ISTATE) IPV= IPV+1 IF(DABS(PU(IPV)).GT.DABS(PV(IPV)))THEN WRITE(6,685) BCNAM(J),I,ISOT, 1 PV(IPV),PU(IPV),PS(IPV) ELSE WRITE(6,686) BCNAM(J),I,ISOT, 1 PV(IPV),PU(IPV),PS(IPV) ENDIF ENDDO IF(NQC(I,ISOT,ISTATE).GT.0) THEN DO J= 1,NQC(I,ISOT,ISTATE) IPV= IPV+1 !! Lambda Count IF(DABS(PU(IPV)).GT.DABS(PV(IPV))) 1 THEN WRITE(6,685) QCNAM(J),I,ISOT, 1 PV(IPV),PU(IPV),PS(IPV) ELSE WRITE(6,686) QCNAM(J),I,ISOT, 1 PV(IPV),PU(IPV),PS(IPV) ENDIF ENDDO ENDIF ENDIF ENDDO WRITE(6,688) ENDDO DO I= VMIN(ISTATE,1),VMAX(ISTATE,1) WRITE(20,687) I,(NBC(I,ISOT,ISTATE),ISOT= 1, 1 NISTP) IF(IOMEG(ISTATE).GT.0) 1 WRITE(20,6872) (NQC(I,ISOT,ISTATE),ISOT= 1,NISTP) ENDDO ENDIF GOTO 90 ENDIF AREF= RREF(ISTATE) IF(AREF.LE.0.d0) AREF= RE(ISTATE) IF(PSEL(ISTATE).EQ.1) THEN c** Header printout for EMO potential WRITE(6,602) SLABL(ISTATE),Nbeta(ISTATE),nQB(ISTATE), 1 nQB(ISTATE),Nbeta(ISTATE) IF(RREF(ISTATE).LE.0.d0) WRITE(6,552) (nQB(ISTATE),i=1,5) IF(RREF(ISTATE).GT.0.d0) WRITE(6,555) AREF,AREF ENDIF IF(PSEL(ISTATE).EQ.2) THEN c** Header printout for MLR potential BINF= betaINF(ISTATE) WRITE(6,604) SLABL(ISTATE),nQB(ISTATE),nPB(ISTATE) IF(APSE(ISTATE).LE.0) THEN WRITE(6,605) nPB(ISTATE),nPB(ISTATE),nQB(ISTATE), 1 Nbeta(ISTATE) ELSE WRITE(6,680) Nbeta(ISTATE) BETA(Nbeta(ISTATE),ISTATE)= BINF ENDIF IF(RREF(ISTATE).LE.0.d0) WRITE(6,552) (nQB(ISTATE),i=1,5) IF(RREF(ISTATE).GT.0.d0) WRITE(6,555) AREF,AREF ENDIF c IF(PSEL(ISTATE).EQ.3) THEN c** Header printout for DELR potential form ... WRITE(6,612) SLABL(ISTATE),Nbeta(ISTATE),nQB(ISTATE), 1 nQB(ISTATE),Nbeta(ISTATE) IF(RREF(ISTATE).LE.0.d0) WRITE(6,552) (nQB(ISTATE),i=1,5) IF(RREF(ISTATE).GT.0.d0) WRITE(6,555) AREF,AREF ENDIF c IF(PSEL(ISTATE).EQ.4) THEN c** Header printout for Surkus GPEF potential form ... WRITE(6,610) SLABL(ISTATE),(nPB(ISTATE),i=1,3), 1 AGPEF(ISTATE),nPB(ISTATE),BGPEF(ISTATE),nPB(ISTATE) ENDIF c IF(PSEL(ISTATE).EQ.5) THEN c** Header printout for Tiemann HPP potential ... c... First, need to define long-and short-range connections .... c ... Begin by getting V(r) and V'(r) of polynomial VX at R_i and R_o WRITE(6,623) SLABL(ISTATE), BETA(Nbeta(ISTATE)+1,ISTATE), 1 BETA(Nbeta(ISTATE)+2,ISTATE),BETA(Nbeta(ISTATE)+3,ISTATE), 2 (nPB(ISTATE)),BETA(Nbeta(ISTATE)+1, ISTATE) BT= BETA(Nbeta(ISTATE)+1, ISTATE) Rinn= BETA(Nbeta(ISTATE)+2, ISTATE) Rout= BETA(Nbeta(ISTATE)+3, ISTATE) c** With long-range tail an NCMM-term inverse-power sum, define De and c add 1 more inverse-power term CMMp2/r**{m_{last}+2}} to ensure c continuity and smoothness at Rout XRO= (Rout - RE(ISTATE))/(Rout+ BT*RE(ISTATE)) YPP= 1.d0 VX= 0.d0 dVX= 0.d0 DO J= 1, Nbeta(ISTATE) dVX= dVX+ J*YPP*BETA(J,ISTATE) YPP= YPP*XRO VX= VX+ YPP*BETA(J,ISTATE) ENDDO dXRO=(RE(ISTATE)+ BT*RE(ISTATE))/(Rout + BT*RE(ISTATE))**2 c*** dXRO= dX(r)/dr @ r=R_{out} & dXRORe= dX(r)/dr_e @ r=R_{out} dXROdRe= -dXRO*Rout/RE(ISTATE) d2XROdRe = (1.d0 + BT)*(Rout - BT*RE(ISTATE))/ 1 (Rout + BT*RE(ISTATE))**3 dVX= dVX*dXRO c VX={polynomial part V_X @ Rout} and dVX is its radial derivative uLR= 0.d0 !! VLIM(ISTATE) CMMp2= 0.d0 DO J= 1, NCMM(ISTATE) B5= CmVAL(J,ISTATE)/Rout**MMLR(J,ISTATE) uLR= uLR + B5 CMMp2= CMMp2 + MMLR(J,ISTATE)*B5 ENDDO MMp2= MMLR(NCMM(ISTATE),ISTATE)+2 fRO= Rout**(MMp2+1)/MMp2 !! factor for derivatives CMMp2= (dVX - CMMp2/Rout)*Rout**(MMp2+1)/MMp2 c!!! zero our C5(A) for Mg2 to try to match Knoeckel cc IF(ISTATE.EQ.2) CMMp2= 0.d0 DE(ISTATE)= uLR + VX + CMMp2/Rout**MMp2 c** CMMp2= C_{m_{last}+2}: now get the updated value of DE(ISTATE) c** now ... Determine analytic function attaching smoothly to inner wall c of polynomial expansion at R= Rinn < Rm XRI= (Rinn - RE(ISTATE))/(Rinn+ BT*RE(ISTATE)) YPP= 1.d0 B5= VLIM(ISTATE) - DE(ISTATE) A1= 0.d0 A2= 0.d0 DO J= 1, Nbeta(ISTATE) A2= A2+ J*YPP*BETA(J,ISTATE) YPP= YPP*XRI A1= A1+ YPP*BETA(J,ISTATE) ENDDO A2= A2*(RE(ISTATE)+ BT*RE(ISTATE))/(Rinn+BT*RE(ISTATE))**2 A2= -A2/A1 c** Extrapolate inwardly with the exponential: B5+ A1*exp(-A2*(R-Rinn)) c... Now ... printout for HPP inward and outward extrapolations WRITE(6,676) Rinn,B5,A1,A2,Rinn,Rout,DE(ISTATE),CMMp2,MMp2 676 FORMAT(5x,'Extrapolate smoothly inward from Rinn=',f6.3/10x, 1 'as ',F14.7' + ',1PD14.7,'*exp[-',d14.7,'(r -',0PF6.3,')]'/5x, 2 'Extrapolate smoothly outward from Rout=',F6.2,/15x, 2 'by setting De=', F14.7,' and adding ',1PD15.7,'/r**',I2) ENDIF c .................................. end of HPP printout ............. IF(PSEL(ISTATE).EQ.6) THEN c** Header printout for Generalized Tang-Toennies type potential ... c first locate ACTUAL minimum to compare with input D_e and r_e values I1= (0.9*RE(ISTATE)- RMIN(ISTATE))/RH(ISTATE) RR= RD(I1,ISTATE) DO m=1,NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) ENDDO ttVMIN= 0.d0 ttRMIN= RR rhoINT= rhoAB(ISTATE)/bTT(IVSR(ISTATE)/2) A1= 0.d0 A2= 0.d0 55 CALL dampF(RR,rhoINT,NCMM(ISTATE),NCMMAX,MMLR1D, 1 IVSR(ISTATE),IDSTT(ISTATE),DM,DMP,DMPP) A1= A2 A2= A3 c....calculate the (damped) long range tail T0= 0.d0 DO m= 1, NCMM(ISTATE) T0= T0+ DM(m)*CmVAL(m,ISTATE)/RR**MMLR(m,ISTATE) ENDDO c.... Now evaluate Generalized TT model T1= BETA(1,ISTATE)*RR+ BETA(2,ISTATE)*RR**2+ 1 BETA(3,ISTATE)/RR + BETA(4,ISTATE)/RR**2 A3= (BETA(5,ISTATE)+ BETA(6,ISTATE)*RR+ BETA(7,ISTATE)/RR 1 + BETA(8,ISTATE)*RR**2+ BETA(9,ISTATE)*RR**3)*DEXP(-T1)- T0 IF(A3.LE.ttVMIN) THEN c... search for potential minimum ... ttVMIN= A3 ttRMIN= RR RR= RR+ RH(ISTATE) GOTO 55 ENDIF WRITE(6,626) (BETA(i,ISTATE),i=1,9) c*** Use quadratic approximation to determine REQ and DSCM T0= (A3- 2.d0*A2 + A1)/(2.d0*RH(ISTATE)**2) !! curvature RR= ttRMIN ttRMIN= ttRMIN+ 0.5d0*RH(ISTATE) 1 -(A3-A2)/(2.d0*RH(ISTATE)*T0) ttVMIN= T0*(RR- ttRMIN)**2 - A2 WRITE(6,627) DE(ISTATE), RE(ISTATE), ttVMIN, ttRMIN ENDIF 626 FORMAT(/' Use a Generalized Tang-Tonnies Potential function with e 1xponent'/' - {{',SP,F15.11,'*r',F15.11,'*r^2',F15.11,'/r',F15.11, 2 '/r^2}}'/' and pre-exponential factor:'/3x,'{{',SP,1PD15.8, 3 D16.8,'*r',d16.8,'/r',d16.8,'*r^2'/21x,D16.8,'*r^3}}',S) 627 FORMAT(10x,'Input DSCM=',F10.4,' REQ=',f9.6/ 10x, 1 'Actual DSCM=',F10.4,' REQ=',f9.6) c====================================================================== IF(PSEL(ISTATE).EQ.7) THEN IF(Nbeta(ISTATE).EQ.5) THEN c** For Aziz'ian HFD-ABC type potential: print header and derive leading c exponent coefficient \beta_1 and pre-exponential factor A for use c in subroutines 'vgen' & 'vgenp'; all in units cm-1 and \AA A1= BETA(1,ISTATE) A2= BETA(2,ISTATE) A3= BETA(3,ISTATE) DX= 1.d0 DX1= 0.d0 IF(A2.GT.RE(ISTATE)) THEN DX= DEXP(-A1*(A2/RE(ISTATE) - 1.d0)**A3) DX1= A1*A2*A3*DX*(A2/RE(ISTATE)- 1.d0)**(A3- 1.d0) 1 /RE(ISTATE)**2 ENDIF T0= 0.d0 T1= 0.d0 DO m= 1,NCMM(ISTATE) Tm= CMVAL(m,ISTATE)/RE(ISTATE)**MMLR(m,ISTATE) T0= T0+ Tm T1= T1+ Tm*(DX1 - MMLR(m,ISTATE)*DX/RE(ISTATE)) ENDDO T0= T0*DX - DE(ISTATE) IF(T0.LE.0.d0) THEN WRITE(6,624) T0,(MMLR(m,ISTATE),CmVAL(m,ISTATE), 1 m= 1, NCMM(ISTATE)) STOP ENDIF BB(ISTATE) = BETA(5,ISTATE)/RE(ISTATE) 1 - 2.d0*BETA(4,ISTATE)*RE(ISTATE) - T1/T0 AA(ISTATE)= T0 * DEXP(RE(ISTATE) 1 *(BB(ISTATE) + BETA(4,ISTATE)*RE(ISTATE))) WRITE(6,628) 'ABC',BETA(5,ISTATE),BB(ISTATE), 1 BETA(4,ISTATE),AA(ISTATE), 2 (MMLR(m,ISTATE),CmVAL(m,ISTATE),m= 1, NCMM(ISTATE)) WRITE(6,629) DE(ISTATE),RE(ISTATE),A2,A1,A2,A3 ELSEIF(Nbeta(ISTATE).EQ.2) THEN c------------------------------------------------------------------------ c** For Aziz'ian HFD-ID type potential: print header and derive leading c exponent coefficient \beta_1 and pre-exponential factor A for use c in subroutines 'vgen' & 'vgenp'; all in units cm-1 and \AA f2= 1.d0 - (rhoAB(ISTATE)*RE(ISTATE)/bohr)**1.68d0 1 *EXP(-0.78d0*rhoAB(ISTATE)*(RE(ISTATE)/bohr)) f2p= (f2- 1.d0)*(1.68d0/RE(ISTATE) - 1 0.78d0*rhoAB(ISTATE)/bohr) DO m=1,NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) ENDDO CALL dampF(RE(ISTATE),rhoAB(ISTATE),NCMM(ISTATE), 1 NCMMAX,MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),DM,DMP,DMPP) T0= 0.d0 T1= 0.d0 DO m= 1,NCMM(ISTATE) Tm= CMVAL(m,ISTATE)/RE(ISTATE)**MMLR(m,ISTATE) T0= T0+ Dm(m)*Tm T1= T1+ Tm*(f2p*Dm(m) + f2*(Dmp(m) 1 - Dm(m)*MMLR1D(m)/RE(ISTATE))) ENDDO T0= T0*f2 BB(ISTATE) = BETA(2,ISTATE)/RE(ISTATE) 1 - 2.d0*BETA(1,ISTATE)*RE(ISTATE) - T1/(T0 - DE(ISTATE)) AA(ISTATE)= (T0 - DE(ISTATE))*EXP(RE(ISTATE) 1 *(BB(ISTATE)+ BETA(1,ISTATE)*RE(ISTATE))) WRITE(6,628) 'ID ',BETA(2,ISTATE),BB(ISTATE), 1 BETA(1,ISTATE),AA(ISTATE), 2 (MMLR(m,ISTATE),CmVAL(m,ISTATE),m= 1, NCMM(ISTATE)) WRITE(6,629) DE(ISTATE),RE(ISTATE) ELSEIF((Nbeta(ISTATE).NE.2).AND.(Nbeta(ISTATE).NE.5)) 1 THEN Write (6,625) Nbeta(ISTATE) STOP ENDIF ENDIF 624 FORMAT(/' *** ERROR in generating HFD potential *** generate VAT 1T=',G15.7,' from Cm coefficients:'/(3x,3(' C',I2,'=',1PD15.7:))) 625 FORMAT(/' *** ERROR *** The number of parameters',I3,' does not e 1qual the the number needed for HFD-ABC or HFD-ID') 628 FORMAT(/' Potential is Generalized HFD-',A3,' with exponent factor 1s gamma=',f9.6/' beta1=',f12.8,' beta2=',f9.6,5x,'A=', 2 1PD16.9:" & Cm's:"/(3x,3(' C',I2,' =',D15.7:))) 629 FORMAT(' De=',f10.4,'[cm-1] Re=',f9.6,'[Angst.]':' and for 1 r <',F9.6/' Damping function D(r)= exp[ -',f6.4,'*(',f9.6, 2 '/r -1.0)**',f5.2,']') c======================================================================= c** Common uLR(r) printout for the MLR, DELR, HPP, TT and HDF potentials IF((PSEL(ISTATE).GE.2).AND.(PSEL(ISTATE).NE.4)) THEN c... first, specify choice of damping fx. {if damping included} IF(rhoAB(ISTATE).GT.0.d0) THEN IF(IDSTT(ISTATE).GT.0) THEN PVSR= DFLOAT(IVSR(ISTATE))*0.5d0 WRITE(6,607) rhoAB(ISTATE),PVSR,bDS(IVSR(ISTATE)), 1 cDS(IVSR(ISTATE)),PVSR ELSE LSR= IVSR(ISTATE)/2 IF(PSEL(ISTATE).NE.6) WRITE(6,617) rhoAB(ISTATE), 1 LSR, bTT(LSR) IF(PSEL(ISTATE).EQ.6) WRITE(6,617) rhoAB(ISTATE), 1 LSR ENDIF ELSE WRITE(6,664) cc WRITE(6,608) MMLR(1,ISTATE),CmVAL(1,ISTATE), cc 1 MMLR(1,ISTATE) ENDIF c** List (inverse) power and coefficients of terms contributing to uLR(r) c... First ... header (& lead coefft.) for all A-F diagonalization cases m1= 1 IF(MMLR(1,ISTATE).LE.0) THEN I4= MMLR(1,ISTATE) IF(I4.GE.-1) WRITE(6,606) LAB4(I4),CmVAL(1,ISTATE) IF(I4.LE.-2) WRITE(6,6066) LAB4(I4),CmVAL(1,ISTATE) m1=2 ENDIF DO m= m1,NCMM(ISTATE) IF(m1.GT.1) THEN !! A-F cases c... now,... Cm's for A-F 2x2 cases IF(I4.GE.-1) WRITE(6,708) LAB2(m),CmVAL(m,ISTATE), 1 MMLR(m,ISTATE) c... now,... Cm's for A-F 3x3 cases IF(I4.LE.-2) WRITE(6,708) LAB3(m),CmVAL(m,ISTATE), 1 MMLR(m,ISTATE) ELSE c... Finally, print Cm's for simple {damped} inverse-power sum cases IF(MMLR(m,ISTATE).LE.9) 1 WRITE(6,608) MMLR(m,ISTATE),CmVAL(m,ISTATE),MMLR(m,ISTATE) IF(MMLR(m,ISTATE).GT.9) 1 WRITE(6,609) MMLR(m,ISTATE),CmVAL(m,ISTATE),MMLR(m,ISTATE) ENDIF ENDDO IF(PSEL(ISTATE).EQ.2) WRITE(6,682) BINF c** quadratic corrections for MLR IF(PSEL(ISTATE).EQ.2) THEN c... First define 1D arrays for L-R powers & coefficients DO m=1, NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) CmVAL1D(m)= CmVAL(m,ISTATE) CmEFF1D(m)= CmVAL1D(m) ENDDO CALL quadCORR(NCMM(ISTATE),MCMM,NCMMAX,MMLR1D, 1 DE(ISTATE),CmVAL1D,CmEFF1D) DO m=1, NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) CmEFF(m,ISTATE)= CmEFF1D(m) ENDDO ENDIF ENDIF c============== End of potential form header printout ================== IF((IOMEG(ISTATE).NE.0).AND.(PSEL(ISTATE).GE.0)) 1 WRITE(6,683) IOMEG(ISTATE), IOMEG(ISTATE)*IOMEG(ISTATE) 50 IF((NUA(ISTATE).GE.0).OR.(NUB(ISTATE).GE.0)) THEN c** Print description of 'adiabatic' BOB functional forms ... IF(BOBCN(ISTATE).GT.0) WRITE(6,556) qAD(ISTATE) IF(BOBCN(ISTATE).LE.0)WRITE(6,557) pAD(ISTATE),qAD(ISTATE) IF(NUA(ISTATE).GE.0) THEN IF(BOBCN(ISTATE).GT.0) WRITE(6,564) '\tilde{S}(', 1 NAME(1),qAD(ISTATE),NUA(ISTATE)-1 IF(BOBCN(ISTATE).LE.0) WRITE(6,558) '\tilde{S}(', 1 NAME(1),pAD(ISTATE),pAD(ISTATE),qAD(ISTATE),NUA(ISTATE)-1 WRITE(6,554) NAME(1),(qAD(ISTATE),i= 1,5) IF(LRad(ISTATE).GT.0) THEN WRITE(6,570) DO m= 1,NCMM(ISTATE) WRITE(6,571) MMLR(m,ISTATE),dCmA(m,ISTATE), 1 MMLR(m,ISTATE) ENDDO ENDIF ENDIF IF(NUB(ISTATE).GE.0) THEN IF(BOBCN(ISTATE).GT.0) WRITE(6,564) '\tilde{S}(', 1 NAME(2),qAD(ISTATE),NUB(ISTATE)-1 IF(BOBCN(ISTATE).LE.0) WRITE(6,558) '\tilde{S}(', 1 NAME(2),pAD(ISTATE),pAD(ISTATE),qAD(ISTATE),NUB(ISTATE)-1 WRITE(6,554) NAME(2),(qAD(ISTATE),i= 1,5) IF(LRad(ISTATE).GT.0) THEN WRITE(6,570) DO m= 1,NCMM(ISTATE) WRITE(6,571) MMLR(m,ISTATE),dCmB(m,ISTATE), 1 MMLR(m,ISTATE) ENDDO ENDIF ENDIF c** Print description of centrifugal BOB functional forms ... IF(BOBCN(ISTATE).GT.0) WRITE(6,560) qNA(ISTATE) IF(BOBCN(ISTATE).LE.0)WRITE(6,559) pNA(ISTATE),qNA(ISTATE) IF(NTA(ISTATE).GE.0) THEN IF(BOBCN(ISTATE).GT.0) WRITE(6,564) '\tilde{R}(', 1 NAME(1),qNA(ISTATE),NTA(ISTATE)-1 IF(BOBCN(ISTATE).LE.0) WRITE(6,558) '\tilde{R}(', 1 NAME(1),pNA(ISTATE),pNA(ISTATE),qNA(ISTATE),NTA(ISTATE)-1 WRITE(6,554) NAME(1),(qNA(ISTATE),i=1,5) ENDIF IF(NTB(ISTATE).GE.0) THEN IF(BOBCN(ISTATE).GT.0) WRITE(6,564) '\tilde{R}(', 1 NAME(2),qNA(ISTATE),NTB(ISTATE)-1 IF(BOBCN(ISTATE).LE.0) WRITE(6,558) '\tilde{R}(', 1 NAME(1),pNA(ISTATE),pNA(ISTATE),qNA(ISTATE),NTB(ISTATE)-1 WRITE(6,554) NAME(2),(qNA(ISTATE),i=1,5) ENDIF ENDIF IF((NwCFT(ISTATE).GE.0).AND.(PSEL(ISTATE).GT.0).OR. 1 (PSEL(ISTATE).EQ.-1)) THEN c** Print description of Lambda/2-Sigma doubling functional forms ... IF(IOMEG(ISTATE).GT.0) THEN WRITE(6,618) 'Lambda',Pqw(ISTATE),NwCFT(ISTATE), 1 (Pqw(ISTATE),i= 1,5) IF(efREF(ISTATE).EQ.-1) WRITE(6,692) SLABL(ISTATE) IF(efREF(ISTATE).EQ.0) WRITE(6,694) SLABL(ISTATE) IF(efREF(ISTATE).EQ.1) WRITE(6,696) SLABL(ISTATE) ENDIF IF(IOMEG(ISTATE).EQ.-1) THEN WRITE(6,618) ' Gamma',Pqw(ISTATE),NwCFT(ISTATE), 1 (Pqw(ISTATE),i= 1,5) ENDIF ENDIF IF(IOMEG(ISTATE).LE.-2) WRITE(6,619) -IOMEG(ISTATE) c c** Write out headings for parameter list IF(PSEL(ISTATE).GT.0) THEN IF(NPASS.EQ.1) WRITE(6,614) IF(NPASS.EQ.2) WRITE(6,615) ENDIF c----------------------------------------------------------------------- c** Writing out heading for the .20 file c----------------------------------------------------------------------- IF(NPASS.GT.1) THEN WRITE(20,*) IF(VMAXIN(ISTATE).GE.0) THEN WRITE(20,700) SLABL(ISTATE), IOMEG(ISTATE), 1 VMIN(ISTATE,1), VMAX(ISTATE,1), 2 JTRUNC(ISTATE), EFSEL(ISTATE),ISTATE ELSE WRITE(20,700) SLABL(ISTATE), IOMEG(ISTATE), 1 VMIN(ISTATE,1), VMAXIN(ISTATE), 2 JTRUNC(ISTATE), EFSEL(ISTATE),ISTATE WRITE(20,705) (VMAX(ISTATE,I), I=1,NISTP) ENDIF WRITE(20,701) PSEL(ISTATE),VLIM(ISTATE),MAXMIN(ISTATE), 1 BOBCN(ISTATE),OSEL(ISTATE) WRITE(20,702) RMIN(ISTATE), RMAX(ISTATE), RH(ISTATE) IF((PSEL(ISTATE).GE.2).AND.(PSEL(ISTATE).LE.5)) THEN WRITE(20,*) WRITE(20,703) NCMM(ISTATE),rhoAB(ISTATE), 1 IVSR(ISTATE),IDSTT(ISTATE) IF(NCMM(ISTATE).GT.0) THEN IF(MMLR(1,ISTATE).GT.0) THEN DO I= 1,NCMM(ISTATE) WRITE(20,704) MMLR(I,ISTATE), 1 CmVAL(I,ISTATE),IFXCM(I,ISTATE), I,I,I ENDDO ELSE IF(MMLR(1,ISTATE).GE.-1) THEN DO I= 1,NCMM(ISTATE) WRITE(20,706) MMLR(I,ISTATE), 1 CmVAL(I,ISTATE),IFXCM(I,ISTATE),LAB2(I) ENDDO ELSE DO I= 1,NCMM(ISTATE) WRITE(20,706) MMLR(I,ISTATE), 1 CmVAL(I,ISTATE),IFXCM(I,ISTATE),LAB3(I) ENDDO ENDIF ENDIF ENDIF ENDIF ENDIF IF(PSEL(ISTATE).EQ.-1) GOTO 90 c----------------------------------------------------------------------- c** Writing out the absolute energy information. c----------------------------------------------------------------------- WRITE(6,636) 'VLIM',VLIM(ISTATE) c----------------------------------------------------------------------- c** Writing out the Te information. c----------------------------------------------------------------------- IF(ISTATE.GT.1) THEN UAT = 0.0d0 UBT = 0.0d0 IF(IFXDE(1).LE.0) UAT = PU(1) IF(IFXDE(ISTATE).LE.0) UBT = -PU(IPV+1) cc UBT = (UAT+UBT)*DSQRT(DECM(ISTATE)+1.0d0) UBT = DSQRT(UAT**2 + UBT**2 + 2.d0*DECM(ISTATE)*UAT*UBT) UAT = DE(1) - VLIM(1) + VLIM(ISTATE) - DE(ISTATE) SAT= DSQRT(PS(1)**2 + PU(IPV+1)**2) WRITE(6,620) 'Te',UAT,UBT,SAT ENDIF c----------------------------------------------------------------------- c** Writing out the De information. c----------------------------------------------------------------------- IF((PSEL(ISTATE).GE.1).AND.(PSEL(ISTATE).NE.4)) THEN IPV= IPV + 1 IF(IFXDE(ISTATE).LE.0) THEN IF(DABS(DE(ISTATE)).GT.PU(IPV)) THEN WRITE(6,620) 'De',DE(ISTATE),PU(IPV),PS(IPV) ELSE WRITE(6,621) 'De',DE(ISTATE),PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,622) 'De',DE(ISTATE) ENDIF IF(NPASS.GT.1) THEN WRITE(20,670) WRITE(20,670) DE(ISTATE),IFXDE(ISTATE),'De','De' ENDIF ENDIF IF((PSEL(ISTATE).EQ.4).AND.(NPASS.GT.1)) 1 WRITE(6,620) 'De',DE(ISTATE),uDe c----------------------------------------------------------------------- c** Writing out the Re information. c----------------------------------------------------------------------- IF(PSEL(ISTATE).EQ.0) GO TO 60 IPV= IPV + 1 IPVRe(ISTATE) = IPV IF(IFXRE(ISTATE).LE.0) THEN IF (DABS(RE(ISTATE)).GT.PU(IPV)) THEN WRITE(6,620) 'Re',RE(ISTATE),PU(IPV),PS(IPV) ELSE WRITE(6,621) 'Re',RE(ISTATE),PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,622) 'Re',RE(ISTATE) ENDIF IF(NPASS.GT.1) WRITE(20,670)RE(ISTATE),IFXRE(ISTATE),'Re','Re' c IF((PSEL(ISTATE).GE.2).AND.(PSEL(ISTATE).NE.4)) THEN c----------------------------------------------------------------------- c** For MLR or DELR, HPP, TT, or HFD write out the Cm information. c----------------------------------------------------------------------- IF(MMLR(1,ISTATE).LE.0) THEN c** For Aubert-Frecon treatment of C3(r):C6(r) for alkali dimers DO m=1,NCMM(ISTATE) IPV= IPV+1 IF((MMLR(1,ISTATE).EQ.0) 1 .OR.(MMLR(1,ISTATE).EQ.-1)) THEN IF(IFXCm(m,ISTATE).LE.0) THEN IF(DABS(CmVAL(m,ISTATE)).GT.PU(IPV)) 1 WRITE(6,720) LAB2(m),CmVAL(m,ISTATE), 2 PU(IPV),PS(IPV) IF(DABS(CmVAL(m,ISTATE)).LE.PU(IPV)) 1 WRITE(6,721) LAB2(m),CmVAL(m,ISTATE), 2 PU(IPV),PS(IPV) ELSE WRITE(6,722) LAB2(m),CmVAL(m,ISTATE) ENDIF ELSE IF(IFXCm(m,ISTATE).LE.0) THEN IF(DABS(CmVAL(m,ISTATE)).GT.PU(IPV)) THEN WRITE(6,720) LAB3(m),CmVAL(m,ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,721) LAB3(m),CmVAL(m,ISTATE), 1 PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,722) LAB3(m),CmVAL(m,ISTATE) ENDIF ENDIF ENDDO ELSE c ... For 'regular' MLJ or MLR or DELR or HPP or TT cases ... DO m= 1,NCMM(ISTATE) IPV= IPV+ 1 IF(IFXCm(m,ISTATE).LE.0) THEN IF(DABS(CmVAL(m,ISTATE)).GT.PU(IPV)) 1 WRITE(6,660) MMLR(m,ISTATE),CmVAL(m,ISTATE),PU(IPV),PS(IPV) IF(DABS(CmVAL(m,ISTATE)).LE.PU(IPV)) 1 WRITE(6,661) MMLR(m,ISTATE),CmVAL(m,ISTATE),PU(IPV),PS(IPV) ELSE WRITE(6,662) MMLR(m,ISTATE),CmVAL(m,ISTATE) ENDIF ENDDO IF((PSEL(ISTATE).EQ.4).AND.(NPASS.GT.1)) 1 WRITE(6,660) MMp2,CMMp2,uCMMp2 ENDIF c** Check & do printouts re. Cm values constrained in fits IPV= IPVRe(ISTATE) DO m= 1, NCMM(ISTATE) IPV= IPV+1 IF(IFXCm(m,ISTATE).GT.1) THEN c... Print re. a fitted Cm value constrained to equal that from another c state (with smaller ISTATE). Input value of IFXCm(m,ISTATE) is IPV c parameter-counter value for that earlier Cm value. c NOTE !!!! Need c to fix ISTATE count label !!!!!!!!! DO JSTATE= ISTATE,1,-1 IF((IFXCm(m,ISTATE).LT.IPVRe(JSTATE)).AND. 1 (IFXCm(m,ISTATE).GT.IPVRE(JSTATE-1))) THEN CmVAL(m,ISTATE)= CmVAL(m,JSTATE-1) WRITE(6,666) MMLR(m,ISTATE),IPV, 1 IFXCm(m,ISTATE),MMLR(m,ISTATE),JSTATE-1, 2 CmVAL(m,ISTATE) ENDIF ENDDO ENDIF ENDDO 666 FORMAT(' Constrain C_',I1,' = PV(',i3,') to equal fitted PV(' 1 ,I3,') = C_',I1,'(ISTATE=',I2,')'/53x,'=',1Pd14.7) ENDIF c----------------------------------------------------------------------- c** For DELR, calculate and write out the A and B coefficients c----------------------------------------------------------------------- IF(PSEL(ISTATE).EQ.3) THEN yqRe=(RE(ISTATE)**nQB(ISTATE) - AREF**nQB(ISTATE)) 1 /(RE(ISTATE)**nQB(ISTATE) + AREF**nQB(ISTATE)) betaRe= beta(0,ISTATE) yPOW= 1.d0 DO i= 1, Nbeta(ISTATE) YPOW= YPOW*yqRe betaRe= betaRe+ YPOW*beta(I,ISTATE) ENDDO DO m=1,NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) ENDDO CALL DAMPF(RE(ISTATE),rhoAB(ISTATE),NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),DM,DMP,DMPP) IF(MMLR1D(1).LE.0) THEN CALL AFdiag(RE(ISTATE),VLIM(ISTATE),NCMM(ISTATE), 1 NCMMax,MMLR1D,CmVAL(1:NCMMax,ISTATE),rhoAB(ISTATE), 2 IVSR(ISTATE),IDSTT(ISTATE),VATTRe,dULRdCm,dVATTRE) ELSE DO m=1,NCMM(ISTATE) Tm= CmVAL(m,ISTATE)/Re(ISTATE)**MMLR1D(m) VATTRe= VATTRe + DM(m)*Tm dVATTRe= dVATTRe + Tm*(DMP(m) 1 - Dm(m)*MMLR1D(m)/RE(ISTATE)) ENDDO ENDIF AA(ISTATE)= DE(ISTATE) - VATTRe - dVATTRE/betaRe BB(ISTATE)= AA(ISTATE) + DE(ISTATE) - VATTRe WRITE(6,633) 'A(DELR)',AA(ISTATE) WRITE(6,633) 'B(DELR)',BB(ISTATE) ENDIF c----------------------------------------------------------------------- c** Writing out the exponent expansion parameter information. c----------------------------------------------------------------------- BTEMP= 0.d0 IF(NPASS.GT.1) WRITE(20,671) Nbeta(ISTATE), APSE(ISTATE), 1 nQB(ISTATE), nPB(ISTATE), RREF(ISTATE) J=0 IF((PSEL(ISTATE).EQ.2).AND.(APSE(ISTATE).GT.0)) J=1 IF(PSEL(ISTATE).GE.6) J=1 DO I=J, Nbeta(ISTATE) IPV= IPV + 1 IF(IFXBETA(I,ISTATE).LE.0) THEN IF(DABS(BETA(I,ISTATE)).GT.PU(IPV)) THEN IF(APSE(ISTATE).LE.0) WRITE(6,640) 'be','ta',I, 1 BETA(I,ISTATE),PU(IPV),PS(IPV) IF(APSE(ISTATE).GT.0) WRITE(6,640) 'be','ta',I, 1 BETA(I,ISTATE),PU(IPV),PS(IPV),yqBETA(I,ISTATE) ELSE IF(APSE(ISTATE).LE.0) WRITE(6,641) 'be','ta',I, 1 BETA(I,ISTATE),PU(IPV),PS(IPV) IF(APSE(ISTATE).GT.0) WRITE(6,641) 'be','ta',I, 1 BETA(I,ISTATE),PU(IPV),PS(IPV),yqBETA(I,ISTATE) ENDIF ELSE IF(APSE(ISTATE).LE.0) WRITE(6,638) 'be','ta',I, 1 BETA(I,ISTATE) IF(APSE(ISTATE).GT.0) WRITE(6,638) 'be','ta',I, 1 BETA(I,ISTATE),yqBETA(I,ISTATE) ENDIF IF(NPASS.GT.1) THEN IF(APSE(ISTATE).LE.0) THEN WRITE(20,669) BETA(I,ISTATE),IFXBETA(I,ISTATE), 1 'BETA',I,'BETA',I ELSE WRITE(20,668) yqBETA(I,ISTATE),BETA(I,ISTATE), 1 IFXBETA(I,ISTATE) ENDIF ENDIF BTEMP= BTEMP+ BETA(I,ISTATE) ENDDO c??? IF(PSEL(ISTATE).EQ.4) THEN ! HPP ??why bother doing it here? c DO I= Nbeta(ISTATE)+1, Nbeta(ISTATE)+3 c IPV= IPV+1 c IF(IFXBETA(I,ISTATE).LE.0) THEN c IF(DABS(BETA(I,ISTATE)).GT.PU(IPV)) THEN c WRITE(6,640) 'pa','rm',I,BETA(I,ISTATE), c 1 PU(IPV),PS(IPV) c WRITE(6,641) 'pa','rm',I,BETA(I,ISTATE), c 1 PU(IPV),PS(IPV) c ENDIF c ELSE c WRITE(6,638) 'pa','rm',I,BETA(I,ISTATE) c ENDIF c ENDDO c ENDIF ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc if(npass.gt.1) then cc write(6,500) DE(ISTATE),ddedre,(j,dDe(j),j=0,nbeta(istate)) cc500 FORMAT(/' De=',f12.7,' d{De}/d{Re}=',1p,d12.4,' and'/ cc 1 3(' d{De}/db(',i2,')=',d12.4):) cc write(6,510) CMMp2,dCmp2dRe, (j,dCmp2(j),j=0,nbeta(istate)) cc510 FORMAT(/' CMMp2=',1P,d14.7,' d{CMMp2}/d{Re}=',D12.4,' and'/ cc 1 3(' d{Cmmp2}/db(',i2,')=',d12.4):) cc endif ccccccccccccccccccccccccccccccccccCCcccccccccccccccccccccccccccccccccccc c c** Write out phi_\infty constant for the EMO or DELR forms IF((PSEL(ISTATE).EQ.1).OR.(PSEL(ISTATE).EQ.3)) THEN BINF= BTEMP WRITE(6,648) BINF IF(BINF.LT.0.d0) WRITE(6,647) 647 FORMAT(' *** CAUTION *** negative beta_INf means potential blows u 1p at large r ***') ENDIF IF(PSEL(ISTATE).EQ.2) THEN WRITE(6,648) BINF IF(MMLR(1,ISTATE).GT.0) THEN BTEMP= CmVAL(1,ISTATE)*2.d0*(2.d0*BINF - BTEMP) 1 *RE(ISTATE)**nPB(ISTATE) WRITE(6,652) MMLR(1,ISTATE)+nPB(ISTATE),BTEMP ELSE BTEMP= CmVAL(2,ISTATE)*2.d0*(2.d0*BINF - BTEMP) 1 *RE(ISTATE)**nPB(ISTATE) WRITE(6,652) MMLR(2,ISTATE)+nPB(ISTATE),BTEMP ENDIF ENDIF c----------------------------------------------------------------------- c** Writing out the adiabatic BOB radial function for atom A. c----------------------------------------------------------------------- 60 IF(NPASS.GT.1) THEN !! next 4 - to stablize printout NUApr= NUA(ISTATE)-1 NUBpr= NUB(ISTATE)-1 NTApr= NTA(ISTATE)-1 NTBpr= NTB(ISTATE)-1 IF(NUA(ISTATE).LT.0) NUApr= -1 IF(NUB(ISTATE).LT.0) NUBpr= -1 IF(NTA(ISTATE).LT.0) NTApr= -1 IF(NTB(ISTATE).LT.0) NTBpr= -1 WRITE(20,672) NUApr, NUBpr,qAD(ISTATE),pAD(ISTATE), 1 LRad(ISTATE) IF(LRad(ISTATE).GT.0) THEN DO m= 1,NCMM(ISTATE) WRITE(20,677) dCmA(m,ISTATE),'A',MMLR(m,ISTATE) ENDDO DO m= 1,NCMM(ISTATE) WRITE(20,677) dCmB(m,ISTATE),'B',MMLR(m,ISTATE) ENDDO ENDIF ENDIF IF(NUA(ISTATE).GE.1) THEN DO I= 0,NUA(ISTATE)-1 IPV= IPV + 1 IF(IFXUA(I,ISTATE).LE.0) THEN IF(DABS(UA(I,ISTATE)).GT.PU(IPV)) THEN WRITE(6,640) ' u',NAME(1),I,UA(I,ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,641) ' u',NAME(1),I,UA(I,ISTATE), 1 PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,650) ' u',NAME(1),I,UA(I,ISTATE) ENDIF IF(NPASS.GT.1) WRITE(20,667) UA(I,ISTATE), 1 IFXUA(I,ISTATE),'UA',I,'UA',I ENDDO IPV= IPV + 1 IF(NPASS.GT.1) WRITE(20,674) UA(NUA(ISTATE),ISTATE), 1 IFXUA(NUA(ISTATE),ISTATE),'uAinf','uAinf' IF(IFXUA(NUA(ISTATE),ISTATE).LE.0) THEN WRITE(6,644) ' u',NAME(1),UA(NUA(ISTATE),ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,646) ' u',NAME(1),UA(NUA(ISTATE),ISTATE) ENDIF ENDIF 667 FORMAT(1Pd20.12,0P,I3,9x,'% ',A2,I2,' IFX',A2,I2) 668 FORMAT(1Pd20.12,d20.12,0P,I3) 669 FORMAT(1Pd20.12,0P,I3,9x,'% ',A4,I2,' IFX',A4,I2) 670 FORMAT(1Pd20.12,0P,I3,9x,'% ',A2,' IFX',A2) 671 FORMAT(/2I3,I4,I3,1PD11.2,8x,'% Nbeta APSE nQB nPB RREF') 672 FORMAT(/2I3,I4,I3,I5,14x,'% NUA NUB qAD pAD LRad') 673 FORMAT(/2I3,I4,I3,19x,'% NTA NTB qNA pNA') 674 FORMAT(1Pd20.12,0P,I3,9x,'% ',a5,' IFX',A5) 675 FORMAT(/3I3,24x,'% NwCFT Pqw efREF') 677 FORMAT(F15.4,21x,'% dCm',A1,'('I2,')' ) c----------------------------------------------------------------------- c** Writing out the adiabatic BOB radial function for atom B. c----------------------------------------------------------------------- IF(NUB(ISTATE).GE.1) THEN DO I= 0, NUB(ISTATE)- 1 IPV= IPV + 1 IF(IFXUB(I,ISTATE).EQ.0) THEN IF(DABS(UB(I,ISTATE)).GT.PU(IPV)) THEN WRITE(6,640) ' u',NAME(2),I,UB(I,ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,641) ' u',NAME(2),I,UB(I,ISTATE), 1 PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,650) ' u',NAME(2),I,UB(I,ISTATE) ENDIF IF(NPASS.GT.1) WRITE(20,667) UB(I,ISTATE), 1 IFXUB(I,ISTATE),'UB',I,'UB',I ENDDO IPV= IPV + 1 IF(NPASS.GT.1) WRITE(20,674) UB(NUB(ISTATE),ISTATE), 1 IFXUB(NUB(ISTATE),ISTATE),'uBinf','UBinf' IF(IFXUB(NUB(ISTATE),ISTATE).LE.0) THEN WRITE(6,644) ' u',NAME(2),UB(NUB(ISTATE),ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,646) ' u',NAME(2),UB(NUB(ISTATE),ISTATE) ENDIF ENDIF c----------------------------------------------------------------------- c** Writing out the Rotational Non-Adiabatic information for atom A. c----------------------------------------------------------------------- IF(NPASS.GT.1) WRITE(20,673) NTApr, NTBpr,qNA(ISTATE), 1 qNA(ISTATE) IF(NTA(ISTATE).GE.1) THEN DO I= 0, NTA(ISTATE)-1 IPV= IPV + 1 IF(IFXTA(I,ISTATE).LE.0) THEN IF(DABS(TA(I,ISTATE)).GT.PU(IPV)) THEN WRITE(6,640) ' t',NAME(1),I,TA(I,ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,641) ' t',NAME(1),I,TA(I,ISTATE), 1 PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,650) ' t',NAME(1),I,TA(I,ISTATE) ENDIF IF(NPASS.GT.1) WRITE(20,667) TA(I,ISTATE), 1 IFXTA(I,ISTATE),'TA',I,'TA',I END DO IPV= IPV + 1 IF(NPASS.GT.1) WRITE(20,674) TA(NTA(ISTATE),ISTATE), 1 IFXTA(NTA(ISTATE),ISTATE),'tAinf','TAinf' IF(IFXTA(NTA(ISTATE),ISTATE).LE.0) THEN WRITE(6,644) ' t',NAME(1),TA(NTA(ISTATE),ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,646) ' t',NAME(1),TA(NTA(ISTATE),ISTATE) ENDIF ENDIF c----------------------------------------------------------------------- c** Writing out the Rotational Non-Adiabatic information for atom B. c----------------------------------------------------------------------- IF(NTB(ISTATE).GE.1) THEN DO I= 0, NTB(ISTATE)-1 IPV= IPV + 1 IF(IFXTB(I,ISTATE).LE.0) THEN IF(DABS(TB(I,ISTATE)).GT.PU(IPV)) THEN WRITE(6,640) ' t',NAME(2),I,TB(I,ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,641) ' t',NAME(2),I,TB(I,ISTATE), 1 PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,650) ' t',NAME(2),I,TB(I,ISTATE) ENDIF IF(NPASS.GT.1) WRITE(20,667) TB(I,ISTATE), 1 IFXTB(I,ISTATE),'TB',I,'TB',I END DO IPV= IPV + 1 IF(NPASS.GT.1) WRITE(20,674) TB(NTB(ISTATE),ISTATE), 1 IFXTB(NTB(ISTATE),ISTATE),'tBinf','TBinf' IF(IFXTB(NTB(ISTATE),ISTATE).LE.0) THEN WRITE(6,644) ' t',NAME(2),TB(NTB(ISTATE),ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,646) ' t',NAME(2),TB(NTB(ISTATE),ISTATE) ENDIF ENDIF c----------------------------------------------------------------------- c** Writing out Lambda-doubling/2-Sigma coefficients c----------------------------------------------------------------------- IF((IOMEG(ISTATE).GT.0).OR.(IOMEG(ISTATE).EQ.-1)) THEN IF(NPASS.GT.1) WRITE(20,675) NwCFT(ISTATE),Pqw(ISTATE), 1 efREF(ISTATE) ENDIF IF(NwCFT(ISTATE).GE.0) THEN J= 1 IF(IOMEG(ISTATE).EQ.-1) J=2 DO I= 0, NwCFT(ISTATE) IPV= IPV + 1 IF(IFXwCFT(I,ISTATE).LE.0) THEN IF(DABS(wCFT(I,ISTATE)).GT.PU(IPV)) THEN WRITE(6,642) NAMEDBLE(J),I,wCFT(I,ISTATE), 1 PU(IPV),PS(IPV) ELSE WRITE(6,643) NAMEDBLE(J),I,wCFT(I,ISTATE), 1 PU(IPV),PS(IPV) ENDIF ELSE WRITE(6,651) NAMEDBLE(J),I,wCFT(I,ISTATE) ENDIF IF(NPASS.GT.1) WRITE(20,669) wCFT(I,ISTATE), 1 IFXwCFT(I,ISTATE),'wCFT',I,'wCFT,',I END DO ENDIF 90 CONTINUE WRITE(6,600) RETURN c----------------------------------------------------------------------- 552 FORMAT(11x,'using radial expansion variable: y',I1,' = (R^',I1, 1 ' - Re^',I1,')/(R^',I1,' + Re^',I1,')') 555 FORMAT(8x,'with radial variable: y_{p,q} = (R^q -',F9.6,'^q)/(R^ 1q +',F9.6,'^q)') 554 FORMAT(8x,'with ',A2,'-atom radial expansion variable: y',I1, 1 ' = (R^',I1,' - Re^',I1,')/(R^',I1,' + Re^',I1,')') 556 FORMAT(' Adiabatic BOB functions are simple power series in y_' 1 I1,'(r) scaled by m_e/M(A):') 557 FORMAT(' Adiabatic BOB functions with {p=',i2,', q=',i2, 1 '} are scaled by DELTA{M(A)}/M(A):') 564 FORMAT(4x,A10,A2,';R) = \sum\{u_i * [y',I1,']^i} for i= 0 to', 1 i3) 558 FORMAT(4x,A10,A2,';R) = u(inf)*y',i1,' + (1 - y',I1, ')*\Sum{u_i * 1 [y',I1,']^i} for i= 0 to',i3) 559 FORMAT(' Non-Adiabatic centrifugal BOB fx. with {p=',i2,', q=',i2, 1 '} are scaled by M(1)/M(A):') 560 FORMAT(' Non-Adiabatic centrifugal BOB fx are power series in y_', 1 I2,'(r) scaled by m_e/M(A):') 570 FORMAT(8x,'but replace u(inf) with u(inf) + Sum{dCm/r**m} wher 1e:') 571 FORMAT(48x,'dC',I1,'=',1PD14.7,'[cm-1 Ang^',i1,']') 600 FORMAT(1X,39('==')) 601 FORMAT(' All distinct levels of State ',A3,' fitted as independent 1 term values') 603 FORMAT(/' FIXED State ',A3,' potential defined by interpolating ov 1er input turning points') 684 FORMAT(/' For state ',A3,' fits represents level with Band Constan 1ts'/1x,6('==')) 685 FORMAT(' *',A6,I3,'; IS=',I2,')=',1PD20.12,3X,1PD8.1,6X,1PD8.1, 1 10x) 686 FORMAT(2X,A6,I3,'; IS=',I2,')=',1PD20.12,3X,1PD8.1,6X,1PD8.1,10x) 687 FORMAT(I4,10I4) 6872 FORMAT(4x,10I4) 688 FORMAT(' ') 690 FORMAT(7x,'Parameter',10x,'Final Value',5x,'Uncertainty Sensitivit 1y') 602 FORMAT(/' State ',A3,' represented by an EMO(Nbeta=',I2,' q=',i2, 1 ') potential defined in terms of'/1x,4('=='), ' exponent coeffi 2cient: beta(R)= Sum{beta_i*y',i1,'^i} for i= 0 -',i3) 604 FORMAT(/' State ',A3,' represented by an MLR(q=',i2,', p=',i2, 1 ') potential defined in terms of') 605 FORMAT(1x,4('=='), ' exponent coefficient: beta(R)= betaINF*y', 1 i1,' +(1-y',I1,')*Sum{beta_i*y',i1,'^i}'/62x,'for i= 0 to',I3) 610 FORMAT(/' For state ',A3," use Surkus' Generalized Potential Ener 1gy Function GPEF with"/1x,6('=='),' expansion vble: y_',i1, 2 '(r) = (r^',i1,' - re^',i1,')/(',F5.2,'*r^',i1,' +',F5.2,'*re^', 3 i1,'p)') 6102 FORMAT(' *** Input ERROR *** band constant specification v=',I3, 1 ' .NE.', I3) 612 FORMAT(/' State ',A3,' represented by a DELR(N=',I2,' q=',i2,') 1potential with'/1x,4('=='),' exponent coefficient: beta(r)= Su 2m{beta_i*y',i1,'^i}'/48x,'with polynomial order Nbeta=',I3) 607 FORMAT(4x,'uLR inverse-power terms incorporate DS-type damping wit 1h rhoAB=',f10.7/11x,'defined to give very short-range Dm(r)*Cm/ 2r^m behaviour r^{',SP,f4.1,'}'/8x,SS,'Dm(r)= [1 - exp(-',f5.2, 3 '(rhoAB*r)/m -',f6.3,'(rhoAB*r)^2/sqrt{m})]^{m',SP,F4.1,'}') 6072 FORMAT(4x,18('-'),11(A5: )) 617 FORMAT(4x,'uLR inverse-power terms incorporate TT-type damping wit 1h rhoAB=',f10.7/8x,'defined to give very short-range Dm(r)*Cm/r 2^m behaviour r^{',SP,I2,'}'/8x,'Dm(r)= [1 - exp(-bTT*r)*SUM{(bT 3T*r)^k/k!}] where bTT= rhoAB': '*',SS,f6.3) 680 FORMAT(1x,4('=='),' exponent coefficient defined as a Pashov natu 1ral spline through'/ 10x,i3,' specified points including the fixed 2 value of betaINF at yp= 1') 682 FORMAT(20x,'These constants yield: betaINF=',F14.10 ) 683 FORMAT(/4x,'Since this state has (projected) electronic angular mo 1mentum OMEGA=',I2/10x,'eigenvalue calculations use centrifugal po 2tential [J*(J+1) -',I2,']/r**2') 608 FORMAT(48x,'C',I1,'=',1PD14.7,'[cm-1 Ang^',i1,']') 6082 Format(3x,I4,9x,12I5) 609 FORMAT(47x,'C',I2,'=',1PD14.7,'[cm-1 Ang^{',i2,'}]') 6092 Format(' n(q{lambda}) ',12I5) 606 FORMAT(' Use Aubert-Frecon 2x2 ',A2,'-state uLR(r) with Aso=', 1 F11.6,'[cm-1]') 6062 FORMAT(/' For state ',A3,' represent level energies by independent 1 band constant for each'/1x,6('=='),27x,'vibrational levels of eac 2h isotologue'/3x,'No. band constants'/6x,'v',' isotop: #',I1: 3 11(' #',I1:):) 6066 FORMAT(' Use Aubert-Frecon 3x3 ',A2,'-state uLR(r) with Aso=', 1 F11.6,'[cm-1]') 614 FORMAT(' Parameter Initial Value Uncertainty Sensitivity 1') 615 FORMAT(' Parameter Final Value Uncertainty Sensitivity 1') 618 FORMAT(1x,A6,'-doubling splitting strength function is expanded as 1'/7x,'f(r) = Sum{w_i * (y',i1,')^i} for i= 0 to',i3/ 2 11x,'with radial expansion variable: y',I1,' = (R^',I1, 3 ' - Re^',I1,')/(R^',I1,' + Re^',I1,')') 619 FORMAT(/' Including BOB term makes centrifugal potential strength 1factor [J(J+1) +',I2,']') 620 FORMAT(6X,A2,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1,10x) 621 FORMAT(5X,'*',A2,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1) 622 FORMAT(6X,A2,3X,1PD21.12,7X,'--',12X,'--') 623 FORMAT(/' State ',A3,' represented by a Tiemann polynomial (b=', 1 F5.2,', R_in=',F4.2,', R_out=',F4.2,')'/1x,4('=='),5x,'with exp 2ansion variable: y_',i1,'(r) = (r - re)/(r ',SP,F5.2,'*re)') c 1,3726(1984)]'/5x,'[1 - exp(-3.13*RHO*r)*SUM{(3.13*RHO*r)^k/k!}]', c 2 ' with rhoAB=',F9.6) 630 FORMAT(3X,A5,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1) 631 FORMAT(2X,'*',A5,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1) 632 FORMAT(3X,A5,3X,1PD21.12,7X,'--',12X,'--') 633 FORMAT(4x,A7,1PD21.12) 636 FORMAT(4X,A4,3X,1PD21.12,7X,'--',12X,'--') 638 FORMAT(3X,A2,A2,'(',I2,')',1PD21.12,7X,'--',12X,'--': 1 ' at yp=',0pF14.10) 640 FORMAT(3X,A2,A2,'(',I2,')',1PD21.12,3X,1PD8.1,6X,1PD8.1: 1 ' at yp=',0pF14.10) 641 FORMAT(' *',2A2,'(',I2,')',1PD21.12,3X,1PD8.1,6X,1PD8.1: 1 ' at yp=',0pF14.10) 642 FORMAT(1X,A6,'(',I2,')',1PD21.12,3X,1PD8.1,6X,1PD8.1) 643 FORMAT('*',A6,'(',I2,')',1PD21.12,3X,1PD8.1,6X,1PD8.1) 644 FORMAT(1x,A2,'_inf(',A2,')',1PD21.12,1PD11.1,6X,1PD8.1) 646 FORMAT(1x,A2,'_inf(',A2,')',1PD21.12,7X,'--',12X,'--') 648 FORMAT(3X,'beta_INF',1PD21.12,7X,'--',12X,'--') cc649 FORMAT(3X,'beta_INF',1PD21.12,7X,'--',12X,'--') cc ,5x,'at yp= 1.000 1000000') 650 FORMAT(3X,A2,A2,'(',I2,')',1PD21.12,7X,'--',12X,'--') 651 FORMAT(1X,A6,'(',I2,')',1PD21.12,7X,'--',12X,'--') 652 FORMAT(' C',I2,'{exp}',1PD21.12,7X,'--',12X,'--') 654 FORMAT(1X,A6,'_inf',1PD21.12,3X,1PD8.1,6X,1PD8.1) 656 FORMAT('*',A6,'_inf',1PD21.12,3X,1PD8.1,6X,1PD8.1) 658 FORMAT(1X,A6,'_inf',1PD21.12,7X,'--',12X,'--') 660 FORMAT(5X,'C',I2,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1) 661 FORMAT(3X,'* C',I2,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1) 662 FORMAT(5X,'C',I2,3X,1PD21.12,7X,'--',12X,'--':) 664 FORMAT(4x,'uLR inverse-power terms incorporate NO damping function 1s') 692 FORMAT(' ', A3,' state Lambda-doubling split levels referenced to 1 f-parity levels') 694 FORMAT(' ', A3,' state Lambda-doubling split levels referenced to 1 the e/f level mid-point') 696 FORMAT(' ', A3,' state Lambda-doubling split levels referenced to 1 e-parity levels') 700 FORMAT(1x,"'",A3,"'",2I3,2I5,I3,6x,' % ('I1')SLABL IOMEG VMIN' 1 ' VMAX JTRUNC EFSEL') 701 FORMAT(I3,F12.4,2I3,I4,6x,' % PSEL VLIM MAXMIN BOBCN OSEL') 702 FORMAT(2F7.2,F8.4,9x,' % RMIN RMAX RH') 703 FORMAT(I3,F7.2,2I3,15x,' % NCMM RHOab IDF IDSTT') 704 FORMAT(I3,1P,D17.8,0P,I3,8x,' % MMLR(',I1,'), CmVAL(',I1, 1 '), IFXCm(',I1,')') 705 FORMAT(10I4) 706 FORMAT(I3,1P,D17.8,0P,I3,8x,' % ',A10) 708 FORMAT(39x,A10,'=',1PD14.7,'[cm-1 Ang^{',i2,'}]') 720 FORMAT(2X,A6,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1,10x) 721 FORMAT(1X,'*',A6,3X,1PD21.12,3X,1PD8.1,6X,1PD8.1) 722 FORMAT(2X,A6,3X,1PD21.12,7X,'--',12X,'--') END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE VGEN(ISTATE,RDIST,VDIST,BETADIST,IDAT) c*********************************************************************** c** This subroutine will generate one of seven possible families of c analytical molecular potentials for the program dPotFit,as specified c by parameter PSEL c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c+++ COPYRIGHT 2006-2016 by R.J. Le Roy, Jenning Seto, Yiye Huang ++ c and N. Dattani, Department of Chemistry, University of of Waterloo, + c 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 ----- Version of 17 March 2016 ----- c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c ISTATE is the electronic state being considered in this CALL. c RDIST: If RDIST > 0, calculate potl & derivs only @ that onee distance c ----- * return potential function at that point as VDIST and c potential function exponent as BETADIST c * skip partial derivative calculation if IDAT.LT.0 {pointless??} c * If RDIST.le.0 calculate PEC & BOB fx. & partial derivatives c at distances given by array RD(i,ISTATE) & return them c -> RDIST > 0 & IDAT > 0 for tunneling width & derivative calc'n c -> RDIST > 0 & IDAT.le.0 for PEC only w. IDAT<0 to omit derivs c** On entry via common blocks: c* PSEL specifies how data for state ISTATE are to be represented! c PSEL = -2 : Represent {v,J,p} levels of state ISTATE by term values c PSEL = -1 : Represent {v,J} levels with band constants c PSEL = 0 : Use a fixed potential function defined in READPOT. c PSEL = 1 : Use an Expanded Morse Oscillator(p) potential. c PSEL = 2 : Use a Morse/Lennard-Jones(p) potential. c PSEL = 3 : Use a Double-Exponential Long-Range Potential. c PSEL = 4 : Use a Surkus "Generalized Potential Energy Function". c PSEL = 5 : Use a [Tiemann Polynomial] c PSEL = 6 : Use a Generalized Tang-Toennies-type potential c PSEL = 7 : Use an Aziz'ian HFD-ABC or HFD-D potential c* Nbeta(s) is order of the beta(r) {exponent} polynomial or # spline points c APSE(s).le.0 to use PE-MLR {p,q}-type exponent polynomial of order Nbeta(s) c if APSE(s) > 0 \beta(r) is SE-MLR spline defined by Nbeta(s) points c \beta_i=PARM(i) at distances defined by y_q^{Rref} c* MMLR(j,s) are long-range inverse-powers for an MLR or DELR potential c* nPB(s) the basic value of power p for the beta(r) exponent function c* nQB(s) the power q for the power series expansion variable in beta(r) c* pAD(s) & qAD(s) the values of power p for adiabatic u(r) BOB functions c* nNA(s) & qNA(s) the values of power p for centrifugal q(r) BOB functions c* Pqw(s) the power of r defining the y_{Pqw}(r) expansion variable in c* the f_{Lambda}(r) strength function c* DE is the Dissociation Energy for each state. c* RE is the Equilibrium Distance for each state. c* BETA is the array of potential (exponent) expansion parameters c* NDATPT is the number of meshpoints used for the array. c----------------------------------------------------------------------- c** On exit via common blocks: c-> R is the distance array c-> VPOT is the potential that is generated. c-> BETAFX is used to contain the beta(r) function. c** Internal partial derivative arrays ... c DUADRe & DUBDRe are p.derivs of adiabatic fx. w.r.t. Re c DVDQA & DVDQB are p.derivs of non-adiabatic fx. wrt q_A(i) & q_B(i) c DTADRe & DTBDRe are p.derivs of non-adiabatic fx. w.r.t. Re c dVdL & dLDDRe are p.derivatives of f_\lambda(r) w.r.t. beta_i & Re c DBDB & DBDRe are p.derives of beta(r) w.r.t. \beta_i & Re, respectively c c** Temp: c BTEMP is used to represent the sum used for dV/dRe. c is used in GPEF for De calculations. c BINF is used to represent the beta(\infty) value. c YP is used to represent (R^p-Re^p)/(R^p+Re^p) or R-Re. c XTEMP is used to represent (uLR/uLR_e)* exp{-beta*RTEMP} c PBTEMP is used to calculate dV/dBi. c PETEMP is used to calculate dV/dBi. c AZERO is used for the trial exponential calculations. c AONE is used for the trial exponential calculations. c ATWO is used for the trial exponential calculations. c AZTEMP is used in the MMO trial exponential calculations. c is used in the GPEF = (a+b)/k c AOTEMP is used in the GPEF = [a(k+1)-b(k-1)]/k c ATTEMP is used in the GPEF = [a^2(k+1)-b^2(k-1)]/k c ARTEMP is used in the GPEF = [a^3(k+1)-b^3(k-1)]/k c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKBOBRF.h' c======================================================================= c** Born-Oppenheimer breakdown radial functions REAL*8 UAR(NPNTMX,NSTATEMX),UBR(NPNTMX,NSTATEMX), 1 TAR(NPNTMX,NSTATEMX),TBR(NPNTMX,NSTATEMX),wRAD(NPNTMX,NSTATEMX) c COMMON /BLKBOBRF/UAR,UBR,TAR,TBR,wRAD c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c----------------------------------------------------------------------- c** Common block for partial derivatives of potential at the one c distance RDIST and HPP derivatives for uncertainties REAL*8 dVdPk(HPARMX),dDe(0:NbetaMX),dDedRe COMMON /dVdPkBLK/dVdPk,dDe,dDedRe c======================================================================= c** Define local variables ... INTEGER I,J,I1,ISTATE,IPV,IPVSTART,ISTART,ISTOP,LAMB2,m,m1,npow, 1 POWmax,IDAT,IISTP,MMp2, NIFL,MCMM,MMLR1D(NCMMax) REAL*8 BTEMP,BINF,RVAL,RTEMP,RM2,XTEMP,PBTEMP,PETEMP,Btemp2,RMF, 1 PBtemp2, bohr, Cm1D(NCMMax),CmEFF1D(NCMMax), 2 C3VAL,C3bar,C3Pi,C6bar,C6adj,C6Pi,C8Pi,C9adj,C11adj,C8VAL,YP,YQ, 3 YPA,YPB,YQA,YQB,YPE,YPM,YPMA,YPMB,YPP,YQP,REp,RDp,RDq,DYPDRE, 4 DYQDRE,VAL,DVAL,HReP,HReQ,yqRe,dyqRedRe,betaRe,DbetaRe,yPOW, 4 dAAdb0,dbetaFX,ULRe,dULRe,d2ULRe,SL,SLB,SLBB,AREF,AREFp,AREFq,T0, 5 T1,T2,Scalc,dLULRedRe,dLULRedCm(NCMMax),dLULRedDe,dULRdDe,rhoINT, 6 dULRdCm(NCMMax),dULRepdCm(NCMMax),dULRedCm(NCMMax),DVDD,RDIST, 7 VDIST,BETADIST,X,BFCT,JFCT,JFCTLD,REadAp,REadBp,REadAq,REadBq, 8 REnaAp,REnaBp,REnaAq,REnaBq,REwp,dC6dDe,dC9dC3,dC9dC6,dC9dDe,BT, 9 Rinn,Rout,A0,A1,A2,A3,xBETA(NbetaMX),rKL(NbetaMX,NbetaMX),C1LIM, o B5,BETA0,BETAN,TM,VATT,dATTdRe,dATTdb,ATT,REq,VMIN, a REQQ,XRI,dXRI,fRO,XRIpw,XRO,dXRO,XROpw,ROmp2,dXROdRe,d2XROdRe, b DXRIdRe,d2XRIdRe,dCmp2dRe,EXPBI,BIrat,CMMp2,RMMp2,dAIdRe,dBIdRe, c VX,dVX,dVdRe,dDeROdRe,dDeRIdRe,dULRdR,dCmASUM, dCmBSUM, d dAI(0:NbetaMX),dBI(0:NbetaMX),dCmp2(0:NbetaMX), e DEIGM1(1,1),DEIGM3(1,1),DEIGM5(1,1),DEIGR(1,1),DEIGRe(1,1), f DEIGDe(1,1),DEIGMx(NCMMax,1,1) c*********************************************************************** c** Temporary variables for MLR and DELR potentials REAL*8 ULR,dAAdRe,dBBdRe,dVdBtemp,CmVALL, Dm(NCMMax),Dmp(NCMMax), 1 Dmpp(NCMMax) c*********************************************************************** cc SAVE MCMM,Cm1D,MMLR1D ??? not needed - regenerate every call c** Initializing variables. DATA bohr/0.52917721092d0/ !! 2010 physical constants d:mohr12 REp= RE(ISTATE)**nPB(ISTATE) REq= RE(ISTATE)**nQB(ISTATE) IF(RREF(ISTATE).LE.0) AREF= RE(ISTATE) IF(RREF(ISTATE).GT.0) AREF= RREF(ISTATE) AREFP= AREF**nPB(ISTATE) AREFQ= AREF**nQB(ISTATE) c** Normally data point starts from 1 ISTART= 1 ISTOP= NDATPT(ISTATE) c** When calculating only one potential point IF(RDIST.GT.0.d0) THEN ISTART= NPNTMX ISTOP= NPNTMX VDIST= 0.0d0 BETADIST= 0.d0 ENDIF PETEMP= 0.0d0 DO I= ISTART,ISTOP BETAFX(I,ISTATE)= 0.0d0 UAR(I,ISTATE)= 0.d0 UBR(I,ISTATE)= 0.d0 TAR(I,ISTATE)= 0.d0 TBR(I,ISTATE)= 0.d0 UAR(I,ISTATE)= 0.d0 WRAD(I,ISTATE)= 0.d0 ENDDO c** Initialize parameter counter for this state ... IPVSTART= POTPARI(ISTATE) - 1 IF(PSEL(ISTATE).EQ.0) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For forward data simulation using a known input pointwise potential c?????? Prepare distance array ... ?? {Should it then call PPREPOT ?} c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ccc DO I= ISTART,ISTOP ccc RVAL= RD(I,ISTATE) ccc VDIST= VPOT(I,ISTATE) ccc ENDDO ENDIF ******7***** End Forward Calculation *********************************** IF(PSEL(ISTATE).EQ.1) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the Expanded Morse Oscillator: exponent polynomial order /Nbeta c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** First ... calculate the Extended Morse Oscillator exponent DO I= ISTART,ISTOP RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST RDQ= RVAL**nQB(ISTATE) YQ= (RDQ - AREFQ)/(RDQ + AREFQ) VAL= BETA(0,ISTATE) DVAL= 0.d0 DBDB(0,I,ISTATE)= 1.0d0 YQP= 1.d0 DO J= 1, Nbeta(ISTATE) DVAL= DVAL + BETA(J,ISTATE)* DBLE(J)* YQP YQP= YQP*YQ VAL= VAL + BETA(J,ISTATE)*YQP DBDB(J,I,ISTATE)= YQP ENDDO c*** DBDB & DBDRe= dBeta/dRe used in uncertainty calculation in fununc.f DBDRe(I,ISTATE)= 0.d0 BETAFX(I,ISTATE)= VAL XTEMP= DEXP(-VAL*(RVAL-RE(ISTATE))) c** First calculate the partial derivative w.r.t. DE IPV= IPVSTART+ 1 DVtot(IPV,I)= XTEMP*(XTEMP- 2.d0) DVDD= DVtot(IPV,I) c** Now calculate the actual potential VPOT(I,ISTATE)= DE(ISTATE)*DVDD + VLIM(ISTATE) IF(RDIST.GT.0.d0) THEN VDIST= VPOT(I,ISTATE) BETADIST= VAL c... branch to skip derivatives and inclusion of centrifugal & BOB terms IF(IDAT.LE.-1) GOTO 999 ENDIF c... now generate remaining partial derivatives YPP= 2.0d0*DE(ISTATE)*XTEMP*(1.d0 - XTEMP) IF(RREF(ISTATE).LE.0.d0) THEN DBDRe(I,ISTATE)= -0.5d0*nPB(ISTATE)*(1.d0-YP**2) 1 *DVAL/RE(ISTATE) VAL= VAL - (RVAL- RE(ISTATE))*DBDRe(I,ISTATE) ENDIF IPV= IPV+1 DVtot(IPV,I)= -YPP*VAL !! derivative w.r.t Re YQP= YPP*(RVAL - RE(ISTATE)) DO J= 0, Nbeta(ISTATE) IPV= IPV+1 DVtot(IPV,I)= YQP !! derivative w.r.t. \beta_i YQP= YQP*YQ ENDDO ENDDO ccccc Print for testing rewind(10) write(10,610) (RD(i,ISTATE),vpot(i,istate),BETAFX(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) ccccc ENDIF c........ End preparation of Expanded Morse Potential Function ......... IF(PSEL(ISTATE).EQ.2) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the {Morse/Long-Range} potential. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For 'normal' inverse-power sum MLR case, with or without damping, c set up and write 'Dattani-corrected' effective Cm values DO m= 1, NCMM(ISTATE) CmEFF(m,ISTATE)= CmVAL(m,ISTATE) Cm1D(m)= CmVAL(m,ISTATE) MMLR1D(m)= MMLR(m,ISTATE) !! powers in 0D array for dampF ENDDO MCMM= NCMM(ISTATE) cc ! Assuming {adj} corrections remembered from a previous call ..... cc IF((RDIST.GT.0.d0).AND.((IDAT.GT.1).OR.(IDAT.LT.0))) GO TO 50 c*** ! ELSE - make (& write) 'Dattani' Cm{adj} correctons here ********* CALL quadCORR(NCMM(ISTATE),MCMM,NCMMAX,MMLR1D, 1 DE(ISTATE),Cm1D,CmEFF1D) c??? try to devise sensible way to skip quadCORR in late iterations IF(MCMM.GT.NCMM(ISTATE)) THEN DO m= NCMM(ISTATE),MCMM CmEFF(m,ISTATE)= CmEFF1D(m) ENDDO ENDIF flush(6) 50 IF(MMLR(1,ISTATE).LE.0) THEN c------------------------------------------------------------------------ c** Define value & derivatives of uLR at Re ... first for A-F cases c... Cm 1 2 3 4 5 6 7 8 9 10 c... 2x2 {DELTAE, C3s, C3p, C6s, C6p, C8s, C8p} c Aubert-Frecon 2x2 treatment of {C3,C6,C8} for Li2 A- or b-state c... 3x3 {DELTAE, C3s, C3p1, C3p3, C6s, C6p1, C6p3, C8s, C8p1, C8p3} c Aubert-Frecon 3x3 treatment of {C3,C6,C8} for Li2 1^3\Pi_g or B-state c------------------------------------------------------------------------ CALL AFdiag(RE(ISTATE),VLIM(ISTATE),NCMM(ISTATE),NCMMax, 1 MMLR1D,Cm1D,rhoAB(ISTATE),IVSR(ISTATE),IDSTT(ISTATE), 2 ULRe,dLULRedCm,dLULRedRe) DO m= 1,NCMM(ISTATE) dLULRedCm(m)= dLULRedCm(m)/ULRe ENDDO dLULRedRe= dLULRedRe/ULRe ELSE c** and then for 'normal' inverse-power sum uLR fx. CALL dampF(RE(ISTATE),rhoAB(ISTATE),MCMM,NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) ULRe= 0.d0 T1= 0.d0 DO m= 1,MCMM IF(rhoAB(ISTATE).LE.0.d0) THEN dLULRedCm(m)= 1.d0/RE(ISTATE)**MMLR(m,ISTATE) ELSE dLULRedCm(m)= Dm(m)/RE(ISTATE)**MMLR(m,ISTATE) ENDIF T0= CmEFF(m,ISTATE)*dLULRedCm(m) ULRe= ULRe + T0 T1= T1 + MMLR(m,ISTATE)*T0 ENDDO dLULRedRe= -T1/(ULRe*RE(ISTATE)) DO m= 1,MCMM dLULRedCm(m)= dLULRedCm(m)/ULRe IF(rhoAB(ISTATE).GT.0) dLULRedRe= dLULRedRe + 1 dLULRedCm(m)*Dmp(m)/Dm(m) ENDDO ENDIF BINF= DLOG(2.0d0*DE(ISTATE)/ULRe) betaINF(ISTATE)= BINF IF(APSE(ISTATE).GT.0) THEN c*** For Pashov-natural-spline exponent coefficient ... DO I= 1,Nbeta(ISTATE) xBETA(I)= yqBETA(I,ISTATE) ENDDO BETA(Nbeta(ISTATE),ISTATE)= BINF CALL Lkoef(Nbeta(ISTATE),xBETA,rKL,NbetaMX) ENDIF c----------------------------------------------------------------------- DO I= ISTART,ISTOP c** Now - generate potential while looping over radial array RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST RDp= RVAL**nPB(ISTATE) RDp= RVAL**nPB(ISTATE) RDq= RVAL**nQB(ISTATE) YPE= (RDp-REp)/(RDp+REp) YP= (RDp-AREFp)/(RDp+AREFp) YQ= (RDq-AREFq)/(RDq+AREFq) YPM= 1.d0 - YP DYPDRE= -0.5d0*nPB(ISTATE)*(1.d0 - YP**2)/RE(ISTATE) DYQDRE= -0.5d0*nQB(ISTATE)*(1.d0 - YQ**2)/RE(ISTATE) YPP= 1.d0 DVAL= 0.d0 DBDB(0,I,ISTATE)= 1.0d0 npow= Nbeta(ISTATE) IF(APSE(ISTATE).LE.0) THEN c** For 'conventional' Huang power-series exponent function ... VAL= BETA(0,ISTATE) DO J= 1, Nbeta(ISTATE) c... now calculate power series part of the MLR exponent DVAL= DVAL + BETA(J,ISTATE)* DBLE(J)* YPP YPP= YPP*YQ VAL= VAL + BETA(J,ISTATE)*YPP DBDB(J,I,ISTATE)= YPM*YPP ENDDO c*** DBDB & DBDRe= dBeta/dRe used in uncertainty calculation in fununc.f DBDRe(I,ISTATE)= -YP*dLULRedRe IF(RREF(ISTATE).LE.0.d0) DBDRe(I,ISTATE)= 1 DBDRe(I,ISTATE)+ (BINF - VAL)*DYPDRE 2 + (1.d0-YP)*DVAL*DYQDRE VAL= YP*BINF + (1.d0- YP)*VAL ELSE c... now calculate Pashov-spline exponent coefficient & its derivatives VAL= 0.d0 DO J= 1, Nbeta(ISTATE) DBDB(J,I,ISTATE)= 1 Scalc(YQ,J,npow,xBETA,rKL,NbetaMX) VAL= VAL+ DBDB(J,I,ISTATE)*BETA(J,ISTATE) ENDDO DBDRe(I,ISTATE)= -DBDB(npow,I,ISTATE)*dLULRedRe ENDIF BETAFX(I,ISTATE)= VAL XTEMP= DEXP(-VAL*YPE) c** Now begin by generating uLR(r) c----- Special Aubert-Frecon cases ------------------------------------ IF(MMLR(1,ISTATE).LE.0) THEN c ... generate ULR for Aubert-Frecon type case ... CALL AFdiag(RVAL,VLIM(ISTATE),NCMM(ISTATE),NCMMax, 1 MMLR1D,Cm1D,rhoAB(ISTATE),IVSR(ISTATE), 2 IDSTT(ISTATE),ULR,dULRdCm,dULRdR) c----- End of special Aubert-Frecon Li2 cases ------------------------ ELSE c ... for the case of a 'normal' inverse-power sum u_{LR}(r) function ULR= 0.d0 CALL dampF(RVAL,rhoAB(ISTATE),MCMM,NCMMAX, 2 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) DO m= 1,MCMM IF(rhoAB(ISTATE).LE.0.d0) THEN dULRdCm(m)= 1.d0/RVAL**MMLR(m,ISTATE) ELSE dULRdCm(m)= Dm(m)/RVAL**MMLR(m,ISTATE) ENDIF ULR= ULR + CmEFF(m,ISTATE)*dULRdCm(m) ENDDO ENDIF XTEMP= XTEMP*ULR/ULRe c... note ... reference energy for each state is its asymptote ... DVDD= XTEMP*(XTEMP - 2.D0) VPOT(I,ISTATE)= DE(ISTATE)*DVDD + VLIM(ISTATE) IF(RDIST.GT.0.d0) THEN VDIST= VPOT(I,ISTATE) BETADIST= VAL c... branch to skip derivatives and inclusion of centrifugal & BOB terms IF(IDAT.LE.-1) GOTO 999 ENDIF YPP= 2.d0*DE(ISTATE)*(1.0d0-XTEMP)*XTEMP !! == DER IPV= IPVSTART+2 c... derivatives w.r.t long-range parameters ... m1= 1 IF(MMLR(1,ISTATE).LE.0) THEN c... for Aubert-Frecon diagonalization uLR ..... IPV=IPV+1 DVtot(IPV,I)= 0.d0 !! derivative w.r.t. splitting=0.0 m1= 2 ENDIF c... now derivative w.r.t. Cm's DO m= m1, NCMM(ISTATE) IPV= IPV+ 1 DVtot(IPV,I)= YPP*(dLULRedCm(m)*(1.d0 - YP*YPE) 1 - dULRdCm(m)/ULR) ENDDO IF(MCMM.GT.NCMM(ISTATE)) THEN c ... ideally should ajdust dV/dC3 for C6{adj} and C9{adj} ... but ... ENDIF c... derivative w.r.t. Re DVtot(IPVSTART+2,I)= YPP*(YPE*DBDRe(I,ISTATE) 1 + VAL*DYPDRE + dLULRedRe) IF(APSE(ISTATE).LE.0) THEN c... derivatives w.r.t. \beta_i for PE-MLR cases... YPP= YPP*YPE*(1 - YP) DO J= 0, Nbeta(ISTATE) IPV= IPV+1 DVtot(IPV,I)= YPP YPP= YPP*YQ ENDDO c... derivative w.r.t. De for 'conventional' power-series exponent DVtot(IPVSTART+1,I)= DVDD + YPP*YP*YPE/DE(ISTATE) ELSE c... derivatives w.r.t. \beta_i for Pashov-spline exponent cases... YPP= YPP*YPE DO J= 1,Nbeta(ISTATE) IPV= IPV+ 1 DVtot(IPV,I)= DBDB(J,I,ISTATE)*YPP ENDDO c... derivative w.r.t. De for Pashov-Spline expoinent DVtot(IPVSTART+1,I)= DVDD !! OK (I think) 1 + YPP*DBDB(Nbeta(ISTATE),I,ISTATE)/DE(ISTATE) ENDIF ENDDO !! end of loop over MLR radial array ccccc Print for testing rewind(10) write(10,610) (RD(i,ISTATE),vpot(i,istate),BETAFX(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) 610 FORMAT(/(f10.4,f15.5,f12.6)) ccccc End of Print for testing ENDIF flush(6) c......... End for Morse/Lennard-Jones(p) potential function ........... IF(PSEL(ISTATE).EQ.3) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the Double-Exponential Long-Range (DELR) potential AA(ISTATE)= 0.0d0 BB(ISTATE)= 0.0d0 dAAdRe= 0.0d0 dBBdRe= 0.0d0 dVdBtemp= 0.0d0 c ... First, save uLR powers & coefficients in 1D arrays DO m= 1, NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) Cm1D(m)= CmVAL(m,ISTATE) ENDDO c... then get AA & BB and their derivatives! yqRe= (REq - AREFQ)/(REq + AREFQ) !! next - dyq/dr @ r_e dyqRedRe = 2.d0*nQB(ISTATE)*REq*AREFQ/(Re(ISTATE)* 1 (REq + AREFQ)**2) IF(RREF(ISTATE).LE.0.d0) dyqRedRe= 0.d0 betaRe= beta(0,ISTATE) DbetaRe= 0.d0 !! this is d{beta}/d{y} at r= Re yPOW= 1.d0 npow= Nbeta(ISTATE) POWmax= npow IF(npow.GE.1) THEN DO j= 1,npow DbetaRe= DbetaRe + j*beta(J,ISTATE)*yPOW yPOW= yPOW*yqRe betaRe= betaRe + yPOW*beta(J,ISTATE) ENDDO ENDIF CALL dampF(RE(ISTATE),rhoAB(ISTATE),NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) ULRe= 0.d0 dULRe= 0.d0 d2ULRe= 0.d0 IF(MMLR(1,ISTATE).LE.0) THEN c ... for Aubert-Frecon diagonalization for u_{LR}(r) CALL AFdiag(RE(ISTATE),VLIM(ISTATE),NCMM(ISTATE), 1 NCMMax,MMLR1D,Cm1D,rhoAB(ISTATE),IVSR(ISTATE), 2 IDSTT(ISTATE),ULRe,dULRedCm,dULRe) dLULRedRe=dULRe/ULRe ELSE c ... for ordinary inverse-power sum u_{LR}(r) DO m= 1,NCMM(ISTATE) T0= CmVAL(m,ISTATE)/RE(ISTATE)**MMLR(m,ISTATE) IF(rhoAB(ISTATE).GT.0.d0) THEN ULRe= ULRe+ T0*DM(m) dULRe= dULRe+ T0*(Dmp(m) - 1 Dm(m)*MMLR1D(m)/RE(ISTATE)) d2ULRe= d2ULRe + T0*(Dmpp(m) - 1 2.d0*MMLR1D(m)*Dmp(m)/Re(ISTATE) + 2 MMLR1D(m)*(MMLR1D(m)+1.d0)*Dm(m)/Re(ISTATE)**2) ELSE ULRe= ULRe+ T0 dULRe= dULRe - T0*MMLR1D(m)/RE(ISTATE) d2ULRe= d2ULRe + T0*MMLR1D(m)*(MMLR1D(m)+1.d0) 1 /Re(ISTATE)**2 ENDIF ENDDO ENDIF c AA(ISTATE)= DE(ISTATE) - ULRe - dULRe/betaRe BB(ISTATE)= AA(ISTATE) + DE(ISTATE) - ULRe dAAdb0 = dULRe/betaRe**2 !! this is d{AA}/d{beta(0)} dAAdRe= -dULRe - d2ULRe/dbetaRe + dAAdb0*DbetaRe*dyqRedRe dBBdRe= dAAdRe - dULRe c===== end of calcn. for properties at Re performed, for 1'st point ==== c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Now to calculate the actual potential and partial derivatives: DO I= ISTART,ISTOP c** Start by generating the exponent and its derivative w.r.t. yq RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST !! for calc at onee point RDQ= RVAL**NQB(ISTATE) YQ= (RDQ-AREFQ)/(RDQ+AREFQ) YPOW= 1.d0 npow= NBETA(ISTATE) betaFX(I,ISTATE)= beta(0,ISTATE) dbetaFX= 0.d0 !! this is d{beta(r)}/dy_p(r) DO J= 1,npow dbetaFX= dbetaFX + DBLE(J)*beta(J,ISTATE)*YPOW YPOW= YPOW*YQ betaFX(I,ISTATE)= betaFX(I,ISTATE) + 1 beta(J,ISTATE)*YPOW ENDDO c** Calculate some temporary variables. XTEMP= DEXP(-betaFX(I,ISTATE)*(RVAL-RE(ISTATE))) c** Now to calculate uLR and the actual potential function value ULR= 0.0d0 c*** For Aubert-Frecon alkali dimer nS + nP diagonalization u_{LR}(r) IF(MMLR(1,ISTATE).LE.0) THEN CALL AFdiag(RVAL,VLIM(ISTATE),NCMM(ISTATE),NCMMax, 1 MMLR1D,Cm1D,rhoAB(ISTATE),IVSR(ISTATE), 2 IDSTT(ISTATE),ULR,dULRdCm,dULRdR) ELSE c... now for 'regular' inverse-power sum u_{LR}(r) CALL dampF(RVAL,rhoAB(ISTATE),NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) DO m= 1,NCMM(ISTATE) ULR= ULR + CmVAL(m,ISTATE)*Dm(m)/ 1 RVAL**MMLR(m,ISTATE) ENDDO ENDIF c... END of u_{LR}(r) calculation ........ cc REWIND(30) cc WRITE(30,*) RVAL,ULR !! test printout for error check VPOT(I,ISTATE)= (AA(ISTATE)*XTEMP - BB(ISTATE))*XTEMP 1 - ULR + VLIM(ISTATE) IF((I.EQ.ISTART).AND.(I.EQ.ISTOP)) THEN VDIST= VPOT(I,ISTATE) !! if getting V(r) at onee point betaDIST= betaFX(I,ISTATE) ENDIF c... branch to skip derivatives and inclusion of centrifugal & BOB terms IF(IDAT.LE.-1) GOTO 999 c----------------------------------------------------------------------- c** Now, calculate the partial derivatives ... c----------------------------------------------------------------------- IPV= IPVSTART + 1 c ... first, derivative of the potential w.r.t. De DVtot(IPV,I)= (XTEMP - 2.0d0)*XTEMP c** Now to calculate the derivative of the potential w.r.t. Re Btemp= (2.0d0*AA(ISTATE)*XTEMP - BB(ISTATE))*XTEMP IPV= IPV + 1 DVtot(IPV,I)= betaFX(I,ISTATE)*Btemp 1 + XTEMP*(dAAdRe*XTEMP - dBBdRe) Btemp= (RVAL- RE(ISTATE))*Btemp IF(RREF(ISTATE).LE.0.d0) 1 DVtot(IPV,I)= DVtot(IPV,I) - Btemp*DbetaRe*dyqRedRe c... ** when calculating Cm derivatives, dULRe'/dCm has been excluded ** DO m= 1,NCMM(ISTATE) dULRepdCm(m)=0.d0 ENDDO c... IF((NCMM(ISTATE).GE.4).AND.(MMLR(1,ISTATE).LE.0)) THEN c... derivatives w.r.t long-range parameters for Aubert-Frecon uLR IPV=IPV+1 DVtot(IPV,I)= 0.d0 DO m=2,NCMM(ISTATE) IPV=IPV+1 DVtot(IPV,I)= XTEMP*(2*dULRedCm(m)+ 1 dULRepdCm(m)/betaRe - XTEMP* 2 (dULRedCm(m)+dULRepdCm(m)/betaRe)) 3 - dULRdCm(m) ENDDO ELSE c ... derivative w.r.t. Cm's for ordinary MLR/MLJ case ... DO m= 1, NCMM(ISTATE) IPV= IPV+ 1 DVtot(IPV,I)= XTEMP*(2*dULRedCm(m)+ 1 dULRepdCm(m)/betaRe - XTEMP* 2 (dULRedCm(m)+dULRepdCm(m)/betaRe)) 3 - dULRdCm(m) ENDDO ENDIF c c ... finally, derivatives of the potential w.r.t. the \beta_i Btemp2= (Xtemp - 1.d0)*Xtemp*dAAdb0 IPV= IPV+ 1 DVtot(IPV,I)= - Btemp + Btemp2 DO J= 1,npow IPV= IPV+ 1 Btemp= Btemp*YQ Btemp2= Btemp2*yqRe DVtot(IPV,I)= - Btemp + Btemp2 ENDDO IF(npow.LT.POWmax) THEN DO J= npow+1, POWmax IPV= IPV+1 DVtot(IPV,I)= 0.0d0 ENDDO ENDIF c *** DBDRe and DBDB is used in uncertainty calculation, see fununc.f c c??? QUESTION ,,, IS the parameter count correct here ????? c DBDRe(I,ISTATE)= 0.d0 IF(RREF(ISTATE).LE.0) DBDRe(I,ISTATE)= 1.d0 DBDB(0,I,ISTATE)= 1.0d0 DO J= 1, npow DBDB(J,I,ISTATE)= DBDB(J-1,I,ISTATE)*YQ ENDDO IF(npow.LT.POWmax) THEN DO J= npow+1,POWmax DBDB(J,I,ISTATE)= 0.0d0 ENDDO ENDIF ENDDO ccccc Print for testing rewind(10) write(10,610) (RD(i,ISTATE),vpot(i,istate),betaFX(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) ccccc End of Print for testing ENDIF c....... End Double-Exponential Long-Range Potential Function ........ IF(PSEL(ISTATE).EQ.4) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the Surkus-type Generalized Potential Energy Function. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** First, we calculate the implied Dissociation Energy (if it exists) IF(AGPEF(ISTATE).NE.0.0d0) THEN YPP= 1.d0/AGPEF(ISTATE)**2 VAL= YPP DO I= 1, Nbeta(ISTATE) YPP= YPP/AGPEF(ISTATE) VAL= VAL + BETA(I,ISTATE)*YPP ENDDO DE(ISTATE)= VAL*BETA(0,ISTATE) ENDIF DO I= ISTART, ISTOP RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST RDp= RVAL**nPB(ISTATE) YP= (RDp-REp)/(AGPEF(ISTATE)*RDp + BGPEF(ISTATE)*REp) c** Now to calculate the actual potential YPP= 1.d0 VAL= 1.d0 DVAL= 2.d0 DO J= 1, Nbeta(ISTATE) YPP= YPP*YP VAL= VAL + BETA(J,ISTATE)*YPP DVAL= DVAL+ (J+2)*BETA(J,ISTATE)*YPP ENDDO VPOT(I,ISTATE)= VAL*BETA(0,ISTATE)*YP**2 + VLIM(ISTATE) IF(RDIST.GT.0) THEN VDIST= VPOT(I,ISTATE) BETADIST= 0.d0 c... branch to skip derivatives and inclusion of centrifugal & BOB terms IF(IDAT.LE.-1) GOTO 999 ENDIF DVAL= DVAL*BETA(0,ISTATE)*YP c** Now to calculate the partial derivatives DVDD= 0.d0 IPV= IPVSTART + 1 c ... derivative of the potential w.r.t. Re DVtot(IPV,I)= -DVAL*REp*RDp*(AGPEF(ISTATE)+BGPEF(ISTATE)) 1 *(nPB(ISTATE)/RE(ISTATE))/(AGPEF(ISTATE)*RDp + 2 BGPEF(ISTATE)*REp)**2 c ... and derivatives w.r.t. the beta_i expansion coefficients ... IPV= IPV+ 1 DVtot(IPV,I)= VAL*YP**2 IPV= IPV+ 1 DVtot(IPV,I)= BETA(0,ISTATE)*YP**3 DO J= 2, Nbeta(ISTATE) IPV= IPV+ 1 DVtot(IPV,I)= DVtot(IPV-1,I)*YP ENDDO ENDDO IF(RDIST.LE.0.d0) VLIM(ISTATE)= VPOT(NDATPT(ISTATE),ISTATE) c???? rewind(10) write(10,612) (RD(i,ISTATE),vpot(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) 612 FORMAT(/(f10.4,f15.5)) c???? ENDIF c.......................... End Surkus GPEF Potential Function ......... IF(PSEL(ISTATE).EQ.5) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the Tiemann 'HPP' Polynomial Potential Energy Function. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ BT= BETA(Nbeta(ISTATE)+1, ISTATE) Rinn= BETA(Nbeta(ISTATE)+2, ISTATE) Rout= BETA(Nbeta(ISTATE)+3, ISTATE) c** With long-range tail an NCMM-term inverse-power sum, adjust De and c add 1 more inverse-power term CMMp2/r**{m_{last}+2}} to ensure continuity c and smoothness at Rout XRO= (Rout - RE(ISTATE))/(Rout+ BT*RE(ISTATE)) YPP= 1.d0 VX= 0.d0 dVX= 0.d0 DO J= 1, Nbeta(ISTATE) dVX= dVX+ J*YPP*BETA(J,ISTATE) YPP= YPP*XRO VX= VX+ YPP*BETA(J,ISTATE) ENDDO dXRO= (RE(ISTATE)+ BT*RE(ISTATE))/(Rout + BT*RE(ISTATE))**2 dXRI= (RE(ISTATE)+ BT*RE(ISTATE))/(Rinn + BT*RE(ISTATE))**2 c*** dXRO= dX(r)/dr @ r=R_{out} & dXRORe= dX(r)/dr_e @ r=R_{out} dXROdRe= -dXRO*Rout/RE(ISTATE) dXRIdRe= -dXRI*Rinn/RE(ISTATE) d2XROdRe = (1.d0 + BT)*(Rout - BT*RE(ISTATE))/ 1 (Rout + BT*RE(ISTATE))**3 d2XRIdRe = (1.d0 + BT)*(Rinn - BT*RE(ISTATE))/ 1 (Rinn + BT*RE(ISTATE))**3 dVX= dVX*dXRO c VX={polynomial part V_X @ Rout} and dVX is its derivative w.r.t. r uLR= 0.d0 CMMp2= 0.d0 DO J= 1, NCMM(ISTATE) B5= CmVAL(J,ISTATE)/Rout**MMLR(J,ISTATE) uLR= uLR+ B5 CMMp2= CMMp2+ MMLR(J,ISTATE)*B5 ENDDO MMp2= MMLR(NCMM(ISTATE),ISTATE)+2 fRO= Rout**(MMp2+1)/MMp2 !! factor for derivatives CMMp2= (dVX- CMMp2/Rout)*fRO c??? zero out C5(A) for Mg2 to match KNoeckel ?? !! as per Marcel ccc IF(ISTATE.GT.1) CMMp2= 0.d0 DE(ISTATE)= uLR + VX + CMMp2/Rout**MMp2 c** CMMp2= C_{m_{last}+2}: now get the updated value of DE(ISTATE) c** now ... Determine analytic function attaching smoothly to inner wall c of polynomial expansion at R= Rinn < Rm XRI= (Rinn - RE(ISTATE))/(Rinn+ BT*RE(ISTATE)) YPP= 1.d0 B5= VLIM(ISTATE) - DE(ISTATE) A1= 0.d0 A2= 0.d0 DO J= 1, Nbeta(ISTATE) A2= A2+ J*YPP*BETA(J,ISTATE) YPP= YPP*XRI A1= A1+ YPP*BETA(J,ISTATE) ENDDO A2= A2*dXRI !! dXRI= dX(r)/dr @ r=R_{inn} A2= -A2/A1 c** Extrapolate inwardly with the exponential: B5 + A1*exp(-A2*(R-Rinn)) c... but first collect some common factors for the derivatives dCmp2dRe= 0.d0 dDeROdRe= 0.d0 dDeRIdRe= 0.d0 XROpw= 1.d0/XRO**2 XRIpw= 1.d0/(A1*XRI**2) ROmp2= 1.d0/Rout**MMp2 BIrat= A2/A1 DO J=1, Nbeta(ISTATE) c... first ... outer boundary factors & derivatives w.r.t. beta_i dCmp2dRe= dCmp2dRe + J*(J-1)*BETA(J,ISTATE)*XROpw XROpw= XROpw*XRO !! power now (J-1) dDeROdRe= dDeROdRe + J*BETA(J,ISTATE)*XROpw dCmp2(J)= J*XROpw*dXRO*fRO dDe(J)= XROpw*XRO + ROmp2*dCmp2(J) !! uses power J c... then ... inner boundary factors & derivatives w.r.t. beta_i dBIdRe= dBIdRe + J*(J-1)*BETA(J,ISTATE)*XRIpw XRIpw= XRIpw*XRI !! power now (J-1) dDeRIdRe= dDeRIdRe + J*BETA(J,ISTATE)*XRIpw dAI(J)= XRIpw*XRI - dDe(J) !! add term with power J dBI(J)= J*XRIpw*dXRI - BIrat*dAI(J) ENDDO dCmp2dRe= (dDeROdRe*d2XROdRe + dCmp2dRe*dXRO*dXROdRe)*fRO dDedRe= dDeROdRe*dXROdRe + ROmp2*dCmp2dRe dAIdRe= -dDeDRe + dDeRIdRe*A1*dXRI dBIdRe= - dDeRIdRe*d2XRIdRe- dBIdRe*dXRI*dXRIdRe- BIrat*dAIdRe DO I= ISTART, ISTOP c*** Now ... loop to generate the potential ... RVAL= RD(I,ISTATE) IF(RDIST.GT.0) RVAL= RDIST YP= (RVAL - RE(ISTATE))/(RVAL + BT*RE(ISTATE)) IF(RVAL.LE.Rinn) THEN c ... for exponential inward extrapolation2 ... EXPBI= DEXP(-A2*(RVAL- Rinn)) VPOT(I,ISTATE)= B5 + A1*EXPBI IPV= IPVSTART+ 1 !! count for Re, NOT for De DO J=1, NCMM(ISTATE) IPV= IPV+1 !! count for derivatives w.r.t. Cm's DVtot(IPV,I)= 0.d0 ENDDO DO J=1, Nbeta(ISTATE) IPV= IPV+ 1 !! counter for \beta_i DVtot(IPV,I)= - dDe(J) + EXPBI*(dAI(J) 1 - A1*(RVAL- Rinn)*dBI(J)) ENDDO DVTOT(IPVSTART+1,I)= -dDe(J) + EXPBI*(dAIdRe 1 - A1*dBIdRe*(RVAL- Rinn)) ELSEIF(RVAL.LE.Rout) THEN c ... for 'middle' well region X-polynomial power series ... IPV= IPVSTART+ 1 !! count for Re, NOT for De DO J=1, NCMM(ISTATE) IPV= IPV+1 !! for derivatives w.r.t. Cm's DVtot(IPV,I)= 0.d0 ENDDO VX= VLIM(ISTATE) - DE(ISTATE) dVdRe= 0.d0 YPOW= 1.d0 cc IF(DABS(YP).GT.0.d0) YPOW= 1.d0/YP !! if start @ J=0 DO J=1, Nbeta(ISTATE) IPV= IPV+ 1 !! counter for \beta_i dVdRe= dVdRe + J*BETA(J,ISTATE)*YPOW !! YPOW= YPOW* YP !! brings power up to J DVTOT(IPV,I)= -dDe(J) + YPOW VX= VX + BETA(J,ISTATE)*YPOW ENDDO VPOT(I,ISTATE)= VX DVTOT(IPVSTART+1,I)= - dDedRe - dVdRe*RVAL*(BT+1.d0) 1 /(RVAL + BT*RE(ISTATE))**2 ELSEIF(RVAL.GT.Rout) THEN c ... for Van der Waals tail region with added inverse-power term IPV= IPVSTART+ 1 !! count for Re, NOT for De A3= VLIM(ISTATE) DO J= 1, NCMM(ISTATE) IPV= IPV+1 !! for derivatives w.r.t. Cm's DVtot(IPV,I)= 0.d0 A3= A3- CmVAL(J,ISTATE)/RVAL**MMLR(J,ISTATE) ENDDO RMMp2= 1.d0/RVAL**MMp2 VPOT(I,ISTATE)= A3 - CMMp2*RMMp2 DO J=0, Nbeta(ISTATE) IPV= IPV+ 1 !! counter for \beta_i DVTOT(IPV,I)= -dCmp2(J)*RMMp2 ENDDO DVTOT(IPVSTART+1,I)= -dCmp2dRe*RMMp2 ENDIF ENDDO ** end of loop over distance array IF(RDIST.GT.0) THEN VDIST= VPOT(I,ISTATE) BETADIST= 0.d0 c... branch to skip derivatives and inclusion of centrifugal & BOB terms IF(IDAT.LE.-1) GOTO 999 ENDIF rewind(10) write(10,612) (RD(i,ISTATE),vpot(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) FLUSH(10) ENDIF c........... End Tiemann Potential Energy Function ................. IF(PSEL(ISTATE).EQ.6) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the generalized TANG-Toennies-type potential with 4-term exponent c & 5-term pre-exponential factor minus and damped (s=+1) repulsion terms c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c ... first ... save uLR powers in a 1D array DO m= 1, NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) ENDDO rhoINT= rhoAB(ISTATE)/3.13d0 !! remove btt(IVSR(ISTATE)/2) c** Now, calculate A and De using the input values of b and r_e REQQ= RE(ISTATE) RVAL= RDIST DO I= ISTART, ISTOP IF(RDIST.LE.0.d0) RVAL= RD(I,ISTATE) T0= RVAL*(BETA(1,ISTATE) + RVAL*(BETA(2,ISTATE))) 1 + (BETA(3,ISTATE) + BETA(4,ISTATE)/RVAL)/RVAL ATT= (BETA(5,ISTATE) + RVAL*(BETA(6,ISTATE) + RVAL* 1 (BETA(8,ISTATE) + RVAL*BETA(9,ISTATE)))) 2 + BETA(7,ISTATE)/RVAL CALL dampF(RVAL,rhoINT,NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) VATT= 0.d0 DO M= 1,NCMM(ISTATE) VATT= VATT+ CmVAL(m,ISTATE)*Dm(m)/RVAL**MMLR1D(m) ENDDO VPOT(I,ISTATE)= ATT*EXP(-T0)- VATT c!! Special insert for Shen-Tang Be2 PRA 88, 011517 (2013) c VPOT(I,ISTATE)= VPOT(I,ISTATE) - 9.486575760D+05 c 1 *DEXP(-RVAL*(1.113237666d0+ RVAL*0.2764004206d0)) c write(32,832) RVAL, Vatt, VPOT(I,ISTATE) c 832 Format(F8.3, 2F10.3) IF(VPOT(I,ISTATE).LT.VMIN) THEN VMIN= VPOT(I,ISTATE) REQQ= RVAL ENDIF ENDDO IF(RDIST.GT.0.d0) THEN VDIST= VPOT(ISTOP,ISTATE) BETADIST= 0.d0 ENDIF IF(ISTOP.GT.ISTART) WRITE(6,602) VMIN,REQQ 602 FORMAT(' Extended TT potential has VMIN=',f9.4,' at RMIN=' 1 f8.5) c...... Print for testing rewind(10) write(10,612) (RD(i,ISTATE),vpot(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) FLUSH(10) ENDIF c........... End Tang-Toennies Potential Energy Function ................. IF(PSEL(ISTATE).EQ.7) THEN IF(Nbeta(ISTATE).EQ.5) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the Aziz'ian HFD-ABC potential c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ A1= BETA(1,ISTATE) A2= BETA(2,ISTATE) A3= BETA(3,ISTATE) X= RDIST DO I= ISTART, ISTOP IF(RDIST.LE.0.d0) X= RD(I,ISTATE) VATT= 0.d0 DO M= 1,NCMM(ISTATE) VATT= VATT+ CmVAL(m,ISTATE)/X**MMLR(m,ISTATE) ENDDO IF(X.LT.A2) VATT= VATT*DEXP(-A1*(A2/X -1.d0)**A3) VPOT(I,ISTATE)= AA(ISTATE)* 1 (X/RE(ISTATE))**BETA(5,ISTATE) 1 *EXP(-X*(BB(ISTATE) + X*BETA(4,ISTATE))) - VATT ENDDO IF(RDIST.GT.0.d0) THEN VDIST= VPOT(ISTOP,ISTATE) BETADIST= 0.d0 ENDIF ELSEIF(Nbeta(ISTATE).EQ.2) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** For the Aziz'ian HFD-D potential c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c ... first ... save uLR powers in a 1D array DO m= 1, NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) ENDDO X= RDIST DO I= ISTART, ISTOP IF(RDIST.LE.0.d0) X= RD(I,ISTATE) CALL dampF(X,rhoAB(ISTATE),NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) VATT= 0.d0 DO M= 1,NCMM(ISTATE) VATT= VATT+ CmVAL(m,ISTATE)*Dm(m)/X**MMLR1D(m) ENDDO VATT= VATT*(1 - (rhoAB(ISTATE)*X/bohr)**1.68d0 1 *DEXP(-0.78d0*rhoAB(ISTATE)*X/bohr)) VPOT(I,ISTATE)= AA(ISTATE)* 1 (X/RE(ISTATE))**BETA(2,ISTATE) 1 *EXP(-X*(BB(ISTATE) + X*BETA(1,ISTATE))) - VATT ENDDO IF(RDIST.GT.0.d0) THEN VDIST= VPOT(ISTOP,ISTATE) BETADIST= 0.d0 ENDIF ENDIF c...... Print for testing rewind(10) write(10,612) (RD(i,ISTATE),vpot(i,istate), 1 i= 1, NDATPT(ISTATE),OSEL(ISTATE)) FLUSH(10) ENDIF c........... End Aziz'ian HFD-ABC & D Potential Energy Function ........ 700 IF((IDAT.LE.0).AND.(RDIST.GT.0)) GOTO 999 IF((NUA(ISTATE).GE.0).OR.(NUB(ISTATE).GT.0)) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Treat any 'adiabatic' BOB radial potential functions here ... c u_A(r) = yp*uA_\infty + [1 - yp]\sum_{i=0,NUA} {uA_i yq^i} c where the u_\infty values stored/fitted as UA(NUA(ISTATE)) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ HReP= 0.5d0*pAD(ISTATE)/RE(ISTATE) HReQ= 0.5d0*qAD(ISTATE)/RE(ISTATE) REadAp= RE(ISTATE)**pAD(ISTATE) REadAq= RE(ISTATE)**qAD(ISTATE) REadBp= RE(ISTATE)**pAD(ISTATE) REadBq= RE(ISTATE)**qAD(ISTATE) IF((BOBCN(ISTATE).GE.1).AND.(pAD(ISTATE).EQ.0)) THEN HReP= 2.d0*HReP HReQ= 2.d0*HReQ ENDIF c ... reset parameter counter ... IPVSTART= IPV DO I= ISTART,ISTOP RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST RDp= RVAL**pAD(ISTATE) RDq= RVAL**qAD(ISTATE) YPA= (RDp - REadAp)/(RDp + REadAp) YQA= (RDq - REadAq)/(RDq + REadAq) YPB= (RDp - REadBp)/(RDp + REadBp) YQB= (RDq - REadBq)/(RDq + REadBq) YPMA= 1.d0 - YPA YPMB= 1.d0 - YPB IF(BOBCN(ISTATE).GE.1) THEN c** If BOBCN > 0 & p= 1, assume use of Ogilvie-Tipping vble. IF(pAD(ISTATE).EQ.1) THEN YPA= 2.d0*YPA YPB= 2.d0*YPB ENDIF ENDIF IF(NUA(ISTATE).GE.0) THEN c ... Now ... derivatives of UA w.r.t. expansion coefficients VAL= UA(0,ISTATE) DVAL= 0.d0 IPV= IPVSTART + 1 DVtot(IPV,I)= YPMA YQP= 1.d0 IF(NUA(ISTATE).GE.2) THEN DO J= 1,NUA(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQP*UA(J,ISTATE) YQP= YQP*YQA VAL= VAL+ UA(J,ISTATE)*YQP IPV= IPV+ 1 DVtot(IPV,I)= YPMA*YQP ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YPA IF(LRad(ISTATE).EQ.0) THEN UAR(I,ISTATE)= VAL*YPMA + 1 YPA*UA(NUA(ISTATE),ISTATE) ELSE !! Add up the \delta{Cm} terms dCmASUM = UA(NUA(ISTATE),ISTATE) DO m= 1,NCMM(ISTATE) dCmASUM = dCmASUM + 1 dCmA(m,ISTATE)/(RVAL**MMLR(m,ISTATE)) ENDDO UAR(I,ISTATE)= VAL*YPMA + YPA*dCmASUM ENDIF DUADRe(I,ISTATE)= 0.d0 c ... and derivative of UA w.r.t. Re ... DUADRe(I,ISTATE)= -HReQ*(1.d0 - YQA**2)*YPMA*DVAL 1 + HReP*(1.d0 - YPA**2)*(VAL- UA(NUA(ISTATE),ISTATE)) ENDIF IF(NUB(ISTATE).GE.0) THEN c ... Now ... derivatives of UB w.r.t. expansion coefficients VAL= UB(0,ISTATE) DVAL= 0.d0 IF(NUA(ISTATE).LT.0) THEN IPV= IPVSTART + 1 ELSE IPV= IPV + 1 ENDIF DVtot(IPV,I)= YPMB YQP= 1.d0 IF(NUB(ISTATE).GE.2) THEN DO J= 1,NUB(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQP*UB(J,ISTATE) YQP= YQP*YQB VAL= VAL+ UB(J,ISTATE)*YQP IPV= IPV + 1 DVtot(IPV,I)= YPMB*YQP ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YPB IF(LRad(ISTATE).EQ.0) THEN !! NO \delta{Cm} terms UBR(I,ISTATE)= VAL*YPMB + 1 YPB*UB(NUB(ISTATE),ISTATE) ELSE !! Add up the \delta{Cm} terms dCmBSUM = UA(NUB(ISTATE),ISTATE) DO m= 1,NCMM(ISTATE) dCmBSUM = dCmBSUM + 1 dCmB(m,ISTATE)/(RVAL**MMLR(m,ISTATE)) ENDDO UBR(I,ISTATE)= VAL*YPMB + YPB*dCmBSUM ENDIF DUBDRe(I,ISTATE)= 0.d0 c ... and derivative of UB w.r.t. Re ... DUBDRe(I,ISTATE)= -HReQ*(1.d0 - YQB**2)*YPMB*DVAL 1 + HReP*(1.d0 - YPB**2)*(VAL- UB(NUB(ISTATE),ISTATE)) ENDIF ENDDO ENDIF c++++ END of treatment of adiabatic potential BOB function++++++++++++++ IF((NTA(ISTATE).GE.0).OR.(NTB(ISTATE).GE.0)) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Treat any 'non-adiabatic' centrifugal BOB functions here ... c q_A(r) = yp*qA_\infty + [1 - yp]\sum_{i=0,NTA} {qA_i yq^i} c where the q_\infty values stored/fitted as TA(NTA(ISTATE)) c Incorporate the 1/r^2 factor into the partial derivatives (but not in c the g(r) functions themselves, since pre-SCHRQ takes care of that). c Need to add M_A^{(1)}/M_A^{(\alpha)} factor later too c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ HReP= 0.5d0*pNA(ISTATE)/RE(ISTATE) HReQ= 0.5d0*qNA(ISTATE)/RE(ISTATE) REnaAp= Re(ISTATE)**pNA(ISTATE) REnaAq= Re(ISTATE)**qNA(ISTATE) REnaBp= Re(ISTATE)**pNA(ISTATE) REnaBq= Re(ISTATE)**qNA(ISTATE) IF((BOBCN(ISTATE).GE.1).AND.(pNA(ISTATE).EQ.0)) THEN HReP= 2.d0*HReP HReQ= 2.d0*HReQ ENDIF IPVSTART= IPV DO I= ISTART,ISTOP RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST RM2= 1/RVAL**2 RDp= RVAL**pNA(ISTATE) RDq= RVAL**qNA(ISTATE) YPA= (RDp - REnaAp)/(RDp + REnaAp) YQA= (RDq - REnaAq)/(RDq + REnaAq) YPB= (RDp - REnaBp)/(RDp + REnaBp) YQB= (RDq - REnaBq)/(RDq + REnaBq) YPMA= 1.d0 - YPA YPMB= 1.d0 - YPB IF(BOBCN(ISTATE).GE.1) THEN c** If BOBCN > 0 & p= 1, assume use of Ogilvie-Tipping vble. YPMA= 1.d0 YPA= 2.d0*YPA ENDIF IF(NTA(ISTATE).GE.0) THEN c ... Now ... derivatives of R_{na}(A) w,r,t, expansion coefficients VAL= TA(0,ISTATE) DVAL= 0.d0 IPV= IPVSTART + 1 DVtot(IPV,I)= YPMA*RM2 !! deriv. w.r.t. t_0 YQP= 1.d0 IF(NTA(ISTATE).GE.2) THEN DO J= 1,NTA(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQP*TA(J,ISTATE) YQP= YQP*YQA VAL= VAL+ TA(J,ISTATE)*YQP IPV= IPV + 1 DVtot(IPV,I)= YPMA*YQP*RM2 ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YPA*RM2 !! deriv w.r.r. t_{\inf} TAR(I,ISTATE)= VAL*YPMA + YPA*TA(NTA(ISTATE),ISTATE) c ... and derivative of R_{na}(A) w.r.t. Re ... DTADRe(I,ISTATE)= (-HReQ*(1.d0 - YQA**2)*YPMA*DVAL 1 + HReP*(1.d0 - YPA**2)*(VAL- TA(NTA(ISTATE),ISTATE)))*RM2 c!!! temorary test printing !!!!!n!!!!!! cc write(14,699) RVAL,TAR(I,ISTATE),(DVtot(J,I), cc 1 J=IPVSTART+1,IPV) cc699 FORMAT(f9.4,1P,10D15.7) c!!! temorary test printing !!!!!!!!!!! c!!!!!!!!!!!!!! incomplete -how is IPVSTART initialized for NUA, NUB, NTA, NTB ENDIF IF(NTB(ISTATE).GE.0) THEN c ... Now ... derivatives of TB w.r.t. expansion coefficients VAL= TB(0,ISTATE) DVAL= 0.d0 IF(NTA(ISTATE).LT.0) THEN IPV= IPVSTART + 1 ELSE IPV= IPV + 1 ENDIF DVtot(IPV,I)= YPMB*RM2 YQP= 1.d0 IF(NTB(ISTATE).GE.2) THEN DO J= 1,NTB(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQP*TB(J,ISTATE) YQP= YQP*YQB VAL= VAL+ TB(J,ISTATE)*YQP IPV= IPV + 1 DVtot(IPV,I)= YPMB*YQP*RM2 ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YPB*RM2 TBR(I,ISTATE)= VAL*YPMB + YPB*TB(NTB(ISTATE),ISTATE) c ... and derivative of TA w.r.t. Re ... DTBDRe(I,ISTATE)= (-HReQ*(1.d0 - YQB**2)*YPMB*DVAL 1 + HReP*(1.d0 - YPB**2)*(VAL- TB(NTB(ISTATE),ISTATE)))*RM2 ENDIF c!!! temorary test printing !!!!!!!!!!! c!! write(15,699) RVAL,TAR(I,ISTATE),(DVtot(J,I), c!! 1 J=IPVSTART+1,IPV) c!!! temorary test printing !!!!!!!!!!! ENDDO ENDIF c.... END of treatment of non-adiabatic centrifugal BOB function........ IF(NwCFT(ISTATE).GE.0) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Treat any Lambda- or 2\Sigma-doubling radial strength functions here c representing it as f(r)= Sum{ w_i * y_{Pqw}^i} c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ LAMB2= 2*IOMEG(ISTATE) HReP= 0.5d0*Pqw(ISTATE)/RE(ISTATE) REwp= RE(ISTATE)**Pqw(ISTATE) IPVSTART= IPV DO I= ISTART,ISTOP RVAL= RD(I,ISTATE) IF(RDIST.GT.0.d0) RVAL= RDIST RMF= 1.d0/RVAL**2 IF(IOMEG(ISTATE).GT.0) RMF= RMF**LAMB2 RDp= RVAL**Pqw(ISTATE) YP= (RDp - REwp)/(RDp + REwp) DVAL= 0.d0 YQP= RMF VAL= wCFT(0,ISTATE)*YQP IPV= IPVSTART + 1 DVtot(IPV,I)= YQP IF(NwCFT(ISTATE).GE.1) THEN DO J= 1,NwCFT(ISTATE) DVAL= DVAL+ DBLE(J)*YQP*wCFT(J,ISTATE) YQP= YQP*YP IPV= IPV + 1 DVtot(IPV,I)= YQP VAL= VAL+ wCFT(J,ISTATE)*YQP ENDDO ENDIF wRAD(I,ISTATE)= VAL dLDDRe(I,NSTATEMX)= -HReP*(1.d0 - YP**2)*DVAL ENDDO ENDIF c.... END of treatment of Lambda/2-Sigma centrifugal BOB function....... c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++++ Test for inner wall inflection , and if it occurs, replace inward c++++ potential with linear approximation +++++++ IF(PSEL(ISTATE).NE.5) REQQ= RE(ISTATE) c!!!! temporary fix to handle Sheng/Tang Be2 case I1= (REQQ -RD(1,ISTATE))/(RD(2,ISTATE)-RD(1,ISTATE)) IF((I1.GT.3).AND.(RDIST.LE.0)) THEN !! skip check on 1-point CALLs NIFL=0 !! NIFL is No. (+) to (-) curv. inflection points @ R < Re SLB= +1.d0 SL= 0.d0 DO I= I1-2, 1, -1 SLBB= SLB SLB= SL SL= VPOT(I,ISTATE) - VPOT(I+1,ISTATE) IF((SL.LE.SLB).AND.(SLB.GE.SLBB)) THEN NIFL= NIFL+ 1 WRITE(6,606) SLABL(ISTATE),RD(I,ISTATE),VPOT(I,ISTATE) IF(NIFL.LE.MAXMIN(ISTATE)) THEN !? prob if inner well deeper IF(VPOT(I,ISTATE).GE.VLIM(ISTATE)) THEN DO J= I,1,-1 !! Only for wall above VLIM VPOT(J,ISTATE)= VPOT(I,ISTATE) + (I-J)*SL ENDDO WRITE(6,608) GOTO 66 ENDIF ENDIF ENDIF ENDDO ENDIF 66 CONTINUE 606 FORMAT(12('===')/'!*!* Find State ',A3,' inner-wall inflection at 1 R=', f6.4,' V=',f11.1 '..... !*!*') 608 FORMAT(5x,'... and ... extrapolate repulsive wall inward from the 1re as a LINEAR function'/12('===')) c++++++++++++End of Inner Wall Test/Correction code+++++++++++++++++++++ c====================================================================== c** For simulation & fitting of tunneling width data ...... c** At the one distance RDIST calculate total effective potential VDIST c including (!!) centrifugal and Lambda/2Sigma doubling terms, and c get their partial derivatives w.r.t. Hamiltonian parameters dVdPk. c IF((RDIST.GT.0).AND.(IDAT.GT.0).AND.(IDAT.LT.NDATAMX)) THEN IISTP= ISTP(IB(IDAT)) cccccccc c WRITE (40,644) IISTP,RDIST,RVAL,VDIST,I,NDATPT(ISTATE) c 644 FORMAT ('IISTP =',I3,' RDIST =',G16.8,' RVAL =',G16.8, c & ' VDIST =',G16.8,' I =',I6,' NDATPT =',I6) cccccccc BFCT= 16.857629206d0/(ZMASS(3,IISTP)*RDIST**2) JFCT= DBLE(JPP(IDAT)*(JPP(IDAT)+1)) IF(IOMEG(ISTATE).GT.0) JFCT= JFCT - IOMEG(ISTATE)**2 IF(IOMEG(ISTATE).EQ.-2) JFCT= JFCT + 2.D0 JFCT= JFCT*BFCT c ... First get total effective potential, including BOB terms VDIST= VDIST + JFCT IF(NUA(ISTATE).GE.0) VDIST= VDIST 1 + ZMUA(IISTP,ISTATE)*UAR(ISTOP,ISTATE) IF(NUB(ISTATE).GE.0) VDIST= VDIST 1 + ZMUB(IISTP,ISTATE)*UBR(ISTOP,ISTATE) IF(NTA(ISTATE).GE.0) VDIST= VDIST 1 + JFCT*ZMTA(IISTP,ISTATE)*TAR(ISTOP,ISTATE) IF(NTB(ISTATE).GE.0) VDIST= VDIST 1 + JFCT*ZMTB(IISTP,ISTATE)*TBR(ISTOP,ISTATE) JFCTLD= 0.d0 IF(IOMEG(ISTATE).NE.0) THEN IF(IOMEG(ISTATE).GT.0) THEN c ... for Lambda doubling case ... JFCTLD= (EFPP(IDAT)-EFREF(ISTATE)) 1 *(DBLE(JPP(IDAT)*(JPP(IDAT)+1))*BFCT**2)**IOMEG(ISTATE) ENDIF IF(IOMEG(ISTATE).EQ.-1) THEN c ... for doublet Sigma doubling case ... IF(EFPP(IDAT).GT.0) JFCTLD= 0.5d0*JPP(IDAT)*BFCT IF(EFPP(IDAT).EQ.0) JFCTLD= 0.d0 IF(EFPP(IDAT).LT.0) JFCTLD= -0.5d0*(JPP(IDAT)+1)*BFCT ENDIF VDIST= VDIST + JFCTLD* WRAD(ISTOP,ISTATE) ENDIF cccccccc c WRITE (40,648) JPP(IDAT),EFPP(IDAT),RDIST,VDIST c 648 FORMAT ('J =',I3,' efPARITY =',I3,' RDIST =',G16.8,' VDIST =', c 1 G16.8/) cccccccc IF(PSEL(ISTATE).GT.0) THEN DO IPV= 1,TOTPOTPAR dVdPk(IPV)= 0.d0 ENDDO c** Now ... generate requisite partial derivatives. DO IPV= POTPARI(ISTATE),POTPARF(ISTATE) dVdPk(IPV)= DVtot(IPV,ISTOP) ENDDO IF(NUA(ISTATE).GE.0) THEN DO IPV= UAPARI(ISTATE),UAPARF(ISTATE) dVdPk(IPV)= ZMUA(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NUB(ISTATE).GE.0) THEN DO IPV= UBPARI(ISTATE),UBPARF(ISTATE) dVdPk(IPV)= ZMUB(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NTA(ISTATE).GE.0) THEN DO IPV= TAPARI(ISTATE),TAPARF(ISTATE) dVdPk(IPV)=JFCT*ZMTA(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NTB(ISTATE).GE.0) THEN DO IPV= TBPARI(ISTATE),TBPARF(ISTATE) dVdPk(IPV)=JFCT*ZMTB(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NwCFT(ISTATE).GE.0) THEN DO IPV= LDPARI(ISTATE),LDPARF(ISTATE) dVdPk(IPV)= JFCTLD*DVtot(IPV,ISTOP) ENDDO ENDIF ENDIF ENDIF c*****7********************** BLOCK END ******************************72 999 RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c=========================================================================== SUBROUTINE quadCORR(NCMM,MCMM,NCMMAX,MMLR,De,CmVAL,CmEFF) c=========================================================================== c** subroutine to generate and print MLR CmEFF values incorporating c quadratic 'Dattani' corrections to Cm values for both standard 'linear' c and A-F diagonalized uLR(r) functions for MLR potentials c** Return MCMM= NCMM+1 for C9{adj} term for m_1= 3 potentials c=========================================================================== INTEGER NCMM,MCMM,NCMMAX,MMLR(NCMMAX) REAL*8 De,CmVAL(NCMMAX),CmEFF(NCMMAX) c---------------------------------------------------------------------- IF(MMLR(1).GT.0) THEN c** For 'normal' inverse-power sum MLR case, with or without damping, c set up Dattani's 'Quadratic-corrected' effective Cm values IF((MMLR(1).EQ.6).AND.(NCMM.GE.4)) THEN c... First, consider C6/C12adj(C14adj) for MMLR(m)={6,8,10,(11),12,14} case IF(MMLR(4).EQ.12) THEN ! explicitly MMLR(4)=12 CmEFF(4)= CmVAL(4)+ 0.25D0*CmVAL(1)**2/De WRITE(6,710) MMLR(4),MMLR(4),CmEFF(4) ENDIF IF(NCMM.GE.5) THEN IF(MMLR(4).EQ.11) THEN ! implicitly MMLR(5)=12 CmEFF(5)= CmVAL(5) + 0.25D0*CmVAL(1)**2/De WRITE(6,710) MMLR(5),MMLR(5),CmEFF(5) IF(NCMM.GE.6) THEN ! implicitly MMLR(6)=14 CmEFF(6)= CmVAL(6)+ 0.5D0*CmVAL(1)*CmVAL(2)/De WRITE(6,710) MMLR(6),MMLR(6),CmEFF(6) ENDIF ENDIF IF(MMLR(4).EQ.12) THEN ! assuming MMLR(5)=14 CmEFF(5)= CmVAL(5) + 0.5D0*CmVAL(1)*CmVAL(2)/De WRITE(6,710) MMLR(5),MMLR(5),CmEFF(5) ENDIF ENDIF ENDIF IF((MMLR(1).EQ.5).AND.(NCMM.GE.4)) THEN c... Then, consider C5/C10adj + C12adj for MMLR(m)={5,6,8,10,12,14} cases CmEFF(4)= CmVAL(4) + 0.25D0*CmVAL(1)**2/De WRITE(6,710) MMLR(4),MMLR(4),CmEFF(4) IF(NCMM.GE.5) THEN ! introduce C12^{adj} CmEFF(5)= CmVAL(5) + 0.25D0*CmVAL(2)**2/De WRITE(6,710) MMLR(5),MMLR(5),CmEFF(5) IF(NCMM.GE.6) THEN ! introduce C14^{adj} CmEFF(6)= CmVAL(6) + 0.5D0*CmVAL(2)*CmVAL(3)/De WRITE(6,710) MMLR(6),MMLR(6),CmEFF(6) ENDIF ENDIF ENDIF IF((MMLR(1).EQ.4).AND.(NCMM.GE.3).and.(MMLR(3).EQ.8)) THEN c... Then, consider C4/C8adj + C12adj for MMLR(m)={4,6,8,10,12,14} cases CmEFF(3)= CmVAL(3) + 0.25D0*CmVAL(1)**2/De WRITE(6,712) MMLR(3),MMLR(3),CmEFF(3) IF(NCMM.GE.4) THEN ! implicitly MMLR(4)=10 CmEFF(4)= CmVAL(4) + 0.5D0*CmVAL(1)*CmVAL(2)/De WRITE(6,710) MMLR(4),MMLR(4),CmEFF(4) IF(NCMM.GE.5) THEN ! implicitly MMLR(5)=12 CmEFF(5)= CmVAL(5) + 0.5D0*CmVAL(1)*CmVAL(3)/De 1 + 0.25D0*CmVAL(2)**2/De WRITE(6,710) MMLR(5),MMLR(5),CmEFF(5) IF(NCMM.GE.6) THEN ! implicitly MMLR(6)=14 CmEFF(6)= CmVAL(6)+ 0.5D0*CmVAL(2)*CmVAL(3)/De 1 + 0.5D0*CmVAL(1)*CmVAL(4)/De WRITE(6,710) MMLR(6),MMLR(6),CmEFF(6) ENDIF ENDIF ENDIF ENDIF !! consider no further adjustment IF((MMLR(1).EQ.4).AND.(NCMM.GE.4).and.(MMLR(4).EQ.8)) THEN c... Then, consider C4/C8adj + C12adj for MMLR(m)={4,6,7,8} cases CmEFF(4)= CmVAL(4) + 0.25D0*CmVAL(1)**2/De WRITE(6,712) MMLR(4),MMLR(4),CmEFF(4) ENDIF IF((MMLR(1).EQ.3).AND.(NCMM.GE.2)) THEN c... Then, consider C3/C6adj + C9adj for MMLR(m)={3,6,8,(9),10,12,14} cases CmEFF(2)= CmVAL(2) + 0.25D0*CmVAL(1)**2/De WRITE(6,712) MMLR(2),MMLR(2),CmEFF(2) IF(NCMM.GE.3) THEN ! introduce C9adj & MMLR=9 MCMM= NCMM + 1 MMLR(MCMM)= 9 CmEFF(MCMM)= 0.5d0*CmVAL(1)*CmEFF(2)/De WRITE(6,714) MMLR(MCMM),CmEFF(MCMM) IF(NCMM.GE.5) THEN ! implicitly MMLR(5)=12 CmEFF(5)= CmVAL(5) + 0.5D0*CmVAL(1)*CmEFF(MCMM)/De 1 + 0.25D0*CmEFF(2)**2/De WRITE(6,710) MMLR(5),MMLR(5),CmEFF(5) IF(NCMM.GE.6) THEN ! implicitly MMLR(6)=14 CmEFF(6)= CmVAL(6)+ 0.5D0*CmEFF(2)*CmVAL(3)/De WRITE(6,710) MMLR(6),MMLR(6),CmEFF(6) ENDIF ENDIF ENDIF ENDIF ENDIF c======================================================================= c c** End of CmEFF= Cm + CmADJ setup for non-AF case =================== 710 Format(" 'Quadratic correction' for C",I2,'(MLR) yields', 1 6x,'C',I2,'{adj}=',1PD15.8) 712 Format(" 'Quadratic correction' for C",I1,'(MLR) yields', 1 7x,'C'I1,'{adj}=',1PD15.8) 714 Format(" 'Quadratic corrn' for MLR(m_1=3) introduces C", 1 I1,'(',A4,',adj) =',1PD15.8) 716 Format(" 'Quadratic correction' for C",I1,'(Sigma) yields C', 1 I1,'(Sigma,adj)=',1PD15.8) 718 Format(" 'Quadratic correction' for C",I1,'(^3Pi) yields C', 1 I1,'(^3Pi,adj) =',1PD15.8) 720 Format(" 'Quadratic correction' for C",I1,'(^1Pi) yields C', 1 I1,'(^1Pi,adj) =',1PD15.8) c========================================================================= IF(MMLR(1).LE.0) THEN c** implement Quadratic 'Dattani' MLR corrections for AF cases IF(MMLR(1).GE.-1) THEN !! first for the 2x2 cases ... CmEFF(4)= CmVAL(4) + 0.25*CmVAL(2)**2/De CmEFF(5)= CmVAL(5) + 0.25*CmVAL(3)**2/De WRITE(6,716) MMLR(4),MMLR(4),CmEFF(4) WRITE(6,718) MMLR(5),MMLR(5),CmEFF(5) c* prepare C9{adj} coefficients for addition to chosen root MMLR(8)= 9 !! These terms added just MMLR(9)= 9 !! before exit from AFdiag Cmeff(8)= 0.5*CmVAL(2)*CmEFF(4)/De WRITE(6,714) MMLR(8),'Sigm',CmEFF(8) Cmeff(9)= 0.5*CmVAL(3)*CmEFF(5)/De WRITE(6,714) MMLR(9),'^3Pi',CmEFF(9) ENDIF IF(MMLR(1).LE.-2) THEN !! now for the 3x3 cases ... CmEFF(5)= CmVAL(5) + 0.25*CmVAL(2)**2/De WRITE(6,716) MMLR(5),MMLR(5),CmEFF(5) CmEFF(6)= CmVAL(6) + 0.25*CmVAL(3)**2/De WRITE(6,720) MMLR(6),MMLR(6),CmEFF(6) CmEFF(7)= CmVAL(7) + 0.25*CmVAL(4)**2/De WRITE(6,718) MMLR(7),MMLR(7),CmEFF(7) c* prepare C9{adj} coefficients for addition to chosen root MMLR(11)= 9 !! These terms added just MMLR(12)= 9 !! before exit from AFdiag MMLR(13)= 9 Cmeff(11)= 0.5*CmVAL(2)*CmEFF(5)/De IF(MMLR(1).EQ.-2) WRITE(6,714) MMLR(11),'Sigm',CmEFF(11) Cmeff(12)= 0.5*CmVAL(3)*CmEFF(6)/De IF(MMLR(1).EQ.-3) WRITE(6,714) MMLR(12),'^3Pi',CmEFF(12) Cmeff(13)= 0.5*CmVAL(4)*CmEFF(7)/De IF(MMLR(1).EQ.-4) WRITE(6,714) MMLR(13),'^1Pi',CmEFF(13) ENDIF ENDIF RETURN END c23456789012345678901234567890123456789012345678901234567890123456789012 c*********************************************************************** SUBROUTINE dampF(r,rhoAB,NCMM,NCMMAX,MMLR,sVRS2,IDSTT,DM,DMP,DMPP) c** Subroutine to generate values 'Dm' and its first `Dmp' and second c 'Dmpp' derivatives w.r.t. r of the chosen form of the damping c function, for m= 1 to MMAX. c---------------------- RJL Version of 21 April 2016 ------------------- c----------------------------------------------------------------------- c Upon Input c* r - the radial distance in Angsroms (!) c* RHOab 'universal' scaling coefficient used for systems other than H_2 c RHOab= 2*(RHOa*RHOb)/(RHOa+RHOb) where RHOa = (I_p^A/I_p^H)^0.66 c where I_p^A is the ionization potential of atom A c and I_p^H is the ionization potential of atomic hydrogen c* NCMM the number of inverse-power terms to be considered c* MMLR are the powers of the NCMM inverse-power terms c* sVRS2 defines damping s.th. Dm(r)/r^m --> r^{sVRS2/2} as r --> 0 c* IDSTT specifies damping function type: > 0 use Douketis et al. form c if IDSTT .LE. 0 use Tang-Toennies form c----------------------------------------------------------------------- c Upon Output c DM(m) - The value of the damping function for the long range term c C_MMLR(m)/r^MMLR(m) {m= 1, NCMM} c DMP(m): 1'st derivative w.r.t. r of the damping function DM(m) c DMPP(m): 2'nd derivative w.r.t. r of the damping function DM(m) c IF(rhoAB.LE.0.0) return w. DM(m)= 1.0 & DMP(m)=DMPP(m)=0.0 for all m c----------------------------------------------------------------------- INTEGER NCMM,NCMMAX,MMLR(NCMMAX),sVRS2,IDSTT,sVRS2F,FIRST, Lsr,m, 1 MM,MMAX,MMTEMP REAL*8 r,rhoAB,bTT(-2:2),cDS(-4:4),bDS(-4:4),aTT,br,XP,YP, 1 TK, DM(NCMMAX),DMP(NCMMAX),DMPP(NCMMAX),SM(-3:25), 2 bpm(20,-4:0), cpm(20,-4:0),ZK c------------------------------------------------------------------------ c The following values for the numerical factors used in both TT and DS c were normalized to the Hydrogen data presented c by Kreek and Meath in J.Chem.Phys. 50, 2289 (1969). c The ratio has been chosen such that b= FACTOR*(I_p^X / I_p^H)^{2/3} c for the homoatomic diatomic species X_2, where I_p^A is the ionization c------------------------------------------------------------------------ DATA bTT/2.10d0,2.44d0,2.78d0,3.13d0,3.47d0/ DATA bDS/2.50d0,2.90d0,3.30d0,3.69d0,3.95d0,0.d0,4.53d0, 1 0.d0,4.99d0/ DATA cDS/0.468d0,0.446d0,0.423d0,0.405d0,0.390d0,0.d0, 1 0.360d0,0.d0,0.340d0/ c...For testing: precise Scolegian values of 'b' and 'c' for s=0 ...... cc DATA bDS/2.50d0,2.90d0,3.30d0,3.69d0,3.968424883d0,0.d0,4.53d0, cc DATA cDS/0.468d0,0.446d0,0.423d0,0.405d0,0.3892460703d0,0.d0, DATA FIRST/ 1/ SAVE FIRST, bpm, cpm c----------------------------------------------------------------------- MMTEMP = MMLR(1) IF(MMLR(1).LE.0) MMLR(1) = 1 IF(RHOab.LE.0) THEN DO m=1,NCMMax DM(m)=1.d0 DMP(m)= 0.d0 DMPP(m)= 0.d0 ENDDO RETURN ENDIF IF(IDSTT.LE.0) THEN c=========================================== c** For Tang-Toennies type damping functions c=========================================== Lsr= sVRS2/2 IF((sVRS2.LT.-4).OR.(sVRS2.GT.4).OR.((2*LSR).NE.sVRS2)) THEN WRITE(6,600) 'TT',sVRS2 STOP ENDIF MMAX= MMLR(NCMM) + Lsr - 1 aTT= RHOab*bTT(Lsr) br= aTT*r XP= DEXP(-br) SM(-3)= 0.d0 SM(-2)= 0.d0 SM(-1)= 0.d0 SM(0)= 1.d0 TK= 1.d0 IF(br.GT.0.5d0) THEN DO m= 1,MMAX TK= TK*br/DFLOAT(m) SM(m)= SM(m-1)+ TK ENDDO DO m= 1, NCMM MM= MMLR(m) - 1 + Lsr DM(m)= 1.d0 - XP*SM(MM) DMP(m)= aTT*XP*(SM(MM) - SM(MM-1)) DMPP(m)= -aTT*aTT*XP*(SM(MM) 1 - 2.d0*SM(MM-1) + SM(MM-2)) ENDDO c----------------------------------------------------------------------- c The above section handles the calculation of the value of the damping c function for most values of r. However, at very small r that algorithm c becomes unstable due to numerical noise. To avoid this, if the c argument is very small it is re-evaluated as a finite sum ... c----------------------------------------------------------------------- ELSE MMAX= MMAX+5 DO m= 1, MMAX c... NOTE that here SM(m) is the m'th term (b*r)^m/m! [not a sum] SM(m)= SM(m-1)*br/DFLOAT(m) ENDDO DO m= 1, NCMM MM= MMLR(m) + Lsr DM(m)= XP*(SM(MM)+ SM(MM+1)+ SM(MM+2)+ SM(MM+3) 1 + SM(MM+4)) DMP(m)= aTT*XP*SM(m-1) DMPP(m)= aTT*aTT*XP*(SM(m-2)-SM(m-1)) ENDDO ENDIF ENDIF c IF(IDSTT.GT.0) THEN c======================================================================= c** For Douketis-Scoles-Marchetti-Zen-Thakkar type damping function ... c======================================================================= IF((sVRS2.LT.-4).OR.(sVRS2.GT.4).OR.(sVRS2.EQ.1).OR. 1 (sVRS2.EQ.3)) THEN WRITE(6,600) 'DS',sVRS2 STOP ENDIF IF(FIRST.EQ.1) THEN DO m= 1, 20 DO sVRS2F= -4,0 bpm(m,sVRS2F)= bDS(sVRS2F)/DFLOAT(m) cpm(m,sVRS2F)= cDS(sVRS2F)/DSQRT(DFLOAT(m)) ENDDO ENDDO FIRST= 0 ENDIF br= rhoAB*r DO m= 1, NCMM MM= MMLR(m) XP= DEXP(-(bpm(MM,sVRS2) + cpm(MM,sVRS2)*br)*br) YP= 1.d0 - XP ZK= MM + 0.5d0*sVRS2 DM(m)= YP**ZK TK= (bpm(MM,sVRS2) + 2.d0*cpm(MM,sVRS2)*br)*rhoAB DMP(m) = ZK*XP*TK*DM(m)/YP c ... calculate second derivative [for DELR case] {check this!} DMPP(m)= (ZK-1.d0)*DMP(m)*(XP*TK)/YP 1 - DMP(m)*TK + DMP(m)*2.d0*cpm(MM,sVRS2)*rhoAB**2/TK ENDDO ENDIF MMLR(1) = MMTEMP RETURN 600 FORMAT(/,' *** ERROR *** For ',A2,'-damping functions not yet de 1fined for sVRS2=',i3) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE AFdiag(RDIST,VLIM,NCMM,NCMMax,MMLR,Cm,rhoAB,IVSR, 1 IDSTT,ULR,dULRdCm,dULRdR) c*********************************************************************** c** Aubert-Frecon Potential Model for u_{LR}(r) c*********************************************************************** c** Subroutine to generate, at the onee distance RDIST, an eigenvalue c of the 2x2 or 3x3 long-range interaction matrix described by Eqs.1 c and 10, resp., of J.Mol.Spec.188, 182 (1998) (Aubert-Frecon et al) c** and its derivatives w.r.t. the C_m long-range parameters. c*********************************************************************** c==> Input: r= RDIST, VLIM, NCMM, m=MMLR & Cm's, rhoAB, sVSR2, IDSTT c==> Output: ULR, partial derivatives dULRdCm & radial derivative dULRdR c----------------------------------------------------------------------- c** Original Version from Nike Dattani in June 2011 for 3x3 case c** Generalized to incorporate 2x2 case, removed retardation terms and c incorporate damping ... by Kai Slaughter: July 2014 c* rj: C6{adj} & C9{adj} included in CmEFF & fixed dampF call Jan 2016 c----------------------------------------------------------------------- INTEGER NCMMax c----------------------------------------------------------------------- REAL*8 RDIST,VLIM,Cm(NCMMax),ULR,dULRdCm(NCMMax),dULRdR,R2,R3,R5, 1 R6,R8,R9,T1,T0,T2,T0P,T0P23,Dm(NCMMax),Dmp(NCMMax), 2 Dmpp(NCMMax),rhoAB,A(3,3),DR(3,3),Q(3,3),DMx(NCMMax,3,3), 3 DMtemp(3,3),DEIGMx(NCMMax,1,1),DEIGMtemp(1,1),DEIGR(1,1), 4 EIGVEC(3,1),RESID(3,1),W(3),RPOW(NCMMax),DELTAE,Modulus,Z INTEGER H,I,J,K,L,M,X,NCMM,MMLR(NCMMax),IVSR,IDSTT,MMtemp c----------------------------------------------------------------------- DELTAE=Cm(1) R2= 1.d0/RDIST**2 R3= R2/RDIST R5= R2*R3 R6= R3*R3 R8= R6*R2 c----------------------------------------------------------------------- c....... for rhoAB.le.0.0 returns Dm(m)=1 & Dmp(m)=Dmpp(m)=0 CALL dampF(RDIST,rhoAB,NCMM,NCMMAX,MMLR,IVSR,IDSTT,Dm,Dmp,Dmpp) c----------------------------------------------------------------------- IF(MMLR(1).GE.-1) THEN !! For the A (0) or b (-1) state c*********************************************************************** c************* Aubert Frecon 2x2 case NCMM= 7 and ... c*** Cm(1) = DELTAE c*** Cm(2) = C3Sig c*** Cm(3) = C3Pi c*** Cm(4) = C6Sig c*** Cm(5) = C6Pi c*** Cm(6) = C8Sig c*** Cm(7) = C8Pi c*********************************************************************** T1= R3*(Dm(2)*(Cm(2)-Cm(3)) + R3*Dm(4)*(Cm(4)-Cm(5)) + 1 R5*Dm(6)*(Cm(6)-Cm(7)))/3.d0 T0= DSQRT((T1 - Cm(1))**2 + 8.d0*T1**2) ULR= 0.5d0*(-Cm(1) + R3*(Dm(2)*(Cm(2)+Cm(3)) + 1 R3*Dm(4)*(Cm(4)+Cm(5)) + R5*Dm(6)*(Cm(6)+Cm(7))) + T0) c----------------------------------------------------------------------- IF(MMLR(1).EQ.0) THEN ULR= ULR + Cm(8)*R3*R6 !! add C9{adj correction ENDIF c... adjustment for the b-state IF(MMLR(1).EQ.-1) THEN ULR=ULR-T0 ULR= ULR + Cm(9)*R3*R6 !! add C9{adj correction ENDIF c... now get derivatives T0P= 0.5d0*(9.d0*T1 - Cm(1))/T0 T0P23= 0.5d0 + T0P/3.d0 c... another adjustment for the b-state IF(MMLR(1).EQ.-1) T0P23=T0P23-2.d0*T0P/3.d0 dULRdCm(1)= 0.d0 dULRdCm(2)= R3*(T0P23) dULRdCm(3)= R3*(1.d0-T0P23) dULRdCm(4)= R6*(T0P23) dULRdCm(5)= R6*(1.d0 - T0P23) dULRdCm(6)= R8*T0P23 dULRdCm(7)= R8*(1.d0-T0P23) T2 =-T0P*R3*((Dm(2)*(Cm(2)-Cm(3))+R3*(Dm(4)*2.d0*(Cm(4) 1 -Cm(5))+R2*Dm(6)*8.d0/3.d0*(Cm(6)-Cm(7))))/RDIST 2 +(Dmp(2)*(Cm(2)-Cm(3))+R3*Dmp(4)*(Cm(4)-Cm(5))+ 3 R2*R3*Dmp(6)*(Cm(6)-Cm(7)))/3.d0) dULRdR = -R3*((1.5d0*Dm(2)*(Cm(2)+Cm(3)) + R3*(Dm(4)*3.d0* 1 (Cm(4)+Cm(5))+4.d0*Dm(6)*R2*(Cm(6)+Cm(7))))/RDIST 2 + 0.5d0*(Dmp(2)*(Cm(2)+Cm(3)) + Dmp(4)*R3*(Cm(4)+ 3 Cm(5)) + Dmp(6)*R3*R2*(Cm(6)+Cm(7)))) + T2 c... and a final adjustment for the b-state IF(MMLR(1).EQ.-1) dULRdR= dULRdR- 2.d0*T2 c----------------------------------------------------------------------- ELSE c*********************************************************************** c********* Aubert Frecon 3x3 case NCMM= 10 and ... c********* Cm(1) = DELTAE c********* Cm(2) = C3Sig c********* Cm(3) = C3Pi1 c********* Cm(4) = C3Pi3 c********* Cm(5) = C6Sig c********* Cm(6) = C6Pi1 c********* Cm(7) = C6Pi3 c********* Cm(8) = C8Sig c********* Cm(9) = C8Pi1 c********* Cm(10)= C8Pi3 c*********************************************************************** c... Initialize interaction matrix to 0.d0 DO I= 1,3 DO J= 1,3 A(I,J)=0.0D0 DR(I,J)=0.d0 DO K= 1,NCMMax DMx(K,I,J)=0.d0 ENDDO ENDDO ENDDO c... Prepare interaction matrix A DO I= 2,NCMM,3 RPOW(I)= RDIST**MMLR(I) A(1,1)= A(1,1) - Dm(I)*(Cm(I)+Cm(I+1)+Cm(I+2))/(3.d0*RPOW(I)) A(1,2)= A(1,2) - Dm(I)*(Cm(I+2)+Cm(I+1)-2.d0*Cm(I))/(RPOW(I)) A(1,3)= A(1,3) - Dm(I)*(Cm(I+2)-Cm(I+1))/(RPOW(I)) A(2,2)= A(2,2) - Dm(I)*(Cm(I+2)+Cm(I+1)+4.d0*Cm(I)) 1 /(6.d0*RPOW(I)) A(3,3)= A(3,3) - Dm(I)*(Cm(I+2)+Cm(I+1))/(2.d0*RPOW(I)) ENDDO A(1,1) = A(1,1) + VLIM A(1,2) = A(1,2)/(3.d0*DSQRT(2.d0)) A(2,1) = A(1,2) A(2,2) = A(2,2) + VLIM + DELTAE A(2,3) = A(1,3)/(2.d0*DSQRT(3.d0)) A(1,3) = A(1,3)/(DSQRT(6.d0)) A(3,1) = A(1,3) A(3,2) = A(2,3) A(3,3) = A(3,3) + VLIM + DELTAE c... Prepare radial derivative of interaction matrix (? is it needed ?) DO I= 2,NCMM,3 DR(1,1)= DR(1,1) + Dm(I)*MMLR(I)*(Cm(I)+Cm(I+1)+Cm(I+2)) 1 /(3.d0*RPOW(I)*RDIST) 2 -Dmp(I)*(Cm(I)+Cm(I+1)+Cm(I+2))/(3.d0*RPOW(I)) DR(1,2)= DR(1,2) + Dm(I)*MMLR(I)*(Cm(I+2)+Cm(I+1)-2.d0* 1 Cm(I))/(RPOW(I)*RDIST) 2 -Dmp(I)*(Cm(I+2)+Cm(I+1)-2.d0*Cm(I))/(RPOW(I)) DR(1,3)= DR(1,3) + Dm(I)*MMLR(I)*(Cm(I+2)-Cm(I+1)) 1 /(RPOW(I)*RDIST) 2 -Dmp(I)*(Cm(I+2)-Cm(I+1))/(RPOW(I)) DR(2,2)= DR(2,2) + Dm(I)*MMLR(I)*(Cm(I+2)+Cm(I+1)+ 1 4.d0*Cm(I))/(6.d0*RPOW(I)*RDIST) 2 -Dmp(I)*(Cm(I+2)+Cm(I+1)+4.d0*Cm(I)) 3 /(6.d0*RPOW(I)) DR(3,3)= DR(3,3) + Dm(I)*MMLR(I)*(Cm(I+2)+Cm(I+1)) 1 /(2.d0*RPOW(I)*RDIST) 2 -Dmp(I)*(Cm(I+2)+Cm(I+1))/(2.d0*RPOW(I)) ENDDO DR(1,2) = DR(1,2)/(3.d0*DSQRT(2.d0)) DR(2,1) = DR(1,2) DR(2,3) = DR(1,3)/(2.d0*DSQRT(3.d0)) DR(1,3) = DR(1,3)/(DSQRT(6.d0)) DR(3,1) = DR(1,3) DR(3,2) = DR(2,3) c... Partial derivatives of interaction matrix A w.r.t. Cm's DO I= 2,NCMM,3 DMx(I,1,1)= -Dm(I)/(3.d0*RPOW(I)) DMx(I+1,1,1)= DMx(I,1,1) DMx(I+2,1,1)= DMx(I,1,1) DMx(I,1,2)= 2.d0*Dm(I)/(3.d0*DSQRT(2.d0)*RPOW(I)) DMx(I+1,1,2)= -DMx(I,1,2)/2.d0 DMx(I+2,1,2)= DMx(I+1,1,2) DMx(I,2,1)= DMx(I,1,2) DMx(I+1,2,1)= DMx(I+1,1,2) DMx(I+2,2,1)= DMx(I+2,1,2) DMx(I,1,3)= 0.d0 DMx(I,3,1)= 0.d0 DMx(I+1,1,3)= Dm(I)/(DSQRT(6.d0)*RPOW(I)) DMx(I+1,3,1)= DMx(I+1,1,3) DMx(I+2,1,3)= -DMx(I+1,1,3) DMx(I+2,3,1)= DMx(I+2,1,3) DMx(I,2,2)= 2.d0*Dm(I)/(3.d0*RPOW(I)) DMx(I+1,2,2)= DMx(I,2,2)/4.d0 DMx(I+2,2,2)= DMx(I+1,2,2) DMx(I,2,3)= 0.d0 DMx(I,3,2)= 0.d0 DMx(I+1,2,3)= Dm(I)/(2.d0*DSQRT(3.d0)*RPOW(I)) DMx(I+1,3,2)= DMx(I+1,2,3) DMx(I+2,2,3)= -DMx(I+1,2,3) DMx(I+2,3,2)= DMx(I+2,2,3) DMx(I,3,3)= 0.d0 DMx(I+1,3,3)= Dm(I)/(2.d0*RPOW(I)) DMx(I+2,3,3)= DMx(I+1,3,3) ENDDO c... Call subroutine to prepare and invert interaction matrix A CALL DSYEVJ3(A,Q,W) L=1 c... Now - identify the lowest eigenvalue of A and label it L DO J=2,3 IF (W(J) .LT. W(L)) THEN L=J ENDIF ENDDO c... Identifiy the highest eigenvalue of A and label it H H=1 DO J=2,3 IF(W(J).GT.W(H)) THEN H=J ENDIF ENDDO c... Identify the middle eigenvalue of A and label it M M=1 DO J=2,3 IF((J.NE.L).AND.(J.NE.H)) M= J ENDDO c... Select which eigenvalue to use based on user input IF(MMLR(1).EQ.-2) THEN X = L ELSEIF(MMLR(1).EQ.-3) THEN X = M ELSE X = H ENDIF c... determine ULR and eigenvectors ULR= -W(X) IF(MMLR(1).EQ.-2) ULR= ULR+ Cm(11)*R3*R6 !! C9adj term IF((MMLR(1).EQ.-3).OR.(MMLR(1).EQ.-4)) ULR = ULR + DELTAE IF(MMLR(1).EQ.-3) ULR= ULR+ Cm(12)*R3*R6 !! C9adj term IF(MMLR(1).EQ.-4) ULR= ULR+ Cm(13)*R3*R6 !! C9adj term DO I=1,3 EIGVEC(I,1) = Q(I,X) ENDDO cc loop over values of m to determine partial derivatives w.r.t. each Cm DO I=2,NCMM DMtemp(1:3,1:3) = DMx(I,1:3,1:3) DEIGMtemp= -MATMUL(TRANSPOSE(EIGVEC),MATMUL(DMtemp,EIGVEC)) dULRdCm(I)= DEIGMtemp(1,1) ENDDO DEIGR = -MATMUL(TRANSPOSE(EIGVEC),MATMUL(DR,EIGVEC)) dULRdR= DEIGR(1,1) !! radial derivative w.r.t. r (I think!) c------------------------------------------------------------------------ ENDIF c------------------------------------------------------------------------ RETURN CONTAINS c======================================================================= SUBROUTINE DSYEVJ3(A, Q, W) c ---------------------------------------------------------------------- c** Subroutine to setup and diagonalize the matrix A and return c eigenvalues W and eigenvector matrix Q INTEGER N, I, X, Y, R PARAMETER (N=3) REAL*8 A(3,3), Q(3,3), W(3) REAL*8 SD, SO, S, C, T, G, H, Z, THETA, THRESH c Initialize Q to the identitity matrix c --- This loop can be omitted if only the eigenvalues are desired --- DO X = 1, N Q(X,X) = 1.0D0 DO Y = 1, X-1 Q(X, Y) = 0.0D0 Q(Y, X) = 0.0D0 ENDDO ENDDO c Initialize W to diag(A) DO X = 1, N W(X) = A(X, X) ENDDO c Calculate SQR(tr(A)) SD = 0.0D0 DO X = 1, N SD = SD + ABS(W(X)) ENDDO SD = SD**2 c Main iteration loop DO 40 I = 1, 50 c Test for convergence SO = 0.0D0 DO X = 1, N DO Y = X+1, N SO = SO + ABS(A(X, Y)) ENDDO ENDDO IF(SO .EQ. 0.0D0) RETURN IF(I .LT. 4) THEN THRESH = 0.2D0 * SO / N**2 ELSE THRESH = 0.0D0 END IF c Do sweep DO 60 X = 1, N DO 61 Y = X+1, N G = 100.0D0 * ( ABS(A(X, Y)) ) IF ( I .GT. 4 .AND. ABS(W(X)) + G .EQ. ABS(W(X)) $ .AND. ABS(W(Y)) + G .EQ. ABS(W(Y))) THEN A(X, Y) = 0.0D0 ELSE IF (ABS(A(X, Y)) .GT. THRESH) THEN c Calculate Jacobi transformation H = W(Y) - W(X) IF ( ABS(H) + G .EQ. ABS(H) ) THEN T = A(X, Y) / H ELSE THETA = 0.5D0 * H / A(X, Y) IF (THETA .LT. 0.0D0) THEN T= -1.0D0/(SQRT(1.0D0 + THETA**2)-THETA) ELSE T= 1.0D0/(SQRT(1.0D0 + THETA**2) + THETA) END IF END IF C = 1.0D0 / SQRT( 1.0D0 + T**2 ) S = T * C Z = T * A(X, Y) c Apply Jacobi transformation A(X, Y) = 0.0D0 W(X) = W(X) - Z W(Y) = W(Y) + Z DO R = 1, X-1 T = A(R, X) A(R, X) = C * T - S * A(R, Y) A(R, Y) = S * T + C * A(R, Y) ENDDO DO R = X+1, Y-1 T = A(X, R) A(X, R) = C * T - S * A(R, Y) A(R, Y) = S * T + C * A(R, Y) ENDDO DO R = Y+1, N T = A(X, R) A(X, R) = C * T - S * A(Y, R) A(Y, R) = S * T + C * A(Y, R) ENDDO c Update eigenvectors c --- This loop can be omitted if only the eigenvalues are desired --- DO R = 1, N T = Q(R, X) Q(R, X) = C * T - S * Q(R, Y) Q(R, Y) = S * T + C * Q(R, Y) ENDDO END IF 61 CONTINUE 60 CONTINUE 40 CONTINUE WRITE(6,'("DSYEVJ3: No convergence.")') END SUBROUTINE DSYEVJ3 END SUBROUTINE AFdiag c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE MKPREDICT(NSTATES,NDAT) c*********************************************************************** c** Subroutine to prepare fake input data array which will cause ParFit c to make transition energy predictions for electronic or infrared band c or microwave transitions. On entry: c NSTATES is the number of states involved in the data set. c NSTATES= 1 generates infrared or microwave bands for state SLABL(1) c NSTATES= 2 generates electronic bands from lower state SLABL(1) c into upper state SLABL(2) c VMIN(s) and VMAX(s) are the bounds on the vibrational energy range c for state 's' specified in the main input file. c** On return: c NDAT(v,i,s) is the number of transitions associated with c vibrational level-v of isotopologue-i of state-s [for NDEGB < 0 case] c** This subroutine reads in band specifications on Channel-5 and writes c the transition energy specifications to channel-4 c----------------------------------------------------------------------- c Version of 1 September 2005 c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKTYPE.h' c======================================================================= c** Type statements & common blocks for characterizing transitions REAL*8 AVEUFREQ(NPARMX),MAXUFREQ(NPARMX) INTEGER NTRANSFS(NISTPMX,NSTATEMX), 1 NTRANSVIS(NISTPMX,NSTATEMX,NSTATEMX), 1 NBANDEL(NISTPMX,NSTATEMX,NSTATEMX), 2 NTRANSIR(NISTPMX,NSTATEMX),NTRANSMW(NISTPMX,NSTATEMX), 3 NBANDFS(NISTPMX,NSTATEMX),NBANDVIS(NISTPMX,NSTATEMX), 4 NBANDIR(NISTPMX,NSTATEMX),NBANDMW(NISTPMX,NSTATEMX), 5 NVVPP(NISTPMX,NSTATEMX),NWIDTH(NISTPMX,NSTATEMX), 6 NEBPAS(NISTPMX,NSTATEMX),NVIRIAL(NISTPMX,NSTATEMX), 7 NAcVIR(NISTPMX,NSTATEMX),NBANDS(NISTPMX) c COMMON /BLKTYPE/AVEUFREQ,MAXUFREQ,NTRANSFS,NTRANSVIS,NTRANSIR, 1 NTRANSMW,NBANDFS,NBANDEL,NBANDVIS,NBANDIR,NBANDMW,NVVPP,NWIDTH, 2 NEBPAS,NVIRIAL,NAcVIR,NBANDS c======================================================================= c----------------------------------------------------------------------- c CHARACTER*3 LABLP,LABLPP INTEGER I,J,J2,JD,J2DL,J2DU,J2DD,JMAXX,PP,PPP,NTRANST,COUNT, 1 IBAND,JMAXP(NPARMX),JMINP(NPARMX), 1 VMX(NSTATEMX),ISOT,ESP,ESPP,ISTATE,MN1,MN2 INTEGER NSTATES,NDAT(0:NVIBMX,NISTPMX,NSTATEMX) c----------------------------------------------------------------------- c** Initialize counters for book-keeping on input data COUNT= 0 DO ISOT= 1,NISTP DO ISTATE= 1,NSTATES NTRANSFS(ISOT,ISTATE)= 0 NTRANSIR(ISOT,ISTATE)= 0 NTRANSMW(ISOT,ISTATE)= 0 NBANDFS(ISOT,ISTATE)= 0 NBANDVIS(ISOT,ISTATE)= 0 NBANDIR(ISOT,ISTATE)= 0 NBANDMW(ISOT,ISTATE)= 0 NVVPP(ISOT,ISTATE)= 0 NWIDTH(ISOT,ISTATE)= 0 DO I= 1,NSTATES NTRANSVIS(ISOT,ISTATE,I)= 0 NBANDEL(ISOT,ISTATE,I)= 0 ENDDO ENDDO NBANDS(ISOT)= 0 ENDDO DO ISTATE= 1,NSTATES VMX(ISTATE)= 0 ENDDO NFSTOT= 0 IBAND= 0 70 IBAND= IBAND+ 1 IF(IBAND.GT.NPARMX) THEN WRITE(6,609) IBAND,NPARMX IBAND= IBAND-1 GOTO 99 ENDIF c** Generate "empty" band data sets to allow ParFit to make predictions c for those sets of transitions. c** LABLP & LABLPP are the two-character variables identifying the upper c and lower electronic states, respectively. LABLP=LABLPP for IR or c MW transitions within a given electronic state c** VP & VPP are the v' & v" values identifying the band; c** PP & PPP specify rotational parities (+/- 1) of upper and lower levels c** MN1 & MN2 identify the isotopologue c** Generate 'lines' for J"= 0 to JMAXX subject to selection rule that c Delta(J) runs from J2DL to J2DU in steps of J2DD c----------------------------------------------------------------------- READ(5,*,end=99) VP(IBAND),VPP(IBAND),LABLP,LABLPP,MN1,MN2,PP,PPP, 1 JMAXX,J2DL,J2DU,J2DD c----------------------------------------------------------------------- IF(VP(IBAND).LT.0) GO TO 99 c** Set electronic state number for upper & lower levels. c* Always set lower state as 1'st state considered in input [SLABL(1)] c* For NSTATES= 1, upper state is the same one. For NSTATES= 2 the c upper state is 2'nd one considered [SLABL(2)] IEPP(IBAND)= 1 IEP(IBAND)= NSTATES WRITE(4,400) VP(IBAND),VPP(IBAND),LABLP,LABLPP,MN1,MN2 ISOT= 0 c** Determine the correct isotopologue-number for this band. DO I= 1,NISTP IF((MN1.EQ.MN(1,I)).AND.(MN2.EQ.MN(2,I))) ISOT= I ENDDO ISTP(IBAND)= ISOT MAXUFREQ(IBAND)= 0 JMAXP(IBAND)= JMAXX JMINP(IBAND)= 0 NTRANST= 0 IFIRST(IBAND)= COUNT+ 1 ESP= IEP(IBAND) ESPP= IEPP(IBAND) c** Now - loop over J to generate all possible transitions ... DO J= 0, JMAXX DO JD= J2DL, J2DU, J2DD J2= J+ JD IF((J2.GE.0).AND.((J.NE.0).OR.(J2.NE.0))) THEN COUNT= COUNT+1 IF(COUNT.GT.NDATAMX) THEN WRITE(6,640) COUNT,NDATAMX STOP ENDIF WRITE(4,402) J2,PP,J,PPP JP(COUNT)= J2 EFP(COUNT)= PP JPP(COUNT)= J EFPP(COUNT)= PPP FREQ(COUNT)= 0.d0 UFREQ(COUNT)= 0.001d0 DFREQ(COUNT)= 0.d0 IB(COUNT)= IBAND c** Accumulate count of data associated with each vibrational level ... NDAT(VPP(IBAND),ISTP(IBAND),ESPP)= 1 NDAT(VPP(IBAND),ISTP(IBAND),ESPP)+ 1 NDAT(VP(IBAND),ISTP(IBAND),ESP)= 1 NDAT(VP(IBAND),ISTP(IBAND),ESP)+ 1 ENDIF ENDDO ENDDO WRITE(4,404) 400 FORMAT(2I4," '",A3,"' '",A3,"' ",2I4," 'predictions' ") 402 FORMAT(I4,I3,I5,I3,' 0.d0 1.0d-3') 404 FORMAT(' -1 -1 -1 -1 -1.d0 -1.d-3'/) VMX(ESP)= MAX(VMX(ESP),VP(IBAND)) VMX(ESPP)= MAX(VMX(ESPP),VPP(IBAND)) ILAST(IBAND)= COUNT NTRANST= ILAST(IBAND)-IFIRST(IBAND)+1 GOTO 70 99 RETURN 609 FORMAT(/' *** ERROR *** Dimension allocated for number of bands ex 1ceeded:'/' (IBAND=',i4,') > (NBANDMX=',i4,') so truncate input a 2nd TRY to continue ...') 640 FORMAT(/' *** Input Data Count reaches',i6,' which EXCEEDS ARRAY L 1IMIT of',i6) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE DYIDPJ(IDAT,NDATA,NPTOT,YOBS,YC,PV,PD) c*********************************************************************** c** This program assumes that the upper state IEP is at a higher energy c than the lower state IEPP. c** This subroutine returns the calculated value YC of datum IDAT, and c its partial derivatives PD(k) w.r.t. the NPTOT parameters PV. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++ COPYRIGHT 2007-16 by R.J. Le Roy, Jenning Seto and Yiye Huang +++ 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++++++++++++++++++++ (version of 18/02/2016) ++++++++++++++++++++++++++ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c IDAT is the number of the current observable being considered. c NPTOT is the total number of parameters in the model c PV(i) is the array of parameters being varied. c----------------------------------------------------------------------- c** On exit: c YC is the calculated value of the IDATth observable. c PV(i) is the array of parameters being varied. c PD(i) is the partial derivative array (de/dp). c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c----------------------------------------------------------------------- c** Common block for partial derivatives of potential at the one distance RDIST c and HPP derivatives for uncertainties REAL*8 dVdPk(HPARMX),dDe(0:NbetaMX),dDedRe COMMON /dVdPkBLK/dVdPk,dDe,dDedRe c======================================================================= INTEGER IDAT,NPTOT,NBAND,IISTP,ISTATE,I,J,NDATA,fcount c c** Define parameters required locally and from NLLSSRR. REAL*8 RDIST,VDIST,BETADIST,VLAST,EUP,ELW,YOBS,YC,EO,width, 1 VMAXX(NSTATEMX),PV(NPARMX),PD(NPARMX),UPPER(NPARMX), 2 LOWER(NPARMX),DEDPK(HPARMX),BVIR,dBVIRdP(NPARMX) c c----------------------------------------------------------------------- c INTEGER INNR(0:NVIBMX) SAVE VMAXX c IF(IDAT.EQ.1) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++ At beginning of each fit cycle (datum #1), re-map internal NLLSSRR c parameter array PV onto external (physical) variable set, and get c updated band constant array ZK for estimating trial eigenvalues. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ fcount= 0 CALL MAPPAR(NISTP,PV,1) REWIND(22) REWIND(7) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** If fitting to fluoresence data, convert fluoresence series origin c parameters back to external (logical) variable system. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF((NFSTOT.GT.0).OR.(NTVALL(0).GT.0)) THEN DO J= TOTPOTPAR+1,NPTOT TVALUE(J)= PV(J) ENDDO ENDIF DO ISTATE= 1,NSTATES c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine to update potential functions AND their partial c derivatives w.r.t. fitting parameter for each state. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(PSEL(ISTATE).GT.0) CALL VGEN(ISTATE,-1.d0,VDIST, 1 BETADIST,IDAT) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Now generate band constants for each state and isotopologue for c generating trial eigenvalues in fit calculations. To take account of c the different vibrational ranges for different isotopologues, only c generate values for levels to the input VMAX for isotopologue-1. IF(PSEL(ISTATE).GE.0) THEN DO IISTP= 1,NISTP c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine INITDD to calculate band constants for initial c trial eigenvalue estimates as well as (? what) the partial derivatives. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL INITDD(ISTATE,IISTP,VMAX(ISTATE,IISTP), 1 VMAXX(ISTATE),INNR) ENDDO ENDIF ENDDO ENDIF c++++++++++++++end of datum-1 set-up ++++++++++end of datum-1 set-up +++ c** Initialize variables for current datum EUP= 0.0D0 ELW= 0.0D0 DO I= 1,NPTOT PD(I)= 0.0d0 UPPER(I)= 0.0d0 LOWER(I)= 0.0d0 ENDDO NBAND= IB(IDAT) IISTP= ISTP(NBAND) c c** Now to determine partials with respect to the upper and lower c IF(IEP(NBAND).EQ.0) THEN c======================================================================= c** For fluorescence series data ... c======================================================================= I= NFS1-1 DO J= NFS1,NPTOT IF(FSBAND(J-I).EQ.NBAND) THEN c ... PV(HPARMX+I) is the energy of the I'th fluorescence band. IF(IFXFS(NFS(NBAND)).LE.0) THEN EUP= TVALUE(J) UPPER(J)= 1.0d0 ELSEIF(FSSame.GT.0) THEN c ... if this FS band shares its origin with some earlier FS band ... EUP= TVALUE(IFXFS(NFS(NBAND))) UPPER(IFXFS(NFS(NBAND)))= 1.d0 ENDIF ENDIF ENDDO CALL DEDP(IDAT,IEPP(NBAND),IISTP,ZMASS(3,IISTP), 1 JP(IDAT),JPP(IDAT),EFPP(IDAT),ELW,VMAXX(IEPP(NBAND)), 2 width,LOWER,fcount) IF(ELW.LT.-9.d9) THEN c... if eigenvalue search failed, remove this datumn from the fit WRITE(6,600) SLABL(IEPP(NBAND)),JP(IDAT),JPP(IDAT), 1 IDAT,YOBS YC= YOBS RETURN ENDIF IF(width.GT.0.d0) THEN c*** Reduce weight of Qbdd levels assuming unc(Airy) = Fqb*width UFREQ(IDAT) = DSQRT(YUNC(IDAT)**2 + (Fqb*width)**2) WRITE(22,623) 'LOWER',IDAT,FREQ(IDAT),VP(NBAND), 1 JP(IDAT),width,YUNC(IDAT),UFREQ(IDAT) ENDIF c ELSEIF((IEP(NBAND).EQ.-1).AND.(PSEL(IEPP(NBAND)).GE.0)) THEN c======================================================================= c*** For PAS data ... c======================================================================= CALL DEDP(IDAT,IEPP(NBAND),IISTP,ZMASS(3,IISTP), 1 JP(IDAT),JPP(IDAT),EFPP(IDAT),ELW,VMAXX(IEPP(NBAND)), 2 width,LOWER,fcount) IF(ELW.LT.-9.d9) THEN c... if eigenvalue search failed, remove this datum from the fit WRITE(6,600) SLABL(IEPP(NBAND)),JP(IDAT),JPP(IDAT), 1 IDAT,YOBS YC= YOBS RETURN ENDIF ISTATE= IEPP(NBAND) EUP= VLIM(ISTATE) c... As appropriate, add isotopic u_\infty adjustment to the binding energy IF(NUA(ISTATE).GE.0) EUP= EUP + 1 ZMUA(IISTP,ISTATE)*UA(NUA(ISTATE),ISTATE) IF(NUB(ISTATE).GE.0) EUP= EUP + 1 ZMUB(IISTP,ISTATE)*UB(NUB(ISTATE),ISTATE) c ELSEIF((IEP(NBAND).EQ.-2).AND.(PSEL(IEPP(NBAND)).GE.0)) THEN c======================================================================= c*** If datum is width of a tunneling-predissociation quasibound level c ... for forward calculation, use widths from SCHRQ in DEDP c======================================================================= CALL DEDP(IDAT,IEPP(NBAND),IISTP,ZMASS(3,IISTP), 1 JP(IDAT),JPP(IDAT),EFPP(IDAT),EO,VMAXX(IEPP(NBAND)), 2 width,DEDPK,fcount) IF(EO.LT.-9.d9) THEN c... if eigenvalue search failed, remove this datumn from the fit WRITE(6,600) SLABL(IEPP(NBAND)),JP(IDAT),JPP(IDAT), 1 IDAT,YOBS YC= YOBS RETURN ENDIF c ... otherwise ... calculate 'width' and its derivatives in DWDP IF(PSEL(IEPP(NBAND)).GT.0) THEN CALL DWDP(IDAT,IEPP(NBAND),FREQ(IDAT),ZMASS(3,IISTP), 1 JP(IDAT),JPP(IDAT),EO,width,DEDPK,PD) YC= width RETURN ENDIF c ELSEIF((IEP(NBAND).EQ.-3).AND.(PSEL(IEPP(NBAND)).GT.0)) THEN c======================================================================= c*** If datum is the potential energy function at some specific distance c======================================================================= ISTATE= IEPP(NBAND) RDIST= TEMP(IDAT) VLAST= VPOT(NPNTMX,ISTATE) CALL VGEN(IEPP(NBAND),RDIST,VDIST,BETADIST,IDAT) YC= VDIST DO J= POTPARI(IEPP(NBAND)), POTPARF(IEPP(NBAND)) PD(J)= dVdPk(J) ENDDO VPOT(NPNTMX,ISTATE)= VLAST RETURN ELSEIF((IEP(NBAND).EQ.-4).AND.(PSEL(IEPP(NBAND)).GT.0)) THEN c======================================================================= c*** For Pressure Virial coefficient data ... c======================================================================= CALL DVIRDP(IDAT,IEPP(NBAND),ZMASS(3,IISTP),BVIR,PD) YC= BVIR RETURN ELSEIF((IEP(NBAND).EQ.-5).AND.(PSEL(IEPP(NBAND)).GT.0)) THEN c======================================================================= c*** For Acoustic Virial coefficient data ... c======================================================================= CALL DVACDP(IDAT,IEPP(NBAND),ZMASS(3,IISTP),BVIR,PD) YC= BVIR RETURN c ELSEIF(IEP(NBAND).GT.0) THEN c======================================================================= c*** For 'normal' microwave, infrared, and electronic data, c*** determine the partials for the upper and lower levels` c======================================================================= IF(PSEL(IEP(NBAND)).EQ.-2) THEN c... if upper state being represented by term values ... UPPER(TVUP(IDAT))= 1.d0 EUP= TVALUE(TVUP(IDAT)) ELSE c... for normal case of UPPER level being represented by a potential c======================================================================= CALL DEDP(IDAT,IEP(NBAND),IISTP,ZMASS(3,IISTP), 1 VP(NBAND),JP(IDAT),EFP(IDAT),EUP,VMAXX(IEP(NBAND)), 2 width,UPPER,fcount) IF(EUP.LT.-9.d9) THEN c... if eigenvalue search failed, remove this datumn from the fit WRITE(6,600) SLABL(IEP(NBAND)),VP(NBAND),JP(IDAT), 1 IDAT,YOBS YC= YOBS RETURN ENDIF IF(width.GT.0.d0) THEN c*** Reduce weight of Qbdd levels assuming unc(Airy) = Fqb*width UFREQ(IDAT) = DSQRT(YUNC(IDAT)**2 + (Fqb*width)**2) WRITE(22,623) 'UPPER',IDAT,FREQ(IDAT),VP(NBAND), 1 JP(IDAT),width,YUNC(IDAT),UFREQ(IDAT) ENDIF 623 FORMAT(' ',A5', level of Datum(',I5,')=',F9.2,' v=',I3,' J=', 1 I3,' has width=',1Pd9.2/9x,'so increase datum uncertainty from', 2 0Pf9.6,' to',f9.6) ENDIF IF(PSEL(IEPP(NBAND)).EQ.-2) THEN c... if lower state being represented by term values ... LOWER(TVLW(IDAT))= +1.d0 ELW= TVALUE(TVLW(IDAT)) ELSE c... for normal case of LOWER level being represented by a potential CALL DEDP(IDAT,IEPP(NBAND),IISTP,ZMASS(3,IISTP), 1 VPP(NBAND),JPP(IDAT),EFPP(IDAT),ELW,VMAXX(IEPP(NBAND)), 2 width,LOWER,fcount) IF(ELW.LT.-9.d9) THEN c... if eigenvalue search failed, remove this datumn from the fit WRITE(6,600) SLABL(IEPP(NBAND)),VPP(NBAND),JPP(IDAT), 1 IDAT,YOBS YC= YOBS RETURN ENDIF IF(width.GT.0.d0) THEN c*** Reduce weight of Qbdd levels assuming unc(Airy) = Fqb*width UFREQ(IDAT) = DSQRT(YUNC(IDAT)**2 + (Fqb*width)**2) WRITE(22,623) 'LOWER',IDAT,FREQ(IDAT),VP(NBAND), 1 JP(IDAT),width,YUNC(IDAT),UFREQ(IDAT) ENDIF ENDIF ENDIF DO I= 1,NPTOT PD(I)= UPPER(I) - LOWER(I) ENDDO c---------------------------------------------------------------------- c** Get calculated value for the IDAT'th observable from energy levels c---------------------------------------------------------------------- YC= EUP - ELW cc if((widthLW.GT.0.d0).OR.(widthUP.GT.0.d0)) THEN cc WRITE(22,622) IDAT,FREQ(IDAT),widthUP,widthLW cc622 FORMAT(' Datum(',I5')=',f10.2,' widthUP=',1Pd9.2,' widthLW=', cc 1 d9.2) cc ENDIF c---------------------------------------------------------------------- RETURN 600 FORMAT(' *** FAIL to find level(',A3,') v=',I3,' J=',I3, 1 ' so ignore YOBS(',i5,')=',f12.4) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE INITDD(ISTATE,IISTP,VIMX,VMAXX,INNR) c*********************************************************************** c** This subroutine updates the trial vibrational energies & rotational c constants on each iteration c** On entry: ISTATE is the states being considered. c IISTP is the isotopologue being considered. c VIMX is the upper vibrational bound for this state. c** On exit: ZK (in BLKISOT) are the band constants for this state & isotope c VMAXX is MAX{barrier maximum, VLIM} for this state. c** Internal: RM2 is the (1+ ZMTA*TAR + ZMTB*TBR)/r**2 array for c this state required by CDJOEL for CDC calculation c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKBOBRF.h' c======================================================================= c** Born-Oppenheimer breakdown radial functions REAL*8 UAR(NPNTMX,NSTATEMX),UBR(NPNTMX,NSTATEMX), 1 TAR(NPNTMX,NSTATEMX),TBR(NPNTMX,NSTATEMX),wRAD(NPNTMX,NSTATEMX) c COMMON /BLKBOBRF/UAR,UBR,TAR,TBR,wRAD c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= c----------------------------------------------------------------------- c INTEGER ISTATE,IISTP,VIMX,AFLAG,VIN,NBEG,NEND,WARN,IWR,LPRWF,I,J, 1 INNODE,KV,NCN c REAL*8 GV(0:NVIBMX),RCNST(NROTMX),RR(NPNTMX),RM2(NPNTMX), 1 V(NPNTMX),SWF(NPNTMX),FWHM,PMAX,BFCT,BvWN,RHSQ,C3gu,T3,VMAXX c INTEGER INNR(0:NVIBMX) REAL*8 SWF2,qDBL,qFCT,Cm1 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ VIN= VIMX AFLAG= 0 WARN= 0 IWR= -0 !!! should in general be -1 cc IWR= 5 !!! use this when trouble shooting level search LPRWF= 0 INNODE= 1 c c** Calculate potential scaling factors for ALF and CDJOEL c RHSQ= RH(ISTATE)*RH(ISTATE) BFCT= (ZMASS(3,IISTP)/16.857629206D0)*RHSQ BvWN= 16.857629206D0/ZMASS(3,IISTP) qFCT= RH(ISTATE)*BvWN**(2*IOMEG(ISTATE)) c c** Now generate the BFCT-scaled and adiabatically corrected potential c for the current isotope for use in SCHRQ, plus the 1/R**2 array for c CDC calculations in CDJOEL c DO I=1,NDATPT(ISTATE) RR(I)= RD(I,ISTATE) V(I)= BFCT*(VPOT(I,ISTATE)+ ZMUA(IISTP,ISTATE)*UAR(I,ISTATE) 1 + ZMUB(IISTP,ISTATE)*UBR(I,ISTATE)) RM2(I)= 1.d0/RD(I,ISTATE)**2 c** Special BOB correction for A-state Li2 and analogous cases. !!!!!!!! IF(IOMEG(ISTATE).EQ.-2) V(I)= V(I) + 2.d0*RHSQ*RM2(I) ENDDO IF((NCMM(ISTATE).GE.3).AND.(MMLR(2,ISTATE).LE.0).AND.(AN(1).EQ.3) 1 .AND.(AN(2).EQ.3).AND.(MN(1,IISTP).NE.MN(2,IISTP))) THEN c** Add g/u symmetry breakdown correction for special case {6,7}Li2(A) !! C3gu= (2.d0/3.d0)*CmVAL(1,ISTATE) DO I= 1,NDATPT(ISTATE) T3= C3gu/RD(I,ISTATE)**3 V(I)= V(I) + BFCT*(T3 - DSQRT(T3**2 + 0.03085959756d0)) ENDDO ENDIF IF((NTA(ISTATE).GE.0).OR.(NTB(ISTATE).GE.0)) THEN DO I= 1, NDATPT(ISTATE) RM2(I)= RM2(I)*(1.d0 + ZMTA(IISTP,ISTATE)*TAR(I,ISTATE) 1 + ZMTB(IISTP,ISTATE)*TBR(I,ISTATE)) ENDDO ENDIF NCN= 999 Cm1 = CmVAL(1,ISTATE) IF(MMLR(1,ISTATE).LE.0) Cm1 = CmVAL(2,ISTATE) IF((PSEL(ISTATE).GE.2).AND.(Cm1.GT.0.d0)) 1 NCN= MMLR(1,ISTATE) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine ALF that will locate the needed vibrational levels c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL ALF(NDATPT(ISTATE),RH(ISTATE),NCN,RR,V,SWF,VLIM(ISTATE), 1 MAXMIN(ISTATE),VIN,NVIBMX,VMAXX,AFLAG,ZMASS(3,IISTP), 2 EPS(ISTATE),GV,INNODE,INNR,IWR) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** If a serious error occured during within ALF, then print out a c warning, record the constants that we have and hope the program c doesn't call on the constants for which ALF could not calculate. c IF (AFLAG.LT.0) THEN WRITE(6,600) ISTATE,IISTP IF(AFLAG.EQ.-1) THEN WRITE(6,601) VIN,VIMX, AFLAG STOP !! ?? need to stop or just Print Warning ENDIF IF (AFLAG.EQ.-2) WRITE(6,602) IF (AFLAG.EQ.-3) WRITE(6,603) IF (AFLAG.EQ.-4) WRITE(6,604) IF (AFLAG.EQ.-5) WRITE(6,606) IF (AFLAG.EQ.-6) WRITE(6,608) IF (AFLAG.EQ.-8) THEN WRITE(6,610) ELSE WRITE(6,612) ISTATE,VIN ENDIF ENDIF c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Now to calculate the rotational constants for each vibrational level c of this state for this isotopologue IF(IOMEG(ISTATE).GT.0) THEN IF(NwCFT(ISTATE).GT.0) THEN WRITE(7,615) NAME(1),MN(1,IISTP),NAME(2),MN(2,IISTP), 1 IOMEG(ISTATE), IOMEG(ISTATE)*IOMEG(ISTATE) ELSE WRITE(7,617) NAME(1),MN(1,IISTP),NAME(2),MN(2,IISTP), 1 IOMEG(ISTATE), IOMEG(ISTATE)*IOMEG(ISTATE) ENDIF ELSEIF(IOMEG(ISTATE).LE.-2) THEN IF(NwCFT(ISTATE).GT.0) THEN WRITE(7,6615) NAME(1),MN(1,IISTP),NAME(2),MN(2,IISTP), 1 IOMEG(ISTATE), -IOMEG(ISTATE) ELSE WRITE(7,6617) NAME(1),MN(1,IISTP),NAME(2),MN(2,IISTP), 1 IOMEG(ISTATE), -IOMEG(ISTATE) ENDIF ELSE IF(NwCFT(ISTATE).LT.0) THEN WRITE(7,614) NAME(1),MN(1,IISTP),NAME(2),MN(2,IISTP) ELSE WRITE(7,618) NAME(1),MN(1,IISTP),NAME(2),MN(2,IISTP) ENDIF ENDIF DO KV= 0,VIN AFLAG= 0 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine SCHRQ to calculate the wavefunction required by c CDJOEL to calculate the rotational constants. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL SCHRQ(KV,AFLAG,GV(KV),FWHM,PMAX,VLIM(ISTATE),V,SWF,BFCT, 1 EPS(ISTATE),RMIN(ISTATE),RH(ISTATE),NDATPT(ISTATE), 2 NBEG,NEND,INNODE,INNR(KV),IWR,LPRWF) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine CDJOEL to determine the rotational constants. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL CDJOEL(GV(KV),NBEG,NEND,BvWN,RH(ISTATE),WARN,V,SWF,RM2, 1 RCNST) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Store molecular constants in array ZK(v,J,isotope,state) c ZK(KV,0,IISTP,ISTATE)= GV(KV) DO J= 1,NROTMX ZK(KV,J,IISTP,ISTATE)= RCNST(J) ENDDO IF(NwCFT(ISTATE).LT.0) THEN c*** Write band constants for 'normal' (Lambda= 0) case WRITE(7,616) KV,GV(KV),(RCNST(J),J=1,NROTMX) ELSE c** For Lambda- or 2-Sigma doubling, calculate the q{B} parameter and c then print it with the other band constants qDBL = 0.d0 DO I= NBEG,NEND SWF2= SWF(I)**2 qDBL= qDBL + SWF2*wRAD(I,ISTATE) ENDDO qDBL= qDBL*qFCT WRITE(7,616) KV,GV(KV),(RCNST(J),J=1,NROTMX),qDBL ENDIF ENDDO flush(7) J=1 c c** If all is well, then (without further ado) continue with the c calculations. c RETURN c----------------------------------------------------------------------- 600 FORMAT(/' *** INITDD ERROR ***',/4X,'For state',I3, 1' of isotope',I3,' a serious error has occured:') 601 FORMAT(' *** WARNING !! ALF finds highest level v=',i3,' is bel 1ow desired (v=',I3,', J=',I3,')') 602 FORMAT(4X,'The Schrodinger Solver was unable to use the initial tr 1ial energy.') 603 FORMAT(4X,'The Schrodinger Solver was unable to use the calculated 1 trial energy') 604 FORMAT(4X,'The Automatic Level Finder could not find the first vib 1rational level.') 606 FORMAT(4X,'The next calculated trial energy was too low.') 608 FORMAT(4X,'The next calculated trial energy was too high.') 610 FORMAT(4X,'A second minimum exists in this potential') 612 FORMAT(4X,'Could not find vibrational levels of state',i3, 1 ' beyond (v=',I3,')') 614 FORMAT(/' For ',A2,'(',I3,') - ',A2,'(',I3,')'/1x,11('--')/ 1 ' v ','E',12x,'Bv',11x,'-Dv',13x,'Hv',13x,'Lv', 2 12x,'Mv',13x,'Nv',13x,'Ov'/1x,58('==')) 615 FORMAT(/' For ',A2,'(',I3,') - ',A2,'(',I3,')'/1x,11('==')/ 1 ' Although IOMEGA=',I2,', these band constants were obtained fo 2r [J(J+1) ',SP,I2,'] = 0'/1x,39('--')/' v ','E',12x,'Bv', 3 11x,'-Dv',13x,'Hv',13x,'Lv',12x,'Mv',13x,'Nv',13x,'Ov'/ 4 1x,58('==')) 6615 FORMAT(/' For ',A2,'(',I3,') - ',A2,'(',I3,')'/1x,11('==')/ 1 ' Since IOMEGA=',I3,', these band constants were obtained for', 2' [J(J+1) ',SP,I2,'] = 2'/1x,39('--')/' v ','E',12x,'Bv', 3 11x,'-Dv',13x,'Hv',13x,'Lv',12x,'Mv',13x,'Nv',13x,'Ov'/ 4 1x,58('==')) 616 FORMAT(I4,f12.4,f14.10,7(1PD15.7)) 617 FORMAT(/' For ',A2,'(',I3,') - ',A2,'(',I3,')'/1x,11('==')/ 1 ' Although IOMEGA=',I2,', these band constants were obtained fo 2r [J(J+1) ',SP,I2,'] = 0'/1x,39('--')/' v ','E',12x,'Bv', 3 11x,'-Dv',13x,'Hv',13x,'Lv',13x,'Mv',13x,'Nv',13x,'Ov'13x, 4 'qB(v)'/1x,67('==')) 6617 FORMAT(/' For ',A2,'(',I3,') - ',A2,'(',I3,')'/1x,11('==')/ 1 ' Since IOMEGA=',I3,', these band constants were obtained for', 2' [J(J+1) ',SP,I2,'] = 2'/1x,39('--')/' v ','E',12x,'Bv', 3 11x,'-Dv',13x,'Hv',13x,'Lv',13x,'Mv',13x,'Nv',13x,'Ov'13x, 4 'qB(v)'/1x,67('==')) 618 FORMAT(/' For ',A2,'(',I3,') - ',A2,'(',I3,')'/1x,11('--')/ 1 ' v ','E',12x,'Bv',11x,'-Dv',13x,'Hv',13x,'Lv', 2 13x,'Mv',13x,'Nv',13x,'Ov'13x,'qB(v)'/1x,67('==')) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE DEDP(IDAT,ISTATE,IISTP,ZMU,KVLEV,JROT,efPARITY,EO, 1 VMAXX,FWHM,DEDPK,fcount) c*********************************************************************** c** This subroutine calculates dE/dp from the expectation values of the c partial derivatives of an analytical potential with respect to its c parameters {p(k)}: dE/dp(k) = stored in DEDPK. c c** On entry: c ISTATE is the molecular state being considered. c IISTP is the isotopologue being considered. c ZMU is the reduced mass of the diatom in atomic units. c KVLEV is the vibrational quantum number. c JROT is the rotational quantum number. c EO is the initial trial energy (DE in cm-1). c VMAXX = is MAX{barrier maximum} or VLIM for this state c ZK (in BLKISOT) is matrix of band constants for all levels of all ISOT c c** On exit: c EO is the final calculated energy (DE in cm-1). c DEDPK(i) are the values of the partial derivative dE/dP(k). c c** Flags: Use only when debugging. 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 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 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 The first line identifies the level, gives the position of c 1-st point and radial mesh, & states No. of points. c fcount counts the number of failed attempts to get desired level c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKBOBRF.h' c======================================================================= c** Born-Oppenheimer breakdown radial functions REAL*8 UAR(NPNTMX,NSTATEMX),UBR(NPNTMX,NSTATEMX), 1 TAR(NPNTMX,NSTATEMX),TBR(NPNTMX,NSTATEMX),wRAD(NPNTMX,NSTATEMX) c COMMON /BLKBOBRF/UAR,UBR,TAR,TBR,wRAD c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c======================================================================= INTEGER IDAT, bandN, efPARITY, JRe, fcount c INTEGER I,ICOR,ISTATE,IISTP,INNER,J,JROT,JIN,KVLEV,KV, 1 NBEG,NEND,INNODE, IWR, LPRWF REAL*8 ZMU,EO,BFCT,JFCT,JFCTP,JFCTL,FWHM,UMAX, RM2, ETRY,VMAXX, 1 DGDV2,SWF2,JFCTA,JFCTB,DUARe,DUBRe,DTARe,DTBRe,DLDRe,DEROT, 2 DEROTB,JFCTDBL,JFCTD,muFCT,C3gu,T3,GV(0:NVIBMX),Vtotal(NPNTMX), 3 SWF(NPNTMX), V(NPNTMX), DEDPK(HPARMX) c COMMON /VBLIK/Vtotal c c** Vibrational Band Constants for generating trial energies. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c** Initializing the arrays and variables DATA IWR/0/,LPRWF/0/,INNODE/1/ c c** To calculate the values for c we must first determine the wave equation for the vj state. muFCT= 16.857629206d0/ZMU BFCT= RH(ISTATE)*RH(ISTATE)/muFCT JFCT= DBLE(JROT*(JROT+1)) JFCTL= JFCT-IOMEG(ISTATE)**2 DO J= 1,HPARMX DEDPK(J)= 0.d0 ENDDO IF(IOMEG(ISTATE).GT.0) JFCT= JFCT - 1 DBLE(IOMEG(ISTATE)*IOMEG(ISTATE)) c** If using band constants for this state .... IF(PSEL(ISTATE).EQ.-1) THEN IF(NBC(KVLEV,IISTP,ISTATE).GT.0) THEN I= BCPARI(KVLEV,IISTP,ISTATE) DEDPK(I)= 1.d0 EO= ZBC(KVLEV,0,IISTP,ISTATE) JFCTP= JFCTL IF(NBC(KVLEV,IISTP,ISTATE).GT.1) THEN DO J= 2, NBC(KVLEV,IISTP,ISTATE) I= I+ 1 DEDPK(I)= JFCTP EO= EO+ ZBC(KVLEV,J-1,IISTP,ISTATE)*JFCTP JFCTP= JFCTP*JFCTL ENDDO IF(NQC(KVLEV,IISTP,ISTATE).GT.0) THEN JFCTP= JFCT*0.5d0*(efPARITY-efREF(ISTATE)) IF(IOMEG(ISTATE).EQ.-1) THEN JFCTL= JFCT IF(efPARITY.GT.0) JFCTP= 0.5d0*JROT IF(efPARITY.EQ.0) JFCTP= 0.d0 IF(efPARITY.LT.0) JFCTP= -0.5d0*(JROT+1) ENDIF DO J= 1, NQC(KVLEV,IISTP,ISTATE) I= I+ 1 DEDPK(I)= JFCTP EO= EO+ ZQC(KVLEV,J-1,IISTP,ISTATE)*JFCTP JFCTP= JFCTP*JFCTL ENDDO ENDIF ENDIF ENDIF RETURN ENDIF c** Calculating the trial energy value from the band constants ETRY= ZK(KVLEV,0,IISTP,ISTATE) IF(JROT.GT.0) THEN DEROT= 9.d9 DO I=1,NROTMX DEROTB= DEROT JFCTP= JFCT**I IF(IOMEG(ISTATE).EQ.-1) JFCTP= JFCTP - 2**I DEROT= ZK(KVLEV,I,IISTP,ISTATE) * JFCTP c... if centrifugal term bigger than previous one - truncate summation ETRY= ETRY + DEROT ENDDO 4 ENDIF IF(IOMEG(ISTATE).GT.0) THEN c** For Lambda doubling, prepare rotational/mass factors JFCTDBL= 0.5d0*(efPARITY-efREF(ISTATE)) 1 * (DBLE(JROT*(JROT+1)) * muFCT**2)**IOMEG(ISTATE) ENDIF IF(IOMEG(ISTATE).EQ.-1) THEN c** For doublet Sigma splitting, prepare rotational/mass factors IF(efPARITY.GT.0) JFCTDBL= 0.5d0*JROT*muFCT IF(efPARITY.EQ.0) JFCTDBL= 0.d0 IF(efPARITY.LT.0) JFCTDBL= -0.5d0*(JROT+1)*muFCT ENDIF c c** Generating potential function including centrifugal, adiabatic BOB, c and rotational non-adiabatic BOB, and if appropriate, Lambda c doubling or 2\Sigma doubling radial functions. cc c==> Model-A <== c** First - for Li2(A), add BOB centrifugal shift 2*B(r) cc IF((NCMM(ISTATE).GE.3).AND.(MMLR(2,ISTATE).LE.0) cc 1 .AND.(IOMEG(ISTATE).NE.-2)) cc 2 JFCT= JFCT + 2.d0*ZMASS(3,1)/ZMASS(3,IISTP) - 2.d0 c==> Model-A <== cc c** Include ad BOB function for A-state Li2 & analogous cases cc IF(IOMEG(ISTATE).LE.-2) JFCT= JFCT - IOMEG(ISTATE) JFCT= JFCT* RH(ISTATE)* RH(ISTATE) JFCTD= JFCTDBL* RH(ISTATE)* RH(ISTATE)/muFCT bandN= IB(IDAT) DO I= 1,NDATPT(ISTATE) RM2= 1/RD(I,ISTATE)**2 V(I)= BFCT*(VPOT(I,ISTATE) + ZMUA(IISTP,ISTATE)*UAR(I,ISTATE) 1 + ZMUB(IISTP,ISTATE)*UBR(I,ISTATE)) 2 + JFCT* (1.0d0 + ZMTA(IISTP,ISTATE)*TAR(I,ISTATE) 3 + ZMTB(IISTP,ISTATE)*TBR(I,ISTATE))*RM2 IF((IOMEG(ISTATE).GT.0).OR.(IOMEG(ISTATE).EQ.-1)) THEN c** Add radial potential for Lambda- or 2-Sigma splitting c ... note that power of 1/r**2 included in wRAD array ... V(I)= V(I) + JFCTD*wRAD(I,ISTATE) ENDIF Vtotal(I)= V(I)/BFCT ENDDO c!! IF((NCMM(ISTATE).GE.3).AND.(MMLR(2,ISTATE).LE.0)) THEN IF((AN(1).EQ.3).AND.(AN(2).EQ.3) 1 .AND.(MN(1,IISTP).NE.MN(2,IISTP))) THEN c** Add g/u symmetry breakdown correction for special case {6,7}Li2(A) !! C3gu= (2.d0/3.d0)*CmVAL(1,ISTATE) DO I= 1,NDATPT(ISTATE) T3= C3gu/RD(I,ISTATE)**3 Vtotal(I)= Vtotal(I)+ T3- DSQRT(T3**2+ 3.085959756d-2) V(I)= Vtotal(I)*BFCT ENDDO ENDIF ENDIF ICOR= 0 INNER= 0 EO= ETRY 10 KV= KVLEV c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL SCHRQ(KV,JROT,EO,FWHM,UMAX,VLIM(ISTATE),V,SWF,BFCT, 1 EPS(ISTATE),RMIN(ISTATE),RH(ISTATE),NDATPT(ISTATE), 2 NBEG,NEND,INNODE,INNER,IWR,LPRWF) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(KV.NE.KVLEV) THEN c** If SCHRQ found the wrong level .... write(6,666) KVLEV,JROT,ETRY,KV,EO 666 FORMAT(' Search for v=',I3,' J=',I3,' starting from E=', 1 f9.2,' finds E(v=',I3,')=', f9.2) ICOR= ICOR+1 IF((ICOR.LE.10).AND.(KV.GE.0)) THEN c... SCECOR uses semiclassical methods to estimate correct energy CALL SCECOR(KV,KVLEV,JROT,INNER,ICOR,IWR,EO,RH(ISTATE),BFCT, 1 NDATPT(ISTATE),MMLR(1,ISTATE),V,VMAXX,VLIM(ISTATE),DGDV2) c*********************************************************************** KV= KVLEV GOTO 10 ENDIF c** If the calculated wavefunction is still for the wrong vibrational c level, then write out a warning and skip the calculation of the c partial derivatives (hence setting them to zero). fcount= fcount+1 WRITE(6,610) fcount,KVLEV,JROT,KV IF(fcount.ge.1000) THEN WRITE(6,612) 612 FORMAT(/' *** Excessive SCECOR failures, so stop and figure out wh 1y *** ' //) STOP ENDIF c.. eigenvalue of -9.9d9 indicates that eigenvalue search failed completely EO= -9.9d9 IWR= 0 RETURN ENDIF c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** If the calculated wavefunction is for the right vibrational level, c then continue with calculation of the partial derivatives by c integration using the modified trapezoidal rule. c c** First determine which partials need to be changed, increment so c that the (fluorescence term values and) lower states are skipped. c JRe= POTPARI(ISTATE)+ 1 IF(PSEL(ISTATE).EQ.6) JRe= POTPARI(ISTATE) c** Now calculate the rotational factors JFCT, JFCTA & JFCTB JFCT= JFCT/BFCT JFCTA= JFCT * ZMTA(IISTP,ISTATE) JFCTB= JFCT * ZMTB(IISTP,ISTATE) DUARe= 0.d0 DUBRe= 0.d0 DTARe= 0.d0 DTBRe= 0.d0 DLDRe= 0.d0 c** Eigenvalue derivative calc using compact partial derivative array IF(PSEL(ISTATE).LE.0) RETURN DO I= NBEG,NEND SWF2= SWF(I)**2 IF((I.EQ.NBEG).OR.(I.EQ.NEND)) SWF2= 0.5d0*SWF2 c ... collect contributions of BOB terms to derivatives w.r.t. Re IF(NUA(ISTATE).GE.0) DUARe= DUARe+ SWF2*DUADRe(I,ISTATE) IF(NUB(ISTATE).GE.0) DUBRe= DUBRe+ SWF2*DUBDRe(I,ISTATE) IF(NTA(ISTATE).GE.0) DTARe= DTARe+ SWF2*DTADRe(I,ISTATE) IF(NTB(ISTATE).GE.0) DTBRe= DTBRe+ SWF2*DTBDRe(I,ISTATE) IF(NwCFT(ISTATE).GE.0) DLDRe= DLDRe+ SWF2*DLDDRe(I,ISTATE) DO J= POTPARI(ISTATE), POTPARF(ISTATE) DEDPK(J)= DEDPK(J) + SWF2*DVtot(J,I) ENDDO ENDDO DEDPK(JRe)= DEDPK(JRe) + DUARe*ZMUA(IISTP,ISTATE) 1 + DUBRe*ZMUB(IISTP,ISTATE) + JFCTA*DTARe + JFCTB*DTBRe 2 + JFCTDBL*DLDRE DO J= POTPARI(ISTATE), POTPARF(ISTATE) DEDPK(J)= DEDPK(J)* RH(ISTATE) ENDDO IF(NUA(ISTATE).GE.0) THEN DO I= NBEG,NEND SWF2= SWF(I)**2 IF((I.EQ.NBEG).OR.(I.EQ.NEND)) SWF2= 0.5d0*SWF2 DO J= UAPARI(ISTATE), UAPARF(ISTATE) DEDPK(J)= DEDPK(J) + SWF2*DVtot(J,I) ENDDO ENDDO DO J= UAPARI(ISTATE), UAPARF(ISTATE) DEDPK(J)= DEDPK(J)* ZMUA(IISTP,ISTATE)* RH(ISTATE) ENDDO ENDIF IF(NUB(ISTATE).GE.0) THEN DO I= NBEG,NEND SWF2= SWF(I)**2 IF((I.EQ.NBEG).OR.(I.EQ.NEND)) SWF2= 0.5d0*SWF2 DO J= UBPARI(ISTATE), UBPARF(ISTATE) DEDPK(J)= DEDPK(J) + SWF2*DVtot(J,I) ENDDO ENDDO DO J= UBPARI(ISTATE), UBPARF(ISTATE) DEDPK(J)= DEDPK(J)* ZMUB(IISTP,ISTATE)* RH(ISTATE) ENDDO ENDIF IF(NTA(ISTATE).GE.0) THEN DO I= NBEG,NEND SWF2= SWF(I)**2 IF((I.EQ.NBEG).OR.(I.EQ.NEND)) SWF2= 0.5d0*SWF2 DO J= TAPARI(ISTATE), TAPARF(ISTATE) DEDPK(J)= DEDPK(J) + SWF2*DVtot(J,I) ENDDO ENDDO DO J= TAPARI(ISTATE), TAPARF(ISTATE) DEDPK(J)= DEDPK(J)* JFCTA* RH(ISTATE) ENDDO ENDIF IF(NTB(ISTATE).GE.0) THEN DO I= NBEG,NEND SWF2= SWF(I)**2 IF((I.EQ.NBEG).OR.(I.EQ.NEND)) SWF2= 0.5d0*SWF2 DO J= TBPARI(ISTATE), TBPARF(ISTATE) DEDPK(J)= DEDPK(J) + SWF2*DVtot(J,I) ENDDO ENDDO DO J= TBPARI(ISTATE), TBPARF(ISTATE) DEDPK(J)= DEDPK(J)* JFCTB* RH(ISTATE) ENDDO ENDIF IF(NwCFT(ISTATE).GE.0) THEN DO I= NBEG,NEND SWF2= SWF(I)**2 IF((I.EQ.NBEG).OR.(I.EQ.NEND)) SWF2= 0.5d0*SWF2 DO J= LDPARI(ISTATE), LDPARF(ISTATE) DEDPK(J)= DEDPK(J) + SWF2*DVtot(J,I) ENDDO ENDDO DO J= LDPARI(ISTATE), LDPARF(ISTATE) DEDPK(J)= DEDPK(J)* JFCTDBL* RH(ISTATE) ENDDO ENDIF RETURN c----------------------------------------------------------------------- 610 FORMAT(' *** SCECOR failed',I4,' times, Currently Seeking v=', 1 i3,', J=',i3,'; Found v=',I3) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE DWDP(IDAT,ISTATE,EXPT,ZMU,vb,Jr,EO,width,DEDPK,dWdPk) c======================================================================= c** This subroutine calculates dW/dP using Pajunen's quadrature method c Ref: JCP. 71(6), 2618, 1979. c** The values of dW/dP(k) for each parameter P(k) are stored in dWdPk. c====================RJL's Version of 11 May 2002======================= c** On entry: c IDAT is the experimental data number c ISTATE is the molecular state being considered. c IISTP is the isotopologue being considered. c ZMU is the reduced mass of the diatom in atomic units. c vb is the vibrational quantum number. c Jr is the rotational quantum number. c EO is the energy for this level (DE in cm-1). c width is the FWHM level width calculated in SCHRQ c DEDPK(i) are the values of the partial derivative dE/dP(k) c c** On exit: c width is the width calculated herein (DE in cm-1). c dWdPk(i) are the values of the partial derivative dW/dP(k). c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= INTEGER I,ISTATE,IDAT,NN,NST,vb,Jr,IPV c ** Phase integral and partial derivative arrays .... REAL*8 Iwell(0:HPARMX,-1:1),Ibarr(0:HPARMX,-1:1), DEDPK(HPARMX), 1 dWdPk(HPARMX) REAL*8 ARG,dARG,ZMU,EO,FCTOR,FWHM,Pi,EXPT,width, R1, R2, R3, 1 KAPPA,KAPPAcl,EMSC,EPSRJ,dKdEPS, XX,TI,COR,dvdG2pi DATA pi/3.141592653589793D0/ *----------------------------------------------------------------------* *** Begin by calling subroutine locateTP to find the three turning * points of the quasi-bound level FCTOR= DSQRT(ZMU/16.857629206d0) DO IPV= POTPARI(ISTATE),HPARF(ISTATE) dWdPk(IPV)= 0.0d0 ENDDO CALL locateTP(IDAT,ISTATE,vb,Jr,EO,R1,R2,R3) c *** if some turning points are not found, ignore this datum IF((R1.LT.0.d0) .OR. (R2.LT.0.d0) .OR. (R3.LT.0.d0)) THEN width= EXPT WRITE(6,600) IDAT RETURN 600 FORMAT(' <>') ENDIF c** Call subroutine phaseIntegral to calculate the phase integrals c using Pajunen's quadrature method CALL PhaseIntegral(IDAT,ISTATE,R2,R3,-1,EO,DEDPK,Ibarr) CALL PhaseIntegral(IDAT,ISTATE,R1,R2,0,EO,DEDPK,Iwell) c ... save WIDTH calculated in SCHRQ to test vs. new value FWHM= width *** Calculate the width EPSRJ= 2.0d0*FCTOR*Ibarr(0,-1) KAPPAcl= DEXP(-EPSRJ) KAPPA= DSQRT(1.d0 + KAPPAcl) - 1.d0 c ... alternate calculation to give better precision for small TUN0 IF(KAPPAcl.LT.1.d-5) KAPPA= KAPPAcl*(0.5d0- KAPPAcl*(0.125d0- 1 0.0625d0*KAPPAcl)) KAPPA= 4.d0* KAPPA /(KAPPA+ 2.d0) c** Derivative of complex gamma function argument calculated as c ..... EPSRJ= -2.* PI* EMSC c per eq.(6.1.27) in Abramowitz and Stegun. EMSC= - EPSRJ/(2.d0*pi) NST= DABS(EMSC)*1.d2 NST= MAX0(NST,4) ARG= -1.963510026021423d0 dARG= 0.d0 DO I= 0,NST NN= I XX= I + 0.5d0 TI= 1.d0/((XX/EMSC)**2 + 1.d0) dARG= dARG+ XX*TI*TI TI= TI/XX ARG= ARG+TI IF(DABS(TI).LT.1.d-10) GO TO 233 ENDDO c ... and use integral approximation for tails of summations ... 233 COR= 0.5d0*(EMSC/(NN + 1.d0))**2 ARG= ARG + COR - COR**2 dARG= dARG + EMSC**2 *(COR - 2.d0* COR**2) dvdG2pi= FCTOR * (Iwell(0,0) 1 + (DLOG(DABS(EMSC)) - ARG)* Ibarr(0,0)/(2.d0*pi) ) width= KAPPA/dvdG2pi c?????? c WRITE(32,320) vb,Jr,EO,width, width/FWHM- 1.d0, FWHM c 320 FORMAT ('Level v=',I3,' J=',I3,' Ep=',G16.8,' FWHM(new)=', c 1 1Pd16.8/ 12x,'Relative Diff.=',d9.2,' FWHM(SCHRQ)=', d16.8) c?????? dKdEPS= DSQRT(1.d0 + KAPPAcl) dKdEPS= -4.d0*KAPPAcl/(dKdEPS*(dKdEPS+ 1.d0)**2) DO IPV= POTPARI(ISTATE),HPARF(ISTATE) dWdPk(IPV)= dKdEPS * FCTOR * Ibarr(IPV,0)/dvdG2pi 1 - (KAPPA/dvdG2pi**2)* (0.5d0 * FCTOR * Iwell(IPV,1) 2 + (FCTOR**2 *Ibarr(0,0)/(2.d0*pi* EPSRJ))* Ibarr(IPV,0) 3 * (1.d0 - dARG* 8.d0*pi**2/EPSRJ**2) 4 - (FCTOR* Ibarr(IPV,1)/(4.d0*pi))* (DLOG(DABS(EMSC)- ARG)) ) ENDDO c????? cc write(32,321) (dWdPk(IPV), IPV= POTPARI(ISTATE),HPARF(ISTATE) cc write(33,321) (dEdPk(IPV), IPV= POTPARI(ISTATE),HPARF(ISTATE) cc write(33,*) cc321 format(1Pd11.3,6d11.3/(11x,6d11.3)) c?????? RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE locateTP(IDAT,ISTATE,vb,Jr,EO,R1,R2,R3) c======================================================================= c Subroutine locateTP locates the turning points R1, R2 and R3 for c level v= vb, J= Jr at energy EO. The search for each starts with c a scan over the pre-prepared total potential function array Vtotal, c and then applies iterative local linear interpolation until the c numerical-noise machine precision limit is reached. c======================================================================= c** On entry c IDAT is the experimental data number c ISTATE is the molecular state being considered. c vb is the vibrational quantum number. c Jr is the rotational quantum number. c EO is the energy for this level (DE in cm-1). c** On exit c R1 is the array of inner turning points. c R2 is the array of second turning points. c R3 is the array of third turning points. c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= c----------------------------------------------------------------------- c** Define types for local variables INTEGER I,IDAT,ISTATE,vb,Jr,index REAL*8 VLIMT,R1,R2,R3,EO,bMi,Vmid,EMV,EMVB,EMVBB,RTB,RTBB, 1 RR(1),RM2(1),VV(1),Vtotal(NPNTMX) COMMON /VBLIK/Vtotal c*** Start search for innermost turning point ... index= 1 EMV= -99.d0 c ... First, scan to find first mesh point past innermost turning point DO I= 1, NDATPT(ISTATE) EMVB= EMV EMV= EO- Vtotal(I) IF(EMV.GT.0.d0) THEN INDEX= I GOTO 4 ENDIF ENDDO WRITE(6,600) 'R1',vb,Jr,EO R1= -1.0d0 GO TO 999 4 R1= RD(index,ISTATE) c ... test to see if by accident, mesh point IS exactly R1 IF(DABS(EO-Vtotal(INDEX)).GT.0.d0) THEN R1= RD(index,ISTATE) RTB= RD(index-1,ISTATE) 10 RTBB= RTB EMVBB= EMVB RTB= R1 EMVB= EMV c ... interpolate linearly between the two most recent estimates R1= RTB - (RTB-RTBB)*EMVB/(EMVB-EMVBB) IF(PSEL(ISTATE).GT.0) THEN c ... obtain potential function value at new turning point estimate CALL VGEN(ISTATE,R1,Vmid,bMi,IDAT) ELSE RR(1)= R1 RM2(1)= 1.0d0/R1**2 c ... for fixed pointwise potential, interpolate for potential value CALL PREPOTT(0,AN(1),AN(2),MN(1,1),MN(2,1),1,VLIMT,RR,VV) Vmid= VV(1) ENDIF EMV= EO- VMID ccccc ccc WRITE (30,21) RTB,'R1',R1,RTBB,EO,Vmid ccc21 FORMAT (' RTB=',F11.8,2x,A2,'=',F11.8,' RTBB=',F11.8,' E=', ccc 1 1PD16.9,' Vmid=',D16.9) ccccc c ... test for convergence to machine precision IF(DABS(EMV).LT.DABS(EMVB)) GOTO 10 ccc cc WRITE(30,100) vb,Jr,'R1',R1,EO,EMV,EMVB cc100 FORMAT('For v=',I3,' J=',I3,2x,a2,'=',F9.6,' E =',1PD15.8, cc & ' EmV=',D15.8,' EmVB=',D15.8) ccc R1= RTB ENDIF c c****************now Locate second turning point R2 ***************** EMV= +99.d0 c ... Now, scan to find first mesh point past the second turning point DO I= INDEX, NDATPT(ISTATE) EMVB= EMV EMV= EO- Vtotal(I) IF(EMV.LT.0.d0) THEN INDEX= I GOTO 14 ENDIF ENDDO WRITE(6,600) 'R2',vb,Jr,EO R2= -1.0d0 GO TO 999 14 R2= RD(index,ISTATE) c ... test to see if by accident, mesh point IS exactly R2 IF(DABS(EO-Vtotal(INDEX)).GT.0.d0) THEN R2= RD(index,ISTATE) RTB= RD(index-1,ISTATE) 20 RTBB= RTB EMVBB= EMVB RTB= R2 EMVB= EMV c ... interpolate linearly between the two most recent estimates R2= RTB - (RTB-RTBB)*EMVB/(EMVB-EMVBB) IF(PSEL(ISTATE).GT.0) THEN c ... obtain PEC value at new turning point estimate: no deriv or BOB neeeded CALL VGEN(ISTATE,R2,Vmid,bMi,IDAT) ELSE RR(1)= R2 RM2(1)= 1.0d0/R2**2 c ... for fixed pointwise potential, interpolate for potential value CALL PREPOTT(0,AN(1),AN(2),MN(1,1),MN(2,1),1,VLIMT,RR,VV) Vmid= VV(1) ENDIF EMV= EO- VMID ccc ccc WRITE (30,21) RTB,'R2',R2,RTBB,EO,Vmid ccc c ... test for conergence to machine precision IF(DABS(EMV).LT.DABS(EMVB)) GOTO 20 ccc ccc WRITE(30,100) vb,Jr,'R2',R2,EO,EMV,EMVB ccc R2= RTB ENDIF c c****************now Locate third turning point R3 ***************** EMV= +99.d0 c ... Now, scan to find first mesh point past the third turning point DO I= INDEX, NDATPT(ISTATE) EMVB= EMV EMV= EO- Vtotal(I) IF(EMV.GT.0.d0) THEN INDEX= I GOTO 24 ENDIF ENDDO WRITE(6,600) 'R3',vb,Jr,EO R3= -1.0d0 GO TO 999 24 R3= RD(index,ISTATE) c ... test to see if by accident, mesh point IS exactly R3 IF(DABS(EO-Vtotal(INDEX)).GT.0.d0) THEN R3= RD(index,ISTATE) RTB= RD(index-1,ISTATE) 30 RTBB= RTB EMVBB= EMVB RTB= R3 EMVB= EMV c ... interpolate linearly between the two most recent estimates R3= RTB - (RTB-RTBB)*EMVB/(EMVB-EMVBB) IF(PSEL(ISTATE).GT.0) THEN c ... obtain potential function value at new turning point estimate CALL VGEN(ISTATE,R3,Vmid,bMi,IDAT) ELSE RR(1)= R3 RM2(1)= 1.0d0/R3**2 c ... for fixed pointwise potential, interpolate for potential value CALL PREPOTT(0,AN(1),AN(2),MN(1,1),MN(2,1),1,VLIMT,RR,VV) Vmid= VV(1) ENDIF EMV= EO- VMID ccc ccc WRITE (30,21) RTB,'R3',R3,RTBB,EO,Vmid ccc c ... test for conergence to machine precision IF(DABS(EMV).LT.DABS(EMVB)) GOTO 30 ccc ccc WRITE(30,100) vb,Jr,'R3',R3,EO,EMV,EMVB ccc R3= RTB ENDIF 999 RETURN 600 FORMAT(' Turning point ',A2,' at E(v=',I3,' J=',I3,')=', 1 G14.7,' lies beyond RMAX.') END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE PhaseIntegral(IDAT,ISTATE,Ri,Ro,k1,EO,DEDPK,Jntegral) c======================================================================= c Subroutine PhaseIntegral calculates phase integrals of the integrand c f(R)/[E-V(R)]**(k+1/2), for k=-1,0 or 1 on interval between turning c points Ri and Ro, where f(R) is either 1 or a derivative of the c potential w.r.t. some potential parameter. c Ro N c Jntegral = Int dr f(r)/|E-V(r)|^{k+1/2} = ½(Ro - Ri) Sum{Wi*F(Zi)} c Ri i=1 c Evaluate integrals for k=k1 to 1 where for k=k1 f(r)=1 c for k>k1 f(r)=[dE/dp-dV/dp] c====================RJL's Version of 11 May 2002======================= c Tests against proper Gaussian (25.4.38 & 25.4.40) gave agreement of c ca. 10^{-10} to 10^{-8) for I_{-1}^{barr}({1}) and ranging from c 10^{-13} to [rare worst case] 10^{-6} fo I_0^{barr}({deriv}) c typically 1-^{-6} for I_0^{well}({1}). c* For k=1 integrals, comparing PP "k=1" vs. "k=3" integration gave c typical agreement for I_1^{barr}({deriv.}) of ca. 10^{-6}, but c occasionally as bad as 10^{-1} and as good as 10^{-9} c [?? check cgce. of turning point search!]. c** I_1^{well}({f}) derivatives always poor cgce. w.r.t. k=1 vs. k=3 c PP method integration tests ... ??? c* Notice deriv.'s w.r.t. q(r) parameters typically orders of magnitude c poorer than others (??) c c* On entry: IDAT is the experimental datum number c----------- ISTATE is the molecular state being considered. c Ri is the inner turning point c Ro is the outer turning point c EO is the energy for this level (DE in cm-1). c k is the powers in the phase integral Jntegral c n=0 for f(r)= 1; n=1 for f(r)= [dV(r)/dp_k - dE/dp_k] c DEDPK(i) are the values of the partial derivative dE/dp_k. c* On exit: Jntegral(j,k) are the phase integral(s) c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c** Type statements & common block for data INTEGER i,IPV,ISTATE, k,k1,kmx,M,IDAT c** M is the number of quadrature mesh points PARAMETER (M=21) c** Common block for partial derivatives of potential at the one distance RDIST c and HPP derivatives for uncertainties REAL*8 dVdPk(HPARMX),dDe(0:NbetaMX),dDedRe COMMON /dVdPkBLK/dVdPk,dDe,dDedRe c======================================================================= REAL*8 Ri,Ro,EO,Fzt,RDIST,VDIST,BETADIST,EMinusV, 1 Jntegral(0:HPARMX,-1:1),DEDPK(HPARMX) c REAL*8 Zp21(M),Wp21k1(M) ccc 1 ,Wp21k3(M) ccc 2 ,Zp11(M),Wp11k1(M),Wp11k3(M),Zp15(M),Wp15k1(M),Wp15k3(M) ccc ccc DATA Zp11/0.9659258262890683, 0.8660254037844386, ccc 1 0.7071067811865475, 0.5000000000000000, ccc 2 0.2588190451025208, ccc 3 0.0000000000000000, ccc 4 -0.2588190451025208,-0.5000000000000000, ccc 5 -0.7071067811865475,-0.8660254037844386, ccc 6 -0.9659258262890683, ccc 7 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ ccc ccc DATA Wp11k1/22.06633397656787,-37.69911184307752, ccc 1 35.60471674068432,-37.69911184307752, ccc 2 36.57672889044161, ccc 3 -37.69911184307752, ccc 4 36.57672889044161,-37.69911184307752, ccc 5 35.60471674068432,-37.69911184307752, ccc 6 22.06633397656787, ccc 7 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ ccc ccc DATA Wp11k3/228.3214545745810, -720.4719152232592, ccc 1 1139.3509357018984,-1357.1680263507907, ccc 2 1447.1946273399755, ccc 3 -1474.4541520848097, ccc 4 1447.1946273399755,-1357.1680263507907, ccc 5 1139.3509357018984, -720.4719152232592, ccc 6 228.3214545745810, ccc 7 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ ccc ccc DATA Zp15/0.9807852804032304, 0.9238795325112868, ccc 1 0.8314696123025452, 0.7071067811865475, ccc 2 0.5555702330196022, 0.3826834323650898, ccc 3 0.1950903220161283, ccc 4 0.0000000000000000, ccc 5 -0.1950903220161283,-0.3826834323650898, ccc 6 -0.5555702330196022,-0.7071067811865475, ccc 7 -0.8314696123025452,-0.9238795325112868, ccc 8 -0.9807852804032304, ccc 9 0.0,0.0,0.0,0.0,0.0,0.0/ ccc ccc DATA Wp15k1/29.62981929591175,-50.26548245743668, ccc 1 47.72092686124880,-50.26548245743664, ccc 2 49.12943331558201,-50.26548245743658, ccc 3 49.44900912828539, ccc 4 -50.26548245743656, ccc 5 49.44900912828539,-50.26548245743658, ccc 6 49.12943331558201,-50.26548245743664, ccc 7 47.72092686124880,-50.26548245743668, ccc 8 29.62981929591175, ccc 9 0.0,0.0,0.0,0.0,0.0,0.0/ ccc ccc DATA Wp15k3/1164.639428963841,-3580.432803129281, ccc 1 5525.620597073791,-6534.512719466765, ccc 2 7020.542275282852,-7276.911407677031, ccc 3 7400.700330802901, ccc 4 -7439.291403700618, ccc 5 7400.700330802901,-7276.911407677031, ccc 6 7020.542275282852,-6534.512719466765, ccc 7 5525.620597073791,-3580.432803129281, ccc 8 1164.639428963841, ccc 9 0.0,0.0,0.0,0.0,0.0,0.0/ ccc DATA Zp21/0.9898214418809327, 0.9594929736144974, 1 0.9096319953545184, 0.8412535328311812, 2 0.7557495743542583, 0.6548607339452851, 3 0.5406408174555976, 0.4154150130018864, 4 0.2817325568414297, 0.1423148382732851, 5 0.0000000000000000, 6 -0.1423148382732851,-0.2817325568414297, 7 -0.4154150130018864,-0.5406408174555976, 8 -0.6548607339452851,-0.7557495743542583, 9 -0.8412535328311812,-0.9096319953545184, a -0.9594929736144974,-0.9898214418809327/ c DATA Wp21k1/40.91258980361040,-69.11503837897816, 1 65.80507790523560,-69.11503837898373, 2 67.78308420797106,-69.11503837899778, 3 68.30792716563759,-69.11503837900795, 4 68.49459295516724,-69.11503837901213, 5 68.54383971474920, 6 -69.11503837901213, 68.49459295516724, 7 -69.11503837900795, 68.30792716563759, 8 -69.11503837899778, 67.78308420797106, 9 -69.11503837898373, 65.80507790523560, a -69.11503837897816, 40.91258980361040/ ccc ccc DATA Wp21k3/6364.91821744174,-19267.83229098791, ccc 1 29317.26172550868,-34478.42376106038, ccc 2 37049.70046340271,-38499.30026119479, ccc 3 39357.74970048209,-39887.54536375314, ccc 4 40205.64256060925,-40378.03411697539, ccc 5 40431.72625305376, ccc 6 -40378.03411697539, 40205.64256060925, ccc 7 -39887.54536375314, 39357.74970048209, ccc 8 -38499.30026119479, 37049.70046340271, ccc 9 -34478.42376106038, 29317.26172550868, ccc a -19267.83229098791, 6364.91821744174/ c ccc DATA Pi/3.141592653589793D0/ ccc SAVE Pi, Zp21, Wp21k1, Wp21l3 ******7***************************************************************72 * In Pajunen method, there is a option to choose different points of * weight. To do this, just change the variable names for the Zp* & Wp* * e.g., in order to use only 15 points * Zi(i) = Zp15(i) and Wi(i) = -Wp15k1(i), * and to use only 11 points * Zi(i) = Zp11(i) and Wi(i) = -Wp11k1(i) ******7***************************************************************72 c*** Zero integral arrays kmx= k1 kmx= 1 IF(k1 .eq. -1) kmx= 0 DO k= k1,kmx Jntegral(0,k)= 0.d0 DO IPV= POTPARI(ISTATE),HPARF(ISTATE) Jntegral(IPV,k)= 0.0d0 ENDDO ENDDO c c*** Begin quadrature loop for sums over M mesh points DO i= 1,M c ... first get potential and derivatives at Pajunen k=1 point RDIST= 0.5d0*(Ro+Ri + (Ro-Ri)*Zp21(i)) CALL VGEN(ISTATE,RDIST,VDIST,BETADIST,IDAT) EMinusV= DABS(EO- VDIST) DO k= k1, kmx c ... loop over posible k values IF(k .EQ. -1) THEN c* For k= -1, using Pajunen k=1 quadrature method ...... Fzt= DSQRT(EminusV/(1-Zp21(i)**2))* (1-Zp21(i)**2)**2 ELSEIF(k .EQ. 0) THEN c* For k= 0, using Pajunen k=1 quadrature method ...... Fzt= DSQRT((1-Zp21(i)**2)/EminusV) * (1-Zp21(i)**2) c* For k= 1, use Pajunen quadrature method [JCP, 71(6), 2618, 1979] ELSEIF(k .EQ. 1) THEN c* If k = 1 points are used Fzt= ( DSQRT((1-Zp21(i)**2)/EminusV) )**3 ENDIF c*** Accumulate the phase integrals Jntegral(0,k)= Jntegral(0,k) - Wp21k1(i)* Fzt ccc IF(k .gt. k1) THEN DO IPV= POTPARI(ISTATE),HPARF(ISTATE) c ... Loop over free parameters accumulating phase integral derivs. Jntegral(IPV,k)= Jntegral(IPV,k)- Wp21k1(i)* Fzt 1 *(dVdPk(IPV)- DEDPK(IPV)) ENDDO ccc ENDIF c .... end of loop over k values ENDDO c ... end of quadrature loop over mesh points .................... ENDDO DO k= k1,kmx Jntegral(0,k)= 0.25d0*(Ro-Ri) * Jntegral(0,k) DO IPV= POTPARI(ISTATE),HPARF(ISTATE) c*** In Pajunen's method, a factor of (1/2) is incorporated because c the phase integral is a contour integral Jntegral(IPV,k)= 0.25d0*(Ro-Ri) * Jntegral(IPV,k) ENDDO ENDDO c???????????????????????? c** Test that 'regular' & Pajunen integrals agree for k= -1 & 0 cc and that Pajunen k=1 & 3 integrals agree for k=1 case cc DO IPV= POTPARI(ISTATE),HPARF(ISTATE) cc WRITE(32, 320) EO, (Jntegral(IPV,k), k= k1, kmx) cc WRITE(32, 321) (Jntegral(IPV,k), k= k1, kmx) cc Do k= k1, kmx cc tst(k)= 0.d0 cc IF(DABS(Ink(IPV,k)) .gt. 0.d0) cc 1 tst(k)= Jntegral(IPV,k)/Ink(IPV,k)-1.d0 cc enddo cc write(32, 322) (tst(k), k= k1,kmx) cc ENDDO cc320 FORMAT(' At E=',F12.6,1P3D16.8) cc321 FORMAT(21x,1P3D16.8) cc322 FORMAT(21x,3(1PD10.2,6x)) c???????????????????????? RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE DVIRDP(IDAT,ISTATE,ZMU,BVIR,dBVIRdP) c======================================================================= c This subroutine calculates the second virial coefficient BVIR and its c partial derivatives with respect to the various parameters. It is c used when virial data has been input into the program. It performs a c classical calcultion with two quantum corrections. Update: 15/05/16 c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= c* Define types for local variables INTEGER check,j,counter,nParams,ISTATE,ISTART,IDAT,i,m,k,kk,jj,n, 1 VIRCNT(NSTATEMX) REAL*8 XG(8),WG(8),x(4),w(4),BTemp,BTempInv, 1 CONST(3),jump,a,b,YVAL(8),RDIST(8),Class,Q1corr,Q2corr, 2 VDIST(8),EXP_TERM,int_fact,Vsq,VPsq,Rsq,RINV,XTEMP,Bclass,Bq1, 3 Bq2,INTEGRALS(NPARMX+3),error,BVIR,dVdR(8),d2VdR(8), 4 XTEMP1,dBcdP(NPARMX),dBq1dP(NPARMX),dBVIRdP(NPARMX),ZMU,dBVIR c REAL*8, PARAMETER :: k_boltz=1.3806488D-23, NA=6.02214129D23, 1 h = 6.62606957D-34, c = 2.99792458D10, k_cm = k_boltz/(h*c), 2 h_cm = 1.d0/c, pi = 3.14159265358979323846, amu=1.660538921D-27, 3 Cu= 16.857629206D0 c* Common block data for quadrature weights and points data x/0.960289856497536d0, 0.796666477413627d0, 1 0.525532409916329d0, 0.183434642495650d0/, 2 w/0.101228536290376d0, 0.222381034453374d0, 3 0.313706645877887d0, 0.362683783378362d0/ c*********************************************************************** ERROR= 0.001d0 IF(VIRCNT(ISTATE).EQ.0) THEN VIRCNT(ISTATE)= VIRCNT(ISTATE) + 1 WRITE(32,100) ENDIF ISTART = POTPARI(ISTATE)- 1 c.. runs a loop to set all quadrature weights and points DO j= 1,4 XG(j)= -x(j) WG(j)= w(j) XG(9-j)= x(j) WG(9-j)= w(j) ENDDO c.. initializes the array dBVIRdP to zero. DO J= 1,HPARMX+3 dBVIRdP(J)= 0.d0 ENDDO c.. takes the current temperature from the virial data and changes it to E cm BTemp = k_cm*Temp(IDAT) c.. inverts BTemp BTempInv = 1.d0/BTemp c.. sets the constants for the intergration of each correction term Const(1)= -2.d0*pi*0.6022140857d0 !! updated Avogadro No. Const(2)= pi*0.6022140857d0*Cu*BTempInv**3/(6.d0*ZMU) Const(3)= -(pi*0.6022140857d0/6.d0)*(Cu*BTempInv**2/ZMU)**2 c.. sets the number of paramters used for the integration and initializes c. the integrals to zero nParams = 3 + NCMM(ISTATE) + Nbeta(ISTATE) check = 1 c.. this first loop is here to repeat the calculations until the values c** Outermost loop: repeatedly bisect overall [-1,+1] interval NBISMX c times until convergence to within absolute error ERROR is achieved n= 12 DO kk= 1,n DO J= 1,nParams+3 INTEGRALS(J)= 0.d0 ENDDO IF(check.EQ.-1) EXIT counter= 2**kk c.. futher subdivides the interval for gaussian integration formula jump= 2.d0/DBLE(counter) b= -1.d0 c. the first loop is over each subinterval within (-1,1) DO m= 1,counter a= b b= a+ jump IF(m.EQ.counter) b= 1.d0 DO i= 1,8 c.. sets the y value for the gaussian formula YVAL(i)= 0.5d0*((b - a)*XG(i) + (b + a)) c... q=1 mapping r <-> y= (r/re - 1)/(r/re + 1) RDIST(i)= Re(ISTATE)*DSQRT((1.0d0 + YVAL(i))/ 1 (1.d0 - YVAL(i))) VDIST(i)= 0.d0 ENDDO c.. calls VGENP to find the neccesary PEC value and radial derivatives CALL VGENP(ISTATE,RDIST,VDIST,dVdR,d2VdR,IDAT) c.. the next loop over each Gaussian point within each subinterval DO i= 1,8 c.. some of the terms that will be used in later calculations of the c. virial coefficients are constructed here IF(RDIST(I).LT.0.8d0*RE(ISTATE)) THEN c** Check for and correct for potential turnover problems IF((VDIST(I).LT.0.d0).OR.(DVDR(I).GT.0.d0) c... or for potential becoming singular at very short dist (r < 0.1 Ang) 1 .OR.(RDIST(I).LE.0.1d0).OR.(D2VDR(I).LT.0.d0)) THEN VDIST(I)= 1.d6 dVdR(I)= -1.d6 d2VdR(I)= 1.d6 ENDIF ENDIF EXP_TERM= DEXP(-VDIST(i)*BTempINV) RINV= 1.d0/RDIST(i) int_fact= (Re(ISTATE)/(1.d0 - YVAL(i)))**2 1 *RINV*(b - a)*0.5d0 Vsq= VDIST(i)**2 VPsq= dVdR(i)**2 Rsq= RDIST(i)**2 XTEMP= d2VdR(i)**2/10.d0 + VPsq*RINV**2/5.d0 1 + dVdR(i)**3*BTempInv*RINV/9.d0 - (VPsq*BTempInv)**2/72.d0 c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c* Finally the relevant partial derivatives of the virial c* coefficients w.r.t. potential param are calculated DO J = 1,nParams jj = ISTART + J c* the derivative of the classical expression dBcdP(J)= -BTempInv*EXP_TERM 1 *DVtot(jj,i)*Rsq*int_fact c* and of the first quantum correction XTEMP1 = -VPsq*BTempInv*DVtot(jj,i) 1 + 2*dVdR(i)*dVpdP(jj,i) dBq1dP(J)= EXP_TERM*XTEMP1*Rsq*int_fact c.. As the final step these terms all added together in a weighted sum INTEGRALS(J) = INTEGRALS(J) + Const(1) 1 *dBcdP(J)*WG(I) + Const(2)*dBq1dP(J)*WG(I) ENDDO c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c. now the integrands are evaluated at each particular Gaussian point c. and summed together with the proper weighting Bclass= (EXP_TERM - 1.d0)*Rsq*int_fact INTEGRALS(nParams+1)= INTEGRALS(NParams+1) 1 + Bclass*WG(i) Bq1= EXP_TERM*VPsq*Rsq*int_fact INTEGRALS(nParams+2)= INTEGRALS(nParams+2) 1 + Bq1*WG(i) Bq2= EXP_TERM*XTEMP*Rsq*int_fact INTEGRALS(nParams+3)= INTEGRALS(nParams+3) 1 + Bq2*WG(i) ENDDO !! end of 'i' loop over 8 gaussian points ENDDO !! end of 'm' loop over 'counter' radial subintervals IF(PSEL(ISTATE).LE.3) THEN DO j= 1,nParams ! partial derivatives for fit cases dBVIRdP(j)= INTEGRALS(j) ENDDO ENDIF dBVIR=BVIR Class= Const(1)*INTEGRALS(nParams+1) Q1corr= Const(2)*INTEGRALS(nParams+2) Q2corr= Const(3)*Integrals(nParams+3) BVIR= Class + Q1corr+ Q2corr c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c. Check to see if BVIR has converged IF(counter.GE.2) THEN error=0.000001 IF(DABS(BVIR-dBVIR).LE.(abs(error*BVIR))) THEN check= -1 ENDIF ENDIF ENDDO !! end of 'kk' loop over # sets of subdivisions WRITE(32,102) Temp(IDAT),Class,Q1corr,Q2corr,BVIR,counter 100 FORMAT('Temperature Classical FirstQ SecondQ Total counter 1', /24('===')) 102 FORMAT(2X,F7.2,2X,F8.3,2X,F8.3,2X,F8.3,2X,F8.3,I6) RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE DVACDP(IDAT,ISTATE,ZMU,BVIR,dBVIRdP) c======================================================================= c This subroutine calculates the acoustic second virial coefficient BVIR c and its partial derivatives with respect to the various parameters. It is c used when virial data have been input into the program. It performs a c classical calculation plus two quantum corrections c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= c* Define types for local variables INTEGER check,j,counter,nParams,ISTATE,ISTART,IDAT,i,m,k,kk,jj, 1 n,IPASS,VACCNT(NSTATEMX) REAL*8 XG(8),WG(8),x(4),w(4),BTemp,BTempInv,BV,BVP,BVPP,BVsq, 1 CONST(3),jump,a,b,YVAL(8),RDIST(8),BVPsq,BVPcu,BVPTtF,BVPPsq, 2 VDIST(8),EXP_TERM,int_fact,Vsq,VPsq,Rsq,RINV,XTEMP,Bclass,Bq1, 3 Bq2,INTEGRALS(NPARMX+3),error,BVIR,dVdR(8),d2VdR(8),Risq, 4 XTEMP1,dBcdP(NPARMX),dBq1dP(NPARMX),dBVIRdP(NPARMX),ZMU,dBVIR 5 ,Ccorr,Qcorr,Q2corr c REAL*8, PARAMETER :: k_boltz=1.3806488D-23, NA=6.02214129D23, 1 h = 6.62606957D-34, c = 2.99792458D10, k_cm = k_boltz/(h*c), 2 h_cm = 1.d0/c, pi = 3.14159265358979323846, amu=1.660538921D-27, 3 Cu= 16.857629206D0 c* Common block data for quadrature weights and points data x/0.960289856497536d0, 0.796666477413627d0, 1 0.525532409916329d0, 0.183434642495650d0/, 2 w/0.101228536290376d0, 0.222381034453374d0, 3 0.313706645877887d0, 0.362683783378362d0/ c*********************************************************************** ERROR= 0.001d0 IF(VACCNT(ISTATE).EQ.0) THEN VACCNT(ISTATE)= VACCNT(ISTATE) + 1 WRITE(34,100) ENDIF ISTART = POTPARI(ISTATE)- 1 c.. runs a loop to set all quadrature weights and points DO j= 1,4 XG(j)= -x(j) WG(j)= w(j) XG(9-j)= x(j) WG(9-j)= w(j) ENDDO c.. initializes the array dBVIRdP to zero. DO J= 1,HPARMX dBVIRdP(J)= 0.d0 ENDDO c.. takes the current temperature from the virial data and changes it to E cm-1 BTemp = k_cm*Temp(IDAT) c.. inverts BTemp BTempInv = 1.d0/BTemp c.. sets the constants for the integration of each correction term Const(1)= 4.d0*pi*0.602214179d0 Const(2)= Cu*pi*0.602214129d0*BTempInv/(3.d0*ZMU) Const(3)= (pi*0.602214129d0/36.d0)*(Cu*BTempInv/ZMU)**2 c.. sets the number of parameters used for the integration and initializes c. the integrals to zero nParams = 3 + NCMM(ISTATE) + Nbeta(ISTATE) check = 1 c.. this first loop is here to repeat the calculations until the values c** Outermost loop: repeatedly bisect overall [-1,+1] interval NBISMX c times until convergence to within absolute error ERROR is achieved n= 12 DO kk= 1,n DO J= 1,nParams+3 INTEGRALS(J)= 0.d0 ENDDO IF(check.EQ.-1) EXIT counter= 2.d0**kk c.. further subdivides the interval for gaussian integration formula jump= 2.d0/DBLE(counter) b= -1.d0 c. the first loop is over each subinterval within (-1,1) DO m= 1,counter a= b b= a+ jump IF(m.EQ.counter) b= 1.d0 DO i= 1,8 c.. sets the y value for the gaussian formula YVAL(i)= 0.5d0*((b - a)*XG(i) + (b + a)) c... mapping r<->y=(r/re - 0.9999)/(r/re + 1.0001) c where 'real' range is 0.01*Re to infty - with 'p=2' RDIST(i)= Re(ISTATE)*DSQRT((1.0001d0 1 + 0.9999d0*YVAL(i))/(1.d0 - YVAL(i))) VDIST(i)= 0.d0 ENDDO IPASS= 0 c.. calls VGENP to find the necessary derivatives CALL VGENP(ISTATE,RDIST,VDIST,dVdR,d2VdR,IDAT) c.. the next loop is over each Gaussian point within each subinterval DO i= 1,8 c.. some of the terms that will be used in later calculations of the c. virial coefficients are constructed here IF(RDIST(I).LT.0.8d0*RE(ISTATE)) THEN c** Check for and correct for potential turnover problems IF((VDIST(I).LT.0.d0).OR.(DVDR(I).GT.0.d0) 1 .OR.(D2VDR(I).LT.0.d0)) THEN VDIST(I)= 1.d6 dVdR(I)= -1.d6 d2VdR(I)= 1.d6 ENDIF ENDIF EXP_TERM= DEXP(-VDIST(i)*BTempINV) RINV= 1.d0/RDIST(i) int_fact= (Re(ISTATE)/(1.d0 - YVAL(i)))**2 1 *RINV*(b - a)*0.5d0 Vsq= VDIST(i)**2 VPsq= dVdR(i)**2 Rsq= RDIST(i)**2 Risq= 1.d0/Rsq BV= BTempInv*VDIST(I) BVP= BTempInv*dVdR(I) BVPP= BTempInv*d2VdR(I) BVsq= BV**2 BVPsq= BVP**2 BVPcu= BVP**3 BVPTtF= BVP**4 BVPPsq= BVPP**2 XTEMP= ((-6.d0/5.d0)*BVPPsq - (12.d0/5.d0)*Risq*BVPsq 1 - (20.d0/9.d0)*RINV*BVPcu + (13.d0/30.d0)*BVPTtF) + BV*((4.d0/ 2 5.d0)*BVPPsq + (8.d0/5.d0)*Risq*BVPsq + (56.d0/45.d0)*RINV*BVPcu 3 - (1.d0/5.d0)*BVPTtF) + BVsq*((-4.d0/25.d0)*BVPPsq - (8.d0/25.d0) 4 *Risq*BVPsq - (8.d0/45.d0)*RINV*BVPcu + (1.d0/45.d0)*BVPTtF) c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c* Finally the relevant partial derivatives of the virial c* coefficients w.r.t. potential params are calculated DO J = 1,nParams jj = ISTART + J c* the derivative of the classical expression dBcdP(J)= EXP_TERM*Rsq*BTempInv*DVtot(jj,i)*(1.d0+ 1(2.d0/5.d0)*BV +(2.d0/15.d0)*BVsq - (2.d0/5.d0) - (4.d0/15.d0)*BV) 2 *int_fact c* and of the first quantum correction XTEMP1= (3.d0/5.d0) - (2.d0/5.d0)*BV + 1 (2.d0/15.d0)*BVsq XTEMP1= -BVP*XTEMP1*DVtot(jj,i) + 2.d0*dVpdP(jj,i) 1 *XTEMP1 + BVP*DVtot(jj,i)*((-2.d0/5.d0) + (4.d0/15.d0)*BV) dBq1dP(J)= EXP_TERM*Rsq*BTempInv*BVP*XTEMP1* 1 int_fact c.. As the final step these terms all added together in a weighted sum INTEGRALS(J) = INTEGRALS(J) + Const(1) 1 *dBcdP(J)*WG(I) + Const(2)*dBq1dP(J)*WG(I) ENDDO c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c. now the integrands are evaluated at each particular Gaussian point c. and summed together with the proper weightings Bclass= ( 1.d0 - EXP_TERM*(1.d0 + 2.d0*BV/5.d0 + 1 (2.d0/15.d0)*BVsq))*Rsq*int_fact INTEGRALS(nParams+1)= INTEGRALS(NParams+1) 1 + Bclass*WG(i) Bq1= EXP_TERM*BVPsq*Rsq*int_fact*((3.d0/5.d0) - 1 (2.d0*BV/5.d0) + (2.d0/15.d0)*BVsq) INTEGRALS(nParams+2)= INTEGRALS(nParams+2) 1 + Bq1*WG(i) Bq2= EXP_TERM*XTEMP*Rsq*int_fact INTEGRALS(nParams+3)= INTEGRALS(nParams+3) 1 + Bq2*WG(i) ENDDO ENDDO DO j= 1,nParams dBVIRdP(j)= INTEGRALS(j) ENDDO dBVIR=BVIR BVIR= Const(1)*INTEGRALS(nParams+1) + 2 Const(2)*INTEGRALS(nParams+2) + 3 Const(3)*Integrals(nParams+3) Ccorr= Const(1)*INTEGRALS(nParams+1) Qcorr= Const(2)*INTEGRALS(nParams+2) Q2corr= Const(3)*Integrals(nParams+3) c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c. Check to see if BVIR has converged IF(counter.GE.2) THEN error=0.000001 IF(DABS(BVIR-dBVIR).LE.(abs(error*BVIR))) THEN check= -1 ENDIF ENDIF ENDDO WRITE(34,102) Temp(IDAT),Ccorr,Qcorr,Q2corr,BVIR 100 FORMAT('Temperature Classical FirstQ SecondQ Total', 1 /24('===')) 102 FORMAT(2X,F7.2,2X,F8.3,2X,F8.3,2X,F8.3,2X,F8.3) RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE VGENP(ISTATE,RDIST,VDIST,dVdR,d2VdR2,IDAT) c*********************************************************************** c** This subroutine will generate function values and derivatives c of Morse/Long-Range potentials as required for semiclassical c calculation (with quantum corrections) of virial coefficients and c their analytical derivatives in direct hamiltonian fitting c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c+++ COPYRIGHT 2009-2016 by R.J. Le Roy, Aleksander Cholewinski and ++ c Philip T. Myatt 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 ----- Version of 17 March 2016 ----- c (after PTW addition of G-TT and specialized HFD potentials) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c ISTATE is the electronic state being considered in this CALL. c RDIST: at the 8 input RDIST(i) distances, calculate potl & derivs c * return potential function at those points as VDIST, and the c first and second radial derivartives as dVdR & d2VdR c??? * skip partial derivative calculation if IDAT.le.0 c * If RDIST.le.0 calculate partial derivatives at distances c given by array RD(i,ISTATE) & return them in array DVtot c** On entry via common blocks: c APSE(s).le.0 to use {p,q}-type exponent polynomial of order Nbeta(s) c if APSE(s) > 0 \beta(r) is Pashov spline defined by Nbeta(s) points c* Nbeta(s) is order of the beta(r) exponent polynomial or # spline points c MMLR(j,s) are long-range inverse-powers for an MLR or DELR potential c nPB(s) the basic value of power p for the beta(r) exponent function c nQB(s) the power p for the power series expansion variable in beta(r) c pAD(s) & qAD(s) the values of power p for adiabatic u(r) BOB functions c nNA(s) & qNA(s) the values of power p for centrifugal q(r) BOB functions c Qqw(s) the power defining the radial variable y_{Pqw}(r) in the c Lambda-doubling radial strength function f_{\Lambda}(r) c DE is the Dissociation Energy for each state. c RE is the Equilibrium Distance for each state. c BETA is the array of potential (exponent) expansion parameters c NDATPT is the number of meshpoints used for the array. c----------------------------------------------------------------------- c** On exit via common blocks: c R is the distance array c VPOT is the potential that is generated. c BETAFX is used to contain the beta(r) function. c** Internal partial derivative arrays ... c DUADRe & DUBDRe are p.derivs of adiabatic fx. w.r.t. Re c DVDQA & DVDQB are p.derivs of non-adiabatic fx. wrt q_A(i) & q_B(i) c DTADRe & DTBDRe are p.derivs of non-adiabatic fx. w.r.t. Re c dVdL & dLDDRe are p.derivatives of f_\lambda(r) w.r.t. beta_i & Re c DBDB & DBDRe are p.derives of beta(r) w.r.t. \beta_i & Re, respectively c c** Temp: c BTEMP is used to represent the sum used for dV/dRe. c is used in GPEF for De calculations. c BINF is used to represent the beta(\infty) value. c YP is used to represent (R^p-Re^p)/(R^p+Re^p) or R-Re. c XTEMP is used to represent (uLR/uLR_e)* exp{-BINF*RTEMP} c PBTEMP is used to calculate dV/dBi. c PETEMP is used to calculate dV/dBi. c AZERO is used for the trial exponential calculations. c AONE is used for the trial exponential calculations. c ATWO is used for the trial exponential calculations. c AZTEMP is used in the MMO trial exponential calculations. c is used in the GPEF = (a+b)/k c AOTEMP is used in the GPEF = [a(k+1)-b(k-1)]/k c ATTEMP is used in the GPEF = [a^2(k+1)-b^2(k-1)]/k c ARTEMP is used in the GPEF = [a^3(k+1)-b^3(k-1)]/k c FSW is used to represent the MLJ switching function. c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKBOBRF.h' c======================================================================= c** Born-Oppenheimer breakdown radial functions REAL*8 UAR(NPNTMX,NSTATEMX),UBR(NPNTMX,NSTATEMX), 1 TAR(NPNTMX,NSTATEMX),TBR(NPNTMX,NSTATEMX),wRAD(NPNTMX,NSTATEMX) c COMMON /BLKBOBRF/UAR,UBR,TAR,TBR,wRAD c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c----------------------------------------------------------------------- c** Define local variables ... INTEGER I,J,I1,ISTATE,IPV,IPVSTART,ISTART,ISTOP,LAMB2,m,npow, 1 IDAT, NBAND, IISTP,MMLR1D(NCMMax) REAL*8 BTEMP,BINF,RVAL(8),RTEMP,RM2,XTEMP,PBTEMP,PETEMP,RET, 1 FSW,Xtemp2,Btemp2,BMtemp,BMtemp2,RMF,PBtemp2,C3VAL,C3bar,C6bar, 2 C6adj,C9adj,YP,YQ,YPA,YPB,YQA,YQB,YPE,YPM,YPMA,YPMB,YPP,YQP,YQPA, 3 YQPB,REp,Req,RDp,RDq,DYPDRE,DYQDRE,VAL,DVAL,HReP,HReQ,SL,SLB, 4 AREF,AREFp,AREFq, RE3,RE6,RE8,T0,T0P,T1,ULRe,Scalc,dLULRedCm(9), 5 dLULRedRe,dLULRedDe,dULRdDe,dULRdCm(9),RD3,RD6,RD8,DVDD,RDIST(8), 6 VDIST(8),BFCT,JFCT,JFCTLD,RETSig,RETPi,RETp,RETm,A0,A1,A2,T2, 7 REpADA,REpADB,REqADA,REqADB,D2VAL,dYPdR,A3,X,VATT,dVATT,D2VATT, 8 dYPEdR,dYQdR,d2YPdR,d2YQdR,d2YPEdR,RINV,dDULRdR,d2DULRdR,dULRdR, 9 d2ULRdR,DXTEMP,D2XTEMP,dVdR(8),d2VdR2(8),dLULRdR,YPPP,dBdR,d2BdR, x DX,T1P,T1PP, dULRdRCm(9),dXdP(HPARMX),dXpdP(HPARMX),dLULRdCm(9), y DYPEDRE,dVALdRe,dYBdRe,dBpdRe,DYPpDRE,DYPEpdRE,DYQpDRE,dYBpdRe, z xBETA(NbetaMX),rKL(NbetaMX,NbetaMX),BR,r,bohr,rhoINT,f2,f2p,f2pp c*********************************************************************** c** Common block for partial derivatives of potential at the one distance RDIST c and HPP derivatives for uncertainties REAL*8 dVdPk(HPARMX),dDe(0:NbetaMX),dDedRe COMMON /dVdPkBLK/dVdPk,dDe,dDedRe c======================================================================= c** Temporary variables for MLR and DELR potentials INTEGER MMLRP,IDATLAST REAL*8 ULR,dAAdRe,dBBdRe,dVdBtemp,CmVALL,tDm,tDmp,tDmpp, 1 Dm(NCMMAX),Dmp(NCMMAX),Dmpp(NCMMAX) ccc DATA IDATLAST/999999999/ ccc SAVE IDATLAST,REP,AREF,AREFp,AREFq c*********************************************************************** c** Initializing variables on first entry for each cycle. ccc IF(IDAT.LE.IDATLAST) THEN ccc IDATLAST= IDAT ccc put much of the initialization stuff here to be done once per cycle DATA bohr/0.52917721092d0/ !! 2010 physical constants d:mohr12 REP= RE(ISTATE)**nPB(ISTATE) IF(RREF(ISTATE).LE.0) AREF= RE(ISTATE) IF(RREF(ISTATE).GT.0) AREF= RREF(ISTATE) AREFp= AREF**nPB(ISTATE) AREFq= AREF**nQB(ISTATE) c** Normally data point starts from 1 ISTART= 1 ISTOP= 8 c** When calculating only one potential point VDIST= 0.0d0 PBTEMP= 0.0d0 PETEMP= 0.0d0 DO I= ISTART,ISTOP BETAFX(I,ISTATE)= 0.0d0 UAR(I,ISTATE)= 0.d0 UBR(I,ISTATE)= 0.d0 TAR(I,ISTATE)= 0.d0 TBR(I,ISTATE)= 0.d0 UAR(I,ISTATE)= 0.d0 WRAD(I,ISTATE)= 0.d0 ENDDO IF((PSEL(ISTATE).GE.2).AND.(rhoAB(ISTATE).GT.0.d0)) THEN c ... save uLR powers in a 1D array for calls to SUBROUTINE dampF DO m= 1, NCMM(ISTATE) MMLR1D(m)= MMLR(m,ISTATE) ENDDO ENDIF c** Initialize parameter counter for this state ... IPVSTART= POTPARI(ISTATE) - 1 c======================================================================= c First ... for the case of an MLR potential ... c----------------------------------------------------------------------- IF(PSEL(ISTATE).EQ.2) THEN c** First - define values & derivatives of uLR at Re for MLR potential ULRe= 0.d0 T1= 0.d0 IF(rhoAB(ISTATE).GT.0.d0) THEN CALL dampF(RE(ISTATE),rhoAB(ISTATE),NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) ENDIF DO m= 1,NCMM(ISTATE) dLULRedCm(m)= 1.d0/RE(ISTATE)**MMLR(m,ISTATE) IF(rhoAB(ISTATE).GT.0.d0) dLULRedCm(m)= Dm(m)*dLULRedCm(m) T0= CmVAL(m,ISTATE)*dLULRedCm(m) ULRe= ULRe + T0 T1= T1 + MMLR(m,ISTATE)*T0 ENDDO dLULRedRe= -T1/(ULRe*RE(ISTATE)) DO m= 1,NCMM(ISTATE) dLULRedCm(m)= dLULRedCm(m)/ULRe IF(rhoAB(ISTATE).GT.0) THEN dLULRedRe= dLULRedRe + dLULRedCm(m)*Dmp(m)/Dm(m) ENDIF ENDDO BINF= DLOG(2.0d0*DE(ISTATE)/ULRe) betaINF(ISTATE)= BINF DO I= ISTART,ISTOP RVAL(I)= RDIST(I) RINV= 1.d0/RVAL(I) RDp= RVAL(I)**nPB(ISTATE) RDq= RVAL(I)**nQB(ISTATE) YPE= (RDp-REP)/(RDp+REP) YP= (RDp-AREFp)/(RDp+AREFp) YQ= (RDq-AREFq)/(RDq+AREFq) YPM= 1.d0 - YP DYPDRE= -0.5d0*nPB(ISTATE)*(1.d0 - YP**2)/RE(ISTATE) DYQDRE= -0.5d0*nQB(ISTATE)*(1.d0 - YQ**2)/RE(ISTATE) DYPEDRE= -0.5d0*nPB(ISTATE)*(1.d0 - YPE**2)/RE(ISTATE) DYPDR= -DYPDRE*RE(ISTATE)*RINV DYPEDR= 0.5d0*nPB(ISTATE)*RINV*(1.d0 - YPE**2) DYQDR= -DYQDRE*RE(ISTATE)*RINV D2YPDR= -DYPDR*RINV*(1.d0 + nPB(ISTATE)*YP) D2YPEDR= -DYPEDR*RINV*(1.d0 + nPB(ISTATE)*YPE) D2YQDR= -DYQDR*RINV*(1.d0 + nQB(ISTATE)*YQ) DYPpDRE= -nPB(ISTATE)*YP*RINV*DYPDRE DYPEpDRE= -nPB(ISTATE)*YPE*RINV*DYPEDRE DYQpDRE= -nQB(ISTATE)*YQ*RINV*DYQDRE D2VAL= 0.d0 YPP= 1.d0 DVAL= 0.d0 DBDB(0,I,ISTATE)= 1.0d0 VAL= BETA(0,ISTATE) + YQ*BETA(1,ISTATE) DVAL= BETA(1,ISTATE) npow= Nbeta(ISTATE) c------------------------------------------------------------------- DO J= 2,npow c... now calculate power series part of the Morse-like exponent,along c with its radial derivatives D2VAL= D2VAL + BETA(J,ISTATE)* DBLE(J) 1 *DBLE(J - 1) *YPP YPP= YPP*YQ DVAL= DVAL + BETA(J,ISTATE)* DBLE(J)* YPP YPPP= YPP* YQ VAL= VAL + BETA(J,ISTATE)*YPPP DBDB(J,I,ISTATE)= YPM*YPPP ENDDO YPP= YPPP c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c*** DBDB & DBDRe= dBeta/dRe used in uncertainty calculation in fununc.f DBDRe(I,ISTATE)= -YP*dLULRedRe dVALdRe= DBDRe(I,ISTATE) + (BINF - VAL)*DYPDRE 1 + (1.d0 - YP)*DVAL*DYQDRE IF(RREF(ISTATE).LE.0.d0) DBDRe(I,ISTATE)= dVALdRe c----------------------------------------------------------------------- c... now the power series and its radial derivatives are used in the c construction of the derivatives with respect to the parameters dBpdRe= DYPpDRE*(BINF - VAL) - DYPDR*dLULRedRe 1 + (-DYPDR*DYQDRE + (1.d0 - YP)*DYQpDRE - DYPDRE*DYQDR)*DVAL 2 + (1.d0 - YP)*DYQDR*DYQDRE*D2VAL D2VAL= (BINF - VAL)*D2YPDR - 2.d0*DYPDR*DYQDR*DVAL 1 + (1.d0- YP)*(D2YQDR*DVAL + DYQDR**2*D2VAL) DVAL= (BINF - VAL)*DYPDR + (1.d0- YP)*DYQDR*DVAL VAL= YP*BINF + (1.d0- YP)*VAL dBdR= dYPEdR*VAL + YPE*DVAL d2BdR= d2YPEdR*VAL + 2.d0*dYPEdR*DVAL + YPE*D2VAL dYBdRe= DYPEDRE*VAL + YPE*dVALdRe dYBpdRe= VAL*DYPEpDRE + DYPEDRE*DVAL + DYPEDR*dVALdRe 1 + YPE*dBpdRe c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BETAFX(I,ISTATE)= VAL XTEMP= DEXP(-VAL*YPE) c** Now begin by generating uLR(r) ULR= 0.d0 c------------------------------------------------------------------- dULRdR= 0.d0 d2ULRdR= 0.d0 dULRdRCm= 0.d0 c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ IF(rhoAB(ISTATE).GT.0.d0) THEN CALL dampF(RVAL(I),rhoAB(ISTATE),NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) ENDIF DO m= 1,NCMM(ISTATE) IF(rhoAB(ISTATE).LE.0.d0) THEN c----------------------------------------------------------------------- dULRdCm(m)= 1.d0*RINV**MMLR(m,ISTATE) dULRdRCm(m)= -dULRdCm(m)*RINV*DBLE(MMLR(m,ISTATE)) dDULRdR= 0.d0 d2DULRdR= 0.d0 ELSE dULRdCm(m)= Dm(m)*RINV**MMLR(m,ISTATE) dULRdRCm(m)= -dULRdCm(m)*RINV*DBLE(MMLR(m,ISTATE)) 2 + Dmp(m)*RINV**MMLR(m,ISTATE) dDULRdR= Dmp(m)*RINV**MMLR(m,ISTATE) d2DULRdR= Dmpp(m)*RINV**MMLR(m,ISTATE) ENDIF ULR= ULR + CmVAL(m,ISTATE)*dULRdCm(m) dULRdR= dULRdR + CmVAL(m,ISTATE)*(dDULRdR 1 - dULRdCm(m)*RINV*DBLE(MMLR(m,ISTATE))) d2ULRdR= d2ULRdR + CmVAL(m,ISTATE)*(d2DULRdR 1 - 2.d0*dDULRdR*RINV*DBLE(MMLR(m,ISTATE)) + dULRdCm(m)*RINV**2 2 *DBLE(MMLR(m,ISTATE))*DBLE((MMLR(m,ISTATE) + 1))) ENDDO dLULRdR= dULRdR/ULR DO m= 1,NCMM(ISTATE) dLULRdCm(m)= dULRdCm(m)/ULR ENDDO c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ XTEMP= XTEMP*ULR/ULRe c... note ... reference energy for each state is asymptote ... DVDD= XTEMP*(XTEMP - 2.D0) c--- VPOT(I,ISTATE)= DE(ISTATE)*DVDD + VLIM(ISTATE) c--- VDIST(I)= VPOT(I,ISTATE) VDIST(I)= DE(ISTATE)*DVDD + VLIM(ISTATE) c BETADIST= VAL IF(IDAT.LE.0) GO TO 999 c- ENDDO YPP= 2.d0*DE(ISTATE)*(1.0d0-XTEMP)*XTEMP IPV= IPVSTART+2 c... derivatives w.r.t R DXTEMP= XTEMP*(dLULRdR - dBdR) D2XTEMP= XTEMP*(dBdR**2 - d2BdR + (d2ULRdR 1 - 2*dBdR*dULRdR)/ULR) dVdR(I)= 2.d0*DE(ISTATE)*DXTEMP*(XTEMP - 1.d0) d2VdR2(I)= 2.d0*DE(ISTATE)*(DXTEMP**2 + D2XTEMP 1 *(XTEMP - 1.d0)) c *** This is just to write the derivatives for testing c IF(RDIST.LT.0) WRITE (40,640) (RVAL,VVAL,dVdR,d2VdR2, c 1 YVAL) c 640 FORMAT(G12.5, G18.10, G18.10, G18.10, G14.7) c ... derivative w.r.t. Cm's DO m= 1, NCMM(ISTATE) IPV= IPV+ 1 dXdP(IPV)= XTEMP*(dLULRdCm(m) + (YPE*YP - 1.d0) 1 *dLULRedCm(m)) dXpdP(IPV)= DEXP(-VAL*YPE)/ULRe*(dULRdRCm(m) 1 - dBdR*dULRdCm(m)) + (DXTEMP*(YPE*YP - 1.d0) 2 + XTEMP*(dYPEdR*YP + YPE*dYPdR))*dLULRedCm(m) dVpdP(IPV,I)= 2.d0*DE(ISTATE)*(dXdP(IPV)*DXTEMP 1 + (XTEMP - 1.d0)*dXpdP(IPV)) DVtot(IPV,I)= -YPP*(dLULRedCm(m)*(YP*YPE- 1.d0) 1 + dULRdCm(m)/ULR) ENDDO c... derivative w.r.t. Re dXdP(IPVSTART+2)= -XTEMP*(dYBdRe + dLULRedRe) dXpdP(IPVSTART+2)= -DXTEMP*(dYBdRe + dLULRedRe) 1 - XTEMP*dYBpdRe dVpdP(IPVSTART+2,I)= 2.d0*DE(ISTATE)*(dXdP(IPVSTART+2) 1 *DXTEMP + (XTEMP - 1.d0)*dXpdP(IPVSTART+2)) DVtot(IPVSTART+2,I)= YPP*(dYBdRe + dLULRedRe) c... derivative w.r.t. De dXdP(IPVSTART+1)= -XTEMP*YPE*YP dXpdP(IPVSTART+1)= -(XTEMP*(YPE*DYPDR + DYPEDR*YP) 1 + YPE*YP*DXTEMP) DVDD= DVDD + YPP*YP*YPE/DE(ISTATE) YPP= YPP*YPE*(1.d0 - YP) dVpdP(IPVSTART+1,I)= 2.d0*(dXdP(IPVSTART+1)*DXTEMP 1 + (XTEMP - 1.d0)*dXpdP(IPVSTART+1)) 2 + 2.d0*(XTEMP - 1.d0)*DXTEMP DVtot(IPVSTART+1,I)= DVDD c... finally ... derivatives w.r.t. exponent expansion coefficients DO J= 0,npow IPV= IPV+1 dXdP(IPV)= XTEMP*YPE*(1.d0 - YP)*YQ**J dXpdP(IPV)= (XTEMP*((1.d0 - YP)*DYPEDR - DYPDR*YQ) 1 + YPE*(1.d0 - YP)*DXTEMP)*YQ**J + XTEMP*J*(YPE 2 *(1.d0 - YP))*YQ**(J - 1) dVpdP(IPV,I)= 2.d0*DE(ISTATE)*(dXdP(IPV)*DXTEMP 1 + (XTEMP - 1.d0)*dXpdP(IPV)) DVtot(IPV,I)= YPP YPP= YPP*YQ ENDDO ENDDO ENDIF c-----------Finished calculations for MLR potential C====================================================================== c For the Tang Toennies potential c---------------------------------------------------------------------- IF(PSEL(ISTATE).EQ.6) THEN rhoINT= rhoAB(ISTATE)/3.13d0 !! remove btt(IVSR(ISTATE)/2) DO I= 1,8 VATT= 0.d0 dVATT= 0.d0 d2VATT= 0.d0 r= RDIST(I) IF(rhoAB(ISTATE).GT.0.d0) THEN CALL dampF(r,rhoINT,NCMM(ISTATE),NCMMAX, 1 MMLR1D,IVSR(ISTATE),IDSTT(ISTATE),Dm,Dmp,Dmpp) DO m= 1,NCMM(ISTATE) T0= CMval(m,ISTATE)/r**MMLR1D(m) VATT= VATT + T0*Dm(m) dVATT= dVATT + T0*(Dmp(m) - Dm(m)*MMLR1D(m)/r) d2VATT= d2VATT + T0*(Dmpp(m) - MMLR1D(m)*(2.d0* 1 Dmp(m)- Dm(m)*(MMLR1D(m)+1)/r)/r) ENDDO ELSE DO m= 1,NCMM(ISTATE) T0= CMval(m,ISTATE)/r**MMLR1D(m) VATT= VATT + T0 dVATT= dVATT + T0*MMLR1D(m)/r d2VATT= d2VATT + T0*MMLR1D(m)*(MMLR1D(m)+1)/r**2 ENDDO ENDIF T0= r*(BETA(1,ISTATE) + r*BETA(2,ISTATE)) 1 + (BETA(3,ISTATE) + BETA(4,ISTATE)/r)/r T1= BETA(1,ISTATE) + 2.d0*r*BETA(2,ISTATE) 1 - (BETA(3,ISTATE) + 2.d0*BETA(4,ISTATE)/r)/r**2 T2= 2*BETA(2,ISTATE) + (2.d0*BETA(3,ISTATE) 1 + 6.d0*BETA(4,ISTATE)/r)/r**3 A0= BETA(5,ISTATE) + r*(BETA(6,ISTATE) 1 + r*(BETA(8,ISTATE) + r*BETA(9,ISTATE))) 2 + BETA(7,ISTATE)/r A1= BETA(6,ISTATE) + r*(2.d0*BETA(8,ISTATE) 1 + 3.d0*r*BETA(9,ISTATE)) - BETA(7,ISTATE)/r**2 A2= 2.d0*BETA(8,ISTATE)+ 6.d0*r*BETA(9,ISTATE) 1 + 2.d0*BETA(7,ISTATE)/r**3 DX= A0*EXP(-T0) VDIST(I)= DX - VATT dVdr(I)= DX*(A1/A0 - T1) - dVATT d2VdR2(I)= DX*((A2- 2.d0*T1*A1)/A0+ T1**2- T2) - d2VATT ENDDO ENDIF c======================================================================= c ....... for the case of an Aziz'ian HFD-ABC potential ... c----------------------------------------------------------------------- IF((PSEL(ISTATE).EQ.7).AND.(Nbeta(ISTATE).EQ.5)) THEN A1= BETA(1,ISTATE) A2= BETA(2,ISTATE) A3= BETA(3,ISTATE) DO I= 1,8 r= RDIST(I) X= RDIST(I)/RE(ISTATE) VATT= 0.d0 dVATT= 0.d0 d2VATT= 0.d0 T1= 1.d0 T1P= 0.d0 T1PP= 0.d0 IF(r.LT.A2) THEN T1= EXP(-A1*(A2/r - 1.d0)**A3) T1P= (A1*A2*A3/(r**2))*((A2/r)-1.d0)**(A3-1.d0) T1PP= T1P*T1P - (A1*A2*A3/r**3)*(A2*(A3-1.d0)/r) 1 *((A2/r)-1.d0)**(A3-2.d0) - 2.d0*((A2/r)-1.d0)**(A3-1.d0) T1P= T1*T1P T1PP= T1*T1PP ENDIF DO M= 1,NCMM(ISTATE) T0= (CmVAL(m,ISTATE)/r**MMLR(m,ISTATE)) VATT= VATT+ T0*T1 dVATT= dVATT+ (T1P-MMLR(m,ISTATE)*T1/r)*T0 d2VATT= d2VATT + (T1PP-2.d0*(T1P*MMLR(m,ISTATE)/r) + 1 T1*((MMLR(m,ISTATE)**2)+MMLR(m,ISTATE))/(r**2))*T0 ENDDO DX= AA(ISTATE)*(X**BETA(5,ISTATE))*EXP(-r*(BB(ISTATE) 1 + r*BETA(4,ISTATE))) VDIST(I)= DX - VATT T0= BETA(5,ISTATE)/r - BB(ISTATE)- 2.d0*r*BETA(4,ISTATE) dVdR(I)= DX*T0 - DVATT d2VdR2(I)= DX*(T0**2 - BETA(5,ISTATE)/r**2 1 - 2.d0*BETA(4,ISTATE)) - d2VATT ENDDO ENDIF c======================================================================= c... Finally ...For the case of an Aziz'ian HFD-ID potential ... C----------------------------------------------------------------------- IF((PSEL(ISTATE).EQ.7).AND.(Nbeta(ISTATE).EQ.2)) THEN A1= BETA(1,ISTATE) A2= BETA(2,ISTATE) DO I= ISTART,ISTOP r= RDIST(I) CALL dampF(r,rhoAB(ISTATE),NCMM(ISTATE),NCMMAX,MMLR1D, 1 IVSR(ISTATE),IDSTT(ISTATE),DM,DMP,DMPP) X= r/RE(ISTATE) BR= RHOab(ISTATE)*r VATT= 0.d0 dVATT= 0.d0 D2VATT= 0.d0 f2= (BR/bohr)**1.68d0 *EXP(-0.78d0*BR/bohr) f2p= 1.68d0/r - 0.78d0*RHOab(ISTATE)/bohr f2pp= - f2*(f2p**2 - 1.68d0/(r**2)) f2p= -f2*f2p f2= 1.d0 - f2 VATT= 0.d0 dVATT= 0.d0 d2VATT= 0.d0 DO m= 1,NCMM(ISTATE) T0= CmVAL(m,ISTATE)/r**MMLR1D(m) VATT= VATT+ T0*DM(m) dVATT= dVATT+ T0*(f2p*DM(m)+ f2*(DMP(m) - 1 DM(m)*(MMLR1D(m)/r))) d2VATT= d2VATT + T0*(f2pp*DM(m)+ f2*DMPP(m) + 1 2.d0*f2p*DMP(m) - 2.d0*(f2p*DM(m) + f2*DMP(m)*(MMLR1D(m)/r)) 2 + f2*DM(m)*MMLR1D(m)*(MMLR1D(m)+ 1.d0)/r**2) ENDDO DX= AA(ISTATE)*(X**A2)*EXP(-r*(BB(ISTATE) + r*A1)) VDIST(I)= DX - f2*VATT T0= A2/r - BB(ISTATE) - 2.d0*r*A1 dVdR(I)= DX*T0 - dVATT d2VdR2(I)= DX*(T0**2 - A2/r**2 - 2.d0*A1) - d2VATT ENDDO ENDIF IF((NUA(ISTATE).GE.0).OR.(NUB(ISTATE).GT.0)) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Treat any 'adiabatic' BOB radial potential functions here ... c u_A(r) = yp*uA_\infty + [1 - yp]\sum_{i=0,NUA} {uA_i yq^i} c where the u_\infty values stored/fitted as UA(NUA(ISTATE)) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REp= RE(ISTATE)**pAD(ISTATE) REq= RE(ISTATE)**qAD(ISTATE) HReP= 0.5d0*pAD(ISTATE)/RE(ISTATE) HReQ= 0.5d0*qAD(ISTATE)/RE(ISTATE) REpADA= RE(ISTATE)**pAD(ISTATE) REqADA= RE(ISTATE)**qAD(ISTATE) REpADB= RE(ISTATE)**pAD(ISTATE) REqADB= RE(ISTATE)**qAD(ISTATE) IF((BOBCN(ISTATE).GE.1).AND.(pAD(ISTATE).EQ.0)) THEN HReP= 2.d0*HReP HReQ= 2.d0*HReQ ENDIF c ... reset parameter counter ... IPVSTART= IPV DO I= ISTART,ISTOP RVAL(I)= RD(I,ISTATE) IF(RDIST(I).GT.0.d0) RVAL(I)= RDIST(I) RDp= RVAL(I)**pAD(ISTATE) RDq= RVAL(I)**qAD(ISTATE) YPA= (RDp - REpADA)/(RDp + REpADA) YQA= (RDq - REqADA)/(RDq + REqADA) YPB= (RDp - REpADB)/(RDp + REpADB) YQB= (RDq - REqADB)/(RDq + REqADB) YPMA= 1.d0 - YPA YPMB= 1.d0 - YPB IF(BOBCN(ISTATE).GE.1) THEN c** If BOBCN > 0 & p= 1, assume use of Ogilvie-Tipping vble. IF(pAD(ISTATE).EQ.1) THEN YPA= 2.d0*YPA YPB= 2.d0*YPB ENDIF ENDIF IF(NUA(ISTATE).GE.0) THEN c ... Now ... derivatives of UA w.r.t. expansion coefficients VAL= UA(0,ISTATE) DVAL= 0.d0 IPV= IPVSTART + 1 DVtot(IPV,I)= YPMA YQPA= 1.d0 IF(NUA(ISTATE).GE.2) THEN DO J= 1,NUA(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQPA*UA(J,ISTATE) YQPA= YQPA*YQA VAL= VAL+ UA(J,ISTATE)*YQPA IPV= IPV+ 1 DVtot(IPV,I)= YPMA*YQPA ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YPA UAR(I,ISTATE)= VAL*YPMA + YPA*UA(NUA(ISTATE),ISTATE) DUADRe(I,ISTATE)= 0.d0 c ... and derivative of UA w.r.t. Re ... DUADRe(I,ISTATE)= -HReQ*(1.d0 - YQA**2)*YPMA*DVAL 1 + HReP*(1.d0 - YPA**2)*(VAL- UA(NUA(ISTATE),ISTATE)) ENDIF IF(NUB(ISTATE).GE.0) THEN c ... Now ... derivatives of UB w.r.t. expansion coefficients VAL= UB(0,ISTATE) DVAL= 0.d0 IF(NUA(ISTATE).LT.0) THEN IPV= IPVSTART + 1 ELSE IPV= IPV + 1 ENDIF DVtot(IPV,I)= YPMB YQPB= 1.d0 IF(NUB(ISTATE).GE.2) THEN DO J= 1,NUB(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQPB*UB(J,ISTATE) YQPB= YQPB*YQB VAL= VAL+ UB(J,ISTATE)*YQPB IPV= IPV + 1 DVtot(IPV,I)= YPMB*YQPB ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YPB UBR(I,ISTATE)= VAL*YPMB + YPB*UB(NUB(ISTATE),ISTATE) DUBDRe(I,ISTATE)= 0.d0 c ... and derivative of UB w.r.t. Re ... DUBDRe(I,ISTATE)= -HReQ*(1.d0 - YQB**2)*YPMB*DVAL 1 + HReP*(1.d0 - YPB**2)*(VAL- UB(NUB(ISTATE),ISTATE)) ENDIF ENDDO ENDIF c++++ END of treatment of adiabatic potential BOB function++++++++++++++ IF((NTA(ISTATE).GE.0).OR.(NTB(ISTATE).GE.0)) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Treat any 'non-adiabatic' centrifugal BOB functions here ... c q_A(r) = yp*qA_\infty + [1 - yp]\sum_{i=0,NTA} {qA_i yq^i} c where the q_\infty values stored/fitted as TA(NTA(ISTATE)) c Incorporate the 1/r^2 factor into the partial derivatives (but not in c the g(r) functions themselves, since pre-SCHRQ takes care of that). c Need to add M_A^{(1)}/M_A^{(\alpha)} factor later too c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REp= RE(ISTATE)**pNA(ISTATE) REq= RE(ISTATE)**qNA(ISTATE) HReP= 0.5d0*pNA(ISTATE)/RE(ISTATE) HReQ= 0.5d0*qNA(ISTATE)/RE(ISTATE) IF((BOBCN(ISTATE).GE.1).AND.(pNA(ISTATE).EQ.0)) THEN HReP= 2.d0*HReP HReQ= 2.d0*HReQ ENDIF IPVSTART= IPV DO I= ISTART,ISTOP RVAL(I)= RD(I,ISTATE) IF(RDIST(I).GT.0.d0) RVAL(I)= RDIST(I) RM2= 1/RVAL(I)**2 RDp= RVAL(I)**pNA(ISTATE) RDq= RVAL(I)**qNA(ISTATE) YP= (RDp - REp)/(RDp + REp) YQ= (RDq - REq)/(RDq + REq) YPM= 1.d0 - YP IF(BOBCN(ISTATE).GE.1) THEN YPM= 1.d0 YP= 2.d0*YP ENDIF IF(NTA(ISTATE).GE.0) THEN c ... Now ... derivatives of TA w,r,t, expansion coefficients VAL= TA(0,ISTATE) DVAL= 0.d0 IPV= IPVSTART + 1 DVtot(IPV,I)= YPM*RM2 YQP= 1.d0 IF(NTA(ISTATE).GE.2) THEN DO J= 1,NTA(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQP*TA(J,ISTATE) YQP= YQP*YQ VAL= VAL+ TA(J,ISTATE)*YQP IPV= IPV + 1 DVtot(IPV,I)= YPM*YQP*RM2 ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YP*RM2 TAR(I,ISTATE)= VAL*YPM + YP*TA(NTA(ISTATE),ISTATE) c ... and derivative of TA w.r.t. Re ... DTADRe(I,ISTATE)= (-HReQ*(1.d0 - YQ**2)*YPM*DVAL 1 + HReP*(1.d0 - YP**2)*(VAL- TA(NTA(ISTATE),ISTATE)))*RM2 ENDIF IF(NTB(ISTATE).GE.0) THEN c ... Now ... derivatives of TB w,r,t, expansion coefficients VAL= TB(0,ISTATE) DVAL= 0.d0 IF(NTA(ISTATE).LT.0) THEN IPV= IPVSTART + 1 ELSE IPV= IPV + 1 ENDIF DVtot(IPV,I)= YPM*RM2 YQP= 1.d0 IF(NTB(ISTATE).GE.2) THEN DO J= 1,NTB(ISTATE)-1 DVAL= DVAL+ DBLE(J)*YQP*TB(J,ISTATE) YQP= YQP*YQ VAL= VAL+ TB(J,ISTATE)*YQP IPV= IPV + 1 DVtot(IPV,I)= YPM*YQP*RM2 ENDDO ENDIF IPV= IPV + 1 DVtot(IPV,I)= YP*RM2 TBR(I,ISTATE)= VAL*YPM + YP*TB(NTB(ISTATE),ISTATE) c ... and derivative of TB w.r.t. Re ... DTBDRe(I,ISTATE)= (-HReQ*(1.d0 - YQ**2)*YPM*DVAL 1 + HReP*(1.d0 - YP**2)*(VAL- TB(NTB(ISTATE),ISTATE)))*RM2 ENDIF ENDDO ENDIF c++++ END of treatment of non-adiabatic centrifugal BOB function++++++++ IF(NwCFT(ISTATE).GE.0) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Treat any Lambda- or 2\Sigma-doubling radial strength functions here c representing it as f(r)= Sum{ w_i * yp^i} c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ LAMB2= 2*IOMEG(ISTATE) REP= RE(ISTATE)**Pqw(ISTATE) HReP= 0.5d0*Pqw(ISTATE)/RE(ISTATE) IPVSTART= IPV DO I= ISTART,ISTOP RVAL(I)= RD(I,ISTATE) IF(RDIST(I).GT.0.d0) RVAL(I)= RDIST(I) RMF= 1.d0/RVAL(I)**2 IF(IOMEG(ISTATE).GT.0) RMF= RMF**LAMB2 RDp= RVAL(I)**Pqw(ISTATE) YP= (RDp - REP)/(RDp + REP) DVAL= 0.d0 YPP= RMF VAL= wCFT(0,ISTATE)*YPP IPV= IPVSTART + 1 DVtot(IPV,I)= YPP IF(NwCFT(ISTATE).GE.1) THEN DO J= 1,NwCFT(ISTATE) DVAL= DVAL+ DBLE(J)*YPP*wCFT(J,ISTATE) YPP= YPP*YP IPV= IPV + 1 DVtot(IPV,I)= YPP VAL= VAL+ wCFT(J,ISTATE)*YPP ENDDO ENDIF wRAD(I,ISTATE)= VAL dLDDRe(I,NSTATEMX)= -HReP*(1.d0 - YP**2)*DVAL ENDDO ENDIF c++++ END of treatment of Lambda/2-sigma centrifugal BOB function+++++++ c++++ Test for inner wall inflection above the asymptote, and if it ++++ c++++ occurs, replace inward potential with linear approximation +++++++ cc I1= (RE(ISTATE)-RD(1,ISTATE))/(RD(2,ISTATE)-RD(1,ISTATE)) cc IF(I1.GT.3) THEN cc SL= 0.d0 cc DO I= I1-2, 1, -1 cc SLB= SL cc SL= VPOT(I,ISTATE) - VPOT(I+1,ISTATE) cc IF((SL.LE.SLB).AND.(VPOT(I,ISTATE).GT.VLIM(ISTATE))) THEN cc DO J= I,1,-1 cc VPOT(J,ISTATE)= VPOT(I,ISTATE) + (I-J)*SL cc ENDDO cc WRITE(6,606) SLABL(ISTATE),RD(I,ISTATE),VPOT(I,ISTATE) cc GOTO 66 cc ENDIF cc ENDDO cc ENDIF cc 66 CONTINUE cc606 FORMAT(9('===')/'!!!! Extrapolate to correct ',A3,' inner-wall inf cc 1lection at R=',f6.4,' V=',f8.0/9('===')) c++++++++++++End of Inner Wall Test/Correction code+++++++++++++++++++++ c====================================================================== c** At the one distance RDIST calculate total effective potential VDIST c including (!!) centrifugal and Lambda/2Sigma doubling terms, c and its partial derivatives w.r.t. Hamiltonian parameters dVdPk. c** This case only for simulation & fitting of tunneling width data. c DO I= 1,8 IF((RDIST(I).GT.0).AND.(IDAT.GT.0)) THEN NBAND= IB(IDAT) IISTP= ISTP(NBAND) cccccccc c WRITE (40,644) IISTP,RDIST,RVAL,VDIST,I,NDATPT(ISTATE) c 644 FORMAT ('IISTP =',I3,' RDIST =',G16.8,' RVAL =',G16.8, c & ' VDIST =',G16.8,' I =',I6,' NDATPT =',I6) cccccccc BFCT= 16.857629206d0/(ZMASS(3,IISTP)*RDIST(I)**2) JFCT= DBLE(JPP(IDAT)*(JPP(IDAT)+1)) IF(IOMEG(ISTATE).GT.0) JFCT= JFCT - IOMEG(ISTATE)**2 IF(IOMEG(ISTATE).EQ.-2) JFCT= JFCT + 2.D0 JFCT= JFCT*BFCT c ... First get total effective potential, including BOB terms VDIST(I)= VDIST(I) + JFCT IF(NUA(ISTATE).GE.0) VDIST= VDIST 1 + ZMUA(IISTP,ISTATE)*UAR(ISTOP,ISTATE) IF(NUB(ISTATE).GE.0) VDIST= VDIST 1 + ZMUB(IISTP,ISTATE)*UBR(ISTOP,ISTATE) IF(NTA(ISTATE).GE.0) VDIST= VDIST 1 + JFCT*ZMTA(IISTP,ISTATE)*TAR(ISTOP,ISTATE) IF(NTB(ISTATE).GE.0) VDIST= VDIST 1 + JFCT*ZMTB(IISTP,ISTATE)*TBR(ISTOP,ISTATE) JFCTLD= 0.d0 IF(IOMEG(ISTATE).NE.0) THEN IF(IOMEG(ISTATE).GT.0) THEN c ... for Lambda doubling case ... JFCTLD= (EFPP(IDAT)-EFREF(ISTATE)) 1 *(DBLE(JPP(IDAT)*(JPP(IDAT)+1))*BFCT**2)**IOMEG(ISTATE) ENDIF IF(IOMEG(ISTATE).EQ.-1) THEN c ... for doublet Sigma doubling case ... IF(EFPP(IDAT).GT.0) JFCTLD= 0.5d0*JPP(IDAT)*BFCT IF(EFPP(IDAT).EQ.0) JFCTLD= 0.d0 IF(EFPP(IDAT).LT.0) JFCTLD= -0.5d0*(JPP(IDAT)+1)*BFCT ENDIF VDIST(I)= VDIST(I) + JFCTLD* WRAD(ISTOP,ISTATE) ENDIF cccccccc c WRITE (40,648) JPP(IDAT),EFPP(IDAT),RDIST,VDIST c 648 FORMAT ('J =',I3,' efPARITY =',I3,' RDIST =',G16.8,' VDIST =', c 1 G16.8/) cccccccc DO IPV= 1,TOTPOTPAR dVdPk(IPV)= 0.d0 ENDDO c** Now ... generate requisite partial derivatives. DO IPV= POTPARI(ISTATE),POTPARF(ISTATE) dVdPk(IPV)= DVtot(IPV,ISTOP) ENDDO IF(NUA(ISTATE).GE.0) THEN DO IPV= UAPARI(ISTATE),UAPARF(ISTATE) dVdPk(IPV)= ZMUA(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NUB(ISTATE).GE.0) THEN DO IPV= UBPARI(ISTATE),UBPARF(ISTATE) dVdPk(IPV)= ZMUB(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NTA(ISTATE).GE.0) THEN DO IPV= TAPARI(ISTATE),TAPARF(ISTATE) dVdPk(IPV)=JFCT*ZMTA(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NTB(ISTATE).GE.0) THEN DO IPV= TBPARI(ISTATE),TBPARF(ISTATE) dVdPk(IPV)=JFCT*ZMTB(IISTP,ISTATE)*DVtot(IPV,ISTOP) ENDDO ENDIF IF(NwCFT(ISTATE).GE.0) THEN DO IPV= LDPARI(ISTATE),LDPARF(ISTATE) dVdPk(IPV)= JFCTLD*DVtot(IPV,ISTOP) ENDDO ENDIF ENDIF ENDDO c*****7********************** BLOCK END ******************************72 999 RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c********************************************************************** SUBROUTINE DIFFSTATS(NSTATES,NFPAR,ROBUST,MKPRED,NPTOT,NTVSTOT, 1 PRINP) c** Subroutine to summarise dimensionless standard errors on a band-by- c band basis, and (if desired) print [obs.-calc.] values to channel-8. c----------------------------------------------------------------------- c Version of 30 January 2013 c last change - added NFPAR` to printout c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= cc INCLUDE 'BLKTYPE.h' c======================================================================= c** Type statements & common blocks for characterizing transitions REAL*8 AVEUFREQ(NPARMX),MAXUFREQ(NPARMX) INTEGER NTRANSFS(NISTPMX,NSTATEMX), 1 NTRANSVIS(NISTPMX,NSTATEMX,NSTATEMX), 1 NBANDEL(NISTPMX,NSTATEMX,NSTATEMX), 2 NTRANSIR(NISTPMX,NSTATEMX),NTRANSMW(NISTPMX,NSTATEMX), 3 NBANDFS(NISTPMX,NSTATEMX),NBANDVIS(NISTPMX,NSTATEMX), 4 NBANDIR(NISTPMX,NSTATEMX),NBANDMW(NISTPMX,NSTATEMX), 5 NVVPP(NISTPMX,NSTATEMX),NWIDTH(NISTPMX,NSTATEMX), 6 NEBPAS(NISTPMX,NSTATEMX),NVIRIAL(NISTPMX,NSTATEMX), 7 NAcVIR(NISTPMX,NSTATEMX),NBANDS(NISTPMX) c COMMON /BLKTYPE/AVEUFREQ,MAXUFREQ,NTRANSFS,NTRANSVIS,NTRANSIR, 1 NTRANSMW,NBANDFS,NBANDEL,NBANDVIS,NBANDIR,NBANDMW,NVVPP,NWIDTH, 2 NEBPAS,NVIRIAL,NAcVIR,NBANDS c======================================================================= c INTEGER I,IBN,ISOT,ISTATE,ISTATEE,J,K,NSTATES,MKPRED,ROBUST,NFPAR, 1 NPTOT,NTVSTOT,PRINP REAL*8 AVE,AVETOT,DIV,RMSR,RMSTOT,SSQTOT CHARACTER*3 MARKER,NEF(-1:1) c DATA NEF/' f',' ef',' e'/ c======================================================================== ISOT= 1 SSQTOT= 0.d0 IF(MKPRED.GT.0) THEN WRITE(6,600) REWIND 4 WRITE(4,601) ENDIF c** Summarize data discrepancies for one isotopologue at a time. 10 WRITE(6,602) NBANDS(ISOT),(NAME(I),MN(I,ISOT),I= 1,2) c c** Loop over bands for each (lower) electronic state, in turm DO 90 ISTATE= 1,NSTATES IF(NTRANSMW(ISOT,ISTATE).GT.0)THEN c** Book-keeping for Micowave data WRITE(6,604) NTRANSMW(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I= 1,2),NBANDMW(ISOT,ISTATE) WRITE(6,605) WRITE(8,604) NTRANSMW(ISOT,ISTATE), 1 SLABL(ISTATE),(NAME(I),MN(I,ISOT),I= 1,2),NBANDMW(ISOT,ISTATE) RMSTOT= 0.d0 AVETOT= 0.d0 DO I= 1,NBANDMW(ISOT,ISTATE) IBN= IBB(ISOT,ISTATE,4,I) IF(MKPRED.LE.0) THEN CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR, 1 SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ NTRANS(IBN)*RMSR**2 AVETOT= AVETOT+ NTRANS(IBN)*AVE IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 2 BANDNAME(IBN) ELSE WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF ENDIF WRITE(8,605) IF(MKPRED.LE.0) THEN IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(8,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN), 2 AVE,RMSR,BANDNAME(IBN) ELSE WRITE(8,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN), 2 AVE,RMSR ENDIF ENDIF IF(MKPRED.GT.0) THEN WRITE(8,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN) WRITE(4,640) VP(IBN),VPP(IBN),SLABL(ISTATE), 1 SLABL(ISTATE),(MN(K,ISOT),K=1,2) ENDIF 640 FORMAT(/2I4,2(2x,"'",A3,"'"),2x,2I4) CALL PBNDERR(IBN,MKPRED,NEF) ENDDO RMSTOT= DSQRT(RMSTOT/NTRANSMW(ISOT,ISTATE)) AVETOT= AVETOT/NTRANSMW(ISOT,ISTATE) IF(MKPRED.LE.0) WRITE(6,630) NTRANSMW(ISOT,ISTATE),AVETOT, 1 RMSTOT ENDIF c IF(NTRANSIR(ISOT,ISTATE).GT.0)THEN c** Book-keeping for Infrared data WRITE(6,608) NTRANSIR(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I= 1,2),NBANDIR(ISOT,ISTATE) WRITE(6,605) WRITE(8,608) NTRANSIR(ISOT,ISTATE), 1 SLABL(ISTATE),(NAME(I),MN(I,ISOT),I= 1,2),NBANDIR(ISOT,ISTATE) RMSTOT= 0.d0 AVETOT= 0.d0 DO I= 1,NBANDIR(ISOT,ISTATE) IBN= IBB(ISOT,ISTATE,3,I) IF(MKPRED.LE.0) THEN CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR, 1 SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ NTRANS(IBN)*RMSR**2 AVETOT= AVETOT+ NTRANS(IBN)*AVE IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 2 BANDNAME(IBN) ELSE WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF ENDIF WRITE(8,605) IF(MKPRED.LE.0) THEN IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(8,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 2 BANDNAME(IBN) ELSE WRITE(8,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF ENDIF IF(MKPRED.GT.0) THEN WRITE(8,606) VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN), 1 JMAX(IBN) WRITE(4,640) VP(IBN),VPP(IBN), 1 SLABL(ISTATE),SLABL(ISTATE), 2 (MN(K,ISOT),K=1,2) ENDIF CALL PBNDERR(IBN,MKPRED,NEF) ENDDO RMSTOT= DSQRT(RMSTOT/NTRANSIR(ISOT,ISTATE)) AVETOT= AVETOT/NTRANSIR(ISOT,ISTATE) IF(MKPRED.LE.0) WRITE(6,630) NTRANSIR(ISOT,ISTATE),AVETOT, 1 RMSTOT ENDIF c c** Book-keeping for Electronic vibrational band data DO ISTATEE= 1,NSTATES IF((ISTATEE.NE.ISTATE).AND. 1 (NTRANSVIS(ISOT,ISTATEE,ISTATE).GT.0)) THEN c ... for ISTATEE{upper}-ISTATE{lower} electronic vibrational bands WRITE(6,610) NTRANSVIS(ISOT,ISTATEE,ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),SLABL(ISTATEE), 2 SLABL(ISTATE),NBANDEL(ISOT,ISTATEE,ISTATE) WRITE(6,605) WRITE(8,610) NTRANSVIS(ISOT,ISTATEE,ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),SLABL(ISTATEE), 2 SLABL(ISTATE),NBANDEL(ISOT,ISTATEE,ISTATE) RMSTOT= 0.d0 AVETOT= 0.d0 DO I= 1,NBANDVIS(ISOT,ISTATE) IBN= IBB(ISOT,ISTATE,2,I) IF(IEP(IBN).EQ.ISTATEE) THEN IF(MKPRED.LE.0) THEN CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE, 1 RMSR,SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ NTRANS(IBN)*RMSR**2 AVETOT= AVETOT+ NTRANS(IBN)*AVE IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 2 BANDNAME(IBN) ELSE WRITE(6,606) VP(IBN),VPP(IBN),NTRANS(IBN), 1 JMIN(IBN),JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF ENDIF WRITE(8,605) IF(MKPRED.LE.0) THEN IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(8,606) 1 VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR,BANDNAME(IBN) ELSE WRITE(8,606) 1 VP(IBN),VPP(IBN),NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF ENDIF IF(MKPRED.GT.0) THEN WRITE(8,606) VP(IBN),VPP(IBN), 1 NTRANS(IBN),JMIN(IBN),JMAX(IBN) WRITE(4,640) VP(IBN),VPP(IBN),SLABL(ISTATE), 1 SLABL(ISTATE),(MN(K,ISOT),K=1,2) ENDIF CALL PBNDERR(IBN,MKPRED,NEF) ENDIF ENDDO RMSTOT= DSQRT(RMSTOT/NTRANSVIS(ISOT,ISTATEE,ISTATE)) AVETOT= AVETOT/NTRANSVIS(ISOT,ISTATEE,ISTATE) IF(MKPRED.LE.0) WRITE(6,630) 1 NTRANSVIS(ISOT,ISTATEE,ISTATE),AVETOT,RMSTOT ENDIF ENDDO c IF(NTRANSFS(ISOT,ISTATE).GT.0)THEN c** Book-keeping for Fluorescence data WRITE(6,612) NTRANSFS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NBANDFS(ISOT,ISTATE) WRITE(6,617) WRITE(8,612) NTRANSFS(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NBANDFS(ISOT,ISTATE) RMSTOT= 0.d0 AVETOT= 0.d0 DO I= 1,NBANDFS(ISOT,ISTATE) IBN= IBB(ISOT,ISTATE,1,I) CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR, 1 SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ NTRANS(IBN)*RMSR**2 AVETOT= AVETOT+ NTRANS(IBN)*AVE IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,614) VP(IBN),VPP(IBN),NEF(EFP(IFIRST(IBN))), 1 NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) WRITE(8,617) WRITE(8,614) VP(IBN),VPP(IBN),NEF(EFP(IFIRST(IBN))), 1 NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) ELSE WRITE(6,614) VP(IBN),VPP(IBN),NEF(EFP(IFIRST(IBN))), 1 NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR WRITE(8,617) WRITE(8,614) VP(IBN),VPP(IBN),NEF(EFP(IFIRST(IBN))), 1 NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF CALL PBNDERR(IBN,MKPRED,NEF) ENDDO RMSTOT= DSQRT(RMSTOT/NTRANSFS(ISOT,ISTATE)) AVETOT= AVETOT/NTRANSFS(ISOT,ISTATE) WRITE(6,632) NTRANSFS(ISOT,ISTATE),AVETOT,RMSTOT ENDIF c IF(NEBPAS(ISOT,ISTATE).GT.0) THEN c** Book-keeping for PAS data IBN= IBB(ISOT,ISTATE,7,1) CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,626) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR,BANDNAME(IBN) WRITE(8,626) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR,BANDNAME(IBN) ELSE WRITE(6,626) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR WRITE(8,626) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN),JMAX(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF WRITE(8,627) DO I= IFIRST(IBN),ILAST(IBN) DIV= DABS(DFREQ(I)/UFREQ(I)) marker=' ' IF( (DIV.GE.2.d0).AND.(DIV.LT.5.d0) ) marker='* ' IF( (DIV.GE.4.d0).AND.(DIV.LT.10.d0) ) marker='** ' IF( (DIV.GE.8.d0) ) marker='***' WRITE(8,628) JP(I),JPP(I),NEF(EFPP(I)),FREQ(I), 1 UFREQ(I),DFREQ(I),DFREQ(I)/UFREQ(I),MARKER ENDDO WRITE(6,629) WRITE(8,629) ENDIF c IF(NVVPP(ISOT,ISTATE).GT.0) THEN c** Book-keeping for potential function values as data ..... IBN= IBB(ISOT,ISTATE,5,1) CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,638) NVVPP(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) WRITE(8,638) NVVPP(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) ELSE WRITE(6,639) NVVPP(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR WRITE(8,639) NVVPP(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF DO J= IFIRST(IBN),ILAST(IBN) WRITE(6,637) TEMP(J),FREQ(J),UFREQ(J),DFREQ(J), 1 DFREQ(J)/UFREQ(J) WRITE(8,637) TEMP(J),FREQ(J),UFREQ(J),DFREQ(J), 1 DFREQ(J)/UFREQ(J) ENDDO ENDIF c IF(NWIDTH(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Tunneling Width data IBN= IBB(ISOT,ISTATE,6,1) CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,620) NWIDTH(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN), 2 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) WRITE(8,620) NWIDTH(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN), 2 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) ELSE WRITE(6,621) NWIDTH(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN), 2 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR WRITE(8,621) NWIDTH(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),NTRANS(IBN),JMIN(IBN), 2 JMAX(IBN),AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF DO J= IFIRST(IBN),ILAST(IBN) WRITE(6,622) JP(J),JPP(J),NEF(EFPP(J)),FREQ(J),UFREQ(J), 1 DFREQ(J),DFREQ(J)/UFREQ(J) WRITE(8,622) JP(J),JPP(J),NEF(EFPP(J)),FREQ(J), 1 UFREQ(J),DFREQ(J),DFREQ(J)/UFREQ(J) ENDDO ENDIF c IF(NVIRIAL(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Virial Coefficient data IBN= IBB(ISOT,ISTATE,8,1) CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,634) NVIRIAL(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),' Pressure',NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) WRITE(8,634) NVIRIAL(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),' Pressure', NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) ELSE WRITE(6,635) NVIRIAL(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),' Pressure',NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR WRITE(8,635) NVIRIAL(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),' Pressure',NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF DO J= IFIRST(IBN),ILAST(IBN) WRITE(8,636) TEMP(J),FREQ(J),UFREQ(J),DFREQ(J), 1 DFREQ(J)/UFREQ(J) ENDDO ENDIF c======================================= Avge. ========= c #data Av.Unc. Max.Unc. Err/Unc DRMSD c------------------------------------------------------- c 7 3.3D-08 3.3D-08 -0.15741 0.622 c============================================== calc-obs c temp. Bvir(obs) u(Bvir) calc-obs /u(Bvir) c-------------------------------------------------------- c 1234.00 -141.22 2.00 23.xxx 5.0000 c 1234.00 -141.22 2.00 23.xxx 5.0000 c 1234.00 -141.22 2.00 23.xxx 5.0000 c-------------------------------------------------------- IF(NAcVIR(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Acoustic Virial Coefficient data IBN= IBB(ISOT,ISTATE,9,1) CALL BNDERR(IFIRST(IBN),ILAST(IBN),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) IF((PRINP.EQ.2).OR.(PRINP.EQ.-2)) THEN WRITE(6,634) NAcVIR(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),'Accoustic',NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) WRITE(8,634) NAcVIR(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),'Accoustic', NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR, 3 BANDNAME(IBN) ELSE WRITE(6,635) NAcVIR(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),'Accoustic',NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR WRITE(8,635) NAcVIR(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),'Accoustic',NTRANS(IBN), 2 AVEUFREQ(IBN),MAXUFREQ(IBN),AVE,RMSR ENDIF DO J= IFIRST(IBN),ILAST(IBN) WRITE(8,636) TEMP(J),FREQ(J),UFREQ(J),DFREQ(J), 1 DFREQ(J)/UFREQ(J) ENDDO ENDIF c** End of loop over the various (lower) electronic states 90 CONTINUE c======================================================================= IF(ISOT.LT.NISTP) THEN c** If NISTP > 1, return to print data summaries for other isotopologues ISOT= ISOT+1 GO TO 10 ENDIF RMSR= DSQRT(SSQTOT/COUNTOT) WRITE(6,624) NFPAR,COUNTOT,RMSR IF(NTVSTOT.GT.0) THEN RMSR= RMSR*SQRT(COUNTOT/DFLOAT(COUNTOT - NTVSTOT)) WRITE(6,625) NTVSTOT,(NFPAR-NTVSTOT),(COUNTOT - NTVSTOT), RMSR ENDIF RETURN 600 FORMAT(/1x,36('**')/' Write to Channel-8 Predictions From Complet 1e Set of Input Parameters!'/1x,36('**')) 601 FORMAT(/1x,25('**')/' Predictions From Complete Set of Input Para 1meters!'/1x,25('**')) 602 FORMAT(/1x,21('===')/' *** Discrepancies for',I5,' bands/series o 1f ',A2,'(',I3,')-',A2,'(',I3,') ***'/1x,21('===')) 604 FORMAT(/1x,21('===')/I5,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') MW transitions in',i4,' vib. levels') 605 FORMAT(1x,16('==='),'== Avge. ========'/" v' ", 2 ' v" #data J"min J"max Av.Unc. Max.Unc. Err/Unc DRMSD'/ 1 1x,13('-----')) 606 FORMAT(2I4,I6,3x,I4,3x,I4,1x,1P2D9.1,0PF11.5,F8.3,2x,A30) 608 FORMAT(/1x,63('=')/I5,' State ',A3,1x,A2,'(',I3,')-',A2,'(',I3, 1 ') InfraRed transitions in',I4,' bands') 610 FORMAT(/1x,35('==')/I6,1x,A2,'(',I3,')-',A2,'(',i3,') {State ', 1 A3,'}--{State ',A3,'} Transitions in',i4,' bands') 612 FORMAT(/1x,75('=')/I5,' Fluorescence transitions into State ',A3, 1 2x,A2,'(',I3,')-',A2,'(',I3,') in',i5,' series') 617 FORMAT(1x,52('='),'= Avge. ',15('=')/" v' j' p' ", 2 '#data v"min v"max',' AvgeUnc Max.Unc. Err/Unc DRMSD'/ 3 1x,25('---')) 614 FORMAT(2I4,A3,I6,2I7,1x,1P2D9.1,0PF11.5,F8.3,A31) 616 FORMAT(/1x,66('=')/1x,I3,' State ',A2,1x,A2,'(',I3,')-',A2,'(', 1 I3,') potential fx. values treated as independent data'/ 2 1x,20('=='),' Avge. ',17('=')/' #data v"min v"max AvgeUnc', 1 ' Max.Unc. Err/Unc DRMSD'/1x,55('-')/I5,2I7,2x,1P2D9.1,0PF9.3, 4 F8.3/1x,30('==')/' v p',8x,'Bv',7x,'u(Bv)',4x, 5 '[calc-obs] [calc-obs]/unc',/1x,30('--')) 618 FORMAT(I5,A3,2x,F12.8,1PD9.1,0PF13.8,F12.4) 620 FORMAT(/1x,73('=')/1x,I3,' State ',A3,1x,A2,'(',I3,')-',A2,'(', 1 I3,') Tunneling Widths treated as independent data'/1x,20('=='), 2 ' Avge. ',24('=')/' #data v"min v"max AvgeUnc Max.Unc. Er 3r/Unc DRMSD'/1x,55('-')/I5,2I7,2x,1P2D9.1,0PF9.3,F8.3,A32/ 4 1x,59('=')/' v J p Width',7x,'u(Width) [calc-obs] [cal 5c-obs]/unc'/1x,59('-')) 621 FORMAT(/1x,73('=')/1x,I3,' State ',A3,1x,A2,'(',I3,')-',A2,'(', 1 I3,') Tunneling Widths treated as independent data'/1x,20('=='), 2 ' Avge. ',24('=')/' #data v"min v"max AvgeUnc Max.Unc. Er 3r/Unc DRMSD'/1x,55('-')/I5,2I7,2x,1P2D9.1,0PF9.3,F8.3/ 4 1x,59('=')/' v J p Width',7x,'u(Width) [calc-obs] [cal 5c-obs]/unc'/1x,59('-')) 622 FORMAT(2I4,A3,1PD14.6,D10.1,D13.2,0PF10.3) 624 FORMAT(/1x,39('==')/' Fit of ',I5,' total param to',i6,' data yiel 1ds DRMS(devn.)=',G15.8/1x,39('==')) 625 FORMAT(' ... & after correcting for the',I5,' term values with on 1ly onee transition ...'/' Fit of ',I6,' final param to',i7, ' data 2 yields DRMS(devn.)=',G15.8/1x,39('==')) 626 FORMAT(/1x,29('==')/I5,' PAS Binding Energies for State ',A3,2x, 1 A2,'(',I3,')-',A2,'(',I3,')'/1x,50('='),' Avge. ',('=')/ 2 ' #data v_min v_max AvgeUnc Max.Unc. Err/Unc DRMSD'/ 3 1x,29('--')/I5,2I7,2x,1P2D9.1,0PF9.3,F8.3,A32) 627 FORMAT(1x,51('='),' calc-obs'/' v j p PAS(Eb) u 1(Eb) calc-obs /u(FREQ)'/1x,30('--')) 628 FORMAT(2I4,A3,F15.8,F13.8,F13.8,F11.4,1X,A3) 629 FORMAT(1x,30('==')) 630 FORMAT(1x,7('--'),' For these',i6,' lines, overall:',F11.5,F8.3) 632 FORMAT(1x,17('-'),' For these',i6,' lines, overall:',F11.5,F8.3) 634 FORMAT(/1x,55('=')/I5,' State ',A3,2x,A2,'(',I3,')-',A2,'(', 1 I3,') ',A9,' Virial coefficients'/1x,10('===='),' Avge. ', 2 ('====')/5x,'#data Av.Unc. Max.Unc. Err/Unc DRMSD'/ 3 1x,10('-----')/I9,1PD12.2,D12.2,0PF11.5,F8.3,A30/1x,23('=='), 4 ' calc-obs'/ 5x,'temp.',4x,'Bvir(obs)',4x, 5 'u(Bvir) calc-obs /u(Bvir)'/1x,53('-')) 635 FORMAT(/1x,55('=')/I5,' State ',A3,2x,A2,'(',I3,')-',A2,'(', 1 I3,') ',A9,' Virial coefficients'/1x,10('===='),' Avge. ', 2 ('====')/5x,'#data Av.Unc. Max.Unc. Err/Unc DRMSD'/ 3 1x,10('-----')/I9,1PD12.2,D12.2,0PF11.5,F8.3/1x,23('=='), 4 ' calc-obs'/ 5x,'temp.',4x,'Bvir(obs)',4x, 5 'u(Bvir) calc-obs /u(Bvir)'/1x,53('-')) 636 FORMAT(F11.3,2F10.2,2F11.3) c 637 FORMAT(F11.6,1P,D14.6,d10.1,D13.5,0P,F8.2) 637 FORMAT(F11.6,F12.2,F10.2,2F11.3) 638 FORMAT(/1x,55('=')/I5,' State ',A3,2x,A2,'(',I3,')-',A2,'(', 1 I3,') Potential fx. values'/1x,21('=='),' Avge. ',('====')/5x, 2 '#data Av.Unc. Max.Unc. Err/Unc DRMSD'/1x,26('--') 3 /I9,1PD12.2,D12.2,0PF11.5,F8.3,A30/1x,24('=='),' calc-obs'/ 4 7x,'R',7x,'V(r)',8x,'u(V(r)) calc-obs /u(V(r))'/ 5 1x,53('-')) 639 FORMAT(/1x,55('=')/I5,' State ',A3,2x,A2,'(',I3,')-',A2,'(', 1 I3,') Potential fx. values'/1x,21('=='),' Avge. ',('====')/5x, 2 '#data Av.Unc. Max.Unc. Err/Unc DRMSD'/1x,26('--') 3 /I9,1PD12.2,D12.2,0PF11.5,F8.3/1x,24('=='),' calc-obs'/ 4 7x,'R',7x,'V(r)',8x,'u(V(r)) calc-obs /u(V(r))'/ 5 1x,53('-')) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE BNDERR(FIRST,LAST,ROBUST,AVEDD,RMSDD,SSQTOT,DFREQ, 1 UFREQ) c** Calculate the average (AVEDD) & the root mean square dimensionless c deviation (RSMDD) for the band running from datum # FIRST to LAST. cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c REAL*8 DFREQ(NDATAMX),UFREQ(NDATAMX),AVEDD,RMSDD,SSQTOT INTEGER FIRST,LAST,NDAT,I,ROBUST c AVEDD= 0.d0 RMSDD= 0.d0 DO I= FIRST,LAST AVEDD= AVEDD+ DFREQ(I)/UFREQ(I) IF(ROBUST.LE.0) RMSDD= RMSDD+ (DFREQ(I)/UFREQ(I))**2 IF(ROBUST.GT.0) RMSDD= RMSDD+ DFREQ(I)**2/ 1 (UFREQ(I)**2 + DFREQ(I)**2/3.d0) ENDDO SSQTOT= SSQTOT+ RMSDD NDAT= LAST-FIRST+1 AVEDD= AVEDD/NDAT RMSDD= DSQRT(RMSDD/NDAT) RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE PBNDERR(IBN,MKPRED,NEF) c** Print to channel-8 a listing of the [obs.-calc.] values for the band c running from datum # FIRST to LAST. cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= REAL*8 DIV INTEGER IBN,I,MKPRED CHARACTER*3 marker, NEF(-1:1) c----------------------------------------------------------------------- IF(MKPRED.LE.0) WRITE(8,600) IF(MKPRED.GT.0) WRITE(8,601) DO I= IFIRST(IBN),ILAST(IBN) IF(MKPRED.LE.0) THEN DIV= DABS(DFREQ(I)/UFREQ(I)) marker=' ' IF( (DIV.GE.2.d0).AND.(DIV.LT.4.d0) ) marker='* ' IF( (DIV.GE.4.d0).AND.(DIV.LT.8.d0) ) marker='** ' IF( (DIV.GE.8.d0) ) marker='***' IF(IEP(IBN).GT.0) WRITE(8,602) VP(IBN),JP(I),NEF(EFP(I)), 1 VPP(IBN),JPP(I),NEF(EFPP(I)),FREQ(I),UFREQ(I),DFREQ(I), 2 DFREQ(I)/UFREQ(I),marker IF(IEP(IBN).EQ.0) WRITE(8,602) VP(IBN),VPP(IBN), 1 NEF(EFP(I)),JP(I),JPP(I),NEF(EFPP(I)),FREQ(I), 2 UFREQ(I),DFREQ(I),DFREQ(I)/UFREQ(I),marker ELSE WRITE(8,602) VP(IBN),JP(I),NEF(EFP(I)),VPP(IBN),JPP(I), 1 NEF(EFPP(I)),DFREQ(I) WRITE(4,608) JP(I),EFP(I),JPP(I),EFPP(I),DFREQ(I),UFREQ(I) ENDIF ENDDO WRITE(8,604) RETURN 600 FORMAT(1x,60('='),' calc-obs'/ " v' J' p'", 1 ' v" J" p" FREQ(obs) u(FREQ) calc-obs /u(FREQ)'/ 2 1x,69('-')) 601 FORMAT(1x,36('=')/ " v' J' p'",' v" J" p" FREQ(calc)'/ 1 1x,36('-')) 602 FORMAT(2(2I4,A3),f14.6,2f13.7,f10.4:1x,A3) 604 FORMAT(1x,69('-')) 608 FORMAT(I5,I3,I5,I3,F13.4,F9.4) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE PREPOTT(LNPT,IAN1,IAN2,IMN1,IMN2,NPP,VLIM,RR,VV) c** Driver subroutine of package to generate a potential function VV(i) c at the NPP input distances RR(i) by reading, interpolating over and c extrapolating beyond a set of up to NPTMX read-in points. c Based subroutine PREPOT of program LEVEL. c====================== Version of 8 June 2007 ======================== 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 BOB 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 VLIM (cm-1) is the absolute energy at the potential asymptote c RR (real array) is set of NPP distances where potential calculated c---------------------- c**** Subroutine Output: c---------------------- c VV (real array) is the set of function values generated (in cm-1) 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) c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Set maximum array dimension for the input function values to be c interpolated over & extrapolated beyong cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% INTEGER NTPMX,VMIN,ISTATE,IDAT,K PARAMETER (NTPMX= 1600) INTEGER I,J,IAN1,IAN2,IMN1,IMN2,INPTS,ILR,IR2,JWR,LNPT,LWR, 1 NCN,NLIN,NPP,NROW,NTP,NUSE 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,RDIST(8),VDIST(8),DVDR(8),D2VDR2(8) c c** Save variables needed for 'subsequent' LNPT.le.0 calls SAVE ILR,IR2,NTP,NUSE SAVE CNN,VSHIFT,XI,YI c DATA VWRB/3*0.D0/,D1VB/3*0.D0/ c WRITE(6,600) VLIM c** For a pointwise potential (NTP > 0), now read points & parameters c controlling how the interpolation/extrapolation is to be done. c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** NTP : define potential by interpolation over & extrapolation c beyond the NTP read-in turning points using subroutine GENINT. 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,*) NTP, NUSE, IR2, ILR, NCN, CNN c------------------------------------------------------------------- VMIN= 1.0d9 IF(NTP.LE.0) THEN WRITE(6,601) !'comments to say PEC generated as analytic ...' DO I=1,NPP,8 DO J=1,8 RDIST(J)= RR(J+I-1) ENDDO CALL VGENP(ISTATE,RDIST,VDIST,DVDR,D2VdR2,IDAT) DO J=1,8 VV(J+I-1)= VDIST(J) IF(VV(J+I-1).LT.VMIN) THEN !! locate potential minimum VMIN= VV(J+I-1) ENDIF ENDDO ENDDO IF((I+J-1).LT.NPP) THEN DO K= I+J-1,NPP VV(K)= VLIM ENDDO ENDIF c+++ Write for testing ++++++++++++++++++++++++++++++++++ cc REWIND(10) WRITE(10,603) (RR(I),VV(I),I= 1,NPP,20) c++++++++++++++++++++++++++++++++++++++++++++++++++++++++ RETURN ENDIF c**** End of generation of non-standard PEC ***************************** 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 IF((DABS(YI(NTP)-YI(NTP-1)).LE.0).AND. 1 (XI(NTP).LT.RR(NPP))) WRITE(6,618) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL GENINT(LNPT,NPP,RR,VV,NUSE,IR2,NTP,XI,YI,VLIM,ILR,NCN,CNN) c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c IF((LNPT.GT.0).AND.(LPPOT.NE.0)) THEN c** If desired, on the first pass (i.e. if LNPT > 0) print the potential c RH= RR(2)-RR(1) c INPTS= IABS(LPPOT) c IF(LPPOT.LT.0) THEN c** Option to write resulting function compactly to channel-8. c RMIN= RR(1) c NLIN= NPP/INPTS+ 1 c WRITE(8,800) NLIN,VLIM c WRITE(8,802) (RR(I),VV(I),I= 1,NPP,INPTS) c ELSE c** Option to print potential & its 1-st three derivatives, the latter c calculated by differences, assuming equally spaced RR(I) values. c WRITE(6,620) c NLIN= NPP/(2*INPTS)+1 c RH= INPTS*RH c DO I= 1,NLIN c LWR= 1+ INPTS*(I-1) c DO J= 1,2 c JWR= LWR+(J-1)*NLIN*INPTS c IF(JWR.LE.NPP) THEN c RWR(J)= RR(JWR) c VWR(J)= VV(JWR) c D1V(J)= (VWR(J)-VWRB(J))/RH c VWRB(J)= VWR(J) c D2V(J)= (D1V(J)-D1VB(J))/RH c D1VB(J)= D1V(J) c ELSE c RWR(J)= 0.d0 c VWR(J)= 0.d0 c ENDIF c IF(I.LE.2) THEN c D2V(J)= 0.d0 c IF(I.EQ.1) D1V(J)= 0.d0 c ENDIF c ENDDO c WRITE(6,622) (RWR(J),VWR(J),D1V(J),D2V(J),J= 1,2) c ENDDO c ENDIF c ENDIF c+++ Write for testing ++++++++++++++++++++++++++++++++++ REWIND(10) WRITE(10,603) (RR(I),VV(I),I= 1,NPP,20) c++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(LNPT.GT.0) WRITE(6,624) RETURN 600 FORMAT(' State has energy asymptote: Y(lim)=',F12.4,'[cm-1]') 601 FORMAT(/'NTP is set less than or equal to zero, so use some analyt 1ic function') 602 FORMAT(/' **** ERROR in dimensioning of arrays required' 1 ,' by GENINT; No. input points ',I5,' > NTPMX =',I4) 603 FORMAT(5x, F12.4,f14.4) 604 FORMAT(' Perform',I3,'-point piecewise polynomial interpolation ov 1er',I5,' input points' ) 606 FORMAT(' Perform cubic spline interpolation over the',I5, 1 ' input points' ) 608 FORMAT(' Interpolation actually performed over modified input arra 1y: 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))) 618 FORMAT(/' !!! CAUTION !!! Last two mesh point YI values are equa 1l'/17x,'so extrapolation to large r will be unreliable !!!'/) 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)) c 622 FORMAT(2(0PF7.2,F12.5,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) 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,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 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 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= NINT(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 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 subroutines SPLINE and PLYINTRP ++++++++++++++++++++++ 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 ccc CALL SPLINE(R1,V1,NTP,3,CSP,MAXSP,IER) c... using Pashov 'natural spline' with zero 2'nd derivative @ end points CALL SPLINE(R1,V1,NTP,0,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 c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 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 MAPPAR(NISTP,PV,FORBAC) c*********************************************************************** c** This subroutine will convert external logical physical parameters c into the generic NLLSSRR parameter array PV or the reverse. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++ COPYRIGHT 1997-2016 by J.Y. Seto & R.J. Le Roy (ver. 27/03/2016)+ 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 PV(i) is the NLLSSRR parameter array. c FORBAC is a flag to determine which way the parameters are mapped c FORBAC = 0 : Map internal PV to external variables. c FORBAC = 1 : Map external varuables to internal PV. c* NSTATES is the number of states being considered (in BLKPARAM) c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= c----------------------------------------------------------------------- INTEGER NISTP, m, FORBAC, ISTATE, IPV, I, J, ISOT REAL*8 PV(NPARMX) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Map external free parameters (De, Re, etc.) onto internal NLLSSRR c parameters PV(j) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(FORBAC.EQ.0) THEN IPV= 0 DO ISTATE= 1,NSTATES IF(PSEL(ISTATE).EQ.-1) THEN c*** Manage parameters for term value mappings ... DO ISOT= 1, NISTP DO I= VMIN(ISTATE,ISOT),VMAX(ISTATE,ISOT) IF(NBC(I,ISOT,ISTATE).GT.0) THEN DO J=1,NBC(I,ISOT,ISTATE) IPV= IPV+1 PV(IPV)= ZBC(I,J-1,ISOT,ISTATE) ENDDO IF(NQC(I,ISOT,ISTATE).GT.0) THEN DO J=1,NQC(I,ISOT,ISTATE) IPV= IPV+1 PV(IPV)= ZQC(I,J-1,ISOT,ISTATE) ENDDO ENDIF ENDIF ENDDO DO I= VMIN(ISTATE,ISOT),VMAX(ISTATE,ISOT) ENDDO ENDDO ENDIF IF(PSEL(ISTATE).GT.0) THEN c*** Manage parameters for potential function mapping ... IF(PSEL(ISTATE).LT.4) THEN IPV= IPV+ 1 PV(IPV)= DE(ISTATE) ENDIF IF(PSEL(ISTATE).LE.4) THEN IPV= IPV+ 1 PV(IPV)= RE(ISTATE) ENDIF IF((PSEL(ISTATE).EQ.2).OR.(PSEL(ISTATE).EQ.3)) THEN DO m= 1,NCMM(ISTATE) IPV= IPV+ 1 PV(IPV)= CmVAL(m,ISTATE) ENDDO ENDIF J= 0 !! for all PECs except SE-MLR, TT or HDF IF((APSE(ISTATE).GT.0).OR.(PSEL(ISTATE).GE.6)) J=1 DO I= J,Nbeta(ISTATE) IPV= IPV+ 1 PV(IPV)= BETA(I,ISTATE) ENDDO IF(NUA(ISTATE).GE.0) THEN DO I= 0,NUA(ISTATE) IPV= IPV+ 1 PV(IPV) = UA(I,ISTATE) ENDDO ENDIF IF(NUB(ISTATE).GE.0) THEN DO I= 0,NUB(ISTATE) IPV= IPV+ 1 PV(IPV) = UB(I,ISTATE) ENDDO ENDIF IF(NTA(ISTATE).GE.0) THEN DO I= 0,NTA(ISTATE) IPV= IPV+ 1 PV(IPV) = TA(I,ISTATE) ENDDO ENDIF IF(NTB(ISTATE).GE.0) THEN DO I= 0,NTB(ISTATE) IPV= IPV+ 1 PV(IPV) = TB(I,ISTATE) ENDDO ENDIF IF(NwCFT(ISTATE).GE.0) THEN DO I= 0, NwCFT(ISTATE) IPV= IPV+ 1 PV(IPV) = wCFT(I,ISTATE) ENDDO ENDIF ENDIF ENDDO ELSEIF(FORBAC.EQ.1) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Convert internal NLLSSRR parameter array back into external c (logical) variable system (De, Re, etc.). c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IPV = 0 DO ISTATE=1,NSTATES IF(PSEL(ISTATE).EQ.-1) THEN c*** Manage parameters for term value mappings ... DO ISOT= 1, NISTP DO I= VMIN(ISTATE,ISOT),VMAX(ISTATE,ISOT) IF(NBC(I,ISOT,ISTATE).GT.0) THEN DO J= 1,NBC(I,ISOT,ISTATE) IPV= IPV+1 ZBC(I,J-1,ISOT,ISTATE)= PV(IPV) ENDDO IF(NQC(I,ISOT,ISTATE).GT.0) THEN DO J= 1,NQC(I,ISOT,ISTATE) IPV= IPV+1 ZQC(I,J-1,ISOT,ISTATE)= PV(IPV) ENDDO ENDIF ENDIF ENDDO ENDDO ENDIF IF(PSEL(ISTATE).GT.0) THEN c*** Manage parameters for potential function mappings ... IF(PSEL(ISTATE).LT.4) THEN IPV= IPV + 1 DE(ISTATE)= PV(IPV) ENDIF IF(PSEL(ISTATE).LE.4) THEN IPV= IPV + 1 RE(ISTATE) = PV(IPV) ENDIF IF((PSEL(ISTATE).EQ.2).OR.(PSEL(ISTATE).EQ.3)) THEN DO m= 1,NCMM(ISTATE) IPV= IPV+ 1 CmVAL(m,ISTATE)= PV(IPV) ENDDO ENDIF J=0 !! for all PECs except SE-MLR, TT or HDF IF((APSE(ISTATE).GT.0).OR.(PSEL(ISTATE).GE.6)) J=1 DO I= J, Nbeta(ISTATE) IPV = IPV + 1 BETA(I,ISTATE) = PV(IPV) ENDDO IF(NUA(ISTATE).GE.0) THEN DO I= 0,NUA(ISTATE) IPV = IPV + 1 UA(I,ISTATE) = PV(IPV) ENDDO ENDIF IF(NUB(ISTATE).GE.0) THEN DO I= 0,NUB(ISTATE) IPV = IPV + 1 UB(I,ISTATE) = PV(IPV) ENDDO ENDIF IF(NTA(ISTATE).GE.0) THEN DO I= 0,NTA(ISTATE) IPV = IPV + 1 TA(I,ISTATE) = PV(IPV) ENDDO ENDIF IF(NTB(ISTATE).GE.0) THEN DO I= 0,NTB(ISTATE) IPV = IPV + 1 TB(I,ISTATE) = PV(IPV) ENDDO ENDIF IF(NwCFT(ISTATE).GE.0) THEN DO I=0,NwCFT(ISTATE) IPV = IPV + 1 wCFT(I,ISTATE) = PV(IPV) ENDDO ENDIF ENDIF ENDDO ENDIF RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE ALF(NDP,RH,NCN,RR,V,SWF,VLIM,MAXMIN,KVMAX,NVIBMX,VMAXX, 1 AFLAG,ZMU,EPS,GV,INNODE,INNR,IWR) c*********************************************************************** 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++++++++++ Version last updated February 18, 2016 ++++++++++++++++++ c+++++++++++++ {removed BMAX, added VMAXX to CALL} +++++++++++++++++++++ c+++++++++++++ COPYRIGHT 2008-16 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++++++ Please inform me of any bugs, by phone at: (519)888-4051 +++++++ c+++++++++ by e-mail to: leroy@uwaterloo.ca , or by Post at: +++++++++++ c+++ Dept. of Chemistry, Univ. Waterloo, Waterloo, Ontario N2L 3G1 ++++ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Uses the Schrodinger solver subroutine SCHRQ. c** On entry: c NDP is the number of datapoints used for the potential. c RR(i) is the array of radial distances (in Angst.), for i= 1, NDP c RH is the radial mesh step size (in Angst). c NCN is the (integer) inverse power defining the linmiting attractive c long-range behaviour of the potential. For a barrier, set NCN=99 c RR(i) is the array of distances at which V(i) 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 MAXMIN the code STOPS if a search finds more than MAXMIN potential minima c KVMAX is v for the highest vibrational level we wish to find. c NVIBMX defines dimension of the external Gv array: GV(0:NVIBMX) c AFLAG is rot.quantum J for the (centrifugally distorted) potential c ZMU is the reduced mass of the diatom (amu). c EPS is the energy convergence criterion (cm-1). c INNODE specifies whether wave fx. initiation @ RMIN=RR(1) starts with c a node (normal case: INNODE > 0) or zero slope (when INNODE.le.0) 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 is vib.quantum number for the highest vibrational level c found (may be less than the input value of KVMAX). c VMAXX is MAX{energy at barrier maximim,asymptote} c AFLAG returns calculation outcome to calling program. c >= 0 : found all levels to v=KVMAX{input} & AFLAG= J c = -1 : KVMAX larger than number of levels found. c GV(v) contains the vibrational energy levels found for v=0-KVMAX 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 < or > 0 : print error & warning descriptions. c > 0 : also print intermediate ALF messages. c INNER specifies wave function matching (& initiation) conditions. c .le.0 : Match inward & outward solutions at outermost well t.p. c > 0 : Match at innermost well inner turning point 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 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** NF counts levels found in automatic search option c IMPLICIT NONE INTEGER NDP,KVMAX,KV,KVB,KVBB,AFLAG,NF,NBEG,NEND,NVIBMX, 1 NBEGG(0:NVIBMX),NENDD(0:NVIBMX),INNR(0:NVIBMX),ICOR,IWR, 2 IPMIN(10),IPMINN,I,LTRY,AWO,INNODE,INNER,LPRWF,JROT,NCN,NPMIN, 3 NPMAX,MAXMIN c REAL*8 RMIN,RH,RBAR,RR(NDP),V(NDP),SWF(NDP),VLIM,EO,ZMU,EPS, 1 BZ,BFCT,GAMA,VMIN,VMAX,VMAXX,PMAX, ESAV, ZPEHO, DGDV2, 2 GV(0:NVIBMX),VPMIN(10),RPMIN(10),VPMAX(10),RPMAX(10) c DATA AWO/1/,LPRWF/0/,KVB/-1/,KVBB/-2/ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Check that the array dimensions are adequate. RMIN= RR(1) IF(KVMAX.GT.NVIBMX) THEN WRITE(6,602) KVMAX, NVIBMX STOP ENDIF c c** Initialize the remaining variables and flags. NF= 0 ! NF is label of level being sought LTRY= 0 c** Initialize level counters for each well. DO I= 0,KVMAX INNR(I)= -2 ENDDO c** Store input rotational quantum number. JROT= AFLAG AFLAG= -1 c c** Numerical factor 16.857629206 (+/- 0.000,000,013) based on Compton c wavelength of proton & proton mass (u) from 2011 physical constants. BZ= ZMU/16.857629206d0 BFCT= BZ*RH*RH c cc IWR=5 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Locate the potential minima. NPMIN= 0 VMIN= 1.d99 DO I= 2,NDP-1 IF((V(I).LT.V(I-1)).AND.(V(I).LT.V(I+1))) THEN c.... at each minimum located ... NPMIN= NPMIN + 1 IPMIN(NPMIN)= I RPMIN(NPMIN)= RR(I) VPMIN(NPMIN)= V(I)/BFCT IF(VPMIN(NPMIN).LT.VMIN) THEN IPMINN= I VMIN= VPMIN(NPMIN) ENDIF IF(NPMIN.EQ.10) GOTO 10 ENDIF END DO 10 IF(NPMIN.EQ.0) THEN IF(V(2).LE.V(1)) THEN c** If NO minimum & potential has negative slope, print a warning and stop WRITE(6,604) JROT KVMAX= -1 RETURN ENDIF c... but if potl. alway has positive slope, mesh point 1 is minimum NPMIN= 1 IPMIN(NPMIN)= 1 VPMIN(NPMIN)= V(1)/BFCT RPMIN(NPMIN)= RR(1) VMIN= RPMIN(NPMIN) WRITE(6,606) VPMIN(1),RR(1) ENDIF c c** Locate any potential maxima past innermost minimum (if they exists). NPMAX= 0 VMAX= -9.d99 DO I= IPMIN(1)+1,NDP-1 IF((V(I).GT.V(I-1)).AND.(V(I).GT.V(I+1))) THEN NPMAX= NPMAX + 1 RPMAX(NPMAX)= RR(I) VPMAX(NPMAX)= V(I)/BFCT IF(VPMAX(NPMAX).GT.VMAX) VMAX= VPMAX(NPMAX) IF(NPMAX.EQ.9) GOTO 20 !! array bound stop ENDIF ENDDO c** Whether or not internal maxima found, add end-of-range as maximum 20 NPMAX= NPMAX+ 1 RPMAX(NPMAX)= RR(NDP) c?? should this limit be set at VLIM ?? ... naaahhh VPMAX(NPMAX)= V(NDP)/BFCT IF(VPMAX(NPMAX).GT.VMAX) VMAX= VPMAX(NPMAX) VMAXX= VPMAX(NPMAX) IF(VMAXX.LT.VLIM) VMAXX= VLIM c c** For multiple minima, print out potential extrema count IF(NPMIN.GT.1) THEN WRITE(6,614) NPMIN, (VPMIN(I),I= 1,NPMIN) WRITE(6,616) (RPMIN(I), I= 1,NPMIN) WRITE(6,618) NPMAX, (VPMAX(I),I= 1,NPMAX) WRITE(6,616) (RPMAX(I), I= 1,NPMAX) IF(NPMIN.GT.MAXMIN) THEN c** If PEF has more than MAXMIN minima - print warning & stop WRITE(6,620) STOP ENDIF ENDIF c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c*** Use harmonic approximation to estimate zero point energy. ZPEHO= DSQRT((V(IPMINN+20)-V(IPMINN))/400.d0)/BFCT EO= VMIN + ZPEHO EO= VMIN + ZPEHO IF(EO.GT.VLIM) THEN WRITE(6,612) EO,VLIM EO= VLIM - 2.d0 ENDIF c c=========== Begin Actual Eigenvalue Calculation Loop Here ============= c** Compute eigenvalues ... etc. up to the KVMAX'th 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 ICOR= 0 INNER= 0 100 KVBB= KVB KVB= KV KV= NF 110 ESAV= EO c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Call subroutine SCHRQ to find eigenvalue EO and eigenfunction SWF(I). c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL SCHRQ(KV,JROT,EO,GAMA,PMAX,VLIM,V,SWF,BFCT,EPS,RMIN,RH,NDP, 1 NBEG,NEND,INNODE,INNER,IWR,LPRWF) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(KV.LT.0) THEN c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** The SCHRQ error condition is KV < 0. Allow for 3 cases: c EO > VMAX : energy from previous trial above 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+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(EO.GT.VMAX) THEN c** For the case when the previous trial gave energy above the potential c maximum/asymptote, make one last ditch attempt to find the highest c bound level (quasi or otherwise) in the potential. IF(LTRY.LT.1) THEN LTRY= 1 KV= 999 EO= VMAX - 0.0001d0 GOTO 110 c... if that was unsuccessful, then print out a warning and exit. ELSE WRITE(6,622) NF, EO, VMAX KV= NF-1 GOTO 200 ENDIF ENDIF WRITE(6,624) NF,JROT,ESAV c.. eigenvalue of -9.9d9 signifies that eigenvalue search failed completely KVMAX= NF-1 EO= -9.9d9 RETURN ENDIF IF((NPMIN.GT.1).AND.(EO.LT.VPMAX(1))) THEN c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Begin by asking if the current level is in a double minimum potential c and if so, whether it lies below the barrier maximim and if so, c calculate RBAR = to see which well it lies in RBAR= 0.d0 DO I= NBEG,NEND RBAR= RBAR+ RR(I)*SWF(I)**2 ENDDO RBAR= RBAR*RH INNER= 0 IF(RBAR.LT.RPMAX(1)) INNER= 1 IF(IWR.GT.0) write(6,777) RBAR,RPMAX(1),INNER 777 FORMAT(' Since RBAR=',F8.3,' and RPMAX=',F8.3,' set INNER 1=',I2) ENDIF IF(KV.EQ.NF) THEN c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** If calculated vibrational level is the desired level, NF, then increase c NF by one and call SCECOR to calculate dG/dv and predict next higher level c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ NBEGG(KV)= NBEG NENDD(KV)= NEND GV(NF)= EO INNR(NF)= INNER 120 NF= NF + 1 IF(NF.GT.KVMAX) THEN c** If we have found all desired levels, then RETURN IF((AWO.GT.0).AND.(IWR.GT.0)) WRITE(6,626) JROT,KVMAX AFLAG= JROT RETURN ENDIF c... Check whether the next level had been found earlier in overshoot. c If so, count it in and skip on to the next one IF(INNR(NF).GE.0) THEN EO= GV(NF) INNER= INNR(NF) KV= NF GOTO 120 ENDIF ICOR= 0 c*** NOW, call SCECOR to calculate dG/dv and predict next higher level c** EO enters as G(KV) & exits as predicted G(NF=KV+1) w. predicted INNER CALL SCECOR(KV,NF,JROT,INNER,ICOR,IWR,EO,RH,BFCT,NDP,NCN,V, 1 VMAXX,VLIM,DGDV2) IF(ICOR.GE.11) THEN KVMAX= KV !! for case when vD-v < 1 for v=KV GOTO 200 ENDIF IF(EO.GT.VPMAX(NPMAX)) THEN c... if estimated energy above highest barrier, set value slightly below it EO= VPMAX(NPMAX) - 0.10d0*DGDV2 ICOR= ICOR+10 ELSE IF(DGDV2.LT.0.d0) THEN c... SCECOR returned negative phase integral, so quit loop & RETURN WRITE(6,628) JROT,EO AFLAG= -1 GOTO 200 ENDIF ENDIF LTRY= 0 GOTO 100 ENDIF c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(KV.NE.NF) THEN c*** If last level found was not the desired one ... IF(INNR(KV).LT.-1) THEN c... Record vibrational level (if haven't already) for posterity. GV(KV)= EO INNR(KV)= INNER ENDIF ICOR= ICOR+1 IF(ICOR.LE.10) THEN c... Call subroutine using semiclassical methods to estimate correct energy CALL SCECOR(KV,NF,JROT,INNER,ICOR,IWR,EO,RH,BFCT,NDP,NCN, 1 V,VMAXX,VLIM,DGDV2) IF(EO.GT.VPMAX(NPMAX)) THEN c... if estimated energy above highest barrier, set value below it KV= 999 EO= VPMAX(NPMAX) - 0.05d0*DGDV2 ENDIF GOTO 100 ENDIF c** If the calculated wavefunction is still for the wrong vibrational c level, then write out a warning return WRITE(6,630) NF,JROT KVMAX= NF-1 ENDIF c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 200 IF(AFLAG.LT.0) THEN c** If unable to find all KVMAX+1 levels requested, then return KVMAX as c v for the highest vibrational level actually found, and print out the c the energy of that level. KVMAX= KV !! modified 10/03/15 !! changed back 9/05/15 IF(AWO.NE.0) WRITE(6,632) KV, GV(KVMAX) ENDIF RETURN c----------------------------------------------------------------------- 602 FORMAT(/' *** ALF ERROR ***'/4X,'Number of vib levels requested=' 1 ,i4,' exceeds internal ALF array dimension NVIBMX=',i4) 604 FORMAT(/' *** ALF ERROR *** Find NO potential minima for J=', 1 i4) 606 FORMAT(/' ALF finds onee potential minimum of',1PD15.7, 1 ' at R(1)=',0Pf9.6) 608 FORMAT(/' *** ALF WARNING ***'/4X,'There are',I3,' potential ', 1 A6,' in this potential. Stop searching after 10.') 610 FORMAT(/' *** ALF ERROR ***'/ 4X,'The potential turns over in the 1 short range region at R= ',G15.8) 612 FORMAT(' *** Caution *** H.Osc.ZPE places E=',F10.2, ' above 1 VLIM=',F12.2) 614 FORMAT(' Find',I3,' potential minima: Vmin=',8F11.3) 616 FORMAT(15x,'at mesh points R =',8f11.5) 618 FORMAT(' Find',I3,' potential maxima: Vmax=',8F11.3) 620 FORMAT(' *** So STOP !!!!') 622 FORMAT(/' ALF search finds next estimated trial energy E(v=',I3, 1 ')=',G15.8/8X,'lies above potential maximum or asymptote at VMAX 2=',G15.8) 624 FORMAT(/' *** SCHRQ FAILS in ALF when searching for v=',i3, 1 ' J=',i3,' with EO=',f9.3/5x,'Check range and/or contact R.J 2. Le Roy [leroy@uwaterloo.ca]') 626 FORMAT(/' ALF successfully finds all (J=',i3,') vibrational levels 1 up to v= KVMAX=',I3) 628 FORMAT(/' *** ERROR: at E(J=',i3,')=',f10.3,' SCECOR finds n 1o Phase Integrals') 630 FORMAT(4x,'ALF fails to find level v=',i3,', J=',i3) 632 FORMAT(' ALF finds the highest calculated level is E(v=',I3, 1 ')=',1PD15.8 /) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE SCECOR(KV,KVLEV,JROT,INNER,ICOR,IWR,EO,RH,BFCT,NDP, 1 NCN,V,VMAXX,VLIM,DGDV2) c** Subroutine calculates (approximate!) semiclassical estimate of c dG/dv for level v= KV with energy EO [cm-1] on potential c {V(i),i=1,NDP} (in 'internal BFCT units' {V[cm-1]*BFCT}), and uses c those results to estimate energy of level KVLEV (usually = KV+1) c** If the 'clever' semiclassical procedure fails - try a brute force c step-by-step search, using alternately INNER & OUTER well starting c** VMAXX is height of outermost maximum, or VLIM for barrierless case c** On return, negative DGDV2 signals error! No phase integrals found c======================================================================= c Version date: 18 February 2016 {removed BMAX} c*********************************************************************** INTEGER I,II,I1,I2,I3,I4,IV1,IV2,INNER,ICOR,JROT,KV,KVB,KVLEV, 1 KVDIF,NDP,NCN,IDIF,BRUTE,IB,IWR,NPMAX REAL*8 EO,DE0,RH,BFCT,ARG2,ARG3,EINT,VPH1,VPH2,DGDV1,DGDV2,DGDVM, 1 DGDV2P,DGDVB,DGDVBP,EBRUTE,DEBRUTE,DE1,DE2,Y1,Y2,Y3,RT,ANS1,dv1, 2 dv2,ANS2,XDIF,VLIM,VMAXX,PNCN,PWCN,PP1,VDMV,ENEXT,V(NDP) SAVE BRUTE,EBRUTE,DEBRUTE,DGDVB DATA DGDVB/-1.d0/,KVB/-1/ c DGDV2= -1.d0 EINT= EO*BFCT IF(KVLEV.EQ.0) DGDVB= -1.d0 KVDIF= KVLEV- KV IF(ICOR.EQ.1) BRUTE= 0 PWCN= 2.d0*NCN/DABS(NCN- 2.d0) PNCN= ABS(NCN-2)/DFLOAT(NCN+2) DGDVBP= DGDVB**PNCN PP1= 1.d0/pNCN + 1.d0 I3= NDP IF(EO.GT.VLIM) THEN c*** For Quasibound levels, first search inward to classically forbidden PWCN= 2.d0 PNCN= 1.d0 PP1= 1.d0 DO I= NDP,1,-1 I3= I IF(V(I).GT.EINT) GOTO 8 ENDDO ENDIF c*** Now, search inward for outermost well turning point 8 DO I= I3,1,-1 I4= I IF(V(I).LT.EINT) GOTO 10 ENDDO c*** If never found an 'outer' turning point (e.g., above qbdd. barier) c then simply return with negative DGDV2 as error flag RETURN c... Now collect vibrational phase and its energy deriv. over outer well 10 Y1= EINT- V(I4+1) Y2= EINT- V(I4) Y3= EINT- V(I4-1) CALL LEVQAD(Y1,Y2,Y3,RH,RT,ANS1,ANS2) ARG2= DSQRT(Y3) VPH2= 0.5d0*ARG2 + ANS2/RH DGDV2= 0.5d0/ARG2 + ANS1/RH DO I= I4-2,1,-1 c... here collect (v+1/2) and dv/dG integrals over outer well .... II= I IF(V(I).GT.EINT) GO TO 12 ARG3= ARG2 ARG2= DSQRT(EINT - V(I)) VPH2= VPH2+ ARG2 DGDV2= DGDV2+ 1.d0/ARG2 ENDDO 12 I3= II+1 Y1= EINT- V(I3-1) Y2= EINT- V(I3) Y3= EINT- V(I3+1) CALL LEVQAD(Y1,Y2,Y3,RH,RT,ANS1,ANS2) VPH2= (VPH2 - ARG2 - 0.5d0*ARG3 + ANS2/RH)/3.141592654d0 DGDV2= DGDV2 -1.d0/ARG2 - 0.5d0/ARG3 + ANS1/RH DGDV2= 6.283185308d0/(BFCT*DGDV2) c*** Next, search outward from RMIN for innermost turning point DO I= 1,NDP I1= I IF(V(I).LT.EINT) GOTO 20 ENDDO 20 IF(I1.EQ.1) THEN c... but if RMIN is in the classically allowed region ... STOP here WRITE(6,602) JROT,EO STOP ENDIF IF(I1.GE.I3) THEN c*** For single-well potential or above barrier of double-well potential c use N-D theory estimate based on 'vD-v' from ratio of Eb to dG/dv VDMV= PWCN*(VMAXX-EO)/DGDV2 ENEXT= VMAXX - (VMAXX-EO)*((VDMV- KVDIF)/VDMV)**PWCN IF(IWR.GE.2) THEN IF(ABS(EO).GT.1.d0) WRITE(6,600) ICOR,KV,JROT,EO, 1 VPH2-0.5d0,DGDV2 IF(ABS(EO).LE.1.d0) WRITE(6,601) ICOR,KV,JROT,EO, 1 VPH2-0.5d0,DGDV2 WRITE(6,606) VDMV,ENEXT ENDIF IF(VDMV.LT.1.d0) THEN ICOR= 100 IF(IWR.GT.0) WRITE(6,604) KV,EO ELSE EO= ENEXT ENDIF DGDVB= DGDV2 DGDVBP= DGDVB**PNCN KVB= KV INNER= 0 RETURN ENDIF c c*** For a double-well potential, now collect vibrational phase and its c energy derivative over the inner well Y1= EINT- V(I1-1) Y2= EINT- V(I1) Y3= EINT- V(I1+1) CALL LEVQAD(Y1,Y2,Y3,RH,RT,ANS1,ANS2) ARG2= DSQRT(Y3) VPH1= 0.5d0*ARG2 + ANS2/RH DGDV1= 0.5d0/ARG2 + ANS1/RH DO I= I1+2,NDP c... now, collect integral and count nodes outward to second turning point ... IF(V(I).GT.EINT) GO TO 22 ARG3= ARG2 ARG2= DSQRT(EINT - V(I)) VPH1= VPH1+ ARG2 DGDV1= DGDV1+ 1.d0/ARG2 ENDDO 22 I2= I-1 Y1= EINT- V(I2+1) Y2= EINT- V(I2) Y3= EINT- V(I2-1) CALL LEVQAD(Y1,Y2,Y3,RH,RT,ANS1,ANS2) VPH1= (VPH1 - ARG2 - 0.5d0*ARG3 + ANS2/RH)/3.141592654d0 DGDV1= DGDV1 -1.d0/ARG2 - 0.5d0/ARG3 + ANS1/RH DGDV1= 6.28318531d0/(BFCT*DGDV1) DGDVM= DGDV1*DGDV2/(DGDV1+DGDV2) IF(KVDIF.EQ.0) THEN c** If already at level sought, return IF(IWR.GE.2) WRITE(6,610) KV,JROT,EO,VPH1-0.5d0,DGDV1,KVLEV, 1 ICOR,VPH2-0.5d0,DGDV2 RETURN ENDIF c c** Not at right level - Check whether looking for higher or lower level ... IDIF= SIGN(1,KVDIF) XDIF= IDIF IF((ICOR.GE.3).AND.((IABS(KVDIF).EQ.1).OR.(BRUTE.GT.0))) GOTO 50 c*** 'Conventional' semiclassical search for nearest INNER or OUTER well level c... first, determine whether starting level KV was really INNER or OUTER dv1= (VPH1-0.5d0) - NINT(VPH1-0.5d0) dv2=(VPH2-0.5d0) - NINT(VPH2-0.5d0) IF((DABS(dv2).GT.0.1).AND.(DABS(dv1).LT.0.1)) THEN INNER=1 ENDIF IF(INNER.EQ.0) THEN c... and if current energy EO is for an outer-well level ... DE2= DGDV2*XDIF IF(IDIF.GT.0) DE1= (Ceiling(VPH1-0.5d0) - (VPH1-0.5d0))*DGDV1 IF(IDIF.LE.0) DE1= -((VPH1-0.5d0)- Floor(VPH1-0.5d0))*DGDV1 IF(IWR.GE.2) WRITE(6,610) KV,JROT,EO,VPH1-0.5d0,DGDV1,KVLEV, 1 ICOR,VPH2-0.5d0,DGDV2 ELSE c... and if current energy EO is for an inner-well level ... DE1= DGDV1*XDIF IF(IDIF.GT.0) DE2= (Ceiling(VPH2-0.5d0) - (VPH2-0.5d0))*DGDV2 IF(IDIF.LE.0) DE2= -(1.d0 - dv2)*DGDV2 IF(IWR.GE.2) WRITE(6,610) KV,JROT,EO,VPH1-0.5d0,DGDV1,KVLEV, 1 ICOR,VPH2-0.5d0,DGDV2 ENDIF IF(DABS(DE2).LT.DABS(DE1)) THEN c... for case in which predict that next level will be OUTER INNER= 0 EO= EO+ DE2 ELSE c... for case in which predict that next level will be INNER INNER= 1 EO= EO+ DE1 ENDIF RETURN 50 BRUTE= BRUTE+ 1 c*** Now .. Brute force search for desired level ! IF(IWR.GE.2) WRITE(6,610) KV,JROT,EO,VPH1-0.5d0,DGDV1,KVLEV, 1 ICOR,VPH2-0.5d0,DGDV2 54 IF(BRUTE.EQ.1) THEN c... in first brute-force step, use previous energy with opposite INNER EBRUTE= EO IF(INNER.EQ.0) THEN INNER= 1 ELSE INNER= 0 ENDIF DEBRUTE= DMIN1(DGDV1,DGDV2)*XDIF*0.3d0 RETURN ENDIF IB= BRUTE/2 c... in subsequent EVEN steps, lower EO by DEBRUTE/10 for same INNER IF((IB+IB).EQ.BRUTE) THEN EBRUTE= EBRUTE+ DEBRUTE EO= EBRUTE RETURN ELSE c... in subsequent ODD steps, lower repeat previous EO with INNER changed IF(INNER.EQ.0) THEN INNER= 1 ELSE INNER= 0 ENDIF EO= EBRUTE RETURN ENDIF c RETURN 600 FORMAT(' Single well ICOR=',I2,': E(v=',i3,',J=',I3,')=',f10.2, 1 ' v(SC)=',F8.3,' dGdv=',f8.3) 601 FORMAT(' Single well ICOR=',I2,': E(v=',i3,',J=',I3,')=', 1 1PD12.4,' v(SC)=',0PF8.3, /63x,'dGdv=',1PD12.4) 602 FORMAT(/' *** ERROR *** V(1) < E(J=',i3,')=',f10.2 ) 604 FORMAT(10x,'Find highest level of this potential is E(v=',i3, 1 ')=',1PD18.10) 606 FORMAT(40x,'(vD-v)=',f10.4,' E(next)=',1PD12.4) 610 FORMAT(' Double well E(v=',i3,', J=',I3,')=',f9.3, 1 ': v1(SC)=',F7.3,' dGdv1=',f8.2/8x,'seeking v=',I3, 2 ' (ICOR=',I2,')',8x,': v2(SC)=',F7.3,' dGdv2=',f8.2 ) 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-2016 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 23/05/2016 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ cc INCLUDE 'arrsizes.h' !! bring in array size parameters c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** Dimension: potential arrays and vib. level arrays. c=============================================================== INTEGER I,M,IPASS,M1,M2,NBEG,NEND,WARN REAL*8 V(NPNTMX),WF0(NPNTMX),RM2(NPNTMX),P(NPNTMX),WF1(NPNTMX), 1 WF2(NPNTMX),RCNST(NROTMX) 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.NPNTMX) THEN WRITE(6,602) NEND,NPNTMX 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 DO M= 2, 7 c** Kill nonsensical high-order CDCs (which can occur in double-well cases) IF(DABS(RCNST(M)).GT.DABS(RCNST(M-1))) THEN DO I= M, 7 RCNST(I)= 0.d0 ENDDO EXIT ENDIF ENDDO 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 ' > NPNTMX=',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*********************************************************************** c***** R.J. Le Roy subroutine SCHRQ, last modified 9 May 2015 ******** c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c COPYRIGHT 2008-2014 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.857629206 (1/cm-1) c** INNODE > 0 specifies that wavefx. initiates at RMIN with a node c (normal default case); INNODE.le.0 specifies zero slope at c RMIN (for finding symmetric eigenfunctions of symmetric potential c with potential mid-point @ RMIN). c** INNER specifies wave function matching condition: INNER = 0 makes c matching of inward & outward solutions occur at outermost turning c point; INNER > 0 makes matching occur at innermost turning point. c * Normally use INNER=0 , but to find inner-well levels of double c minimum potential, set INNER > 0 . c---------------------------------------------------------------------- SUBROUTINE SCHRQ(KV,JROT,EO,GAMA,VMAX,VLIM,V,WF,BFCT,EEPS,RMIN, 1 RH,N,NBEG,NEND,INNODE,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,INNODE,INNER,IPSID,IQTST,IT, 1 ITER,ITP1,ITP1P,ITP3,IWR,J,JJ,J1,J2,JPSIQ,JQTST,JROT, 2 KKV,KV,KVIN,LPRWF,M,MS,MSAVE,N,NBEG,NDN,NEND,NLINES,NPR REAL*8 BFCT,DE,DEP,DEPRN,DF,DOLD,DSOC, 2 E,EEPS,EO,EPS,F,FX,GAMA,GI,GN,H,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 DATA RATST/1.D-9/,XPW/27.63d0/ DATA NDN/15/ c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DXPW= XPW/NDN ICOR= 0 KVIN= KV KV= -1 RMINN= RMIN-RH GAMA= 0.d0 VMAX= VLIM VMX= VMAX*BFCT H= RH HT= 1.d0/12.D+0 E= EO*BFCT EPS= EEPS*BFCT DSOC= VLIM*BFCT DE= 0.d0 RATIN= 0.d0 RATOUT= 0.d0 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 30 iterations. DO 90 IT= 1,30 ITER= IT IF(INNER.GT.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*(1.d0+ 0.5d0*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) JROT,EO GO TO 999 12 IF(MS.GE.N) GO TO 998 FX= GN/(GI-GN) SM= 0.5d0*(1.d0+ 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) EXIT ENDDO 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= 1.d0 SI= SB*DSQRT(SRTGN/SRTGI)*DEXP((SRTGN+SRTGI)*0.5d0) 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= 1.d0 SB= 0.d0 ENDIF 24 M= NEND-1 Y1= (1.d0-HT*GN)*SB Y2= (1.d0-HT*GI)*SI WF(NEND)= SB WF(NEND-1)= SI MS= NEND IBEGIN= 3 IF(INNER.GT.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/(1.d0-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= 1.d0/SI DO J= M,MS WF(J)= WF(J)*SI ENDDO ccc MS= M Y2= Y2*SI Y3= Y3*SI SB= SB*SI SI= 1.d0 ENDIF Y1= Y2 Y2= Y3 c** Test for outermost maximum of wave function. c... old S{max} matching condition - turning point works OK & is simpler. ccc IF((INNER.EQ.0).AND.(SI.LE.SB)) GO TO 32 c** Test for outermost well outer turning point IF((INNER.EQ.0).AND.(GI.lt.0.d0)) GO TO 32 ENDDO IF(INNER.EQ.0) THEN c** Error mode ... inward propagation finds no turning point 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= 1.d0/SI MSAVE= M RR= RMINN+MSAVE*H YIN= Y1*SI RATOUT= WF(NEND)*SI DO J= MSAVE,NEND WF(J)= WF(J)*SI ENDDO IF(INNER.GT.0) GO TO 70 c------------------------------------------------------------------- c** Set up to prepare for outward integration ********************** 38 NBEG= 1 IF(INNODE.LE.0) THEN c** Option to initialize with zero slope at beginning of the range SB= 1.d0 GN= V(1)-E Y1= SB*(1.d0-HT*GN) Y2= Y1+GN*SB*0.5d0 GI= V(2)-E SI= Y2/(1.d0-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.0.d0) WRITE(6,604) JROT,EO,NBEG,V(NBEG)/BFCT ENDIF c** Initialize outward wave function with a node: WF(NBEG) = 0. SB= 0.d0 SI= 1.d0 GI= V(NBEG+1)-E Y1= SB*(1.d0- HT*GN) Y2= SI*(1.d0- HT*GI) ENDIF c WF(NBEG)= SB WF(NBEG+1)= SI IF(INNER.GT.0) MSAVE= N c** Actual outward integration loops start here DO I= NBEG+2,MSAVE Y3= Y2+Y2-Y1+GI*SI GI= V(I)-E SI= Y3/(1.d0- 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= 1.d0/SI DO J= NBEG,I WF(J)= WF(J)*SI ENDDO Y2= Y2*SI Y3= Y3*SI SI= 1.d0 ENDIF Y1= Y2 Y2= Y3 ITP1= I c** Exit from this loop at onset of classically allowed region IF(GI.LE.0.d0) GO TO 52 ENDDO MS= MSAVE IF((INNER.EQ.0).AND.(GN.LE.0.d0)) 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.GT.0) GO TO 60 DO I= ITP1P,MSAVE Y3= Y2+Y2-Y1+GI*SI GI= V(I)-E SI= Y3/(1.d0- HT*GI) WF(I)= SI IF(DABS(SI).GT.1.D+17) THEN c** Renormalize to prevent overflow of WF(I) , as needed. SI= 1.d0/SI DO J= NBEG,I WF(J)= WF(J)*SI ENDDO Y2= Y2*SI Y3= Y3*SI SI= 1.d0 ENDIF Y1= Y2 Y2= Y3 ENDDO MS= MSAVE c** Finished outward integration. Normalize w.r.t. WF(MSAVE) 60 SI= 1.d0/SI YOUT= Y1*SI YM= Y2*SI RATIN= WF(NBEG+1)*SI DO I= NBEG,MS WF(I)= WF(I)*SI ENDDO IF(INNER.GT.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= 0.d0 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.1.d0)) 1 DF= DF+ WF(NEND)**2/(2.d0*DLOG(WF(NEND-1)/WF(NEND))) ENDIF c... note that by construction, at this point WF(MSAVE)= 1.0 F= (-YOUT-YIN+2.d0*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. cc WRITE(6,603) IT,EO,F,DF,DEPRN,MSAVE,RR,RATIN,RATOUT, cc 1 XEND,NBEG,ITP1 WRITE(6,603) IT,EO,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.999 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.0.d0)) 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) JROT,EO,IT,DEP DE= 0.5d0*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.(INNODE.GT.0) 1 .AND.(RMIN.GT.0.d0)) WRITE(6,614) KVIN,JROT,EO,RATIN IF((E.LT.DSOC).AND.(DABS(RATOUT).GT.RATST)) THEN WKBTST=0.5d0*DABS(V(NEND)-V(NEND-1))/DSQRT((V(NEND)-E)**3) IF(WKBTST.GT.1.d-3) WRITE(6,615) KVIN,JROT,EO,RATOUT, 1 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.0.d0).AND.(PROD.GT.0.d0)) KKV= KKV+1 ENDDO KV = KKV c** Normalize & find interval (NBEG,NEND) where WF(I) is non-negligible SN= 1.d0/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)= 0.d0 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)= 0.d0 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 IF(IWR.GE.2) WRITE(6,607) KV,JROT,EO,ITER,RR,NBEG,RATIN,INNER, 1 NEND,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) cc602 FORMAT(' ITER ETRIAL',8X,'F(E) DF(E) D(E)', cc 1 6X,'M R(M) /WF(M) /WF(M) R(NEND) NBEG ITP1'/ cc 2 1X,99('-')) 602 FORMAT(' ITER ETRIAL',7X,'D(E) M r(M) wf(1)/wf(M) wf(NE 1ND)/wf(M) R(NEND) NBEG ITP1'/1X,85('-')) 603 FORMAT(I4,1PD15.7,D10.2,0P,I7,F7.2,1P2D9.1,0PF8.2,I5,I5) 604 FORMAT(' NOTE: for J=',I3,' EO=',F12.4,' .ge. V(',i3,')=', 1 F12.4) 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,I4,' Iter R(M)=',F6.2, 1 ' WF(NBEG=',i6,')/WF(M)=',1PD8.1/36x,'INNER=',I2,6x, 2 'WF(NEND=',i6,')/WF(M)=',D8.1) 608 FORMAT(' *** SCHRQ Error: E=',F9.2,' > V(',I6,')=',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 inward search at J=',i3,' E=',f11.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(' ****** For v=',I3,', J=',I3,' E=',G15.8/16x, 1 'WF(first)/WF(Max)=',D9.2,' suggests RMIN may be too large') 615 FORMAT(' ****** For v=',I3,',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=',G14.7, 1 ': inward propagation finds no turning point ... Energy too low 2 or potential too weak' ) 617 FORMAT(' ** @ J=',I3,' E=',1PD9.2,' SCHRQ has cgce prob at IT=', 1 0P,I3,', so halve DE=',1PD10.2 ) 618 FORMAT(' *** For J=',I3,' E=',F9.2,' JWKB start gives SB/SI=', 1 1PD10.3,' so use a node.') 619 FORMAT(1X,99('-')) 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(0Pf9.4,1PD13.5))) 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 theory see c J.Chem.Phys. 54, 5114 (1971), 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 DATA 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 10 II=J c** Check that there is a classically allowed region inside this point c and determine height of barrier maximum. 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). c Uses series expansions of Abramowitz & Stegun Eq.(10.4.3) SL=(GI-GB)**(1.d0/3.d0)/H IF((SL*H).LT.1.d0) THEN A1=GI/(SL*H)**2 A2=GB/(SL*H)**2 A13=A1*A1*A1 A23=A2*A2*A2 FIA= 1.d0+ A13*(A13*(A13+72.D0)+2160.D0)/12960.D0 GIA=A1+A1*A13*(A13*(A13+90.D0)+3780.D0)/45360.D0 FBA= 1.d0+ 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= 1.d0+ DF*FJ**3/6.d0 SB= 1.d0 -DF*(1.d0- FJ)**3/6.d0 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)] and Huang & Le Roy c [J.Chem.Phys. 119, 7398 (2003); Erratum, ibid, 126, 169904 (2007)] c** Final level width calculation from Eq.(4.5) of Connor & Smith. c Rearranged slightly for consistency with PotFit derivatives 9/05/02 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 ANS1,ANS2,ARG,BFCT,COR, 1 D1,D2,D3,DFI,DSGB,DSGN,DSOC,DWEB,OMEGJC, 2 E,EO,EMSC,EMV,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,U1,U2,V(N),VMAX,VMX, 7 XJ,XX CHARACTER*5 LWELL(2) DATA 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= 0.d0 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.0.d0) GO TO 218 SM= SM+ 0.5d0*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.0.d0) 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- 0.5d0*DSQRT(GA)+ (DLOG((1.d0+U1)/U2)-U1)*RMX* 1 DSQRT(V(M)- DSOC)/H XJ= (DSQRT(1.d0+ 4.d0*(V(M)-DSOC)*(RMX/H)**2)- 1.d0)*0.5d0 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(1.d0,S(M-1)) c** Find the effective quantum number for the outer well DO I= M,ITP3 DSGB= DSGN DSGN= DSIGN(1.d0,S(I)) IF((DSGN*DSGB).LT.0.d0) 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.0.d0) 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- 0.5d0*DSQRT(G3)-DSQRT(G2) + ANS2/H 218 EMSC= -SM/PI IF(INNER.GT.0) VMX= PMX VMAX= VMX/BFCT c** Tunneling factors calculated here ** TUN0 is simple WKB result c as in Child's eqs.(57c) & (59). c ..... EPSRJ= -2.* PI* EMSC TUN0= 0.5d0*DEXP(2.d0*PI*EMSC) c ... for permeability calculate Connor-Smith's Eq.(3.7) \omega=OMEGJC OMEGJC= DSQRT(1.d0+ 2.d0*TUN0) - 1.d0 c ... alternate calculation to give better precision for small TUN0 IF(TUN0.LT.1.d-5) OMEGJC= TUN0*(1.d0-0.5d0*TUN0*(1.d0-TUN0)) OMEGJC= 4.d0*OMEGJC/(OMEGJC + 2.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.0.d0) GO TO 228 SM= SM+ 0.5d0/DSQRT(D3) DO I= ITP1P1,ITP2M2 IMM= I EMV= E- V(I) IF(EMV.LT.0.d0) GO TO 222 SM= SM+ 1.d0/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-0.5d0/DSQRT(D3) + ANS1/H c** Get HBW in same energy units (1/cm) associated with BFCT 228 HBW=2.d0*PI/(BFCT*SM) c** HBW fix up suggested by Child uses his eqs.(48)&(62) for HBW c** Derivative of complex gamma function argument calculated as c per eq.(6.1.27) in Abramowitz and Stegun. NST= INT(DABS(EMSC)*1.D2) NST= MAX0(NST,4) ARG= -1.963510026021423d0 DO I= 0,NST NN= I XX= I + 0.5d0 TI= 1.d0/(XX*((XX/EMSC)**2 + 1.d0)) ARG= ARG+TI IF(DABS(TI).LT.1.D-10) GO TO 233 ENDDO c ... and use continuum approximation for tail of summation (???) 233 COR= 0.5d0*(EMSC/(NN+1.d0))**2 ARG= ARG+ COR- COR**2 c** Now use WKL's Weber fx. approx for (?) derivative of barrier integral .. DWEB= (EO-VMAX)*BFCT/(H2*EMSC) DFI= (DLOG(DABS(EMSC)) - ARG)*BFCT/(H2*DWEB) HBWB= 1.d0/(1.d0/HBW + DFI/(2.d0*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/(2.d0*PI))* 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 ELSE GAMALG= DLOG10(HBWB/(2.d0*PI))+2.d0*PI*EMSC/2.302585093D0 TAULG= DLOG10(5.308837457D-12)-GAMALG IF(IWR.GT.0) WRITE(6,611) TAULG,GAMALG,HBWB,VMAX ENDIF 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,' dG/dv=',G12.5,' V(max)=',G14.7,'(cm-1)') END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 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,ZT c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DATA HPI/1.570796326794896D0/ IF((Y1.GE.0).OR.(Y2.LT.0)) GO TO 99 IF(Y3.LT.0.d0) 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-2.d0*Y2+Y1)/(2.d0*H*H) B= (Y3-Y2)/H-C*H A= Y2 CQ= B**2- 4.d0*A*C RCQ= DSQRT(CQ) R1= (-B-RCQ)/(2.d0*C) R2= R1+ RCQ/C IF((R2.LE.0.d0).AND.(R2.GE.-H)) RT=R2 IF((R1.LE.0.d0).AND.(R1.GE.-H)) RT=R1 SL3= 2.d0*C*H+B SLT= 2.d0*C*RT+B IF(C.LT.0.d0) GO TO 10 ANS1= DLOG((2.d0*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/2.d0)/(4.d0*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-1.d0)/((RR+1.d0)*2.d0) B= (Y2-Y1)/(H*(2.d0*X0+H)) A= Y2+ B*X0**2 ZT= DSQRT(A/B) RT= X0- ZT ANS1= 2.d0*HPI/DSQRT(B) ANS2= ANS1*A*0.5d0 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= 0.d0 ANS2= 0.d0 RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE NLLSSRR(NDATA,NPTOT,NPMAX,CYCMAX,IROUND,ROBUST,LPRINT, 1 IFXP,YO,YU,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)]. 23/03/16 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c COPYRIGHT 1998-2016 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, 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 total number of parameters in the model (.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 model parameters allowed by current c external array sizes. Should set internal NPINTMX = NPMAX c (may be freely changed by the user). c CYCMAX is the upper bound on the allowed number of iterative cycles 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 ROBUST > 0 causes fits to use Watson's ``robust'' weighting c 1/[u^2 +{(c-o)^2}/3]. ROBUST > 1 uses normal 1/u^2 on first c fit cycle and 'robust' on later cycles. c LPRINT specifies the level of printing inside NLLSSRR c if: = 0, no print except for failed convergence. c .NE.0 also print DRMSD and convergence tests on each cycle c and indicate nature of convergence c >= 1 also parameters changes & uncertainties, each cycle c >= 2 also print parameter change each rounding step c IFXP(j) specifies whether parameter j is to be held fixed c [IFXP > 0] or to be freely varied in the fit [IFXP= 0] 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=8000) INTEGER I,J,K,L,IDF,ITER,NITER,CYCMAX,IROUND,ISCAL,JROUND,LPRINT, 1 NDATA,NPTOT,NPMAX,NPARM,NPFIT,JFIX,QUIT,ROBUST, 2 IFXP(NPMAX),JFXP(NPINTMX) REAL*8 YO(NDATA), YU(NDATA), YD(NDATA), PV(NPTOT), PU(NPTOT), 1 PS(NPTOT),PSS(NPINTMX),PC(NPINTMX),PX(NPINTMX), 2 PY(NPINTMX),CM(NPMAX,NPMAX), F95(10), 3 RMSR, RMSRB, DSE, TSTPS, TSTPSB, TSTPU, TFACT, S, YC, Zthrd DATA F95/12.7062D0,4.3027D0,3.1824D0,2.7764D0,2.5706D0,2.4469D0, 1 2.3646D0,2.3060D0,2.2622D0,2.2281D0/ IF((NPTOT.GT.NPMAX).OR.(NPTOT.GT.NPINTMX).OR.(NPINTMX.NE.NPMAX) 1 .OR.(NPTOT.GT.NDATA)) THEN c** If array dimensioning inadequate, print warning & then STOP WRITE(6,602) NPTOT,NPINTMX,NPMAX,NDATA STOP ENDIF Zthrd= 0.d0 IF(ROBUST.GE.2) Zthrd= 1.d0/3.d0 TSTPS= 0.d0 RMSR= 0.d0 NITER= 0 QUIT= 0 NPARM= NPTOT DO J= 1, NPTOT PS(J)= 0.d0 JFXP(J)= IFXP(J) IF(IFXP(J).GT.0) NPARM= NPARM- 1 ENDDO NPFIT= NPARM 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 30 cycles DO 50 ITER= 1, CYCMAX ISCAL= 0 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 c iteration to be carried into dyidpj subroutine - used in predicting c increment 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)=YC] 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 1: if more convenient, DYIDPJ could prepare the y(calc) values c and derivatives for all data at the same time (when I=1), but only c returned the values here one datum at a time (for I > 1).] c* NOTE 2: the partial derivative array PC returned by DYIDPJ must have c an entry for every parameter in the model, though for parameters c which are held fixed [JFXP(j)=1], those PC(j) values are ignored. CALL DYIDPJ(I,NDATA,NPTOT,YO(I),YC,PV,PC) IF(NPARM.LT.NPTOT) THEN c** For constrained parameter or sequential rounding, collapse partial c derivative array here DO J= NPTOT,1,-1 IF(JFXP(J).GT.0) THEN c!! First ... move derivative for constrained-parameter case cc666 FORMAT(' For IDAT=',I5,' add PC(',I3,') =',1pD15.8, cc 1 ' to PC(',0pI3,') =',1pD15.8) IF(JFXP(J).GT.1) THEN cc write(6,666) I,J,PC(J),JFXP(J),PC(JFXP(J)) PC(JFXP(J))= PC(JFXP(J))+ PC(J) ENDIF c ... now continue collapsing partial derivative array IF(J.LT.NPTOT) THEN DO K= J,NPTOT-1 PC(K)= PC(K+1) ENDDO ENDIF PC(NPTOT)= 0.d0 ENDIF ENDDO ENDIF YD(I)= YC - YO(I) S = 1.D0/YU(I) cc *** For 'Robust' fitting, adjust uncertainties here IF(Zthrd.GT.0.d0) S= 1.d0/DSQRT(YU(I)**2 + Zthrd*YD(I)**2) YC= -YD(I)*S DSE= DSE+ YC*YC 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,YC,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 I = 1,NPARM J = NPARM - I + 1 PC(J) = 0.D0 DO K = J,NPARM PC(J) = PC(J) + CM(J,K) * PU(K) ENDDO ENDDO c c** Get (upper triangular) "dispersion Matrix" [variance-covarience c matrix without the sigma^2 factor]. DO I = 1,NPARM DO J = I,NPARM YC = 0.D0 DO K = J,NPARM YC = YC + CM(I,K) * CM(J,K) ENDDO CM(I,J) = YC ENDDO ENDDO c** Generate core of Parameter Uncertainties PU(j) and (symmetric) c correlation matrix CM DO J = 1,NPARM PU(J) = DSQRT(CM(J,J)) DO K= J,NPARM CM(J,K)= CM(J,K)/PU(J) ENDDO DO K= 1,J CM(K,J)= CM(K,J)/PU(J) CM(J,K)= CM(K,J) ENDDO ENDDO 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 YC= DSE*0.1d0/DFLOAT(NPARM) S= DSE*TFACT DO J = 1,NPARM PU(J)= S* PU(J) PS(J)= YC*DSQRT(NDATA/PS(J)) ENDDO c========End of core linear least-squares step========================== c ... early exit if Rounding cycle finished ... IF(QUIT.GT.0) GO TO 54 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.NE.0) WRITE(6,604) ITER,RMSR,TSTPS,TSTPU c** Now ... update parameters (careful about rounding) DO J= 1,NPTOT IF(JFXP(J).GT.0) THEN IF(JFXP(J).GT.1) THEN c** If this parameter constrained to equal some earlier parameter .... PV(J)= PV(JFXP(J)) WRITE(6,668) J,JFXP(J),PV(J),ITER ENDIF 668 FORMAT(' Constrain PV('i3,') = PV(',I3,') =',1pd15.8, 1 ' on cycle',i3) c** If parameter held fixed (by input or rounding process), shift values c of change, sensitivity & uncertainty to correct label. IF(J.LT.NPTOT) THEN DO I= NPTOT,J+1,-1 PC(I)= PC(I-1) PS(I)= PS(I-1) PU(I)= PU(I-1) ENDDO ENDIF PC(J)= 0.d0 PS(J)= 0.d0 PU(J)= 0.d0 ELSE PV(J)= PV(J)+ PC(J) ENDIF ENDDO IF(LPRINT.GE.1) WRITE(6,612) (J,PV(J),PU(J),PS(J),PC(J), 1 J=1,NPTOT) IF(ITER.GT.1) THEN c** New Convergence test is to require RMSD to be constant to 1 part in c 10^7 in adjacent cycles (unlikely to occur by accident) IF(ABS((RMSR/RMSRB)-1.d0).LT.1.d-07) THEN IF(LPRINT.NE.0) WRITE(6,607) ITER, 1 ABS(RMSR/RMSRB-1.d0),TSTPS GO TO 54 ENDIF ENDIF IF(ROBUST.GT.0) Zthrd= 1.d0/3.d0 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.LT.NPTOT) THEN c** If necessary, redistribute correlation matrix elements to full c NPTOT-element correlation matrix DO J= 1,NPTOT IF(JFXP(J).GT.0) THEN c* If parameter J was held fixed IF(J.LT.NPTOT) THEN c ... then move every lower CM element down one row: DO I= NPTOT,J+1,-1 c ... For K < J, just shift down or over to the right IF(J.GT.1) THEN DO K= 1,J-1 CM(I,K)= CM(I-1,K) CM(K,I)= CM(I,K) ENDDO ENDIF c ... while for K > J also shift elements one column to the right DO K= NPTOT,J+1,-1 CM(I,K)= CM(I-1,K-1) ENDDO ENDDO ENDIF c ... and finally, insert appropriate row/column of zeros .... DO I= 1,NPTOT CM(I,J)= 0.d0 CM(J,I)= 0.d0 ENDDO CM(J,J)= 1.d0 ENDIF ENDDO ENDIF IF(QUIT.GT.0) GOTO 60 IF(NPARM.EQ.NPFIT) THEN c** If desired, print unrounded parameters and fit properties IF(LPRINT.NE.0) THEN WRITE(6,616) NDATA,NPARM,RMSR,TSTPS WRITE(6,612) (J,PV(J),PU(J),PS(J),PC(J),J=1,NPTOT) ENDIF ENDIF IF(IROUND.EQ.0) RETURN c** Automated 'Sequential Rounding and Refitting' section: round c selected parameter, fix it, and return (above) to repeat fit. IF(IROUND.LT.0) THEN c ... if IROUND < 0, sequentially round off 'last' remaining parameter DO J= 1, NPTOT IF(JFXP(J).LE.0) THEN JFIX= J ENDIF ENDDO ELSE c ... if IROUND > 0, sequentially round off remaining parameter with c largest relative uncertainty. c ... First, select parameter JFIX with the largest relative uncertainty JFIX= NPTOT K= 0 TSTPS= 0.d0 DO J= 1,NPTOT IF(JFXP(J).LE.0) THEN K= K+1 TSTPSB= DABS(PU(J)/PV(J)) IF(TSTPSB.GT.TSTPS) THEN JFIX= J TSTPS= TSTPSB ENDIF ENDIF ENDDO ENDIF YC= PV(JFIX) CALL ROUND(JROUND,NPMAX,NPTOT,NPTOT,JFIX,PV,PU,PS,CM) JFXP(JFIX)= 1 IF(LPRINT.GE.2) 1 WRITE(6,614) JFIX,YC,PU(JFIX),PS(JFIX),JFIX,PV(JFIX),RMSR NPARM= NPARM-1 IF(NPARM.EQ.0) THEN c** After rounding complete, make one more pass with all non-fixed c parameters set free to get full correct final correlation matrix, c uncertainties & sensitivities. Don't update parameters on this pass! NPARM= NPFIT QUIT= 1 DO J= 1,NPTOT JFXP(J)= IFXP(J) 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.NPFIT) THEN DSE= RMSR*DSQRT(DFLOAT(NDATA)/DFLOAT(NDATA-NPFIT)) ELSE DSE= 0.d0 ENDIF IF(NPFIT.GT.0) THEN IF(LPRINT.GT.0) THEN c** Print final rounded parameters with original Uncert. & Sensitivities IF(QUIT.LT.1) WRITE(6,616) NDATA, NPFIT, RMSR, TSTPS IF(QUIT.EQ.1) WRITE(6,616) NDATA, NPFIT, RMSR DO J= 1, NPTOT IF(JFXP(J).GT.0) THEN c** If parameter held fixed (by rounding process), shift values of c change, sensitivity & uncertainty to correct absolute number 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 ENDIF ENDDO 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,': DRMSD=',1PD14.7,' test(PS)=', 1 1PD8.1,' test(PU)=',D8.1) 606 FORMAT(/' Effective',i3,'-cycle Cgce: MAX{|change/unc.|}=', 1 1PD8.1,' < 0.01 DRMSD=',D10.3) 607 FORMAT(/' Full',i3,'-cycle convergence: {ABS(RMSR/RMSRB)-1}=', 1 1PD9.2,' TSTPS=',D8.1) 610 FORMAT(/ ' !! CAUTION !! fit of',i5,' parameters to',I6,' data not 1 converged after',i3,' Cycles'/5x,'DRMS(deviations)=',1PD10.3, 2 ' test(PS) =',D9.2,' test(PU) =',D9.2/1x,31('**')) 612 FORMAT((3x,'PV(',i4,') =',1PD22.14,' (+/-',D8.1,') PS=',d8.1, 1 ' PC=',d9.1)) 614 FORMAT(' =',39('==')/' Round Off PV(',i4,')=',1PD21.13,' (+/-', 1 D9.2,') PS=',d9.2/4x,'fix PV(',I4,') as ',D19.11, 2 ' & refit: DRMS(deviations)=',D12.5) 616 FORMAT(/i6,' data fit to',i5,' param. yields DRMS(devn)=', 1 1PD14.7:' tst(PS)=',D8.1) 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(DABS(Z(1)).LE.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 !! rounded constant !! c** Zero parameters more aggressively ... if unc. > 2* value if(dabs(PU(IPAR)/PV(IPAR)).GT.2.d0) then cnst= 0.d0 endif 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*********************************************************************** c SUBROUTINE DYIDPJ(I,NDATA,NPTOT,YC,PV,PD) 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). ** Elements of the integer array IFXP indicate c whether parameter j is being held fixed [IFXP(j) > 0] or varied in c the fit [IFXP(j).le.0]. If the former, the partial derivative c for parameter j should be PD(j)= 0.0. 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,IFXP(NPTOT) 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 c*********************************************************************** SUBROUTINE FUNUNC(ISTATE,WRITFILE,PU,CM) c*********************************************************************** c** This subroutine will calculate the uncertainties in the radial c strength functions for V(r), phi(r), UA(r), UB(r), tA(r), tB(r) and c wRAD(r) and print them out in `Tecplot' format. c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c ... OSEL print PEF values at every |OSEL|'th mesh point c and if OSEL < 0, also the BOB fx an every |OSEL|'th mesh point c ... ISTATE electronic state counter c ... PU(n) uncertainties in the TOTPOTPAR parameters of the model c ... CM(n,n) (symmetric) correlation matrix from the fit c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKBOBRF.h' c======================================================================= c** Born-Oppenheimer breakdown radial functions REAL*8 UAR(NPNTMX,NSTATEMX),UBR(NPNTMX,NSTATEMX), 1 TAR(NPNTMX,NSTATEMX),TBR(NPNTMX,NSTATEMX),wRAD(NPNTMX,NSTATEMX) c COMMON /BLKBOBRF/UAR,UBR,TAR,TBR,wRAD c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= c----------------------------------------------------------------------- INTEGER I,J,JJ,ISTATE,LAM2,NBETAI REAL*8 FU,FLAM,RHT,RMAXT,RDVAL,RDVAL2,RDVALLD, PU(NPARMX), 1 PT(NPARMX),CM(NPARMX,NPARMX) CHARACTER*20 WRITFILE c c------------------------------------------------------------------------ c*** Common Block info for fununc calculations *********************** REAL*8 Rsr(NPNTMX,NSTATEMX),Vsr(NPNTMX,NSTATEMX), 1 Bsr(NPNTMX,NSTATEMX) INTEGER nPointSR(NSTATEMX) COMMON /VsrBLK/Rsr,Vsr,Bsr,nPointSR c REAL*8 Rlr(NPNTMX,NSTATEMX),Plr(NPNTMX,NSTATEMX), 1 Blr(NPNTMX,NSTATEMX) INTEGER nPointLR(NSTATEMX) COMMON /PlrBLK/Rlr,Plr,Blr,nPointLR c------------------------------------------------------------------------ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ RHT= RD(2,ISTATE)- RD(1,ISTATE) RMAXT= RD(NDATPT(ISTATE),ISTATE) WRITE(10,900) 'V(r) ', ISTATE, 'V(r) ', WRITFILE ccc WRITE(11,900) 'B(r) ', ISTATE, 'B(r) ', WRITFILE DO I= 1,nPointSR(ISTATE),MAX(1,IABS(OSEL(ISTATE))/10) WRITE(10,909) Rsr(I,ISTATE),Vsr(I,ISTATE) ccc WRITE(11,909) Rsr(I,ISTATE),Bsr(I,ISTATE) END DO IF(OSEL(ISTATE).LT.0) THEN IF(NUA(ISTATE).GE.0) WRITE(12,900) 'UA(r)',ISTATE,'UA(r)', 1 WRITFILE IF(NUB(ISTATE).GE.0) WRITE(13,900) 'UB(r)',ISTATE,'UB(r)', 1 WRITFILE IF(NTA(ISTATE).GE.0) WRITE(14,900) 'tA(r)',ISTATE,'qA(r)', 1 WRITFILE IF(NTB(ISTATE).GE.0) WRITE(15,900) 'tB(r)',ISTATE,'qB(r)', 1 WRITFILE IF(NwCFT(ISTATE).GE.0) THEN WRITE(16,902) 'lambda(r)',ISTATE,'lambda(r)',WRITFILE LAM2= 2 IF(IOMEG(ISTATE).GT.0) LAM2= 4*IOMEG(ISTATE) ENDIF ENDIF NBETAI= POTPARF(ISTATE) - Nbeta(ISTATE) FU= 0.d0 DO I= 1,NDATPT(ISTATE),IABS(OSEL(ISTATE)) DO J= 1,TOTPOTPAR PT(J) = 0.0d0 END DO RDVAL = RD(I,ISTATE) RDVAL2= RDVAL*RDVAL RDVALLD= RDVAL**LAM2 c ... first ... the potential function itself ... DO J= POTPARI(ISTATE),POTPARF(ISTATE) PT(J)= PU(J)*DVtot(J,I) ENDDO IF(PSEL(ISTATE).GT.0) 1 CALL MMCALC(POTPARI(ISTATE),POTPARF(ISTATE),PT,CM,FU) WRITE(10,910) RDVAL,VPOT(I,ISTATE),FU c ... then the exponent coefficient function \betai(i) ccc IF(PSEL(ISTATE).LE.5) THEN ccc DO J= NBETAI,POTPARF(ISTATE) ccc JJ= J-NBETAI ccc PT(J)= PU(J)*DBDB(JJ,I,ISTATE) ccc ENDDO ccc CALL MMCALC(NBETAI,POTPARF(ISTATE),PT,CM,FU) ccc WRITE(11,910) RDVAL,BETAFX(I,ISTATE),FU ccc ENDIF c ... adiabatic BOB correction function for atom-A IF(OSEL(1).LT.0) THEN IF(NUA(ISTATE).GE.1) THEN DO J= UAPARI(ISTATE),UAPARF(ISTATE) PT(J)= PU(J)*DVtot(J,I) ENDDO CALL MMCALC(UAPARI(ISTATE),UAPARF(ISTATE),PT,CM,FU) WRITE(12,910) RDVAL,UAR(I,ISTATE),FU ENDIF c ... adiabatic BOB correction function for atom-B IF(NUB(ISTATE).GE.1) THEN DO J= UBPARI(ISTATE),UBPARF(ISTATE) PT(J)= PU(J)*DVtot(J,I) ENDDO CALL MMCALC(UBPARI(ISTATE),UBPARF(ISTATE),PT,CM,FU) WRITE(13,910) RDVAL,UBR(I,ISTATE),FU ENDIF c ... centrifugal BOB correction function for atom-A IF(NTA(ISTATE).GE.1) THEN DO J= TAPARI(ISTATE),TAPARF(ISTATE) PT(J)= PU(J)*DVtot(J,I)*RDVAL2 ENDDO CALL MMCALC(TAPARI(ISTATE),TAPARF(ISTATE),PT,CM,FU) WRITE(14,910) RDVAL,TAR(I,ISTATE),FU ENDIF c ... centrifugal BOB correction function for atom-B IF(NTB(ISTATE).GE.1) THEN DO J= TBPARI(ISTATE),TBPARF(ISTATE) PT(J)= PU(J)*DVtot(J,I)*RDVAL2 ENDDO CALL MMCALC(TBPARI(ISTATE),TBPARF(ISTATE),PT,CM,FU) WRITE(15,910) RDVAL,TBR(I,ISTATE),FU ENDIF c ... Lambda/doublet-sigma doubling correction radial function IF(NwCFT(ISTATE).GE.0) THEN DO J= LDPARI(ISTATE),LDPARF(ISTATE) PT(J)= PU(J)*DVtot(J,I)*RDVALLD ENDDO CALL MMCALC(LDPARI(ISTATE),LDPARF(ISTATE),PT,CM,FU) FLAM= wRAD(I,ISTATE)*RDVALLD WRITE(16,910) RDVAL,FLAM,FU ENDIF ENDIF END DO DO I= 1,nPointLR(ISTATE) WRITE(10,909) Rlr(I,ISTATE),Plr(I,ISTATE) ccc WRITE(11,909) Rlr(I,ISTATE),Blr(I,ISTATE) END DO RETURN c----------------------------------------------------------------------- 900 FORMAT(/'variables = "r", "',A5,'", "Uncertainty"'/ 1'zone T = "State',I2,1x,A5,2x,A20,'"',/) 902 FORMAT(/'variables = "r", "',A9,'", "Uncertainty"'/ 1'zone T = "State',I2,2x,A9,2x,A20,'"',/) 909 FORMAT(F12.6,1x,1PD22.13,5X,'0.0') 910 FORMAT(F12.6,1x,1PD22.13,D11.3) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE MMCALC(JI,JF,PT,CM,FU) c*********************************************************************** c** For elements JI to JF of column vector PT(j) and rows/columns c JI to JF of the square matrix CM, evaluate FU**2 = PT^t CM PT c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Externally dimension PT(NPARMX) and CM(NPARMX,NPARMX) c*********************************************************************** cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% INTEGER I,J,JI,JF REAL*8 PT(NPARMX), CM(NPARMX,NPARMX), TVAL, FU c======================================================================= c** Initialize the variables. FU = 0.0d0 DO J= JI, JF TVAL= 0.d0 DO I= JI,JF c** Multiply the vector PT with the correlation matrix (CM). TVAL= TVAL + PT(I)*CM(I,J) ENDDO c** Now to multiply the vector (PT*CM) with the vector PT. FU= FU + TVAL * PT(J) ENDDO c** Complete calculation of the uncertainty of the function. FU= DSQRT(FU) RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 C*********************************************************************** SUBROUTINE GPROUND(IROUND,NPTOT,NPMAX,NPAR1,NPAR2,LPRINT,IFXP, 1 PV,PU) c** Subroutine to round off parameters PV(i), i= NPAR1 to NPAR2, at the c |IROUND|'th significant digit of the smallest of their uncertainties c min{U(i)}. This procedure does NOT attempt to correct the remaining c parameters to compensate for these changes (as ROUND does), so this c procedure is not appropriate for nonlinear parameters. c** On return, the rounded values replaces the initial values of PV(i). c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c COPYRIGHT 2000-2004 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 Version of 27 January 2004 + c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ INTEGER IROUND,NPMAX,NPTOT,NPAR1,NPAR2,IPAR,IRND,KRND,LPRINT INTEGER IFXP(NPTOT) REAL*8 PV(NPMAX),PU(NPMAX),CNST,CRND,XRND,FCT,YY,UNC c !! This only makes sense if ALL param have same magnitude (e.g. Tvj's) c** Loop over & round off the parameters # NPAR1 to NPAR2 cc IF(LPRINT.GE.2) WRITE(6,602) NPAR2-NPAR1+1,NPTOT,NPAR1,NPAR2 cc UNC= 99.d99 cc DO IPAR= NPAR1, NPAR2 !! search for smallest uncertainty cc IF(PU(IPAR).LT.UNC) UNC= PU(IPAR) !! which is/was used cc ENDDO !! to round ALL parameters! DO IPAR= NPAR1, NPAR2 c** First ... fiddle with log's to perform the rounding XRND= DLOG10(PU(IPAR)) IRND= INT(XRND) IF(XRND.GT.0) IRND=IRND+1 IRND= IRND- IROUND FCT= 10.D0**IRND CNST= PV(IPAR) YY= CNST CRND= PV(IPAR)/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 GO TO 20 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(IPAR) = CNST IFXP(IPAR)= 1 IF(LPRINT.GE.2) WRITE(6,604) IPAR,YY,PV(IPAR) 604 FORMAT(5x,'Round parameter #',i4,' from',G20.12,' to',G20.12) 20 CONTINUE ENDDO IPAR= IPAR- 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 ',i5,' of the ',i5,' parameters #:',i5, 1 ' to',i5) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** double precision function Scalc(x,m,n,y,rKL,LMAX) c** At the position 'x', Scalc is returned as the value of the m'th c of the 'n' Sm(x) function defining a natural cubic spline through the c mesh points located at x= y(x_i), for i=1,n. LMAX specifies the c maximum number of mesh points x= y(x_i) allowed by the calling program c--------------------------------------------------------------------- INTEGER LMAX,I,K,KK,M,N REAL*8 x,y1,y2,y(1:LMAX),rKL(1:LMAX,1:LMAX) k= 0 kk= 0 do i=2,n c... select interval if ((x.gt.y(i-1)).and.(x.le.y(i))) k=i end do if (x.lt.y(1)) then k=2 kk=1 end if if (x.gt.y(n)) then k=n kk=1 end if if(x.eq.y(1)) k=2 y1=y(k-1) y2=y(k) Scalc= 0.d0 IF(kk.eq.0) 1 Scalc= rKL(m,k)*((y1-x)*(((y1-x)/(y1-y2))**2-1)/6)*(y1-y2) 2 + rKL(m,k-1)*((x-y2)*(((x-y2)/(y1-y2))**2-1)/6)*(y1-y2) IF(k.EQ.m) Scalc= Scalc + (y1-x)/(y1-y2) IF(k-1.EQ.m) Scalc= Scalc + (x-y2)/(y1-y2) c... Asen's original coding ... cc Scalc=ndirac(k,m)*A(x,y1,y2)+ndirac(k-1,m)*B(x,y1,y2)+ cc + C(x,y1,y2)*rKL(m,k)+D(x,y1,y2)*rKL(m,k-1) cc else cc Scalc=ndirac(k,m)*A(x,y1,y2)+ndirac(k-1,m)*B(x,y1,y2) cc A=(x1-z)/(x1-x2) cc B=(z-x2)/(x1-x2) cc C=((x1-z)*(((x1-z)/(x1-x2))**2-1)/6)*(x1-x2) cc D=((z-x2)*(((z-x2)/(x1-x2))**2-1)/6)*(x1-x2) c... Asen's original coding ... end c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** double precision function Sprime(x,m,n,y,rKL,LMAX) c** At the position 'x', evaluate the derivative w.r.t. x of the m'th c Sm(x) function contributing the definition of the the natural cubic c spline defined by function values at the n points y(i) [i=1,n] INTEGER i,k,kk,m,n,LMAX REAL*8 x,del,y1,y2,y(1:LMAX),rKL(1:LMAX,1:LMAX) k=0 kk=0 do i=2,n if((x.gt.y(i-1)).and.(x.le.y(i))) k=i enddo if(x.lt.y(1)) then k=2 kk=1 end if if (x.gt.y(n)) then k=n kk=1 end if if (x.eq.y(1)) k=2 y1=y(k-1) y2=y(k) del=y1-y2 Sprime= 0.d0 if(kk.eq.0) Sprime= (del-3.d0*(y1-x)**2/del)*rKL(m,k)/6.d0 + 1 (3.d0*(x-y2)**2/del-del)*rKL(m,k-1)/6.d0 IF(k-1.eq.m) Sprime= Sprime + 1.d0/del IF(k.eq.m) Sprime= Sprime - 1.d0/del ccc if(kk.eq.0) then ccc Sprim=ndirac(k-1,m)/del-ndirac(k,m)/del+ ccc + (del-3*(y1-x)**2/del)*rKL(m,k)/6+ ccc + (3*(x-y2)**2/del-del)*rKL(m,k-1)/6 ccc else ccc Sprim=ndirac(k-1,m)/del-ndirac(k,m)/del ccc end if end c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** subroutine Lkoef(n,x,A,LMAX) c** Call this subroutine with list of the 'n' spline x_i values in array c 'x' with maximum dimension 'LMAX' and it will return the LMAX x LMAX c array of 'rKL' coefficients used for generating the 'n' S_n(x) c spline coefficient functions c----------------------------------------------------------------------- c c*** Based on nespl subroutine INTEGER LMAX INTEGER I,J,N,INDX(1:LMAX) REAL*8 X(1:LMAX),A(1:LMAX,1:LMAX),B(1:LMAX,1:LMAX), d c DO i= 1,LMAX DO j= 1,LMAX A(i,j)= 0.d0 B(i,j)= 0.d0 ENDDO ENDDO A(1,1)= (x(3)-x(1))/3.d0 A(1,2)= (x(3)-x(2))/6.d0 do i= 2,n-3 A(i,i-1)= (x(i+1)-x(i))/6.d0 A(i,i)= (x(i+2)-x(i))/3.d0 A(i,i+1)= (x(i+2)-x(i+1))/6.d0 end do A(n-2,n-3)= (x(n-1)-x(n-2))/6.d0 A(n-2,n-2)= (x(n)-x(n-2))/3.d0 do i= 1,n-2 B(i,i)= 1.d0/(x(i+1)-x(i)) B(i,i+1)= -1.d0/(x(i+2)-x(i+1))-1.d0/(x(i+1)-x(i)) B(i,i+2)= 1.d0/(x(i+2)-x(i+1)) end do call ludcmp(A,n-2,LMAX,indx,d) do i= 1,n call lubksb(A,n-2,LMAX,indx,B(1,i)) end do do i= 1,n-2 do j= 1,n A(j,i+1)= B(i,j) end do end do do i= 1,n A(i,1)= 0.0d0 A(i,n)= 0.0d0 end do end c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE ludcmp(a,n,np,indx,d) INTEGER n,np,indx(n),NMAX double precision d,a(np,np),TINY PARAMETER (NMAX= 500,TINY= 1.0e-20) INTEGER i,imax,j,k double precision aamax,dum,sum,vv(NMAX) d= 1.d0 do i= 1,n aamax= 0.d0 do j= 1,n if (abs(a(i,j)).gt.aamax) aamax= abs(a(i,j)) enddo if (aamax.eq.0.) WRITE(6,*) 'singular matrix in ludcmp' vv(i)= 1.d0/aamax enddo do j= 1,n do i= 1,j-1 sum= a(i,j) do k= 1,i-1 sum= sum-a(i,k)*a(k,j) enddo a(i,j)= sum enddo aamax= 0.d0 do i= j,n sum= a(i,j) do k= 1,j-1 sum= sum-a(i,k)*a(k,j) enddo a(i,j)= sum dum= vv(i)*abs(sum) if (dum.ge.aamax) then imax= i aamax= dum endif enddo if(j.ne.imax)then do k= 1,n dum= a(imax,k) a(imax,k)= a(j,k) a(j,k)= dum enddo d= -d vv(imax)= vv(j) endif indx(j)= imax if(a(j,j).eq.0.)a(j,j)= TINY if(j.ne.n)then dum= 1.d0/a(j,j) do i= j+1,n a(i,j)= a(i,j)*dum enddo endif enddo return END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE lubksb(a,n,np,indx,b) INTEGER i,ii,j,ll, n,np,indx(n) double precision a(np,np),b(n), sum ii= 0 do i= 1,n ll= indx(i) sum= b(ll) b(ll)= b(i) if (ii.ne.0)then do j= ii,i-1 sum= sum-a(i,j)*b(j) enddo else if (sum.ne.0.) then ii= i endif b(i)= sum enddo do i= n,1,-1 sum= b(i) do j= i+1,n sum= sum-a(i,j)*b(j) enddo b(i)= sum/a(i,i) enddo return END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE UNCBV(NPTOT,PV,PU,CM) c*********************************************************************** c** Subroutine to compute the uncertainties in calcuated Bv values, c 1) by the finite difference R(0) approximation c 2) from the LIDE expression c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** On entry: c ... OSEL print values at every OSEL'th mesh point c ... ISTATE electronic state counter c ... PU(n) uncertainties in the TOTPOTPAR parameters of the model c ... CM(n,n) (symmetric) correlation matrix from the fit c======================================================================= cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** 'Block' Data Utility routine named: 'arrsizes.h' that governs c array dimensioning in program dPotFit c----------------------------------------------------------------------- IMPLICIT NONE INTEGER NISTPMX,NPARMX,NbetaMX,NBOBMX,HPARMX,NDATAMX, 1 NVIBMX,NBCMX,NSTATEMX,NPNTMX,NROTMX,NCMMAX c* NISTPMX is the maximum number of isotopomers allowed for fit PARAMETER (NISTPMX = 12) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 4) c* NPARMX is the largest number of free parameters allowed for fit c Since FS origins may be parameters, this is also max. no, data bands PARAMETER (NPARMX = 8000) c* NbetaMX is the largest number of exponent parameters allowed for fit PARAMETER (NbetaMX = 40) c* NBOBMX-1 is the highest-order polynomial expansion allowed for the c adiabatic or centrifugal Born-Oppenheimer breakdown functions, or c the Lambda-doubling or 2\Sigma splitting radial strength functions PARAMETER (NBOBMX = 15) c* HPARMX is the largest number of Hamiltonian parameters of all types c (potential energy, BOB. etc.) for all states. c HPARMX >= NSTATEMX*[5 + (NbetaMX+1) + 5*(NBOBMX+1)] PARAMETER (HPARMX= NSTATEMX*(5 + (NbetaMX+1) + 5*(NBOBMX+1))) cc PARAMETER (HPARMX = 300) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 35000) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 200) ** NBCMX is the maximum number of band constants per vib level to be c allowed when doing band constant fits (PSEL= -1) PARAMETER (NBCMX = 8) c* NPNTMX is the largest number of potential data points that can be c stored in a single 1D array PARAMETER (NPNTMX = 90000) c* NROTMX is the highest order of rotational constants calculated and c used for estimating level energies PARAMETER (NROTMX = 7) c* NCMMAX is the largest number of Cm terms in the MLR or DELR c long-range potential PARAMETER (NCMMAX = 12) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKPOT.h' c======================================================================= c** Effective adiabatic radial potential variables. INTEGER BOBCN(NSTATEMX),PSEL(NSTATEMX),MAXMIN(NSTATEMX), 1 IOMEG(NSTATEMX),Nbeta(NSTATEMX),APSE(NSTATEMX),IFXDE(NSTATEMX), 2 IFXRE(NSTATEMX),IFXCm(NCMMax,NSTATEMX), 3 IFXBETA(0:NbetaMX,NSTATEMX),NDATPT(NSTATEMX),NCMM(NSTATEMX), 4 MMLR(NCMMax,NSTATEMX),nPB(NSTATEMX),nQB(NSTATEMX),pAD(NSTATEMX), 5 qAD(NSTATEMX),LRad(NSTATEMX),pNA(NSTATEMX),qNA(NSTATEMX), 6 Pqw(NSTATEMX),IVSR(NSTATEMX),IDSTT(NSTATEMX) c REAL*8 DE(NSTATEMX),RE(NSTATEMX),BETA(0:NbetaMX,NSTATEMX), 1 yqBETA(NbetaMX,NSTATEMX),BETAFX(NPNTMX,NSTATEMX),RH(NSTATEMX), 2 RMIN(NSTATEMX),RMAX(NSTATEMX),VLIM(NSTATEMX),EPS(NSTATEMX), 3 betaINF(NSTATEMX),AGPEF(NSTATEMX),BGPEF(NSTATEMX), 4 CmVAL(NCMMax,NSTATEMX),CmEFF(NCMMax,NSTATEMX),rhoAB(NSTATEMX), 5 AA(NSTATEMX),BB(NSTATEMX),RREF(NSTATEMX),ASO(NSTATEMX), 6 R01(NSTATEMX),Q12(NSTATEMX),RD(NPNTMX,NSTATEMX), 7 VPOT(NPNTMX,NSTATEMX),dCmA(NCMMax,NSTATEMX),dCmB(NCMMax,NSTATEMX) c COMMON /BLKPOT/DE,RE,BETA,yqBETA,BETAFX,RH,RMIN,RMAX,VLIM,EPS, 1 betaINF,AGPEF,BGPEF,CmVAL,CmEFF,rhoAB,AA,BB,RREF,ASO,R01,Q12,RD, 2 VPOT,dCmA,dCmB, BOBCN,PSEL,MAXMIN,IOMEG,Nbeta,APSE,IFXDE,IFXRE, 3 IFXCm,IFXBETA,NDATPT,NCMM,MMLR,nPB,nQB,pAD,qAD,LRad,pNA,qNA,Pqw, 4 IVSR,IDSTT c======================================================================= cc INCLUDE 'BLKDVDP.h' c======================================================================= c** Partial derivative arrays for fits and uncertainties (fununc) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ REAL*8 DVtot(HPARMX,NPNTMX),DLDDRe(NPNTMX,NSTATEMX), 1 DUADRe(NPNTMX,NSTATEMX),DUBDRe(NPNTMX,NSTATEMX), 2 DTADRe(NPNTMX,NSTATEMX),DTBDRe(NPNTMX,NSTATEMX), 3 DBDB(0:NbetaMX,NPNTMX,NSTATEMX),DBDRe(NPNTMX,NSTATEMX), 4 dVpdP(HPARMX,NPNTMX) COMMON/BLKDVDP/DVtot,DUADRe,DUBDRe,DTADRe,DTBDRe,DLDDRe,DBDB, 1 DBDRe,dVpdP c======================================================================= cc INCLUDE 'BLKBOB.h' c======================================================================= c** Born-Oppenheimer Breakdown & doubling function parameters. c** March 16 2012 c======================================================================= INTEGER NUA(NSTATEMX),NUB(NSTATEMX),NTA(NSTATEMX),NTB(NSTATEMX), 1 IFXUA(0:NBOBMX,NSTATEMX),IFXUB(0:NBOBMX,NSTATEMX), 2 IFXTA(0:NBOBMX,NSTATEMX),IFXTB(0:NBOBMX,NSTATEMX), 3 NwCFT(NSTATEMX),IFXwCFT(0:NBOBMX,NSTATEMX),efREF(NSTATEMX) c REAL*8 UA(0:NBOBMX,NSTATEMX),UB(0:NBOBMX,NSTATEMX), 1 TA(0:NBOBMX,NSTATEMX),TB(0:NBOBMX,NSTATEMX), 2 wCFT(0:NBOBMX,NSTATEMX) c COMMON /BLKBOB/UA,UB,TA,TB,wCFT,NUA,NUB,NTA,NTB,NwCFT, 1 IFXUA,IFXUB,IFXTA,IFXTB,IFXwCFT,efREF c======================================================================= cc INCLUDE 'BLKPARAM.h' c======================================================================= c** Parameters and count-labels for band constant (PSEL=-1) or term c value (PSEL=-2) fits REAL*8 TVALUE(NPARMX),ZBC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX), 1 ZQC(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c INTEGER NSTATES,NTVALL(0:NSTATEMX),NTVI(NSTATEMX),NTVF(NSTATEMX), 1 VMIN(NSTATEMX,NISTPMX),VMAX(NSTATEMX,NISTPMX),JTRUNC(NSTATEMX), 2 EFSEL(NSTATEMX),NBC(0:NVIBMX,NISTPMX,NSTATEMX), 3 NQC(0:NVIBMX,NISTPMX,NSTATEMX), 4 BCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 5 BCPARF(0:NVIBMX,NISTPMX,NSTATEMX), 6 QCPARI(0:NVIBMX,NISTPMX,NSTATEMX), 7 QCPARF(0:NVIBMX,NISTPMX,NSTATEMX) COMMON /BLKPARAM/TVALUE,ZBC,ZQC,NSTATES,NTVALL,NTVI,NTVF,VMIN, 1 VMAX,JTRUNC,EFSEL,NBC,NQC,BCPARI,BCPARF,QCPARI,QCPARF c======================================================================= cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors c** Array ZK carries about the band constants for all levels of all ISOT INTEGER NISTP,NDUNMX,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA PARAMETER (NDUNMX=0) REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX),ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), 2 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX), 3 ZK(0:NVIBMX,0:NROTMX,NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,ZMUA,ZMUB,ZMTA,ZMTB,ZK, 1 NISTP,AN,MN c======================================================================= cc INCLUDE 'BLKBOBRF.h' c======================================================================= c** Born-Oppenheimer breakdown radial functions REAL*8 UAR(NPNTMX,NSTATEMX),UBR(NPNTMX,NSTATEMX), 1 TAR(NPNTMX,NSTATEMX),TBR(NPNTMX,NSTATEMX),wRAD(NPNTMX,NSTATEMX) c COMMON /BLKBOBRF/UAR,UBR,TAR,TBR,wRAD c======================================================================= cc INCLUDE 'BLKCOUNT.h' c======================================================================= c Block data file BLKCOUNT.h c======================================================================= c** Counters for numbers of potential parameters of different types for c each state INTEGER TOTPOTPAR,POTPARI(NSTATEMX),POTPARF(NSTATEMX), 1 UAPARI(NSTATEMX),UAPARF(NSTATEMX),UBPARI(NSTATEMX), 2 UBPARF(NSTATEMX),TAPARI(NSTATEMX),TAPARF(NSTATEMX), 3 TBPARI(NSTATEMX),TBPARF(NSTATEMX),LDPARI(NSTATEMX), 4 LDPARF(NSTATEMX),HPARF(NSTATEMX),OSEL(NSTATEMX) c COMMON /BLKCOUNT/TOTPOTPAR,POTPARI,POTPARF,UAPARI,UAPARF,UBPARI, 1 UBPARF,TAPARI,TAPARF,TBPARI,TBPARF,LDPARI,LDPARF,HPARF,OSEL c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX),TEMP(NDATAMX), 1 YUNC(NDATAMX),Fqb INTEGER COUNTOT,NFS1,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NPARMX),VPP(NPARMX),EFP(NDATAMX),EFPP(NDATAMX), 2 TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NPARMX),IFXFS(NPARMX), 3 NFS(NPARMX),IEP(NPARMX),IEPP(NPARMX),ISTP(NPARMX), 4 IFIRST(NPARMX),ILAST(NPARMX),NTV(NSTATEMX,NISTPMX),FSsame, 5 NTRANS(NPARMX),IBB(NISTPMX,NSTATEMX,9,NPARMX),JMIN(NPARMX), 6 JMAX(NPARMX) CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) CHARACTER*30 BANDNAME(NPARMX) COMMON /DATABLK/Fqb,FREQ,UFREQ,YUNC,DFREQ,TEMP,COUNTOT,NFS1, 1 NFSTOT,NBANDTOT,IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,IFXFS, 2 NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV,FSsame, 3 NTRANS,IBB,JMIN,JMAX,NAME,SLABL,BANDNAME c======================================================================= c----------------------------------------------------------------------- INTEGER IISTP, IV, I, J, JROT,KVLEV,efPARITY,NPTOT,NB1,COUNT1, 1 ISTATE, NBEG,NEND,INNODE,INNER,IWR,LPRWF,WARN, fcount REAL*8 PV(NPARMX), PU(NPARMX), PD(NPARMX), CM(NPARMX,NPARMX), 1 PQ(NPARMX),PT(NPARMX),DEDPK(HPARMX),V1D(NPNTMX),SWF(NPNTMX), 2 DVDPK(NPNTMX),Bunc1, Bunc2, Eunc2, CALC, EIV, FWHM, BFCT,BvWN, 3 EO,Bv,UMAX,dBdPk c** First - set up fake R(0) datum WARN= 1 COUNT1= COUNTOT+1 NB1= NBANDTOT+1 IB(COUNT1)= NB1 JPP(COUNT1)= 0 JP(COUNT1)= 1 FREQ(COUNT1)= 0.d0 UFREQ(COUNT1)= 0.d0 DO ISTATE= 1, NSTATES IF(PSEL(ISTATE).LE.0) CYCLE IEP(NB1)= ISTATE IEPP(NB1)= ISTATE DO IISTP= 1,NISTP write(7,600) ISTP(NB1)= IISTP cc WRITE(17,600) IISTP, SLABL(ISTATE) c** Generate 1-D potential for this state/isotopologue to prepare ... BFCT=RH(ISTATE)*RH(ISTATE)*ZMASS(3,IISTP)/16.857629206d0 BvWN= 16.857629206D0/ZMASS(3,IISTP) DO I= 1,NDATPT(ISTATE) V1D(I)= BFCT*(VPOT(I,ISTATE) 1 + ZMUA(IISTP,ISTATE)*UAR(I,ISTATE) 2 + ZMUB(IISTP,ISTATE)*UBR(I,ISTATE)) ENDDO c** for each vibrational level of each isotopologue .... DO IV= VMIN(ISTATE,IISTP), VMAX(ISTATE,IISTP) VP(NB1)= IV VPP(NB1)= IV c** Next get partial derivatives from Bv as half of a pure R(0) energy CALL DYIDPJ(COUNT1,COUNT1,NPTOT,FREQ(COUNT1),CALC,PV, 1 PD) c ... set up column vector for uncertainty calculation DO J= POTPARI(ISTATE), POTPARF(ISTATE) PT(J)= 0.5*PD(J)*PU(J) ENDDO c... Uncertainty calculation for this level via "R(0)" approvimation CALL MMCALC(1,NPTOT,PT,CM,Bunc1) c cc WRITE(7,602) IV,0.5d0*CALC/ZK(IV,1,IISTP,ISTATE), cc 1 Bunc1 c... Call SCHRQ to get energy and wavefunction for exact calculation JROT= 0 KVLEV= IV EO= ZK(IV,0,IISTP,ISTATE) Bv= ZK(IV,1,IISTP,ISTATE) CALL SCHRQ(IV,JROT,EO,FWHM,UMAX,VLIM(ISTATE),V1D,SWF, 1 BFCT,EPS(ISTATE),RMIN(ISTATE),RH(ISTATE), 2 NDATPT(ISTATE),NBEG,NEND,INNODE,INNER,IWR,LPRWF) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ efPARITY= 0 c ... call DEDP to get eigenvalue derivatives DEDPK(j) for E & Bv unc. CALL DEDP(COUNT1,ISTATE,IISTP,ZMASS(3,IISTP),KVLEV, 1 JROT,efPARITY,EO,VLIM(ISTATE),FWHM,DEDPK,fcount) c... Now Loop over potential parameters for this state, calculating DO J= POTPARI(ISTATE), HPARF(ISTATE) PQ(J)= DEDPK(J)*PU(J) c... first - define 1D partial derivative array DO I= 1,NDATPT(ISTATE) DVDPK(I)= BFCT*dVtot(J,I) ENDDO cc CALL dPSIdp(ISTATE,IISTP,EO,NBEG,NEND, cc ?? problem to solve in my 'spare time' cc 1 NDATPT(ISTATE),BvWN,V1D,SWF,DEDPK(J),dBdPk,dVdPk) cc cc WRITE(17,604) J,0.5*PD(J),dBdPk cc PT(J)= dBdPk*PU(J) CONTINUE ENDDO c... get eigenvalue Gv uncertainties CALL MMCALC(1,NPTOT,PQ,CM,Eunc2) c... get Bv uncertainties CALL MMCALC(1,NPTOT,PT,CM,Bunc2) ccc cc WRITE(17,610) IV,EO,Eunc2,Bv,Bunc1 WRITE(7,610) IV,EO,Eunc2,Bv,Bunc1 cc WRITE(17,608) IV,Bunc1,Bunc2 ccc WRITE(7,608) IV,Bunc1,Bunc2 ENDDO ENDDO ENDDO RETURN 600 FORMAT(:/' Predict Bv uncertainties for isotopologue-',I1,' in st 1ate ',A3) 602 FORMAT(' For v=',I3,' Bv{R(0)/2}/Bv(exact)=',F13.10, 1 ' unc(Bv)=',1PD13.6) 604 FORMAT(' for param(',I2,') dBvdp(approx)=',1P1D13.6, 1 ' Bvdp(numerical)=',D13.6) 608 FORMAT(' For v=',I3,' u(Bv{R(0)/2})=',F13.10, 1 ' u(Bv;numerical)=',1PD13.6) 610 FORMAT(' v=',I3,' E=', F12.4,' u(E)=',F10.6,' Bv=',f11.8, 1 ' u(Bv)=',1PD13.6) END c234567890 234567890 234567890 234567890 234567890234567890 234567890 c234567890 234567890 234567890 234567890 234567890234567890 234567890