c*********************************************************************** PROGRAM dParFit16 c*********************************************************************** c** Program "D(iatomic)Par(ameter)Fit" (DParFit) performs least-squares c fits of a data set made up of any combination of MW, IR or electronic c vibrational bands, PAS data, fluorescence series and/or Bv values, c involving one or more singlet or doublet-sigma electronic states and c one or more isotopomers, to parameters defining the observed levels c of each state. Those levels may be described by band constants {Gv, c Bv, Dv, etc.}, by Dunham expansions, by Near-Dissociation Expansions c (NDE's), or by Tellinghuisen's mixed Dunham/NDE 'MXS' functions, and c different expressions may be used for different states, while Lambda c or spin-rotation doubling is described by band constants or by Dunham- c type expansions in (v+1/2). Dunham, NDE or MXS function fits c automatically take account of normal (1'st order semiclassical) multi- c isotopomer mass scaling, and allow for inclusion of atomic-mass- c dependent Born-Oppenheimer and 1'st order JWKB breakdown corrections c (collectively called BOB corrections). c++++++++++++++++++++ Version of 04 April 2016 ++++++++++++++++++++++++ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c COPYRIGHT 2000-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+ Please inform me of any bugs, by phone at: (519)888-4567, ext. 4051 + c++++++++ by e-mail to: leroy@UWaterloo.ca , or write me at: +++++++++++ c+++ Dept. of Chemistry, Univ. Waterloo, Waterloo, Ontario N2L 3G1 ++++ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++++ Uses least-squares subroutine NLLSSRR written by R.J. Le Roy +++++ c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c* In any of these types of fits, centrifugal distortion constants, c and/or Lambda doubling parameters and/or BOB corrections and/or c the Gv & Bv parameters, for one or more of the electronic state may c be held fixed, while a limited parameter set is varied. c* This program always reports "sensitivities" of fitted parameters, which c indicate the numbers of significant digits which must be retained in c order to ensure predictions are in optimal agreement with experiment. c* It will also perform automatic "Sequential Rounding & Refitting" [see c J.Mol.Spectrosc. 191, 223 (1998)] in order to yield a final parameter c set involving the smallest possible number of significant digits. c** If desired, it will also use a set of read-in constants to make c predictions or to calculate deviations [calc.-obs.] for any chosen c input data set involving diatomic singlet-singlet transitions. c** Illustrative applications of this code are found in papers on HF/DF c [JMS 194,189 (1999)], GeO [JMS 194, 197 (1999)] and the coinage metal c hydrides [JCP 110, 11756 (1999)]. c======================================================================= c** Dimensioning parameters intrinsic to the program are input through c PARAMETER statements in the file/data block 'arrsizes.h'. c** Parameters characterizing the problem and governing the fits are c read on Channel-5 while the experimental data are read on Channel-4. c** The principle output goes to Channel-6 while higher output channel c numbers are used for secondary or more detailed/voluminous output. c*********************************************************************** cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= cc INCLUDE 'PARMBLK.h' c======================================================================= c** Type statements and common block for actual parameter values c REAL*8 Te(NSTATEMX),VPHPW(0:NVIBMX,0:NDUNMX), 1 YLM(0:NDUNMX,0:9,NSTATEMX),DELTA(2,0:NDUNMX,0:9,NSTATEMX), 2 QLM(0:NDUNMX,9,NSTATEMX),DLIMIT(NSTATEMX),VD(NSTATEMX), 3 PM0(NDUNMX,NSTATEMX),QM0(NDUNMX,NSTATEMX),PM1(NDUNMX,NSTATEMX), 4 QM1(NDUNMX,NSTATEMX),VS(NSTATEMX),DVS(NSTATEMX), 5 VSISO(NSTATEMX,NISTPMX),DVSISO(NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 6 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX), 6 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /PARMBLK/Te,VPHPW,YLM,DELTA,QLM,DLIMIT,VD,PM0,QM0,PM1,QM1, 1 VS,DVS,VSISO,DVSISO,ORIGIN,ZK,ZQ c======================================================================= c CHARACTER*40 DATAFILE,MAKEPRED CHARACTER*43 FN4,FN6,FN7,FN8,FN9,FN10 CHARACTER*20 NAMEPARM(NPARMX),WRITFILE CHARACTER*12 CTYPE(3) CHARACTER*3 CCDC(0:10) CHARACTER*2 CATOM CHARACTER*8 SPIN(4) INTEGER*4 lnblnk c INTEGER EFSEL(NSTATEMX),JTRUNC(NSTATEMX),NOWIDTHS,NLR(NSTATEMX), 1 NSIG,NDAT(0:NVIBMX,NISTPMX,NSTATEMX),IFXP(NPARMX), 2 NTVALL(0:NSTATEMX), I,I1,I2,IV,J,L,M,NSETS,NPARM,NDEORD,MMIN, 3 MMAX,MQ0,MQM,MQMAX,PRINP,VMAXX,NRBC(NSTATEMX), 3 ISTATE,ISOT,IROUND,JROUND,LPRINT,NDECOUNT,ATOM,ATOM2, 4 CHARGE,LAMIN,IDUM1,IDUM2, NEWGv,NEWBv, MKPRED, ROBUST,CYCMAX c REAL*8 PV(NPARMX),PU(NPARMX),PS(NPARMX),CM(NPARMX,NPARMX), 1 PUSAV(NPARMX),PSSAV(NPARMX),CN(NSTATEMX),RM(NDUNMX), XX,XXP,YY, 2 VDMV,VDMVP,Sw,SwLR,FNDE,DSE,PW,VPH,TSTPS,TSTPU,ZME,ZATOM, 3 UCUTOFF,FDUM1 c c** Type statements and common block for case (type of representation) c REAL*8 XM(0:9,NSTATEMX,NISTPMX),PNDE(0:9,NSTATEMX) c INTEGER NSTATES,IBAND,VMIN(NSTATEMX),VMAX(NSTATEMX), 1 NCDC(NSTATEMX),IOMEG(NSTATEMX),NLDMX(NSTATEMX),efREF(NSTATEMX), 2 MULTPLT(NSTATEMX),NDEGv(NSTATEMX),NDEBv(NSTATEMX), 3 NDECDC(NSTATEMX),NDELD(NSTATEMX),IFXGv(NSTATEMX),IFXBv(NSTATEMX), 4 IFXCDC(NSTATEMX),IFXLD(NSTATEMX),BOBORD(NSTATEMX), 5 NUMNDE(NSTATEMX),IFXD(NSTATEMX),IFXVD(NSTATEMX),ITYPE(NSTATEMX), 6 NP0(NSTATEMX),NQ0(NSTATEMX),IP0(NSTATEMX),IQ0(NSTATEMX), 7 ITYPB(NSTATEMX),NP1(NSTATEMX),NQ1(NSTATEMX),IP1(NSTATEMX), 8 IQ1(NSTATEMX),LMAX(0:9,NSTATEMX),LDMAX(9,NSTATEMX), 9 IFXVS(NSTATEMX),IFXDVS(NSTATEMX),BOB00,LAMAX(2,0:9,NSTATEMX), a IPSTATE(NSTATEMX),NPAR(0:NVIBMX,NSTATEMX,NISTPMX), b NQPAR(0:NVIBMX,NSTATEMX,NISTPMX), c FITGV(0:NVIBMX,NSTATEMX,NISTPMX),NRC(0:NVIBMX,NSTATEMX,NISTPMX), d NQC(0:NVIBMX,NSTATEMX,NISTPMX),NEBC(NSTATEMX) c COMMON /CASEBLK/XM,PNDE, NSTATES,IBAND,VMIN,VMAX,NCDC,IOMEG,NLDMX, 1 efREF,MULTPLT,NDEGv,NDEBv,NDECDC,NDELD,IFXGv,IFXBv,IFXCDC,IFXLD, 2 IFXVS,IFXDVS,BOBORD,NUMNDE,IFXD,IFXVD,ITYPE,NP0,NQ0,IP0,IQ0, 3 ITYPB,NP1,NQ1,IP1,IQ1,LMAX,LDMAX,BOB00,LAMAX,IPSTATE,NPAR,NQPAR, 4 FITGV,NRC,NQC,NEBC c DATA ZME/5.4857990945d-04/,CYCMAX/30/ DATA CCDC/' Gv',' Bv','-Dv',' Hv',' Lv',' Mv',' Nv',' Ov',' Pv', 1 ' Qv','CDC'/ DATA CTYPE/' Outer Pade ',' Inner Pade ','Exponential '/ DATA SPIN/' Singlet',' Doublet',' Triplet',' Quartet'/ DATA MAKEPRED/'MAKEPRED '/ c Doublet can only be used for Sigma states; c Triplet and Quartet NOT IN USE YET! c** Only special Data Types 0, -1 and -3 used in dParFit SLABL(-6)= ' ' !! data type not yet defined SLABL(-5)='VAC' !! Accoustic Virial Coefficient SLABL(-4)='VIR' !! Pressure Virial Coefficients SLABL(-3)='BVV' !! Experimental Bv values SLABL(-2)='WID' !! tunneling level widths SLABL(-1)='PAS' !! Photo-Association binding energies SLABL(0)='FLS' !! fluorescence series NOWIDTHS= 1 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 the integer atomic numbers identifying the atoms c forming the 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 c NISTP is the number of isotopomers 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 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 variable 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 20 characters, enclosed in single quotes, with no leading spaces. c----------------------------------------------------------------------- READ(5,*) AN(1), AN(2), CHARGE, NISTP, NSTATES READ(5,*) DATAFILE READ(5,*) WRITFILE c----------------------------------------------------------------------- c** These statements construct and define the names of output files c associated with WRITE's to channels 6-10 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(FN9,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.9' WRITE(FN10,'(2A)') WRITFILE(1:lnblnk(WRITFILE)),'.10' OPEN(UNIT= 6, FILE= FN6) OPEN(UNIT= 7, FILE= FN7) OPEN(UNIT= 8, FILE= FN8) OPEN(UNIT= 9, FILE= FN9) OPEN(UNIT=10, FILE= FN10) MKPRED= 0 IF(DATAFILE.EQ.MAKEPRED) THEN MKPRED= 1 ENDIF c======================================================================= c UCUTOFF Neglect any input data with uncertainties > UCUTOFF (cm-1) c 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 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 LPRINT specifies the level of printing inside NLLSSRR c if: = 0, no print except for failed convergence. c < 0 only converged, unrounded parameters, PU & PS's c >= 1 print converged parameters, PU & PS's c >= 2 also print parameter change each rounding step c >= 3 also indicate nature of convergence c >= 4 also print convergence tests on each cycle c >= 5 also parameters changes & uncertainties, each cycle c c PRINP > 0 causes a summary of the input data to be printed before c the fitting starts. Normally set =0. c----------------------------------------------------------------------- READ(5,*) UCUTOFF, IROUND, ROBUST, LPRINT, PRINP c----------------------------------------------------------------------- c I= 999 IF(NISTP.LE.NISTPMX) THEN IF(CHARGE.NE.0) WRITE(6,600) NISTP,CHARGE IF(CHARGE.EQ.0) WRITE(6,600) NISTP ELSE WRITE(6,601) NISTP,NISTPMX STOP ENDIF WRITE(6,602) DO ISOT= 1,NISTP c** Read the mass numbers of the atoms in each of the isotopomers 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) of 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,IDUM1,IDUM2,ZMASS(1,ISOT), 1 FDUM1) IF(ISOT.EQ.1) NAME(1)= CATOM CALL MASSES(AN(2),MN(2,ISOT),CATOM,IDUM1,IDUM2,ZMASS(2,ISOT), 1 FDUM1) IF(ISOT.EQ.1) NAME(2)= CATOM ZMASS(3,ISOT)= (ZMASS(1,ISOT)*ZMASS(2,ISOT))/ 1 (ZMASS(1,ISOT)+ ZMASS(2,ISOT)- CHARGE*ZME) WRITE(6,603) NAME(1),MN(1,ISOT),NAME(2),MN(2,ISOT), 1 (ZMASS(J,ISOT),J=1,3) XX= ZMASS(3,1)/ZMASS(3,ISOT) DO M=0, 9 RMUP(M,ISOT)= XX**M ENDDO RSQMU(ISOT)= DSQRT(XX) XX= 1.d0 DO L= 0,NDUNMX RSQMUP(L,ISOT)= XX XX= XX*RSQMU(ISOT) ENDDO ENDDO IF(CHARGE.NE.0) WRITE(6,604) CHARGE IF(I.EQ.0) WRITE(6,605) WRITE(6,599) DATAFILE 599 FORMAT(/' Use experimental data input file: ',a30) IF(IROUND.NE.0) WRITE(6,606) IABS(IROUND) IF(IROUND.GT.0) WRITE(6,608) IF(IROUND.LT.0) WRITE(6,610) IF(ROBUST.GT.0) THEN ROBUST= 1 WRITE(6,596) ELSE WRITE(6,598) ENDIF NDECOUNT= 0 DO I= 1,NPARMX PV(I)= 0.d0 ENDDO c c======================================================================= c** Now ... loop over the NSTATES electronic states, reading parameters c characterizing those states and how to represent the data for each. c======================================================================= DO 60 ISTATE= 1, NSTATES c** For each of the electronic states s=ISTATE involved in the data set, c read parameters characterizing that state and the data to be used, c and identifying the types of parameters used to characterize its term c values and whether they are to be fixed or fitted. c================================ c SLABL(s) is a 2-character alphameric label enclosed in single quotes c to identify the electronic state; e.g., 'X0', 'A1', ... etc. c c IOMEG(s) .GE.0 is electronic angular momentum of singlet state with c projection quantum number Lambda= IOMEG c < 0 for Sigma state with spin multiplicity |IOMEG|= -IOMEG c [currently only coded for IOMEG= -2 {doublet Sigma}] c c IOMEG(s) .LT.0 if it indicates a doublet SIGMA electronic state c [may later introduce an additional read-in parameter MULTPLT(s) c to label other electronic state spin-multiplicities] c c JTRUNC(s): Omit from fit electronic state-s data with J(s) > JTRUNC c 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 c VMIN(s)/VMAX(s): Neglect data for electronic state-s vibrational c levels outside the range VMIN(s) to VMAX(s). c--------------------------------------------------------------------- READ(5,*) SLABL(ISTATE), IOMEG(ISTATE), JTRUNC(ISTATE), 1 EFSEL(ISTATE), VMIN(ISTATE), VMAX(ISTATE) c--------------------------------------------------------------------- c** MULTPLT(s) is the spin multiplicity of electronic state-s c Currently only allow Doublet states for IOMEG(s) < 0 and Singlet c states for IOMEG(s) .ge. 0 MULTPLT(ISTATE)= 1 IF(IOMEG(ISTATE).LT.0) THEN MULTPLT(ISTATE)=IABS(IOMEG(ISTATE)) efREF(ISTATE)= 0 IF(MULTPLT(ISTATE).NE.1) THEN WRITE(6,594) MULTPLT(ISTATE) 594 FORMAT(/' *** INPUT ERROR *** program not coded to handle',i3, 1 '-Sigma spin multiplets') STOP ENDIF ENDIF IF((SLABL(ISTATE).EQ.'FLS').OR.(SLABL(ISTATE).EQ.'BVV').OR. 1 (SLABL(ISTATE).EQ.'PAS')) THEN WRITE(6,607) ISTATE, SLABL(ISTATE) STOP ENDIF c c NCDC(s) denotes the number of centrifugal distortion constants c (CDC's) considered for electronic state-s. c c NDEGv(s) & NDEBv(s), respectively, specify whether Gv & Bv for levels c of electronic state-s will be represented by: c (a) band constants (Gv & Bv) when NDEXv(s) = -1 c (b) pure Dunham expansions when NDEXv(s) = 0 c (c) pure NDE expressions when NDEXv(s) = 1 c (d) MXS mixed NDE/Dunham expressions when NDEXv(s) = 2 c NOTE: require NDEGv .ge. NDEBv c c NDECDC(s) specifies whether CDC's for levels of electronic state-s c will be represented by: c (a) band constants (-Dv, Hv, ...) when NDECDC(s) = -1 c (b) Dunham expansions when NDECDC(s) = 0 c (c) NDE expressions when NDECDC(s) = 1 c c IFXGv(s), IFXBv(s) & IFXCDC(s), respectively, specify whether c constants determining Gv & Bv for electronic state-s will be: c (a) held fixed at read-in values (IFXYv > 0 ) , or c (b) determined from the fits (IFXYv.le.0). c c BOBORD(s) indicates whether atomic-mass-dependent Born-Oppenheimer c breakdown and higher-order JWKB correction (BOB) terms are c to be used for this electronic state: c .ge.0 implies YES, and BOBORD is the highest order in [J(J+1)] used c < 0 implies such terms are NOT considered for this state. c* These constants are fitted or held fixed as defined by the c Gv/Bv parameter IFXGv(s) & IFXBv(s). c----------------------------------------------------------------------- READ(5,*) NCDC(ISTATE), NDEGv(ISTATE), NDEBv(ISTATE), 1 NDECDC(ISTATE), IFXGv(ISTATE), IFXBv(ISTATE), 2 IFXCDC(ISTATE), BOBORD(ISTATE) c----------------------------------------------------------------------- IF(IOMEG(ISTATE).GE.0) WRITE(6,613) SLABL(ISTATE), 1 SPIN(MULTPLT(ISTATE)), IOMEG(ISTATE), IOMEG(ISTATE)**2 IF(IOMEG(ISTATE).LT.0) WRITE(6,613) SLABL(ISTATE), 1 SPIN(MULTPLT(ISTATE)), IOMEG(ISTATE) c======================================================================= c** Ensure internal consistency among read-in parameters ..... c======================================================================= IF(NCDC(ISTATE).GT.8) THEN WRITE(6,611) ISTATE,NCDC(ISTATE) NCDC(ISTATE)= 8 ENDIF IF((NISTP.LE.1).AND.(BOBORD(ISTATE).GE.0)) THEN WRITE(6,612) ISTATE BOBORD(ISTATE)= -1 ENDIF IF(NDEBv(ISTATE).GT.NDEGv(ISTATE)) THEN c** Bv's for a given state cannot be represented by a "more c sophisticated" form than its Gv's WRITE(6,614) SLABL(ISTATE) STOP ENDIF IF((NDECDC(ISTATE).GT.NDEBv(ISTATE)).AND. 1 (NDECDC(ISTATE).LE.0))THEN c** CDC's for a given state cannot be represented by a "more c sophisticated" form than its Bv's UNLESS is if fixed NDE fx. WRITE(6,616) SLABL(ISTATE) STOP ENDIF IF((BOBORD(ISTATE).GE.0).AND.(NDEGv(ISTATE).EQ.-1)) THEN c** If use Band Constants for vib or rot constants, cannot consider BOB WRITE(6,620) SLABL(ISTATE) BOBORD(ISTATE)= -1 ENDIF IF((BOBORD(ISTATE).GE.1).AND.(NDEBv(ISTATE).EQ.-1)) THEN WRITE(6,619) SLABL(ISTATE) BOBORD(ISTATE)= 0 ENDIF IF((BOBORD(ISTATE).GE.2).AND.(NDECDC(ISTATE).EQ.-1)) THEN WRITE(6,618) SLABL(ISTATE) BOBORD(ISTATE)= 1 ENDIF c IF((NDECDC(ISTATE).GT.0).AND.(IFXCDC(ISTATE).LE.0)) THEN c** If CDC's for state s=ISTATE to be represented by NDE functions, c program (currently) requires them to be held fixed. IFXCDC(ISTATE)= 1 WRITE(6,622) SLABL(ISTATE) ENDIF c c** Zero various expansion coefficients DO L= 0, NDUNMX IF(L.GT.0) THEN PM0(L,ISTATE)= 0.d0 QM0(L,ISTATE)= 0.d0 PM1(L,ISTATE)= 0.d0 RM(L)= 0.d0 ENDIF DO M= 0, 9 YLM(L,M,ISTATE)= 0.d0 IF(M.GE.1) QLM(L,M,ISTATE)= 0.d0 DO ATOM= 1,2 DELTA(ATOM,L,M,ISTATE)= 0.d0 ENDDO ENDDO ENDDO c** Zero Rotational Constant counters DO ISOT= 1, NISTP DO IV= VMIN(ISTATE),VMAX(ISTATE) FITGV(IV,ISTATE,ISOT)= 0 NRC(IV,ISTATE,ISOT)= 0 NQC(IV,ISTATE,ISOT)= 0 NPAR(IV,ISTATE,ISOT)= 0 NQPAR(IV,ISTATE,ISOT)= 0 ENDDO ENDDO c** Zero initial values of band constants and some counters DO ISOT= 1,NISTP DO IV= -1,VMAX(ISTATE) IF(IV.GE.0) NDAT(IV,ISOT,ISTATE)= 0 DO M= 0,9 ZK(M,IV,ISTATE,ISOT)= 0.d0 ENDDO DO M= 1,9 ZQ(M,IV,ISTATE,ISOT)= 0.d0 ENDDO ENDDO ENDDO Te(ISTATE)= 0.d0 c 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]') 598 FORMAT(/' Fit uses standard 1/[uncertainty(i)]**2 data weighting 1') 600 FORMAT(' Input data for',I3,' isotopomer(s)': ' of a species with 1 net charge',SP,i3) 601 FORMAT(' *** Array Dimensioning Problem: NISTP=',i2,' > NISTPMX=' 1 , I3/10x,'Need to increase NISTPMX & Recompile') 602 FORMAT(1x,16('**')/' Isotopomer Mass of atom-1 Mass of a 1tom-2 Reduced mass'/1x,'--------------- ', 2 3(' --------------')) 603 FORMAT(1x,A2,'(',i3,')-',A2,'(',I3,') ',3(2x,F15.10)) 604 FORMAT(1x,67('-')/' Since this is an ion with charge',SP,i3, 1 ", use Watson's charge-modified reduced mass.") 605 FORMAT(2x,77('-')/2x,'Note that (Mass Number) = 0 causes the a 1verage atomic mass to be used.') 606 FORMAT(/' Apply "Sequential Rounding & Refitting" at digit-', 1 i1,' of the (local) parameter') 607 FORMAT(/' *** ERROR *** State-',I2,' Label ',A3," uses one of t 1he reserved names"/26x,"'FLS', 'BVV' or 'PAS', so change its name! 2 ") 608 FORMAT(4x,'uncertainty, selecting remaining parameter with largest 1 relative uncertainty') 610 FORMAT(4x,'uncertainty, proceeding sequentially from the LAST para 1meter to the FIRST.') 611 FORMAT(/' *** CAUTION *** program array dimensions restrict NCDC 1 < 9'/17x,'so change read-in NCDC(',i1,') from',i3,' to 8'/) 612 FORMAT(/ ' *** INPUT ERROR *** CANNOT have BOB DELTA corrections f 1or only ONE isotopomer!!'/10x,'... so reset BOBORD(',I1,') = -1') 613 FORMAT(/' State ',A3,' is a',A8,' with Omega=',i2/1x,7('***'): 1 ' so rotational energies depend on powers of [J(J+1)-',i2,']') 614 FORMAT(" *** CAUTION - FIXUP State ",A3," INPUT *** Only allow", 1 ' NDEBv .le. NDEGv') 616 FORMAT(" *** CAUTION - FIXUP State ",A3," INPUT *** Only allow", 1 ' NDECDC .le. NDEBv') 618 FORMAT(/" *** INCONSISTENT INPUT: When using band constants for C 1DC's of State ",A3/5x,'CANNOT consider BOB corrections for them.') 619 FORMAT(/" *** INCONSISTENT INPUT: When using band constants for B 1v's & CDC's of State ",A3/5x, 'CANNOT consider BOB corrections for 2them.') 620 FORMAT(/' *** INCONSISTENT INPUT: Since use band constants for St 1ate ',A3/5x,'CANNOT consider any BOB corrections for it.') 622 FORMAT(" *** CAUTION - FIXUP State ",A3," INPUT *** If CDC's rep 1resented by NDE's, REQUIRE them to be held fixed") c======================================================================= c** Begin to explicitly identify nature of data representations c to be used, and to read in any constants to be held fixed. c======================================================================= c** NOTE *** the program assumes the vibrational energy zero for each c state with Dunham or MXS vibrational energies [NGEGv=0 or 2] is the c hypothetical (v=-1/2,J=0) level of its 1-st isotopomer, while the c reference energy for each NDE-described state [for which NGEGB>0] is c its asymptote. Absolute energy of all upper states defined relative c to that for the first. If vib. energies of state-1 treated with band c constants, absolute energy zero is lowest vib. level. c** In the current code, if the Gv's and Bv's for a given state are c to be held fixed, then its CDC's, and (if BOBORD > 0) its BOB c correction coefficients MUST also be fixed. c IF(NDEGv(ISTATE).LE.-2) GOTO 60 MMIN= -1 MMAX= 0 IF((IFXGv(ISTATE).GT.0).OR.(NDEGv(ISTATE).EQ.-1)) 1 IFXD(ISTATE)=1 c c======================================================================= c** If Gv for this state represented by band constants (then Bv's and c CDC's also represented the same way) ..... c======================================================================= IF(NDEGv(ISTATE).EQ.-1) THEN IF(IFXGv(ISTATE).GT.0) THEN c** If the Gv's to be held fixed at read-in numerical values, then so c are Bv's and CDC's, and we read them in here. IFXBv(ISTATE)= 1 IFXCDC(ISTATE)= 1 WRITE(6,630) SLABL(ISTATE) MMAX= 1 IF(IFXCDC(ISTATE).GT.0) MMAX= NCDC(ISTATE)+ 1 c* Read-in vibrational energies are assumed to be absolute energies, c (including the value of Te for that state). c ... Looping over isotopomers ... DO ISOT= 1,NISTP c ... Looping over vibrational levels ... DO IV= VMIN(ISTATE), VMAX(ISTATE) c** For all vibrational levels v=IV from 0 to VMAX, read the c vibrational energy Gv = ZK(0,IV,ISTATE,ISOT), and c Bv = ZK(1,IV,ISTATE,ISOT), and -Dv = ZK(2,IV,ISTATE,ISOT), and c Hv = ZK(3,IV,ISTATE,ISOT), and Lv = ZK(4,IV,ISTATE,ISOT), ... etc. c%%%%%%%%%%%%%%%%%%%%%%%%%%%% NOTE!! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** MAKE SURE THAT (!!) read-in values of leading CDC are -Dv, to make c sign convention for ZK(2,IV,ISTATE,ISOT) consistent with that for c other CDC's (s.th. +ve value makes +ve contribution to the energy!!) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c----------------------------------------------------------------------- READ(5,*) I, (ZK(M,IV,ISTATE,ISOT), M=0, MMAX) c----------------------------------------------------------------------- IF(I.NE.IV) THEN WRITE(6,632) SLABL(ISTATE),I,IV STOP ENDIF ENDDO ENDDO ELSE c====================================================== c** If fitting to band constants for all parameters ... c====================================================== MMAX= 0 c ... Loop over isotopomers ... DO ISOT= 1,NISTP c ... and then loop over vibrational levels ... DO IV= VMIN(ISTATE),VMAX(ISTATE) c ... read variables specifying how many free parameters for each level: c FITGV(v,es,isot) = 0 for the lowest vibrational level (v) of each c separate "connected set"; otherwise set it = 1 c NRC(v,es,isot) = number of rotational constants (Bv, -Dv, Hv, Lv, ...) c to be fitted for that vibrational level ( =0 if no data) c----------------------------------------------------------------------- READ(5,*,END=200) I,FITGV(IV,ISTATE,ISOT), 1 NRC(IV,ISTATE,ISOT) c----------------------------------------------------------------------- IF(I.NE.IV) THEN WRITE(6,632) SLABL(ISTATE),I,IV STOP ENDIF IF(FITGV(IV,ISTATE,ISOT).LT.0) 1 FITGV(IV,ISTATE,ISOT)= 0 IF(FITGV(IV,ISTATE,ISOT).GT.0) 1 FITGV(IV,ISTATE,ISOT)= 1 c** Check consistency with "fixed constant" constraints read earlier IF((ISTATE.EQ.1).AND.(IV.EQ.VMIN(ISTATE)) 1 .AND.(ISOT.EQ.1)) FITGV(IV,ISTATE,ISOT)= 0 IF((IFXCDC(ISTATE).GT.0).AND. 1 (NRC(IV,ISTATE,ISOT).GT.1)) 2 NRC(IV,ISTATE,ISOT)= 1 MMAX= MAX(MMAX,NRC(IV,ISTATE,ISOT)) ENDDO ENDDO ENDIF IF(MMAX.EQ.1) GOTO 20 IF(IOMEG(ISTATE).NE.0) GO TO 30 GOTO 60 ENDIF c IF(NDEGv(ISTATE).EQ.2) THEN c======================================================================= c** If using Tellinghuisen-style Mixed Representations ... read c VS(s) ... the isotopomer-1 v=v_S value where Dunham switches to NDE & c DVS(s) ... the width parameter for the switching function c (NOTE: be sure to put d0 on these REAL*8 numbers!) c IFXVS(s) .le.0 if Gv's fitted AND want to fit to VS; else IFXVS > 0. c IFXDVS(s) .le.0 if Gv's fitted AND want to fit to DVS; else > 0. c======================================================================= READ(5,*) VS(ISTATE), DVS(ISTATE), IFXVS(ISTATE), 1 IFXDVS(ISTATE) c----------------------------------------------------------------------- IF(IFXGv(ISTATE).GT.0) THEN IFXVS(ISTATE)= 1 IFXDVS(ISTATE)= 1 ENDIF XX= VS(ISTATE)+ 0.5d0 DO ISOT= 1, NISTP VSISO(ISTATE,ISOT)= XX/RSQMU(ISOT) - 0.5d0 DVSISO(ISTATE,ISOT)= DVS(ISTATE)/RSQMU(ISOT) ENDDO MMIN= 0 MMAX= 0 ENDIF c c======================================================================= c** If Gv's defined by Dunham Y(l,m)'s ... c======================================================================= IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).EQ.2)) THEN c** L=LMAX(0,s) labels highest-order (highest-power) non-zero Y(L,0) in c the Dunham Gv expansion for electronic state 's' c----------------------------------------------------------------------- READ(5,*) LMAX(0,ISTATE) c----------------------------------------------------------------------- cc IF(LMAX(0,ISTATE).LE.0) LMAX(0,ISTATE)= -1 IF(NDEGv(ISTATE).EQ.2) WRITE(6,634) SLABL(ISTATE),CCDC(0), 1 LMAX(0,ISTATE),VS(ISTATE),VS(ISTATE),DVS(ISTATE) IF(IFXGv(ISTATE).GT.0) THEN c c** If Gv's held fixed at values defined by Dunham constants, read c Te=T(v=-1/2) & Dunham Y(l,m) expansion coefficients for isotopomer-1 c and define other coefficients using the normal isotope relations. c [NOTE ... EXclude Y(0,0) ... and for ISTATE=1, Te = 0 !] c** Program internally sets Y(0,0,s) = 'Te(s)' = T(v=-1/2) c----------------------------------------------------------------------- READ(5,*) Te(ISTATE) IF(LMAX(0,ISTATE).GE.1) READ(5,*) (YLM(L,0,ISTATE), 1 L=1, LMAX(0,ISTATE)) c----------------------------------------------------------------------- WRITE(6,635) SLABL(ISTATE), Te(ISTATE) c ... first consider expansions for Gv and Bv ... c** Set vib. energy zero for each state at Te=T(-1/2) for that state. c For lowest (s=1) state this defines absolute energy zero. YLM(0,0,ISTATE)= Te(ISTATE) WRITE(6,636) SLABL(ISTATE),CCDC(0),(YLM(L,0,ISTATE), 1 L= 1,LMAX(0,ISTATE)) MMIN= 0 MMAX= 0 ENDIF ENDIF c IF(NDEGv(ISTATE).GE.1) THEN c======================================================================= c** If NDE functions used to represent the Gv's, or Gv & Bv, and/or c the CDC's of state s=ISTATE, read the limiting long-range (inverse) c power and (initial trial) values of D(limit), vD and Cn: c======================================================================= c NLR(ISTATE) asymptotically-dominant (inverse) power associated with c the long-range potential defining the NDE function. c DLIMIT(ISTATE) is absolute energy at the dissociation limit relative c to the reference energy for the first state considered. For a c Dunham-described first state [NDEGv(1)=0], that reference energy c is its Gv(v=-1/2); if the first state is described by an NDE or c MXS Gv function [NDEGv(1) > 0], the reference energy is its c asymptote [for which DLIMIT(1)=0]. If NDEGv(1)=-1, the reference c energy is the lowest vib. level of the first "connected set". In c a multi-NDE/MXS case, the differences between the DLIMIT values are c simply the atomic level spacings. c VD(ISTATE) non-integer effective vibrational index at dissociation c for isotopomer-1 c CN(ISTATE) is the coefficient of the asymptotically-dominant long- c range inverse-power potential term in units [(cm-1)*Angst**NLR] c NSIG is the number of significant digits in CN, to be retained in c calculating rounded-off limiting theory coefficient X(Cn,n,zmu) c----------------------------------------------------------------------- READ(5,*) NLR(ISTATE), DLIMIT(ISTATE), VD(ISTATE), 1 CN(ISTATE), NSIG c----------------------------------------------------------------------- NDECOUNT= NDECOUNT+ 1 NUMNDE(ISTATE)= NDECOUNT NDEORD= 0 IF(NDEBv(ISTATE).GT.0) NDEORD= 1 IF(NDECDC(ISTATE).GT.0) NDEORD= NCDC(ISTATE)+1 CALL NDEXM(ISTATE,SLABL(ISTATE),NLR(ISTATE), 1 DLIMIT(ISTATE),VD(ISTATE),CN(ISTATE),NSIG,ZMASS(3,1), 2 NDEORD,NISTP,RSQMU,PNDE,XM) c** Define form of NDE expansion for Gv, and read initial trial/fixed c expansion parameters. c* ITYPE identifies type of NDE function for state 's': c (i) ITYPE=1 for an "outer" Pade expansion; (ii) ITYPE=2 for an c "inner" Pade, and (iii) ITYPE=3 for an exponent polynomial NDE. c* The leading non-zero contribution to the NP0-term numerator polynomial c is (vD-v)**IP0 , while (for ITYPE=1 or 2) the corresponding c leading term in the NQ0-term denominator polynomial is (vD-v)**IQ0. c** NP0 is # terms in vib. exponent polynomial for case (iii) c** PM0 & QM0 are vibrational numerator & denominator polynomial coeffts. c----------------------------------------------------------------------- READ(5,*) ITYPE(ISTATE), NP0(ISTATE), NQ0(ISTATE), 1 IP0(ISTATE), IQ0(ISTATE) IF(NP0(ISTATE).GT.0) READ(5,*) (PM0(I,ISTATE), I=1, 1 NP0(ISTATE)) IF(NQ0(ISTATE).GT.0) READ(5,*) (QM0(I,ISTATE), I=1, 1 NQ0(ISTATE)) c----------------------------------------------------------------------- IF(ITYPE(ISTATE).EQ.3) THEN IP0(ISTATE)= 1 IQ0(ISTATE)= 1 ENDIF c** If fitting NDE or mixed MXS function to Gv (IFXGv.le.0), specify c whether or not DLIMIT and/or vD are to be held fixed: c If IFXD or IFXVD > 0 hold DLIMIT or VD, respectively, fixed at c read-in value; else it is to be varied in the fit. c----------------------------------------------------------------------- IF(IFXGv(ISTATE).LE.0) READ(5,*)IFXD(ISTATE),IFXVD(ISTATE) c----------------------------------------------------------------------- c c** Printout, for input NDE Gv parameters WRITE(6,638) SLABL(ISTATE),CCDC(0),NP0(ISTATE), 1 NQ0(ISTATE),CTYPE(ITYPE(ISTATE)),IP0(ISTATE), 2 IQ0(ISTATE),VD(ISTATE),DLIMIT(ISTATE) IF(NP0(ISTATE).GT.0) WRITE(6,640) (PM0(I,ISTATE),I=1, 1 NP0(ISTATE)) IF(NQ0(ISTATE).GT.0) WRITE(6,642) (QM0(I,ISTATE),I=1, 1 NQ0(ISTATE)) IP0(ISTATE)= IP0(ISTATE)- 1 IQ0(ISTATE)= IQ0(ISTATE)- 1 NEWGv= 1 ccc NEWBv= 0 ccc I= 0 ccc CALL NDEDGB(ISTATE,1,NEWGv,NEWBv,RSQMU,I) ENDIF c c======================================================================= c** If Bv's defined by Band Constants while Gv's are Not -- so are CDC's c======================================================================= IF((NDEBv(ISTATE).EQ.-1).AND.(NDEGv(ISTATE).GE.0)) THEN IF(IFXBv(ISTATE).GT.0) THEN c** If the Bv's to be held fixed at read-in numerical values, then so c are CDC's, and we read them in here. IFXCDC(ISTATE)= 1 WRITE(6,631) SLABL(ISTATE) MMAX= 1 IF(IFXCDC(ISTATE).GT.0) MMAX= NCDC(ISTATE)+ 1 c ... Looping over isotopomers ... DO ISOT= 1,NISTP c ... Looping over vibrational levels ... DO I= VMIN(ISTATE), VMAX(ISTATE) c** For all vibrational levels v=IV from 0 to VMAX, read in v and c Bv = ZK(1,IV,ISTATE,ISOT), and -Dv = ZK(2,IV,ISTATE,ISOT), and c Hv = ZK(3,IV,ISTATE,ISOT), and Lv = ZK(4,IV,ISTATE,ISOT), ... etc. c%%%%%%%%%%%%%%%%%%%%%%%%%%%% NOTE!! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** MAKE SURE THAT (!!) read-in values of leading CDC are -Dv, to make c sign convention for ZK(2,IV,ISTATE,ISOT) consistent with that for c other CDC's (s.th. +ve value makes +ve contribution to the energy!!) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c----------------------------------------------------------------------- READ(5,*) IV, (ZK(M,I,ISTATE,ISOT), M=1, MMAX) c----------------------------------------------------------------------- IF(IV.NE.I) THEN WRITE(6,632) SLABL(ISTATE),I,IV STOP ENDIF ENDDO ENDDO ELSE c** If FITTING to band constant Bv's, SAME for CDC's IFXCDC(ISTATE)= 0 IF(IOMEG(ISTATE).NE.0) IFXLD(ISTATE)= 0 MMAX= 1 c ... Loop over isotopomers ... DO ISOT= 1,NISTP c ... and then loop over vibrational levels ... DO IV= VMIN(ISTATE),VMAX(ISTATE) c ... read variables specifying how many free parameters for each level: c NRC(v,es,isot) = number of rotational constants (Bv, -Dv, Hv, Lv, ...) c to be fitted for vibrational level IV ( =0 if no data) c----------------------------------------------------------------------- READ(5,*,END=200) I ,NRC(IV,ISTATE,ISOT) c----------------------------------------------------------------------- IF(IV.NE.I) THEN WRITE(6,632) SLABL(ISTATE),I,IV STOP ENDIF FITGV(IV,ISTATE,ISOT)= 0 MMAX= MAX(MMAX,NRC(IV,ISTATE,ISOT)) ENDDO ENDDO IF(BOBORD(ISTATE).GT.0) BOBORD(ISTATE)= 0 ENDIF GO TO 30 ENDIF c c======================================================================= c** If Bv's defined by Dunham Y(l,m)'s or by MXS Dunham+NDE functions: c======================================================================= IF((NDEBv(ISTATE).EQ.0).OR.(NDEBv(ISTATE).GE.2)) THEN c** L=LMAX(1,s) labels highest-order non-zero Y(L,1) in the Bv expansion c----------------------------------------------------------------------- READ(5,*) LMAX(1,ISTATE) c----------------------------------------------------------------------- IF(LMAX(1,ISTATE).LT.-1) LMAX(0,ISTATE)= -1 IF(NDEBv(ISTATE).GE.2) WRITE(6,634) SLABL(ISTATE),CCDC(1), 1 LMAX(1,ISTATE),VS(ISTATE) IF(IFXBv(ISTATE).GT.0) THEN c** If Bv's held fixed at values defined by Dunham constants, read c Dunham Y(l,m) expansion coefficients for isotopomer-1 and define c other coeffts. using the normal isotope relations. c----------------------------------------------------------------------- READ(5,*) (YLM(L,1,ISTATE), L=0, LMAX(1,ISTATE)) c----------------------------------------------------------------------- c ... first consider expansions for Gv and Bv ... c** Set vib. energy zero for each state at its isotopomer-1 (v=0,J=0) c level. For lowest (s=1) state this defines absolute energy zero. WRITE(6,636) SLABL(ISTATE),CCDC(1),(YLM(L,1,ISTATE), 1 L= 0,LMAX(1,ISTATE)) IF(MMIN.LT.0) MMIN= 1 MMAX= 1 ENDIF ENDIF c IF(NDEBv(ISTATE).GE.1) THEN c======================================================================= c** If Bv's represented by NDE or MXS functions ... read parameters c defining form of the NDE expansion and initial expansion parameters. c* ITYPB identifies type of NDE Bv function for state 's': c (i) ITYPB=1 for an "outer" Pade expansion; (ii) ITYPB=2 for an c "inner" Pade, and (iii) ITYPB=3 for an exponent polynomial NDE. c* Leading non-zero contribution to the NP1-term numerator polynomial c is (vD-v)**IP1 , while (for ITYPE=1 or 2) the corresponding c leading term in the NQ1-term denominator polynomial is (vD-v)**IQ1. c* NP1 & NQ1 are # terms in rot. numerator & denom rational polynomials c* PM1 & QM1 are vibrational numerator & denominator polynomial coeffts. c----------------------------------------------------------------------- READ(5,*) ITYPB(ISTATE), NP1(ISTATE), NQ1(ISTATE), 1 IP1(ISTATE), IQ1(ISTATE) IF(NP1(ISTATE).GT.0) READ(5,*) (PM1(I,ISTATE), I=1, 1 NP1(ISTATE)) IF(NQ1(ISTATE).GT.0) READ(5,*) (QM1(I,ISTATE), I=1, 1 NQ1(ISTATE)) c----------------------------------------------------------------------- IF(ITYPB(ISTATE).EQ.3) THEN IP1(ISTATE)= 1 IQ1(ISTATE)= 1 ENDIF IF(NP1(ISTATE).LT.0) NP1(ISTATE)= 0 WRITE(6,638) SLABL(ISTATE),CCDC(1),NP1(ISTATE), 1 NQ1(ISTATE),CTYPE(ITYPB(ISTATE)),IP1(ISTATE),IQ1(ISTATE) IF(NP1(ISTATE).GT.0) WRITE(6,640) (PM1(I,ISTATE),I=1, 1 NP1(ISTATE)) IF(NQ1(ISTATE).GT.0) WRITE(6,642) (QM1(I,ISTATE),I=1, 1 NQ1(ISTATE)) IP1(ISTATE)= IP1(ISTATE)- 1 IQ1(ISTATE)= IQ1(ISTATE)- 1 NEWBv= 1 ENDIF c** Call subroutine to generate predicted vibrational energies & Bv's c [returned & held in COMMON/PARMBLK as ZK(0,v,s,ISTP) & ZK(1,v,s,ISTP)] IF((NDEGv(ISTATE).GT.0).OR.(NDEBv(ISTATE).GT.0)) 1 CALL NDEDGB(ISTATE,NISTP,NEWGv,NEWBv,RSQMU,VMAX(ISTATE)) c c======================================================================= c** Now ... begin consideration of CDC's c======================================================================= 20 IF((NDECDC(ISTATE).EQ.-1).AND.(IFXCDC(ISTATE).GT.0) 1 .AND.((NDEBv(ISTATE).GE.0).OR.(IFXBv(ISTATE).LE.0))) THEN c======================================================================= c** If CDC's to be fixed at read-in band constant values (and Gv's & c Bv's not fixed at read-in band constant values!), input CDC's here: c [NOTE: if Gv or Bv also fixed this way, CDC's already read in above!] c======================================================================= WRITE(6,652) SLABL(ISTATE) MMAX= NCDC(ISTATE)+ 1 c ... Loop over isotopomers ... DO ISOT= 1,NISTP c ... Loop over vibrational levels ... DO I= VMIN(ISTATE), VMAX(ISTATE) c** For all vibrational levels v=IV from 0 to VMAX, read c -Dv = ZK(2,IV,ISTATE,ISOT) & Hv = ZK(3,IV,ISTATE,ISOT) & ... etc. c [NOTE - input format assumed to include Gv & Bv, which are ignored!] c%%%%%%%%%%%%%%%%%%%%%%%%%%%% NOTE!! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** MAKE SURE THAT (!!) read-in values of leading CDC are -Dv, to make c sign convention for ZK(2,IV,ISTATE,ISOT) consistent with that for c other CDC's (s.th. +ve value makes +ve contribution to the energy!!) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c----------------------------------------------------------------------- READ(5,*) IV, (ZK(M,I,ISTATE,ISOT), M= 2,MMAX) c----------------------------------------------------------------------- IF(IV.NE.I) THEN WRITE(6,632) SLABL(ISTATE),I,IV STOP ENDIF ENDDO ENDDO ENDIF c IF((NDECDC(ISTATE).EQ.-1).AND.(IFXCDC(ISTATE).LE.0) 1 .AND.((NDEBv(ISTATE).GE.0))) THEN c======================================================================= c** If CDC's to be FITTED as band constants [but Gv's & Bv's are not] c======================================================================= MMAX= 0 c ... Loop over isotopomers ... DO ISOT= 1,NISTP c ... and then loop over vibrational levels ... DO IV= VMIN(ISTATE),VMAX(ISTATE) c ... read variables specifying # free parameters for each level v = I c NRC(v,es,isot) = total number of rotational constants for vib level v c of isotopomer isot in electronic state # es. The number of CDC's c {-Dv, Hv, Lv, ...} to be fitted is, of course (NRC - 1). c [Set it =0 if insufficient data.] c----------------------------------------------------------------------- READ(5,*,END=200) I, NRC(IV,ISTATE,ISOT) c----------------------------------------------------------------------- IF(I.NE.IV) THEN WRITE(6,632) SLABL(ISTATE),I,IV STOP ENDIF FITGV(IV,ISTATE,ISOT)= 0 MMAX= MAX(MMAX,NRC(IV,ISTATE,ISOT)) ENDDO ENDDO c** Ensure that BOB corrections not invoked for these Band Constants IF(BOBORD(ISTATE).GE.2) BOBORD(ISTATE)= 1 GO TO 30 ENDIF c IF(NDECDC(ISTATE).EQ.0) THEN c======================================================================= c** If CDC's represented by Dunham expansions ... c======================================================================= c L=LMAX(m,s) labels highest-order Y(L,m) in the Dunham expansion for c CDC number 'm-1', for State-s [m=2 for -Dv, m=3 for Hv, ...] c----------------------------------------------------------------------- READ(5,*) (LMAX(M,ISTATE), M= 2, NCDC(ISTATE)+1) c----------------------------------------------------------------------- c** If CDC's are to be fixed at values defined by Dunham coefficients, c read in Ylm's for isotopomer-1 (defining others by mass scaling). c** L=LMAX(m,s) labels highest-order Y(L,m) in expansion for ZK(m,v,s,1) IF(IFXCDC(ISTATE).GT.0) THEN IF(MMIN.LT.0) MMIN= 2 MMAX= NCDC(ISTATE)+ 1 DO M= 2,MMAX IF(LMAX(M,ISTATE).GE.0) THEN c----------------------------------------------------------------------- READ(5,*) (YLM(L,M,ISTATE),L= 0,LMAX(M,ISTATE)) c----------------------------------------------------------------------- WRITE(6,654) SLABL(ISTATE),M-1,CCDC(M), 1 (YLM(L,M,ISTATE),L= 0,LMAX(M,ISTATE)) ENDIF ENDDO ENDIF ENDIF IF(NDECDC(ISTATE).GT.0) THEN c======================================================================= c** If CDC's represented by NDE functions [ONLY allowed if CDC's fixed]: c======================================================================= MMAX= NCDC(ISTATE) DO M= 1,NCDC(ISTATE) c ... drop NCDC to omit constants with no expansion terms IF(LMAX(M,ISTATE).LT.0) MMAX= MMAX-1 ENDDO NCDC(ISTATE)= MMAX MMAX= NCDC(ISTATE)+ 1 c** LMAX(m,s) No. of terms in exponential expansion for each CDC(m) c** RM(i) are Isotope=1 exponent expansion coefficients for CDC(M-1) c (Note ... these coefficients not saved past this program segment) c----------------------------------------------------------------------- READ(5,*) (LMAX(M,ISTATE), M= 2,MMAX) DO M= 2,MMAX IF(LMAX(M,ISTATE).GT.0) THEN READ(5,*) (RM(I),I= 1,LMAX(M,ISTATE)) c----------------------------------------------------------------------- WRITE(6,656) SLABL(ISTATE),M-1,CCDC(M),(RM(I), 1 I= 1,LMAX(M,ISTATE)) c** Now ... use read-in coefficients to generate actual fixed CDC values DO ISOT= 1,NISTP DO IV= 0, VMAX(ISTATE) VDMV= (VD(ISTATE)- IV)*RSQMU(ISOT) VDMVP= 1.d0 FNDE= 0.d0 DO I= 1,LMAX(M,ISTATE) VDMVP= VDMVP*VDMV FNDE= FNDE+ VDMVP*RM(I) ENDDO ZK(M,IV,ISTATE,ISOT)= XM(M,ISTATE,ISOT)* 1 DEXP(FNDE)*VDMV**PNDE(M,ISTATE) ENDDO ENDDO ENDIF ENDDO ENDIF c======================================================================= c** If IOMEG(s) > 0 , allow for a Lambda doubling parameter expansion. c If IOMEG(s) < 0 , allow for a Gamma doubling parameter expansion. c======================================================================= 30 IF(IOMEG(ISTATE).NE.0) THEN c======================================================================= c NLDMX(s) is the number of Lambda/Doublet-Sigma doubling parameters to c be considered for each vibrational levels. For IOMEG > 0, leading c term proportional to [J(J+1)]^{IOMEG} and higher terms add powers c of [J(J+1)- IOMEG**2]. For IOMEG < 0 leading term proportional to c J (for e parity) or (J+1) (for f parity), and higher terms add c powers of [J(J+1)]. c efREF(s) identifies the `reference' (zero-shift) level in Lambda c doubling as being the e sublevels [efREF= +1], the f sublevels c [for efREF= -1], or the mid-point [efREF= 0]; e.g., for efREF=-1 c the f levels treated as unperturbed and the e levels shifted by c +q*[J(J+1)]. For efREF= 0 attribute half of splitting to each. c* For 2\Sigma states set efREF(s)= 0 c NDELD(s) specifies form used for the Lambda doubling parameters: c a) NDELD(s) < 0 ... use band constant form c b) NDELD(s) = 0 ... use conventional Dunham form c !!!!! c) NDELD(s) > 0 ... use (Bv)**2 times (v+1/2) polynomial c !!!!! NDELD > 0 option NOT yet implemented! c IFXLD(s) specifies whether these for electronic state-s will be: c (a) held fixed at read-in values (IFXLD > 0 ) , or c (b) determined from the fits (IFXLD.le.0). c----------------------------------------------------------------------- READ(5,*) NLDMX(ISTATE), efREF(ISTATE), NDELD(ISTATE), 1 IFXLD(ISTATE) c----------------------------------------------------------------------- IF(NDELD(ISTATE).GT.0) NDELD(ISTATE)= 0 MQ0= MAX0(0,IOMEG(ISTATE)-1) IF(IOMEG(ISTATE).LT.0) efREF(ISTATE)= 0 c======================================================================= c** If using "band-constant" treatment of Lambda/Gamma-doubling constants c for this state *** Loop over isotopomers and over vibrational levels c to read parameters governing treatment of each level. c======================================================================= IF((NLDMX(ISTATE).GT.0).AND.(NDELD(ISTATE).EQ.-1)) THEN MQMAX= 0 DO ISOT= 1, NISTP DO IV= VMIN(ISTATE), VMAX(ISTATE) c======================================================================= c** ZQ(M, ...) are FIXED values of the Lambda/Gamma doubling parameters c for vibrational level I=IV of state ISTATE for isotopomer ISOT. c NQC(IV,es,isot) = number of Lambda/Gamma doubling constants to be c fitted for vibrational level v=IV [set =0 if no data or IOMEG(s)=0] c----------------------------------------------------------------------- IF(IFXLD(ISTATE).GT.0) READ(5,*) I, 1 (ZQ(MQ0+M,I,ISTATE,ISOT),M= 1,NLDMX(ISTATE)) IF(IFXLD(ISTATE).LE.0) THEN READ(5,*) I,NQC(IV,ISTATE,ISOT) c----------------------------------------------------------------------- MQMAX= MAX(MQMAX,NQC(IV,ISTATE,ISOT)) ENDIF IF(I.NE.IV) THEN WRITE(6,633) SLABL(ISTATE),IV,I STOP ENDIF ENDDO ENDDO IF(IFXLD(ISTATE).LE.0) NLDMX(ISTATE)= MQMAX ENDIF IF((NLDMX(ISTATE).GT.0).AND.(NDELD(ISTATE).GE.0)) THEN c======================================================================= c LDMAX(M,s) labels the highest-order (highest-power in v+1/2) non-zero c q(L,M) coefficient in the Dunham polynomial representation for c the M-th order (power M in [J(J+1)]) Lambda/Gamma doubling coeffts. c If NO coefficients of this type, input: LDMAX(M,s) < 0 c If NDELD > 0 polynomial premultiplies (Bv)**2 [NOT YET IMPLEMENTED] c----------------------------------------------------------------------- READ(5,*) (LDMAX(M+MQ0,ISTATE), M= 1,NLDMX(ISTATE)) c----------------------------------------------------------------------- IF((IFXLD(ISTATE).GT.0).AND.(NLDMX(ISTATE).GT.0)) THEN c** If Lambda/Gamma doubling coefficients are to be held fixed, read in c the Dunham-type expansion coefficients to be used to define them. DO M= 1,NLDMX(ISTATE) MQM= M+ MQ0 IF(LDMAX(MQM,ISTATE).GE.0) THEN c----------------------------------------------------------------------- READ(5,*) (QLM(L,MQM,ISTATE),L= 0, 1 LDMAX(MQM,ISTATE)) c----------------------------------------------------------------------- IF(IOMEG(ISTATE).GE.0) WRITE(6,658) 1 SLABL(ISTATE),CCDC(MQM),(L,MQM,QLM(L,MQM,ISTATE), 2 L= 0,LDMAX(MQM,ISTATE)) IF(IOMEG(ISTATE).LT.0) WRITE(6,659) 1 SLABL(ISTATE),CCDC(M),(L,M,QLM(L,M,ISTATE),L= 0,LDMAX(M,ISTATE)) c** Now ... generate values of the fixed Lambda/Gamma doubling coefft. c for each vibrational level of each isotopomer. DO IV= VMIN(ISTATE),VMAX(ISTATE) DO ISOT= 1,NISTP XX= (IV+0.5d0)*RSQMU(ISOT) YY= QLM(0,MQM,ISTATE) IF(LDMAX(MQM,ISTATE).GE.1) THEN XXP= 1.d0 DO L= 1,LDMAX(MQM,ISTATE) XXP= XXP*XX YY=YY+QLM(L,MQM,ISTATE)*XXP ENDDO ENDIF IF(IOMEG(ISTATE).GT.0) 1 ZQ(MQM,IV,ISTATE,ISOT)= YY*(RMUP(1,ISOT))**(MQ0+MQM+1) IF(IOMEG(ISTATE).LT.0) 1 ZQ(M,IV,ISTATE,ISOT)= YY*RMUP(M,ISOT) ENDDO ENDDO ENDIF ENDDO ENDIF ENDIF ENDIF c IF(BOBORD(ISTATE).GE.0) THEN c======================================================================= c** If allowing for mass-dependent BOB/JWKB breakdown corrections ... c======================================================================= c* If fitting to BOB parameters, for ISTATE=1 must specify whether c (BOB00 > 0) or not (BOB00.le.0) the {0,0} coefficient is to be c included when fitting to vibrational BOB corrections for this state c [Always included for other (ISTATE > 1) states!] c* LAMAX(atom,i,s) labels the highest power of the (v+1/2) expansion c used to represent the atomic-mass-dependent BOB correction term c for [J(J+1)]**i (i=0 for pure vibration, etc.); atom-1 for the c first atom of the pair & atom=2 for the second. c Power series in (v+1/2) starts at linear term (L=1) for i=0, c and at constant [L=0] for i > 0 (rotational) terms c* Set LAMAX.lt.0 if no correction terms to be considered for this i. c* For Homonuclear molecule, only read powers for the onee type of atom. c----------------------------------------------------------------------- IF((IFXGv(ISTATE).LE.0).AND.(ISTATE.EQ.1)) READ(5,*) BOB00 READ(5,*) (LAMAX(1,M,ISTATE), M= 0, BOBORD(ISTATE)) IF(AN(1).NE.AN(2)) 1 READ(5,*) (LAMAX(2,M,ISTATE), M= 0,BOBORD(ISTATE)) c----------------------------------------------------------------------- IF(IFXGv(ISTATE).GT.0) THEN c======================================================================= c** If BOB correction terms are to be used and held fixed ... c ... read-em for each atom in turn c======================================================================= c** NOTE that leading (constant) vibrational correction coefficient c normally fixed at 0.0 for lowest (ISTATE=1) state. CATOM= NAME(1) ATOM2= 2 IF(AN(1).EQ.AN(2)) ATOM2= 1 DO ATOM= 1,ATOM2 DO M= 0, BOBORD(ISTATE) IF(LAMAX(ATOM,M,ISTATE).GE.0) THEN c ... if included, read and write the fixed LeRoy-type BOB correction c expansion coefficients associated with [J(J+1)]**M, for each atom c----------------------------------------------------------------------- READ(5,*) (DELTA(ATOM,L,M,ISTATE), 1 L= 0, LAMAX(ATOM,M,ISTATE)) c----------------------------------------------------------------------- WRITE(6,660) CATOM,CCDC(M),SLABL(ISTATE), 1 (CATOM,L,M,DELTA(ATOM,L,M,ISTATE), 2 L= 0,LAMAX(ATOM,M,ISTATE)) ENDIF ENDDO CATOM= NAME(2) ENDDO ENDIF ENDIF c c======================================================================= c** As appropriate, now use any read-in Dunham coefficients to generate c desired fixed ZK(M,v,ISTATE,ISOT) vib. & rot. energy band constants. c======================================================================= IF(MMIN.GE.0) THEN MMAX= 1 IF((NDECDC(ISTATE).EQ.0).AND.(IFXCDC(ISTATE).GT.0)) 1 MMAX= NCDC(ISTATE)+ 1 Sw= 1.d0 SwLR= 0.d0 DO IV=0, VMAX(ISTATE) DO ISOT= 1,NISTP XX= (IV+0.5d0)*RSQMU(ISOT) IF((NDEGv(ISTATE).EQ.2).OR.(NDEBv(ISTATE).EQ.2)) 1 THEN SwLR= dexp((IV- VSISO(ISTATE,ISOT))/ 1 DVSISO(ISTATE,ISOT)) Sw= 1.d0/(1.d0+ SwLR) SwLR= SwLR*Sw ENDIF DO 44 M= MMIN,MMAX IF((M.EQ.1).AND.((IFXBv(ISTATE).LE.0) 1 .OR.(NDEBv(ISTATE).EQ.1))) GO TO 44 YY= 0.d0 IF(LMAX(M,ISTATE).GE.0) THEN DO L= LMAX(M,ISTATE),0,-1 YY= YY*XX + YLM(L,M,ISTATE) ENDDO ENDIF YY= YY*RMUP(M,ISOT) IF(((M.EQ.0).AND.(NDEGv(ISTATE).EQ.2)).OR. 1 ((M.EQ.1).AND.(NDEBv(ISTATE).GE.2))) 2 YY= Sw*YY +SwLR*ZK(M,IV,ISTATE,ISOT) ZK(M,IV,ISTATE,ISOT)= YY 44 CONTINUE ENDDO ENDDO ENDIF c======================================================================= c** If appropriate, add BOB correction contributions to fixed band constants c======================================================================= IF((BOBORD(ISTATE).GE.0).AND.(IFXGv(ISTATE).GT.0)) THEN ATOM2= 2 IF(AN(1).EQ.AN(2)) ATOM2= 1 LAMIN= 0 DO ISOT= 1,NISTP DO IV= 0, VMAX(ISTATE) XX= (IV+0.5d0)*RSQMU(ISOT) DO 50 M= 0,BOBORD(ISTATE) IF(((M.EQ.0).AND.(IFXGv(ISTATE).LE.0)).OR. 1 ((M.EQ.1).AND.(IFXBv(ISTATE).LE.0)).OR. 2 ((M.GE.2).AND.(IFXCDC(ISTATE).LE.0)))GOTO 50 YY= 0.d0 ZATOM= 1.d0 - ZMASS(1,1)/ZMASS(1,ISOT) IF(AN(1).EQ.AN(2)) ZATOM= ZATOM+ 1.d0 - 1 ZMASS(2,1)/ZMASS(2,ISOT) DO ATOM= 1,ATOM2 IF(LAMAX(ATOM,M,ISTATE).GE.LAMIN) THEN XXP= 1.d0 IF(LAMIN.EQ.0) XXP= 1.d0/XX DO L= LAMIN,LAMAX(ATOM,M,ISTATE) XXP= XXP*XX YY= YY+XXP* 1 DELTA(ATOM,L,M,ISTATE)*ZATOM ENDDO ENDIF ZATOM= 1.d0 - ZMASS(2,1)/ZMASS(2,ISOT) ENDDO ZK(M,IV,ISTATE,ISOT)= ZK(M,IV,ISTATE,ISOT) + 1 YY*RMUP(M,ISOT) 50 CONTINUE ENDDO ENDDO ENDIF IF((IFXGv(ISTATE).GT.0).OR.(IFXBv(ISTATE).GT.0).OR. 1 (IFXCDC(ISTATE).GT.0)) THEN c======================================================================= c** Print values of vib/rotation band constants held fixed in the fits. c======================================================================= MMIN= 2 IF(IFXBv(ISTATE).GT.0) MMIN= 1 IF(IFXGv(ISTATE).GT.0) THEN MMIN= 0 IF(IFXBv(ISTATE).LE.0) MMIN= -1 ENDIF MMAX= 0 IF(IFXBv(ISTATE).GT.0) MMAX= 1 IF(IFXCDC(ISTATE).GT.0) MMAX= NCDC(ISTATE)+ 1 DO ISOT= 1,NISTP IF(MMIN.EQ.0) THEN IF(MMAX.LE.1) WRITE(6,662) 1 SLABL(ISTATE),NAME(1),MN(1,ISOT),NAME(2), 2 MN(2,ISOT),(CCDC(M),M= 0,MMAX) IF(MMAX.GT.1) WRITE(6,662) 1 SLABL(ISTATE),NAME(1),MN(1,ISOT),NAME(2), 2 MN(2,ISOT),(CCDC(M),M=0,1),(M-1,CCDC(M), 3 M=2,MMAX) ENDIF IF(MMIN.LT.0) WRITE(6,667) 1 SLABL(ISTATE),NAME(1),MN(1,ISOT),NAME(2), 2 MN(2,ISOT),CCDC(0),(M-1,CCDC(M),M=2,MMAX) IF(MMIN.EQ.1) WRITE(6,667) 1 SLABL(ISTATE),NAME(1),MN(1,ISOT),NAME(2), 2 MN(2,ISOT),CCDC(1),(M-1,CCDC(M),M=2,MMAX) IF(MMIN.EQ.2) WRITE(6,668) 1 SLABL(ISTATE),NAME(1),MN(1,ISOT),NAME(2), 2 MN(2,ISOT), (M-1,CCDC(M),M=2,MMAX) IF(MMIN.LT.0) WRITE(6,664) ('-',M=1,MMAX) IF(MMIN.GE.0) WRITE(6,664) ('-',M=MMIN,MMAX) DO IV= VMIN(ISTATE),VMAX(ISTATE) IF(MMIN.EQ.0) WRITE(6,666) IV, 1 (ZK(M,IV,ISTATE,ISOT),M= 0,MMAX) IF(MMIN.LT.0) THEN IF(MMAX.LT.2) WRITE(6,665) IV, 1 ZK(0,IV,ISTATE,ISOT) IF(MMAX.GE.2) WRITE(6,665) IV, 1 ZK(0,IV,ISTATE,ISOT),(ZK(M,IV,ISTATE,ISOT),M= 2,MMAX) ENDIF IF(MMIN.EQ.1) WRITE(6,671) IV, 1 (ZK(M,IV,ISTATE,ISOT),M= 1,MMAX) IF(MMIN.EQ.2) WRITE(6,672) IV, 1 (ZK(M,IV,ISTATE,ISOT),M= 2,MMAX) ENDDO ENDDO ENDIF c IF((IOMEG(ISTATE).NE.0).AND.(IFXLD(ISTATE).GT.0).AND. 1 (NLDMX(ISTATE).GT.0)) THEN c======================================================================= c** Print values of Lambda/Gamma Doubling constants held fixed in the fits. c======================================================================= DO ISOT= 1,NISTP IF(IOMEG(ISTATE).GE.0) WRITE(6,663) SLABL(ISTATE), 1 NAME(1),MN(1,ISOT),NAME(2),MN(2,ISOT),(M+MQ0, M=1,NLDMX(ISTATE)) IF(IOMEG(ISTATE).LT.0) WRITE(6,6663) SLABL(ISTATE), 1 NAME(1),MN(1,ISOT),NAME(2),MN(2,ISOT),(M, M=1,NLDMX(ISTATE)) WRITE(6,664) ('---',M=1,NLDMX(ISTATE)) DO IV= VMIN(ISTATE),VMAX(ISTATE) WRITE(6,672) IV, (ZQ(M+MQ0,IV,ISTATE,ISOT), 1 M=1,NLDMX(ISTATE)) ENDDO ENDDO IF(IOMEG(ISTATE).GT.0) THEN IF(efREF(ISTATE).NE.0) WRITE(6,716) SLABL(ISTATE), 1 efREF(ISTATE) IF(efREF(ISTATE).EQ.0) WRITE(6,718) SLABL(ISTATE) ENDIF ENDIF 60 CONTINUE c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Call subroutine to input experimental data in specified band-by-band, c format & do bookkeeping to document amounts of data or each type. 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 isotopomer. Note that LABLP also c identifies the type of data in the 'band' or data-group (see below). c 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 = 'BVV' identifies this data group/band as a set of Bv values c for electronic state LABLPP. In this case, parameters VP c & VPP, and EFPP are dummy variables, as is JP and EFP [see c below], JPP is actually the vibrational quantum number v", c EFPP the parity p", FREQ the Bv value & UFREQ its uncertainty c** STOP reading when run out of bands OR when read-in VPP is negative c----------------------------------------------------------------------- cc READ(4,*,END=20) VP(IBAND), VPP(IBAND), LABLP, LABLPP, MN1,MN2 c----------------------------------------------------------------------- cc IF(VPP(IBAND).LT.0) GO TO 20 c** For each of the lines in a given band/series, read upper level cc rotational quantum number (JP) and e/f parity (EFP= +1 for e, = -1 cc for f, and =0 when e/f splitting not resolved), and lower level cc rotational quantum number (JPP) and parity (EFPP), the transition c frequency FREQ, and its uncertainty UFREQ. c----------------------------------------------------------------------- cc 5 READ(4,*) JP(COUNT), EFP(COUNT), JPP(COUNT), EFPP(COUNT), cc FREQ(COUNT), UFREQ(COUNT) c----------------------------------------------------------------------- c** At end of a band, exit from implicit loop cc IF((JPP(COUNT).LT.0).OR.(JP(COUNT).LT.0)) GOTO 9 cc ----------------------------------- cc Sample IR band data of HF for the '.4' file: cc -------------------------------------------- cc 1 0 'X0' 'X0' 1 19 % VP VPP LABLP LABLPP MN1 MN2 cc 1 0 1 1 1 19 % VP VPP IEP IEPP MN1 MN2 cc 8 1 9 1 266.0131002 0.005 % JP EFP JPP EFPP FREQ UFREQ cc 9 1 10 1 265.8885896 0.003 cc 10 1 11 1 265.7716591 0.002 cc . . . . cc . . . . cc [end of a band indicated by -ve JP and/or JPP value(s)] cc -1 1 -1 1 -1.1 -1.1 c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c IF(MKPRED.LE.0) OPEN(UNIT= 4, STATUS= 'OLD', FILE= DATAFILE) 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(NSTATES,NDEGV,UCUTOFF,JTRUNC,EFSEL,VMIN,VMAX, 1 NDAT,NOWIDTHS,PRINP) c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c** Prepare and store powers of (v+1/2) for use in partial derivatives VMAXX= 0 DO ISTATE= 1,NSTATES VMAXX= MAX(VMAXX,VMAX(ISTATE)) ENDDO IF(VMAXX.GT.NVIBMX) THEN WRITE(6,674) NVIBMX STOP ENDIF DO IV= 0,VMAXX VPH= IV+0.5d0 PW= 1.d0/VPH DO L= 0,NDUNMX PW= PW*VPH VPHPW(IV,L)= PW ENDDO ENDDO c** Zero band origins of any fluorescence series. To fix them, a USER c would need to change the code to add parameters & conditions!!] DO IBAND= 1,NBANDMX ORIGIN(IBAND)= 0.d0 ENDDO 630 FORMAT(/" Fix State ",A3," Gv's, Bv's and CDC's at read-in val 1ues") 631 FORMAT(/" Fix State ",A3," Bv's and CDC's at read-in values") 632 FORMAT(/" **** ERROR when reading State ",A3," Band Constants,", 1 " I=",i3," when IV=v=",i3) 633 FORMAT(/" **** ERROR when reading State ",A3," Q(Lambda)'s.", 1 " I=",i3," when IV=v=",i3) 634 FORMAT(/" Represent State ",A3,1x,A3, "'s by Tellinghuisen-type M 1XS mixed representation:"/1x,9('=='),I3,' order Dunham for v .le. 2 VS=',F9.4,' & NDE for v > VS':/9x, 'with switching function: 3 Sw = 1/[1 + exp{(v -',F11.6,')/',F9.6,'}]') 635 FORMAT(/' Fixed State ',A3, " Gv for Isot.-1 defined relative to 1 T(v=-1/2)=",F12.5,' cm-1') 636 FORMAT(' Fixed State ',A3,1x,A3,' values defined by isotopomer-1' 1 ,' Dunham coefficients:'/(1P4D20.12:)) 638 FORMAT(/' State ',A3,' NDE for',A3,' represented by (NP=',I2, 1 '/NQ=',I2,') ',A12,'NDE in (vD-v)'/1x,19('-'):' with leading n 2umerator and denominator powers',I3,' &',I3:/ 3 8x,'where for Isotopomer-1 vD=',F10.5,' and DLIMIT=',F12.4) 640 FORMAT(5x,'Input numerator coefficients: ',2(1PD21.13:)/ 1 (15X,3D21.13:)) 642 FORMAT(5x,'Input denominator coefficients:',2(1PD21.13:)/ 1 (15X,3D21.13:)) 652 FORMAT(/" Fix State ",A3," CDC's at read-in values") 654 FORMAT(/' Fixed State ',A3, ' CDC(',i1,')=',A3, ' values defined 1 by isotopomer-1 Dunham coefficients:'/(1P4D20.12:)) 656 FORMAT(/" Fixed State ",A3," CDC(",I1,")=",A3,"'s defined by isot 1opomer-1 NDE Exponent coefficients:"/(1P4D20.12:)) 658 FORMAT(/" Fixed State ",A3, ' "',A3,'"-Lambda Doubling defined by 1 isotopomer-1 Dunham coeffts:'/(2x,3(' Q(',i2,',',i1,')=', 2 1PD15.8:))) 659 FORMAT(/" Fixed State ",A3,' "',A3,'"-Gamma Doubling defined by i 1sotopomer-1 Dunham coeffts.:'/(2x,3(' Q(',i2,',',i1,')=', 2 1PD15.8:))) 660 FORMAT(/' Fixed ',A2,' "',A3,'" BOB corrections for State ',A3, 1 ' defined by expansion coefficients:'/ 2 (2x,2(' delta(',A2,',',i2,',',i2,')=',1PD19.11:))) 662 FORMAT(/' State ',A3,' Constants for ',A2,'(',i3,')-',A2,'(', 1 i3,') held fixed at values:'/' v',6x,A3:9x,A3:2x, 2 6(' CDC(',i1,')=',A3:)) 663 FORMAT(/' State ',A3,' Lambda Doubling Constants for ',A2,'(', 1 i3,')-',A2,'(',i3,') fixed at values:'/ 2 ' v ',6(' q(',i1,') ':)) 6663 FORMAT(/' State ',A3,' Gamma Doubling Constants for ',A2,'(', 1 i3,')-',A2,'(',i3,') fixed at values:'/ 2 ' v ',6(' q(',i1,') ':)) 664 FORMAT(2x,'--------------',A1:'----------',A1: 1 6('------------',A1:)) 665 FORMAT(I4,F12.5,1P6D13.5) 666 FORMAT(I4,F12.5,F12.8,1P6D13.5) 667 FORMAT(/' State ',A3,' Constants for ',A2,'(',i3,')-',A2,'(', 1 i3,') held fixed at values:'/' v',5x,A3:4x,6(' CDC(', 2 i1,')=',A3:)) 668 FORMAT(/' State ',A3,' Constants for ',A2,'(',i3,')-',A2,'(', 1 i3,') held fixed at values:'/' v',4(' CDC(',i1,')=',A3), 2 2(' CDC(',i1,')=',A3:)) 671 FORMAT(I4,F12.8,1P4D13.5,2D12.4) 672 FORMAT(I4,1P4D13.5,2D12.4) 674 FORMAT(/' *** DIMENSIONING PROBLEM *** maximum vibrational range o 1f input data EXCEEDS array dimension NVIBMX=',i3/10x,'which is se 2t in "included" arrsizes.h program file') c======================================================================= c======================================================================= c** Loop over the NSTATES electronic states, preparing counters and c labels for the free parameters to be determined by the fit. c======================================================================= c** For a global fit to data for one or more isotopomers with energies c represented by (i) band constants, (ii) Dunham or (iii) NDE functions c++ For each electronic state in turn, the fitted parameters are ordered c++ in the following way: +++++++++ c c 1. For vibrational band-constant fits: for each isotopomer, and for c each vibrational level of that isotopomer (for which there is c data), in turn, Gv, Bv, the free CDC's: then SKIP to #5 c 2. The vibrational energy expansion parameters: c a) For pure Dunham (or MXS) expansions the parameters are (in c order) T(-1/2), Y_{1,0}, Y_{2,0}, Y_{3,0}, ... etc., where c we always fix T(-1/2)=0 if ISTATE=1 to define energy zero. c b) For mixed MXS functions, VS & DVS next (if they are fitted) c c) For NDE or mixed MXS functions, parameter order continues as: c D=DLIMIT, vD, the PM's and then the QM's (where approptiate c for that ITYPE). c 3) The Bv constant expansion parameters: c a) For rotational band-constant fits [when Gv not fitted by band c constants]: for each isotopomer, and for each vibrational c level of that isotopomer (for which there is rotational data), c in turn: Bv & the free CDC's: then SKIP to #5 c b) For Dunham expansions, Y_{0,1}, Y_{1,1}, Y_{2,1}, ... etc. c c) For NDE functions, the exponent polynomial coefficients c p^1_1, p^1_2, p^1_3, p^1_4, ... etc. c 4) The CDC Dunham expansion parameters (if free): c a) For fitted CDC band constants [when Bv's not fitted as band c constants], the CDC's for each vib level of each isotopomer c b) For Dunham expansions, Y_{0,m}, Y_{1,m}, ... etc., for m=2 c to NCDC(s)+1 [NOTE: fitting CDCs to NDE or MXS not implemented] c 5) If IOMEG > 0, and LAMBDA doubling considered, or ... c If IOMEG < 0, and GAMMA doubling considered, then c a) band-constant or Dunham-like doubling parameters for ISOT=1 c b) band-constant or Dunham-like doubling parameters for ISOT=2 c c) ... etc c 6) If BOBORD.ge.0 s.th. BOB correction delta coefficients used: c For each of atom-A and atom-B in turn, consider for M=0 to c M=BOBORD the delta expansion: delta{atom,0,M}, c delta{atom,1,M}, delta{atom,2,M}, delta{atom,3,M}, ... etc. c+ After all electronic state constants taken into account, consider c 7) the ORIGIN of each fluorescence series, in turn (all isotopomers) c----------------------------------------------------------------------- ISOT= 1 NPARM= 0 NSETS= 0 c** IPSTATE(s) is a parameter counter s.th. [IPSTATE(s)+1] is the first c free parameter for state (s) IPSTATE(1)= NPARM NTVALL(0)= 0 DO 90 ISTATE= 1,NSTATES c** Count parameters and prepare final printout .. IF(NDEGv(ISTATE).EQ.-2) THEN c** If fitting to term values Tv(v,J,p) for this state, then ... c================================================================= CALL TVSORT(ISTATE,NPARM,VMAX,NTVALL) NTVALL(0)= NTVALL(0)+ NTVALL(ISTATE) NDEBv(ISTATE)= -2 NDECDC(ISTATE)= -2 BOBORD(ISTATE)= -1 GOTO 90 c!! Go to end of the ISTATES loop if using Term Values for this state ENDIF IF((NDEGv(ISTATE).EQ.-1).AND.(IFXGv(ISTATE).LE.0)) THEN c** If fitting vib-rot levels of this state using band constants: c================================================================= WRITE(6,676) SLABL(ISTATE),CCDC(0),CCDC(1),CCDC(10) WRITE(6,677) MMAX= 0 DO ISOT= 1,NISTP DO IV= VMIN(ISTATE),VMAX(ISTATE) c** Try to ensure that the # free parameters doesn't exceed # data for c that v. These checks are NOT rigorous, and problems yielding c underflows and nan's can still arise if too few independent data. IF(NDAT(IV,ISOT,ISTATE).LT.(FITGV(IV,ISTATE,ISOT) 1 + NRC(IV,ISTATE,ISOT))) THEN IF(NDAT(IV,ISOT,ISTATE).GT. 1 FITGV(IV,ISTATE,ISOT)) THEN NRC(IV,ISTATE,ISOT)= NDAT(IV,ISOT,ISTATE) 1 - FITGV(IV,ISTATE,ISOT) ELSE NRC(IV,ISTATE,ISOT)= 0 IF(NDAT(IV,ISOT,ISTATE).LT. 1 FITGV(IV,ISTATE,ISOT)) FITGV(IV,ISTATE,ISOT)= 0 ENDIF WRITE(6,678) NDAT(IV,ISOT,ISTATE), 1 SLABL(ISTATE),ISOT,IV,FITGV(IV,ISTATE,ISOT), 2 NRC(IV,ISTATE,ISOT) ENDIF MMAX= MAX(MMAX,NRC(IV,ISTATE,ISOT)) c** Use parameter counter NPAR to store the # free parameters preceeding c the first free vib/rot band constants for level IV of state ISTATE of c isotopomer ISOT, & Accumulate total No. free parameters: NPARM NPAR(IV,ISTATE,ISOT)= NPARM NPARM= NPARM+ FITGV(IV,ISTATE,ISOT)+ 1 NRC(IV,ISTATE,ISOT) IF(FITGV(IV,ISTATE,ISOT).GT.0) 1 WRITE(7,761) CCDC(0),IV,ISOT IF(NRC(IV,ISTATE,ISOT).GT.0) WRITE(7,761) 1 (CCDC(M),IV,ISOT,M= 1,NRC(IV,ISTATE,ISOT)) IF((FITGV(IV,ISTATE,ISOT).LE.0).AND. 1 (NRC(IV,ISTATE,ISOT).GT.0)) THEN NSETS= NSETS+ 1 WRITE(6,680) NSETS,SLABL(ISTATE),IV,ISOT ENDIF IF(FITGV(IV,ISTATE,ISOT).GT.0) WRITE(6,682) 1 IV,ISOT,NRC(IV,ISTATE,ISOT) IF(FITGV(IV,ISTATE,ISOT).LE.0) WRITE(6,683) 1 IV,ISOT,NRC(IV,ISTATE,ISOT) ENDDO ENDDO NRBC(ISTATE)= NPARM- IPSTATE(ISTATE) NCDC(ISTATE)= MMAX-1 GO TO 70 c====end of preparation for vib/rot-band-constant fit to this state===== ENDIF c IF(IFXGv(ISTATE).LE.0) THEN c======================================================================= c** If Gv's are to be fitted to Dunham, NDE or mixed MXS functions ... c======================================================================= IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).EQ.2)) THEN c** If representing Gv for this state by fitted Dunham or MXS function: c ... for state-1, absolute zero of energy fixed by setting Te = 0 IF(ISTATE.EQ.1) THEN Te(ISTATE)= 0.d0 WRITE(6,686) SLABL(ISTATE) ELSE c ... for ISTATE > 1 , Te is always fitted for Dunham or MXS Gv's NPARM= NPARM+ 1 PV(NPARM)= Te(ISTATE) WRITE(7,765) SLABL(ISTATE) ENDIF ENDIF IF(NDEGv(ISTATE).EQ.0) WRITE(6,688) SLABL(ISTATE), 1 CCDC(0),LMAX(0,ISTATE) IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).EQ.2)) THEN IF(LMAX(0,ISTATE).GT.0) THEN NPARM= NPARM+ LMAX(0,ISTATE) WRITE(7,766) (L,0,L= 1,LMAX(0,ISTATE)) ENDIF ENDIF c IF(NDEGv(ISTATE).GT.0) THEN c** If representing Gv for this state by fitted NDE or MXS function: c======================================================================= IF(NDEGv(ISTATE).EQ.2) THEN WRITE(6,689) SLABL(ISTATE),CCDC(0),LMAX(0,ISTATE), 1 VS(ISTATE),VS(ISTATE),DVS(ISTATE) IF(IFXVS(ISTATE).LE.0) THEN NPARM= NPARM+ 1 PV(NPARM)= VS(ISTATE) WRITE(6,690) WRITE(7,768) SLABL(ISTATE) ENDIF IF(IFXDVS(ISTATE).LE.0) THEN NPARM= NPARM+ 1 PV(NPARM)= DVS(ISTATE) WRITE(6,691) WRITE(7,769) SLABL(ISTATE) ENDIF ENDIF IF(ISTATE.EQ.1) THEN IF(NDEGv(ISTATE).EQ.1) THEN c** If State-1 fitted to (or fixed by) a pure NDE function, absolute c zero of energy defined by fixing its asymptote at read-in value IFXD(ISTATE)= 1 ENDIF ELSEIF(NUMNDE(ISTATE).GT.1) THEN c** For second or higher NDE-defined state, dissociation limit MUST be c fixed by the known atomic limit spacings (so override read-in IFXD). IFXD(ISTATE)= 1 ENDIF IF(IFXD(ISTATE).GT.0) THEN WRITE(6,692) SLABL(ISTATE),DLIMIT(ISTATE) ELSE WRITE(6,694) SLABL(ISTATE) NPARM= NPARM+1 PV(NPARM)= DLIMIT(ISTATE) WRITE(7,770) SLABL(ISTATE) ENDIF IF(IFXVD(ISTATE).LE.0) THEN NPARM= NPARM+ 1 PV(NPARM)= VD(ISTATE) WRITE(7,771) SLABL(ISTATE) ENDIF c** Accumulate parameter count WRITE(6,698) SLABL(ISTATE),CCDC(0),NP0(ISTATE), 1 NQ0(ISTATE),CTYPE(ITYPE(ISTATE)),IP0(ISTATE)+1, 2 IQ0(ISTATE)+1,VD(ISTATE) IF(NP0(ISTATE).GT.0) THEN DO I= 1,NP0(ISTATE) NPARM= NPARM+ 1 PV(NPARM)= PM0(I,ISTATE) ENDDO WRITE(6,640) (PM0(I,ISTATE),I=1,NP0(ISTATE)) WRITE(7,773) (0,I+IP0(ISTATE),I= 1,NP0(ISTATE)) ENDIF IF(NQ0(ISTATE).GT.0) THEN DO I= 1,NQ0(ISTATE) NPARM= NPARM+ 1 PV(NPARM)= QM0(I,ISTATE) ENDDO WRITE(6,642) (QM0(I,ISTATE),I=1,NQ0(ISTATE)) WRITE(7,775) (0,I+IQ0(ISTATE),I= 1,NQ0(ISTATE)) ENDIF ENDIF ENDIF c IF(IFXBv(ISTATE).LE.0) THEN c======================================================================= c** If Bv's are to be fitted .................. c======================================================================= IF((NDEBv(ISTATE).LT.0).AND.(NDEGv(ISTATE).GE.0)) THEN c----------------------------------------------------------------------- c** If fit Bv's (& hence CDC's) as band constants while Gv's treated as c Dunham, NDE or MXS expansions, then ... c----------------------------------------------------------------------- WRITE(6,676) SLABL(ISTATE),CCDC(1),CCDC(10) WRITE(6,677) MMAX= 0 c** Set parameter counter before beginning with band constants ... NEBC(ISTATE)= NPARM DO ISOT= 1,NISTP DO IV= VMIN(ISTATE),VMAX(ISTATE) c** Try to ensure that the # free parameters doesn't exceed # data for c that v. These checks are NOT rigorous, and problems yielding c underflows and nan's can still arise if too few independent data. IF(NDAT(IV,ISOT,ISTATE).LT. 1 NRC(IV,ISTATE,ISOT)) THEN NRC(IV,ISTATE,ISOT)= 1 NDAT(IV,ISOT,ISTATE) WRITE(6,678) NDAT(IV,ISOT,ISTATE), 1 SLABL(ISTATE),ISOT,IV,FITGV(IV,ISTATE,ISOT), 2 NRC(IV,ISTATE,ISOT) ENDIF MMAX= MAX(MMAX,NRC(IV,ISTATE,ISOT)) c** Use parameter counter NPAR to store the # free parameters preceeding c the free rotational band constants for level IV of state ISTATE of c isotopomer ISOT, & Accumulate total No. free parameters: NPARM NPAR(IV,ISTATE,ISOT)= NPARM IF(NRC(IV,ISTATE,ISOT).GT.0) THEN NPARM= NPARM+ NRC(IV,ISTATE,ISOT) WRITE(7,761) (CCDC(M),IV,ISOT,M= 1 1,NRC(IV,ISTATE,ISOT)) ENDIF IF(NRC(IV,ISTATE,ISOT).GT.1) WRITE(6,683) 1 IV,ISOT,NRC(IV,ISTATE,ISOT) ENDDO ENDDO c** Set no. fitted Rotational band constants for this state NRBC(ISTATE)= NPARM- NEBC(ISTATE) NEBC(ISTATE)= NPARM NCDC(ISTATE)= MMAX-1 GO TO 70 c= end of preparation for all-rotational band-constant fit to this state ENDIF IF((NDEBv(ISTATE).EQ.0).OR.(NDEBv(ISTATE).GE.2)) THEN c** If representing Bv for this state by a fitted Dunham or MXS function c======================================================================= IF(NDEBv(ISTATE).EQ.0) 1 WRITE(6,688) SLABL(ISTATE),CCDC(1),LMAX(1,ISTATE) NPARM= NPARM+ LMAX(1,ISTATE)+ 1 IF(LMAX(1,ISTATE).GE.0) 1 WRITE(7,766) (L,1,L= 0,LMAX(1,ISTATE)) ENDIF c c** If representing Bv for this state by fitted NDE or MXS functions: c======================================================================= IF(NDEBv(ISTATE).GE.1) THEN IF(NDEBv(ISTATE).GE.2) WRITE(6,689) SLABL(ISTATE), 1 CCDC(1),LMAX(1,ISTATE),VS(ISTATE) WRITE(6,698) SLABL(ISTATE),CCDC(1),NP1(ISTATE), 1 NQ1(ISTATE),CTYPE(ITYPB(ISTATE)),IP1(ISTATE)+1,IQ1(ISTATE)+1 IF(NP1(ISTATE).GT.0) THEN DO I= 1,NP1(ISTATE) NPARM= NPARM+ 1 PV(NPARM)= PM1(I,ISTATE) ENDDO WRITE(6,640) (PM1(I,ISTATE),I=1,NP1(ISTATE)) WRITE(7,773) (1,I,I= 1,NP1(ISTATE)) ENDIF IF(NQ1(ISTATE).GT.0) THEN DO I= 1,NQ1(ISTATE) NPARM= NPARM+ 1 PV(NPARM)= QM1(I,ISTATE) ENDDO WRITE(6,642) (QM1(I,ISTATE),I=1,NQ1(ISTATE)) WRITE(7,775) (1,I+IQ1(ISTATE),I= 1,NQ1(ISTATE)) ENDIF ENDIF ENDIF c c================================= c** If fitting to CDC's ..... c================================= IF((IFXCDC(ISTATE).LE.0).AND.(NDECDC(ISTATE).EQ.-1) 1 .AND.(NDEBv(ISTATE).GE.0)) THEN c** If fit CDC's as band constants while & Bv's (& Gv's) represented by c Dunham, NDE or MXS functions, then ... WRITE(6,676) SLABL(ISTATE),CCDC(10) WRITE(6,677) MMAX= 0 c** Set parameter counter before beginning with band constants ... NEBC(ISTATE)= NPARM DO ISOT= 1,NISTP DO IV= VMIN(ISTATE),VMAX(ISTATE) c** Try to ensure that the # free parameters doesn't exceed # data for c that v. These checks are NOT rigorous, and problems yielding c underflows and nan's can still arise if too few independent data. IF(NDAT(IV,ISOT,ISTATE).LT.NRC(IV,ISTATE,ISOT)) 1 THEN NRC(IV,ISTATE,ISOT)= NDAT(IV,ISOT,ISTATE) WRITE(6,678) NDAT(IV,ISOT,ISTATE), 1 SLABL(ISTATE),ISOT,IV,FITGV(IV,ISTATE,ISOT), 2 NRC(IV,ISTATE,ISOT) ENDIF MMAX= MAX(MMAX,NRC(IV,ISTATE,ISOT)) c** Use parameter counter NPAR to store the # free parameters preceeding c the free CDC band constants for level IV of state ISTATE of c isotopomer ISOT, & Accumulate total No. free parameters: NPARM NPAR(IV,ISTATE,ISOT)= NPARM IF(NRC(IV,ISTATE,ISOT).GT.1) THEN NPARM= NPARM+ NRC(IV,ISTATE,ISOT) - 1 WRITE(7,761) (CCDC(M),IV,ISOT,M= 1 2,NRC(IV,ISTATE,ISOT)) ENDIF IF(NRC(IV,ISTATE,ISOT).GT.1) WRITE(6,681) 1 IV,ISOT,NRC(IV,ISTATE,ISOT)-1 ENDDO ENDDO c** Set number of fitted CDC band constants for this state NRBC(ISTATE)= NPARM- NEBC(ISTATE) NEBC(ISTATE)= NPARM NCDC(ISTATE)= MMAX-1 GO TO 70 c=======end of preparation for CDC band-constant fit to this state====== ENDIF IF((NDECDC(ISTATE).EQ.0).AND.(IFXCDC(ISTATE).LE.0)) THEN c** If representing CDC's for this state by fitted Dunham functions c======================================================================= WRITE(6,700) SLABL(ISTATE),(M-1,CCDC(M), 1 LMAX(M,ISTATE),M= 2,NCDC(ISTATE)+1) DO M= 2,NCDC(ISTATE)+1 IF(LMAX(M,ISTATE).GE.0) THEN NPARM= NPARM+ LMAX(M,ISTATE)+ 1 IF(LMAX(M,ISTATE).GE.0) THEN WRITE(7,766) (L,M,L= 0,LMAX(M,ISTATE)) ENDIF ENDIF ENDDO ENDIF c 70 IF((IOMEG(ISTATE).NE.0).AND.(IFXLD(ISTATE).LE.0) 1 .AND.(NLDMX(ISTATE).GT.0)) THEN c======================================================================= c** If Omega.ne.0 and Lambda or Gamma doubling constants being fitted c======================================================================= MQ0= MAX0(0,IOMEG(ISTATE)- 1) IF(NDELD(ISTATE).LT.0) THEN c** If doubling constants are to be fitted using band constants ... c======================================================================= DO ISOT= 1, NISTP DO IV= VMIN(ISTATE), VMAX(ISTATE) c** Try to ensure that the # free parameters doesn't exceed # data for c that v. These checks are NOT rigorous, and problems yielding c underflows and nan's can still arise if too few independent data. IF(NDAT(IV,ISOT,ISTATE) .LT. 1 (NRC(IV,ISTATE,ISOT)+NQC(IV,ISTATE,ISOT))) THEN NQC(IV,ISTATE,ISOT)= NDAT(IV,ISOT,ISTATE) 1 - NRC(IV,ISTATE,ISOT) WRITE(6,702) NDAT(IV,ISOT,ISTATE), 1 SLABL(ISTATE),ISOT,IV,NRC(IV,ISTATE,ISOT),NQC(IV,ISTATE,ISOT) ENDIF IF(NQC(IV,ISTATE,ISOT).GT.0) THEN c** Use parameter counter NQPAR to store the # free parameters preceeding c the first free doubling band constants for level IV of state ISTATE of c isotopomer ISOT, & Accumulate total No. free parameters: NPARM NQPAR(IV,ISTATE,ISOT)= NPARM NPARM= NPARM+ NQC(IV,ISTATE,ISOT) IF(IOMEG(ISTATE).GT.0) THEN WRITE(7,763) (CCDC(M+MQ0),IV,ISOT, 1 M= 1,NQC(IV,ISTATE,ISOT)) WRITE(6,684) IV,ISOT, 1 NQC(IV,ISTATE,ISOT) ENDIF IF(IOMEG(ISTATE).LT.0) THEN WRITE(7,764) (CCDC(M),IV,ISOT, 1 M= 1,NQC(IV,ISTATE,ISOT)) WRITE(6,685) IV,ISOT, 1 NQC(IV,ISTATE,ISOT) ENDIF ENDIF ENDDO ENDDO NQPAR(VMAX(ISTATE)+1,ISTATE,NISTP)= NPARM ENDIF c IF(NDELD(ISTATE).GE.0) THEN c** If fit to doubling parameters using use Dunham-type expansions ... c======================================================================= c** Here NQPAR stores # free parameters preceeding 1'st free Dunham-type c doubling expansion parameter for this state NQPAR(0,ISTATE,1)= NPARM DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M IF(LDMAX(MQM,ISTATE).GE.0) THEN NPARM= NPARM+ LDMAX(MQM,ISTATE)+1 IF(IOMEG(ISTATE).GT.0) THEN WRITE(6,706) SLABL(ISTATE),CCDC(MQM), 1 LDMAX(MQM,ISTATE) WRITE(7,779)(L,MQM,L= 0,LDMAX(MQM,ISTATE)) ELSE WRITE(6,707) SLABL(ISTATE),CCDC(M), 1 LDMAX(M,ISTATE) WRITE(7,780) (L,M,L= 0,LDMAX(M,ISTATE)) ENDIF ENDIF ENDDO ENDIF IF(IOMEG(ISTATE).GT.0) THEN IF(efREF(ISTATE).NE.0) WRITE(6,716) SLABL(ISTATE), 1 efREF(ISTATE) IF(efREF(ISTATE).EQ.0) WRITE(6,718) SLABL(ISTATE) ENDIF ENDIF c======================================================================= c** If fitting to BOB correction expansion coefficients for this state c======================================================================= IF((BOBORD(ISTATE).GE.0).AND.(IFXGv(ISTATE).LE.0)) THEN CATOM= NAME(1) ATOM2= 2 IF(AN(1).EQ.AN(2)) ATOM2= 1 DO ATOM= 1,ATOM2 LAMIN= 0 IF((ISTATE.EQ.1).AND.(BOB00.LE.0)) LAMIN= 1 DO M= 0, BOBORD(ISTATE) IF(LAMAX(ATOM,M,ISTATE).GE.LAMIN) THEN NPARM= NPARM+ LAMAX(ATOM,M,ISTATE)+ 1- LAMIN WRITE(6,708) SLABL(ISTATE),CCDC(M),CATOM, 1 LAMAX(ATOM,M,ISTATE) IF((M.EQ.0).AND.(ISTATE.EQ.1).AND. 1 (BOB00.LE.0)) WRITE(6,709) WRITE(7,781) 1 (CATOM,L,M,L= LAMIN,LAMAX(ATOM,M,ISTATE)) ENDIF LAMIN= 0 ENDDO CATOM= NAME(2) ENDDO ENDIF 90 IF(ISTATE.LT.NSTATEMX) IPSTATE(ISTATE+1)= NPARM c c** Add fluorescence series origin levels to parameter count. c============================================================ IF(NFSTOT.GT.0) THEN WRITE(7,783) (VP(FSBAND(I)),VPP(FSBAND(I)), 1 EFP(IFIRST(FSBAND(I))),ISTP(FSBAND(I)),I= 1,NFSTOT) M= min(20,NFSTOT) WRITE(6,710) NFSTOT,(VP(FSBAND(I)),VPP(FSBAND(I)), 1 EFP(IFIRST(FSBAND(I))),ISTP(FSBAND(I)),I= 1,M) IF(NFSTOT.GT.M) WRITE(6,714) NFSTOT-20 IF((NPARM+NFSTOT).GT.NPARMX) THEN WRITE(6,711) NPARM,NFSTOT,NPARMX STOP ENDIF DO I= 1,NFSTOT PV(NPARM+I)= ORIGIN(I) ENDDO c write(6,715) (origin(i),I= 1,nfstot) c 715 format(' with origins:',4F12.3) NPARM= NPARM+ NFSTOT ENDIF c** Rewind channel-7 and read parameter names for final printout. REWIND(7) DO I= 1,NPARM READ(7,785) NAMEPARM(I) IFXP(I)= 0 ENDDO REWIND(7) IF(NPARM.GT.NPARMX) THEN c** If need more parameters than dimensioning allows ... STOP WRITE(6,712) NPARM,NPARMX STOP ENDIF c** Call NLLSSRR to do actual fit JROUND= IROUND IF((IROUND.NE.0).AND.(NFSTOT+NTVALL(0).GT.0)) JROUND= 0 c*********************************************************************** c*********************************************************************** CALL NLLSSRR(COUNTOT,NPARM,NPARMX,CYCMAX,JROUND,ROBUST,LPRINT, 1 IFXP,FREQ,UFREQ,DFREQ,PV,PU,PS,CM,TSTPS,TSTPU,DSE) IF(JROUND.NE.IROUND) THEN c** Perform group rounding of fitted term values and/or fluorescence c series origins. DO I= 1, NPARM PUSAV(I)= PU(I) PSSAV(I)= PS(I) ENDDO JROUND= IABS(IROUND)+ 1 c** Round all term values for each state in a single step IF(NTVALL(0).GT.0) THEN DO ISTATE= 1, NSTATES IF(NTVALL(ISTATE).GT.0) CALL GPROUND(JROUND,NPARM, 1 NPARMX,IPSTATE(ISTATE)+1,IPSTATE(ISTATE)+NTVALL(ISTATE), 2 LPRINT,IFXP,PV,PU) ENDDO ENDIF c** Round all fluorescence series origins in a single step IF(NFSTOT.GT.0) THEN I= NPARM- NFSTOT+ 1 CALL GPROUND(JROUND,NPARM,NPARMX,I,NPARM,LPRINT,IFXP, 1 PV,PU) ENDIF c ... and then call NLLSSRR again to sequentially round remaining parm. CALL NLLSSRR(COUNTOT,NPARM,NPARMX,CYCMAX,IROUND,ROBUST,LPRINT, 1 IFXP,FREQ,UFREQ,DFREQ,PV,PU,PS,CM,TSTPS,TSTPU,DSE) c ... and finally, reset all parameter uncertainties at original values DO I= 1, NPARM PU(I)= PUSAV(I) PS(I)= PSSAV(I) ENDDO DSE= DSE*DSQRT(DFLOAT(COUNTOT- NPARM+ NFSTOT+ NTVALL(0))/ 1 DFLOAT(COUNTOT- NPARM)) ENDIF c*********************************************************************** c*********************************************************************** c** Now ... print results of the fit & final parameter values ... IF(IROUND.NE.0) WRITE(6,720) NPARM,COUNTOT,DSE IF(IROUND.EQ.0) WRITE(6,722) NPARM,COUNTOT,TSTPS,DSE,TSTPU c DO 110 ISTATE= 1,NSTATES I2= IPSTATE(ISTATE) I1= I2+ 1 IF(IFXGv(ISTATE).LE.0) THEN c** Write fitted parameters for Gv Expansion IF(NDEGv(ISTATE).EQ.-2) THEN WRITE(6,675) SLABL(ISTATE),NTVALL(ISTATE) I2= IPSTATE(ISTATE)+ NTVALL(ISTATE) ENDIF IF(NDEGv(ISTATE).EQ.-1) THEN WRITE(6,724) SLABL(ISTATE),VMIN(ISTATE),VMAX(ISTATE) I2= I2+ NRBC(ISTATE) ENDIF IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).EQ.2)) THEN IF(LMAX(0,ISTATE).GT.0) I2= I2+ LMAX(0,ISTATE) IF(ISTATE.GT.1) I2= I2+1 IF(NDEGv(ISTATE).EQ.0) WRITE(6,726) SLABL(ISTATE), 1 CCDC(0) ENDIF IF(NDEGv(ISTATE).GT.0) THEN IF(NDEGv(ISTATE).EQ.2) THEN WRITE(6,730) SLABL(ISTATE),CCDC(0),LMAX(0,ISTATE), 1 VS(ISTATE),VS(ISTATE),DVS(ISTATE),NP0(ISTATE),NQ0(ISTATE), 2 CTYPE(ITYPE(ISTATE)),IP0(ISTATE)+1,IQ0(ISTATE)+1 IF((IFXVS(ISTATE).LE.0).OR.(IFXDVS(ISTATE).LE.0)) 1 THEN IF(IFXVS(ISTATE).LE.0) I2= I2+1 IF(IFXDVS(ISTATE).LE.0) I2= I2+1 WRITE(6,731) ENDIF ENDIF IF(IFXD(ISTATE).LE.0) I2= I2+1 IF(IFXVD(ISTATE).LE.0) I2= I2+ 1 I2= I2+ NP0(ISTATE)+ NQ0(ISTATE) IF(NDEGv(ISTATE).EQ.1) WRITE(6,728) SLABL(ISTATE), 1 CCDC(0),NP0(ISTATE),NQ0(ISTATE),CTYPE(ITYPE(ISTATE)), 2 IP0(ISTATE)+1,IQ0(ISTATE)+1 c??? I= VD(ISTATE) c??? VMAX(ISTATE)= MIN(I,NVIBMX) c??? CALL NDEDGB(ISTATE,NISTP,NEWGv,NEWBv,RSQMU,VMAX(ISTATE)) ENDIF IF(I2.GE.I1) THEN WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) c** For NON term value fits, write vibrational energies to channel-7 IF(NDEGv(ISTATE).GE.-1) THEN DO ISOT= 1,NISTP WRITE(7,791)NAME(1),MN(1,ISOT),NAME(2), 1MN(2,ISOT),SLABL(ISTATE),(I,ZK(0,I,ISTATE,ISOT),I= 0,VMAX(ISTATE)) ENDDO ENDIF ENDIF IF(NDEGv(ISTATE).EQ.-2) GO TO 108 IF(NDEGv(ISTATE).EQ.-1) GO TO 100 ENDIF IF(IFXBv(ISTATE).LE.0) THEN c----------------------------------------------------------------------- c** Write fitted parameters for Bv Expansion c----------------------------------------------------------------------- IF((NDEBv(ISTATE).EQ.-1).AND.(NDEGv(ISTATE).GE.0).AND. 1 (NRBC(ISTATE).GT.0)) THEN I1= I2+1 I2= I2+ NRBC(ISTATE) WRITE(6,734) SLABL(ISTATE) WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF IF(NDEBv(ISTATE).EQ.0) WRITE(6,726) SLABL(ISTATE),CCDC(1) IF(NDEBv(ISTATE).EQ.1) WRITE(6,728) SLABL(ISTATE), 1 CCDC(1),NP1(ISTATE),NQ1(ISTATE),CTYPE(ITYPB(ISTATE)) IF(NDEBv(ISTATE).GE.2) WRITE(6,730) SLABL(ISTATE), 1 CCDC(1),LMAX(1,ISTATE),VS(ISTATE),VS(ISTATE),DVS(ISTATE), 2 NP1(ISTATE),NQ1(ISTATE),CTYPE(ITYPB(ISTATE)) IF(((NDEBv(ISTATE).EQ.0).OR.(NDEBv(ISTATE).GE.2)) 1 .AND.(LMAX(1,ISTATE).GE.0)) THEN I1= I2+1 I2= I2+ LMAX(1,ISTATE)+1 WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF IF((NDEBv(ISTATE).GE.1).AND.(NP1(ISTATE).GT.0)) THEN I1= I2+1 I2= I2+ NP1(ISTATE) WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF IF((NDEBv(ISTATE).GE.1).AND.(NQ1(ISTATE).GT.0)) THEN I1= I2+1 I2= I2+ NQ1(ISTATE) WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF c** Write inertial rotational constants to channel-7 DO ISOT= 1,NISTP WRITE(7,793)NAME(1),MN(1,ISOT),NAME(2),MN(2,ISOT), 1 SLABL(ISTATE),(I,ZK(1,I,ISTATE,ISOT),I= 0,VMAX(ISTATE)) ENDDO ENDIF IF(IFXCDC(ISTATE).LE.0) THEN c----------------------------------------------------------------------- c** Write fitted parameters for CDC expansion(s) c----------------------------------------------------------------------- IF((NDECDC(ISTATE).EQ.-1).AND.(NDEBv(ISTATE).GE.0).AND. 1 (NRBC(ISTATE).GT.0)) THEN I1= I2+1 I2= I2+ NRBC(ISTATE) WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF IF(NDECDC(ISTATE).EQ.0) THEN DO M= 2,NCDC(ISTATE)+1 I1= I2+ 1 IF(LMAX(M,ISTATE).GE.0) I2= I2+ LMAX(M,ISTATE)+1 IF(I2.GE.I1) THEN WRITE(6,736) SLABL(ISTATE),M-1 WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I), 1 I= I1,I2) ENDIF ENDDO ENDIF DO M= 1,NCDC(ISTATE) DO ISOT= 1,NISTP WRITE(7,795) CCDC(M+1),NAME(1),MN(1,ISOT),NAME(2), 1 MN(2,ISOT),SLABL(ISTATE),CCDC(M+1), 2 (I,ZK(M+1,I,ISTATE,ISOT),I= 0,VMAX(ISTATE)) ENDDO ENDDO DO ISOT= 1,NISTP DO I= 0,VMAX(ISTATE) WRITE(7,797) I,(ZK(M,I,ISTATE,ISOT), 1 M= 0,NCDC(ISTATE)+1) ENDDO ENDDO ENDIF c----------------------------------------------------------------------- c** Write fitted parameters for Lambda/Gamma-doubling expansions. c?????????????????????????????????????????????????????????????????????? c If IOMEG < 0 has been reset to 0 (only sigma case considered so far!!) c , thus need to test the value of MULTPLT when considering gamma-doubling c----------------------------------------------------------------------- c IF(((IOMEG(ISTATE).GT.0).OR.(MULTPLT(ITSTATE).EQ.2)).AND. c 1 (IFXLD(ISTATE).LE.0)) THEN c IF((MULTPLT(ISTATE).EQ.2).AND.(IFXLD(ISTATE).LE.0)) THEN c IF(((IOMEG(ISTATE).GT.0).OR.(MULTPLT(ISTATE).EQ.2)).AND. c IF(((IOMEG(ISTATE).GT.0).OR.(IOMEG(ISTATE).LT.0)).AND. c 1 (IFXLD(ISTATE).LE.0).AND.(NDELD(ISTATE).GE.0)) THEN c?????????????????????????????????????????????????????????????????????? 100 IF((IOMEG(ISTATE).NE.0).AND.(IFXLD(ISTATE).LE.0) 1 .AND.(NLDMX(ISTATE).GT.0)) THEN MQ0= MAX0(0,IOMEG(ISTATE)- 1) IF(NDELD(ISTATE).EQ.-1) THEN c ... if doubling parameters represented by isotopic band constants WRITE(6,704) SLABL(ISTATE) I1= I2+1 DO ISOT= 1, NISTP DO IV= VMIN(ISTATE), VMAX(ISTATE) I2= I2+ NQC(IV,ISTATE,ISOT) ENDDO ENDDO IF(I2.GE.I1) WRITE(6,732) (NAMEPARM(I),PV(I), 1 PU(I),PS(I),I= I1,I2) ENDIF c IF(NDELD(ISTATE).GE.0) THEN c ... if doubling constants represented by Dunham-type expansions ... I1= I2+ 1 IF(IOMEG(ISTATE).GT.0) THEN WRITE(6,742) SLABL(ISTATE) IF(efREF(ISTATE).NE.0) WRITE(6,716) SLABL(ISTATE), 1 efREF(ISTATE) IF(efREF(ISTATE).EQ.0) WRITE(6,718) SLABL(ISTATE) ENDIF IF(IOMEG(ISTATE).LT.0) WRITE(6,743) SLABL(ISTATE) DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M IF(LDMAX(MQM,ISTATE).GE.0) I2= I2 + 1 LDMAX(MQM,ISTATE)+1 ENDDO IF(I2.GE.I1) 1 WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M DO ISOT= 1, NISTP WRITE(7,796) CCDC(MQM),ISOT,NAME(1), 1 MN(1,ISOT),NAME(2),MN(2,ISOT),SLABL(ISTATE),CCDC(MQM), 2 (I,ZQ(MQM,I,ISTATE,ISOT),I= 0,VMAX(ISTATE)) ENDDO ENDDO ENDIF ENDIF c** Write fitted parameters for B-O-Breakdown expansion(s) c======================================================================= IF((BOBORD(ISTATE).GE.0).AND.(IFXGv(ISTATE).LE.0)) THEN I1= I2+ 1 WRITE(6,744) SLABL(ISTATE) DO ATOM= 1, ATOM2 DO M= 0, BOBORD(ISTATE) IF(LAMAX(ATOM,M,ISTATE).GE.0) THEN I2= I2+ LAMAX(ATOM,M,ISTATE)+ 1 c** NOTE: for ISTATE=1 must specify whether include vib. BOB {0.0} term IF((M.EQ.0).AND.(ISTATE.EQ.1).AND.(BOB00.LE.0)) 1 I2= I2-1 ENDIF ENDDO ENDDO IF(I2.GE.I1) 1 WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF 108 WRITE(6,*) 110 CONTINUE c** Print the correlation matrix to Channel-10 ... ignoring correlation c to any fluorescence series origins IF(MKPRED.LE.0) THEN WRITE(10,748) CM(1,1),I1,CM(2,1),CM(2,2) IF(I1.GE.3) THEN DO J= 3, I1 WRITE(10,750) (CM(j,i), i= 1,J) ENDDO ENDIF ENDIF c** Now print fluorescence series origins (if any) I1= I2+ 1 I2= NPARM IF(I2.GE.I1) THEN WRITE(6,752) (I2-I1+1) WRITE(6,732) (NAMEPARM(I),PV(I),PU(I),PS(I),I= I1,I2) ENDIF c c** Calculate Y00(semiclass) & zero point energy and their uncertainties c and for multi-isotopomer Dunham case, generate and print rounded YLM c parameters (with their proper uncertainties) for minority isotopomers CALL PPISOT(NISTP,AN,MN,PV,PU,PS,CM,ZMASS,RSQMUP,RMUP,NAME, 1 SLABL,NAMEPARM) DO ISTATE= 1, NSTATES c** Calculate and output values of derived parameters (for NDE case) IF((IFXGv(ISTATE).LE.0).AND.(NDEGv(ISTATE).EQ.1)) THEN I=0 CALL NDEDGB(ISTATE,NISTP,NEWGv,NEWBv,RSQMU,I) CALL NDEDUN(ISTATE,NISTP,ZMASS,RSQMU,PU,CM) ENDIF ENDDO c======================================================================= 675 FORMAT(/' State ',A3,i6,' fitted term values Tv{state:v,J,p;iso 1t}'/1x,6('======')) 676 FORMAT(/' Use a Band-Constant fit for State ',A3,2x,a3,"'s": 1 2x,A3,"'s": ' and ',A3,"'s") 677 FORMAT(1x,6('******')) 678 FORMAT('* WARNING: find',i2,' data for State ',A3,' ISOT-',i1, 1 ' v=',I3,'. Set (FITGV,NRC)=(',I1,',',i1,')') 680 FORMAT(' Base connected-level set #',I2, ' at State ',A3, 1 ' v=',I3,' of isotopomer-',i1) 681 FORMAT(5x,'For v=',i3,' of ISOT=',i2,' fit to',i3,' CDC band c 1onstants') 682 FORMAT(5x,'For v=',i3,' of ISOT=',i2,' fit to the energy and', 1 i3,' rotational band constants') 683 FORMAT(5x,'For v=',i3,' of ISOT=',i2,' fit to',i3,' rotational 1 band constants') 684 FORMAT(5x,'For v=',i3,' of ISOT=',i2,' fit to',i2,' Lambda dou 1bling band constants') 685 FORMAT(5x,'For v=',i3,' of ISOT=',i2,' fit to',i2,' Gamma doub 1ling band constants') 686 FORMAT(/' Absolute zero of energy is fixed at G(v"=-1/2) of Sta 1te ',A2/1x,12('**')) 688 FORMAT(/' Fit for State ',A3,1x,A3,"'s uses Dunham expansion of o 1rder",i3/1x,7('***')) 689 FORMAT(/" Fit for State ",A3,1x,A3,"'s uses Tellinghuisen-type MS 1X mixed representation:"/1x,8('**'),' order',i3,' Dunham for v .l 2e. VS=',F11.6,' & NDE for v > VS':/9x, 'with switching function 3: Sw = 1/[1 + exp{(v -',F11.6,')/',F9.6,'}]') 690 FORMAT(9x,'and treat VS as a free parapeter in the fit') 691 FORMAT(9x,'and treat DVS as a free parapeter in the fit') 692 FORMAT(/" Fit 3tate ",A3," Gv's to NDE or MXS function while fixi 1ng DLIMIT=",F12.5/1x,43('*')) 694 FORMAT(/" Fit to State ",A3, " DLIMIT and to NDE or MXS function 1 for Gv"/) 698 FORMAT(" State ",A3,1x,A3,"'s initially defined by (NP=",I2, 1 '/NQ=',I2,') ',A12,'NDE in (vD-v)'/1x,6('--'),' with leading n 2umerator and denominator powers',I3,' &',I3:/15X, 3 'where for Isotopomer-1 vD=',F13.8) 700 FORMAT(/' Dunham Fit for State ',A3,' uses CDC(',i1,')=',A3,' e 1xpansion of order',i3:/' =======================',8x,'CDC(',i1, 2 ')=',A3,' expansion of order',I3:/(32x,'CDC(',i1,')=',A3, 3 ' expansion of order',I3:)) 702 FORMAT('* WARNING: find',i2,' data for State ',A3,' ISOT-',i1, 1 ' v=',I3,' with NRC=',i2,', so set NQC=',I2) 704 FORMAT(/' Band-Constant Doubling parameters for Electronic State ' 1 ,A3) 706 FORMAT(' Fit state ',A3,' "',A3, '"-type Lambda doubling constants 1 to order',I3,' Dunham expansion') 707 FORMAT(' Fit state ',A3,' "',A3, '"-type Gamma doubling constants 1 to order',I3,' Dunham expansion') 708 FORMAT(' Fit State ',A3,' "',A3,'" BOB corrections for ',A2, 1 ' to Dunham expansion of order:',I3) 709 FORMAT(21x,'while IGNORING the constant delta(0,0) term') 710 FORMAT(/' Fit to the origins of',i5,' fluorescence series with ini 1tial-state labels'/21x,"(where p= 'parity' & IS= 'isotope'):"/ 2 5(2x,13('-'),1x)/5(" v' J' p IS ")/5(2x,13('-'),1x)/ 3 5(i5,i4,SP,I3,SS,I3,1x:)) 711 FORMAT(/' *** ERROR *** Dimension allocated for number of paramete 1rs exceeded:'/15x,'(NPARM=',i4,') + (NFSTOT=',i4,') > (NPARMX=', 2 i4,')') 712 FORMAT(/' **** Case=2 G-B-C-FIT Option FAILS because # of free pa 1rameters NPARM=',I5,' exceeds array dimension limit NPARMX=', 2 I5) 714 FORMAT(' ........ and',i6,' others ...........') 716 FORMAT(' => State ',A3,' parity=',SP,i3,' sublevels treated as un 1perturbed reference energy.') 718 FORMAT(' => State ',A3,' parity sublevel midpoint treated as unp 1erturbed reference energy') 720 FORMAT(/' After Sequential Rounding & Refitting, fit of',i6, 1 ' parameters to',i6,' data'/1x,37('*'),' yields DSE=', 2 G11.4/) 722 FORMAT(/' Fit',i5,' parameters to',i6,' data: Test(PS)=',1PD8.1, 1 ' DSE=',0PG11.4/1x,11('***'),' Test(PU)=',1PD8.1/) 724 FORMAT(' State ',A3,' Pure Band-Constant representation for level 1s v=',i2,' -',i3) 726 FORMAT(' State ',A3,' Dunham expansion',A3,' parameters:') 728 FORMAT(' State ',A3,' NDE ',A3,' function is a (NP=',I2,'/NQ=' 1 ,I2,') ',A12,'NDE in (vD-v)':/17x,'with leading numerator and d 2enominator powers',i3,' &',i3) 730 FORMAT(' State ',A3,' Tellinghuisen-type MSX mixed representation 1',A3,' parameters based on:'/1x,4('=='),I5, "'th order Dunham for 2 v .le. VS=",F11.6,' & NDE for v > VS':/9x,'with switching f 3unction: Sw = 1/[1 + exp{(v -',F11.6,')/',F9.6,'}]'/9x,'where ND 4E function is a (NP=',I2,'/NQ=',I2,') ',A12,'NDE in (vD-v)':/ 5 17x,'with leading numerator and denominator powers',i3,' &',i3) 731 FORMAT(6x,'and fit optimizes switching function parameters VS and 1/or DVS') 732 FORMAT(1x,a20,'=',1PD20.12,' (+/-',D8.1,') Sensitivity=',D8.1) 734 FORMAT(' State ',A3,' Band-Constant rotational constants:') 736 FORMAT(' State ',A3,' Dunham expansion CDC(',i1,') parameters:') 742 FORMAT(' State ',A3,' Lambda-doubling Dunham-type expansion coeff 1icients:') 743 FORMAT(' State ',A3,' Gamma-doubling Dunham-type expansion coeffi 1cients:') 744 FORMAT(' State ',A3,' Born-Oppenheimer breakdown parameters:') 748 FORMAT(/f10.6,13x,'Correlation Matrix linking the first ',i4, 1 ' parameters'/2F10.6,3x,26('==')) 750 FORMAT(8F10.6:/(10x,7F10.6:)) 752 FORMAT(" Energy origins FS(v', j', p'; isotopomer) of the", 1 i5,' fluorescence series') 761 FORMAT(7x,A3,'(v=',i3,';',i2,')') 763 FORMAT(4x,'q[',A3,'(v=',i3,';',i2,')]') 764 FORMAT(4x,'g[',A3,'(v=',i3,';',i2,')]') 765 FORMAT(10x,'T(v= -1/2',A2,')') 766 FORMAT(11x,'YLM(',i2,',',i1,')') 768 FORMAT(13x,'VS(',A2,')') 769 FORMAT(12x,'dVS(',A2,')') 770 FORMAT(10x,'DLimit(',A2,')') 771 FORMAT(14x,'vD(',A2,')') 773 FORMAT(14x,'P',i1,'(',i2,')') 775 FORMAT(14x,'Q',i1,'(',i2,')') 779 FORMAT(10x,'qLM(',i2,',',i1,')') 780 FORMAT(10x,'gLM(',i2,',',i1,')') 781 FORMAT(6x,'delta(',A2,';',i2,',',i1,')') 783 FORMAT(' FS(',SS,i3,',',i3,',',SP,i3,';',SS,i2,')') 785 FORMAT(A20) 791 FORMAT(' Vibrational energies for ',A2,'(',i3,')-',A2,'(',I3, 1 ') in State ',A3,': {v, Gv}'/(4(i5,f15.6))) 793 FORMAT(' Inertial rotational constants Bv for ',A2,'(',i3,')-', 1 A2,'(',I3,') in State ',A3,': {v, Bv}'/(4(i5,f15.8))) 795 FORMAT(' Centrifugal distortion constants ',A3,' for ',A2,'(', 1 i3,')-',A2,'(',I3,') in State ',A3,': {v,',A3,'}'/ 2 (4(i5,1PD15.7))) 796 FORMAT(' Lambda Doubling constants q[',A3,'(v;',i2,')] for ', 1 A2,'(',i3,')-',A2,'(',I3,') in State ',A3,': {v,',A3,'}'/ 2 (4(i5,1PD15.7))) 797 FORMAT(I4,f12.4,f14.10,6(1PD15.7:)) c======================================================================= c======================================================================= c** Now ... calculate band-by-band DSE values for output summary CALL DIFFSTATS(NSTATES,ROBUST,MKPRED) 200 STOP 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(NSTATES,PASok,UCUTOFF,JTRUNC,EFSEL,VMIN,VMAX, 1 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 isotopomers. c ********* Version of 4 April 2016 ********* c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c++ COPYRIGHT 1997-2016 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 isotopomers 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----------------------------------------------------------------------- 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) to VMAX(s), AND NEGLECT any data for which the read- c in uncertainty is > UCUTOFF (cm-1). EFSEL(s) > 0 causes f-parity c 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 isotopomer-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 DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c INTEGER I,IBB,NTRANS,COUNT,IBAND,JMAX(NBANDMX),JMIN(NBANDMX), 1 VMX(NSTATEMX),ISOT,NBND,ESP,ESPP,ISTATE,ISTATEE,MN1,MN2,PRINP, 2 FSOMIT,VMAXesp,VMINesp,VMAXespp,VMINespp,JTRUNCesp,JTRUNCespp INTEGER NSTATES,NOWIDTHS,JTRUNC(NSTATEMX),EFSEL(NSTATEMX), 1 VMIN(NSTATEMX),VMAX(NSTATEMX),NDAT(0:NVIBMX,NISTPMX,NSTATEMX), 2 PASok(NSTATES) REAL*8 UCUTOFF,UMIN,TOTUFREQ CHARACTER*3 NEF(-1:1) CHARACTER*3 LABLP,LABLPP c c** Type statements & common block for data cc cc REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX), cc 1 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), cc 2 RMUP(0:9,NISTPMX) cc INTEGER COUNTOT,NISTP,NFSTOT,NBANDTOT,AN(2),MN(2,NISTPMX), cc 1 IB(NDATAMX),JP(NDATAMX),JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX), cc 2 EFP(NDATAMX),EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX), cc 3 FSBAND(NBANDMX),NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX), cc 4 ISTP(NBANDMX),IFIRST(NBANDMX),ILAST(NBANDMX), cc 5 NTV(NSTATEMX,NISTPMX) cc CHARACTER*2 NAME(2),SLABL(-3:NSTATEMX) cc COMMON /DATABLK/FREQ,UFREQ,DFREQ,ZMASS,RSQMU,RSQMUP,RMUP,COUNTOT, cc 1 NISTP,NFSTOT,NBANDTOT,AN,MN,IB,JP,JPP,EFP,EFPP,TVUP,TVLW,VP,VPP, cc 2 FSBAND,NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV, NAME,SLABL c c** Type statements & common blocks for characterizing transitions c REAL*8 AVEUFREQ(NBANDMX),MAXUFREQ(NBANDMX) 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 NBVPP(NISTPMX,NSTATEMX),NWIDTH(NISTPMX,NSTATEMX), 6 NEBPAS(NISTPMX,NSTATEMX),NBANDS(NISTPMX), 7 YPR(NISTPMX,NSTATEMX,7,6,NBANDMX) c COMMON /TYPEBLK/AVEUFREQ,MAXUFREQ,NTRANSFS,NTRANSVIS,NTRANSIR, 1 NTRANSMW,NBANDFS,NBANDEL,NBANDVIS,NBANDIR,NBANDMW,NBVPP,NWIDTH, 2 NEBPAS,NBANDS,YPR c DATA NEF/' f',' ',' e'/ c----------------------------------------------------------------------- WRITE(6,603) UCUTOFF DO ISTATE= 1,NSTATES IF(JTRUNC(ISTATE).GE.0) THEN WRITE(6,607) SLABL(ISTATE),JTRUNC(ISTATE),VMIN(ISTATE), 1 VMAX(ISTATE) ELSE WRITE(6,605) SLABL(ISTATE),-JTRUNC(ISTATE),VMIN(ISTATE), 1 VMAX(ISTATE) ENDIF 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 NBVPP(ISOT,ISTATE)= 0 NWIDTH(ISOT,ISTATE)= 0 NEBPAS(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 isotopomer at one time. IBAND= 0 10 CONTINUE IBAND= IBAND+1 IF(IBAND.GT.NBANDMX) THEN IF(PRINP.GT.0) WRITE(6,609) IBAND,NBANDMX IBAND= IBAND-1 GOTO 20 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 isotopomer. Note that LABLP also c identifies the type of data in the 'band' or data-group (see below). c 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. Labels as for 'FLS' c LABLP = 'BVV' 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 NOTE: !!!!!!!!!!! This last option is ignored by DSParFit !!!!!!!!! c** STOP reading when run out of bands OR when read-in VPP is negative c----------------------------------------------------------------------- READ(4,*,END=20) VP(IBAND), VPP(IBAND), LABLP, LABLPP, MN1,MN2 c----------------------------------------------------------------------- IF(VP(IBAND).LT.0) GO TO 20 IEP(IBAND)= -99 IEPP(IBAND)= -99 DO I= -3,NSTATES IF(LABLP.EQ.SLABL(I)) IEP(IBAND)= I IF(LABLPP.EQ.SLABL(I)) IEPP(IBAND)= I ENDDO c** Check that this isotopomer 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 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= 0 IFIRST(IBAND)= COUNT ESP= IEP(IBAND) ESPP= IEPP(IBAND) IF((ESPP.GT.0).AND.(ISOT.GT.0)) THEN VMAXespp= VMAX(ESPP) VMINespp= VMIN(ESPP) JTRUNCespp= JTRUNC(ESPP) IF(ISOT.GT.1) THEN VMAXespp= INT((VMAX(ESPP)+0.5d0)/RSQMU(ISOT)-0.5d0) VMINespp= INT((VMIN(ESPP)+0.5d0)/RSQMU(ISOT)-0.5d0) JTRUNCespp= INT(JTRUNC(ESPP)/RSQMU(ISOT)) ENDIF cc VMAXesp= VMAX(ESPP) ?????? huh? ENDIF IF((ESP.GT.0).AND.(ISOT.GT.0)) THEN VMAXesp= VMAX(ESP) VMINesp= VMIN(ESP) JTRUNCesp= JTRUNC(ESP) IF(ISOT.GT.1) THEN VMAXesp= INT((VMAX(ESP)+ 0.5d0)/RSQMU(ISOT) - 0.5d0) VMINesp= INT((VMIN(ESP)+ 0.5d0)/RSQMU(ISOT) - 0.5d0) 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======================================================================= 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 isotopomers chosen to be fitted, c omit its data from the fit IF(ISOT.EQ.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======================================================================= TVUP(COUNT)= 0 TVLW(COUNT)= 0 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.EQ.-3) THEN c... and for Bv data ... IF(JPP(COUNT).LT.JMIN(IBAND)) JMIN(IBAND)= JPP(COUNT) IF(JPP(COUNT).GT.JMAX(IBAND)) JMAX(IBAND)= JPP(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= ILAST(IBAND)-IFIRST(IBAND)+1 IF(NTRANS.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.EQ.1).AND.(LABLP.EQ.'FLS')) 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 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 FSBAND(NFSTOT)= IBAND c** Define counter to label which f.s. is associated with band IBAND NFS(IBAND)= NFSTOT NBANDFS(ISOT,ESPP)= NBANDFS(ISOT,ESPP)+1 NBND= NBANDFS(ISOT,ESPP) NTRANSFS(ISOT,ESPP)= NTRANSFS(ISOT,ESPP)+NTRANS c ... and then set up labels/ranges/properties for each band YPR(ISOT,ESPP,1,1,NBND)= VP(IBAND) YPR(ISOT,ESPP,1,2,NBND)= VPP(IBAND) YPR(ISOT,ESPP,1,3,NBND)= NTRANS YPR(ISOT,ESPP,1,4,NBND)= IBAND YPR(ISOT,ESPP,1,5,NBND)= JMIN(IBAND) YPR(ISOT,ESPP,1,6,NBND)= JMAX(IBAND) 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)= NTRANSVIS(ISOT,ESP,ESPP)+NTRANS c ... and then set up labels/ranges/properties for each of them YPR(ISOT,ESPP,2,1,NBND)= VPP(IBAND) YPR(ISOT,ESPP,2,2,NBND)= VP(IBAND) YPR(ISOT,ESPP,2,3,NBND)= NTRANS YPR(ISOT,ESPP,2,4,NBND)= IBAND YPR(ISOT,ESPP,2,5,NBND)= JMIN(IBAND) YPR(ISOT,ESPP,2,6,NBND)= JMAX(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 c ... and then set up labels/ranges/properties for each of them YPR(ISOT,ESPP,3,1,NBND)= VPP(IBAND) YPR(ISOT,ESPP,3,2,NBND)= VP(IBAND) YPR(ISOT,ESPP,3,3,NBND)= NTRANS YPR(ISOT,ESPP,3,4,NBND)= IBAND YPR(ISOT,ESPP,3,5,NBND)= JMIN(IBAND) YPR(ISOT,ESPP,3,6,NBND)= JMAX(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 c ... and then set up labels/ranges/properties for each of them YPR(ISOT,ESPP,4,1,NBND)= VPP(IBAND) YPR(ISOT,ESPP,4,2,NBND)= VP(IBAND) YPR(ISOT,ESPP,4,3,NBND)= NTRANS YPR(ISOT,ESPP,4,4,NBND)= IBAND YPR(ISOT,ESPP,4,5,NBND)= JMIN(IBAND) YPR(ISOT,ESPP,4,6,NBND)= JMAX(IBAND) ENDIF c c** NOTE ... in YPR array a last index counts bands of this type for c this isotopomer of this electronic state ... and put all Bv's, c Tunneling Widths or PAS binding energies in one group. IF(ESP.EQ.-3) THEN c** Data are not transition energies, but rather the values of Bv in c electronic state s=IEPP [As in the published IBr(A-X) analysis]. ccc IF((NBVPP(ISOT,ESPP).GT.0).AND.(NTRANS.GT.0)) THEN WRITE(6,612) ESPP,ISOT ccc STOP ccc ENDIF NBVPP(ISOT,ESPP)= NTRANS YPR(ISOT,ESPP,5,3,1)= NTRANS YPR(ISOT,ESPP,5,4,1)= IBAND YPR(ISOT,ESPP,5,5,1)= JMIN(IBAND) YPR(ISOT,ESPP,5,6,1)= JMAX(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.GT.0)) THEN ccc WRITE(6,626) ESPP,ISOT ccc STOP ccc ENDIF NWIDTH(ISOT,ESPP)= NTRANS YPR(ISOT,ESPP,6,3,1)= NTRANS YPR(ISOT,ESPP,6,4,1)= IBAND YPR(ISOT,ESPP,6,5,1)= JMIN(IBAND) YPR(ISOT,ESPP,6,6,1)= JMAX(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 YPR(ISOT,ESPP,7,3,1)= NTRANS YPR(ISOT,ESPP,7,4,1)= IBAND YPR(ISOT,ESPP,7,5,1)= JMIN(IBAND) YPR(ISOT,ESPP,7,6,1)= JMAX(IBAND) ENDIF c** Now return to read the next band GOTO 10 c======================================================================== c** Now, write a summary of the input data to the output file 20 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** Print a summary of the data, one isotopomer 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) to the actual c highest v in the data set for this state. ** Reactivate as needed. c VMAX(ISTATE)= 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) IBB= YPR(ISOT,ISTATE,4,4,I) WRITE(6,606) YPR(ISOT,ISTATE,4,2,I), 1 YPR(ISOT,ISTATE,4,1,I), 2 YPR(ISOT,ISTATE,4,3,I),YPR(ISOT,ISTATE,4,5,I), 3 YPR(ISOT,ISTATE,4,6,I), 3 AVEUFREQ(YPR(ISOT,ISTATE,4,4,I)), 4 MAXUFREQ(YPR(ISOT,ISTATE,4,4,I)) 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) IBB= YPR(ISOT,ISTATE,3,4,I) WRITE(6,606) YPR(ISOT,ISTATE,3,2,I), 1 YPR(ISOT,ISTATE,3,1,I), 2 YPR(ISOT,ISTATE,3,3,I),YPR(ISOT,ISTATE,3,5,I), 3 YPR(ISOT,ISTATE,3,6,I), 4 AVEUFREQ(YPR(ISOT,ISTATE,3,4,I)), 5 MAXUFREQ(YPR(ISOT,ISTATE,3,4,I)) 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) IBB= YPR(ISOT,ISTATE,2,4,I) IF(IEP(IBB).EQ.ISTATEE) THEN WRITE(6,606) YPR(ISOT,ISTATE,2,2,I), 1 YPR(ISOT,ISTATE,2,1,I), 2 YPR(ISOT,ISTATE,2,3,I),YPR(ISOT,ISTATE,2,5,I), 3 YPR(ISOT,ISTATE,2,6,I), 4 AVEUFREQ(YPR(ISOT,ISTATE,2,4,I)), 5 MAXUFREQ(YPR(ISOT,ISTATE,2,4,I)) 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) IBB= YPR(ISOT,ISTATE,1,4,I) WRITE(6,616) YPR(ISOT,ISTATE,1,1,I), 1 YPR(ISOT,ISTATE,1,2,I),NEF(EFP(IFIRST(IBB))), 2 YPR(ISOT,ISTATE,1,3,I),YPR(ISOT,ISTATE,1,5,I), 3 YPR(ISOT,ISTATE,1,6,I), 4 AVEUFREQ(YPR(ISOT,ISTATE,1,4,I)), 5 MAXUFREQ(YPR(ISOT,ISTATE,1,4,I)) ENDDO ENDIF IF(NBVPP(ISOT,ISTATE).GT.0)THEN c** Book-keeping for Bv data WRITE(6,618) NBVPP(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2) IBB= YPR(ISOT,ISTATE,5,4,1) WRITE(6,620) YPR(ISOT,ISTATE,5,3,1),YPR(ISOT,ISTATE,5,5,1), 1 YPR(ISOT,ISTATE,5,6,1),AVEUFREQ(YPR(ISOT,ISTATE,5,4,1)), 2 MAXUFREQ(YPR(ISOT,ISTATE,5,4,1)) 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) IBB= YPR(ISOT,ISTATE,6,4,1) WRITE(6,630) YPR(ISOT,ISTATE,6,3,1), 1 YPR(ISOT,ISTATE,6,5,1),YPR(ISOT,ISTATE,6,6,1), 2 AVEUFREQ(YPR(ISOT,ISTATE,6,4,1)), 3 MAXUFREQ(YPR(ISOT,ISTATE,6,4,1)) 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) IBB= YPR(ISOT,ISTATE,6,4,1) WRITE(6,630) YPR(ISOT,ISTATE,7,3,1), 1 YPR(ISOT,ISTATE,7,5,1),YPR(ISOT,ISTATE,7,6,1), 2 AVEUFREQ(YPR(ISOT,ISTATE,7,4,1)), 3 MAXUFREQ(YPR(ISOT,ISTATE,7,4,1)) ENDIF 50 CONTINUE IF(ISOT.LT.NISTP) THEN c** If NISTP > 1, return to print data summaries for other isotopomers 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=',G12.3, 1 ' (cm-1)') 605 FORMAT(7x,'and State ',A3,' data with J < JTRUNC=',I4, 1 ' or v outside range',i3,' to',i4) 607 FORMAT(7x,'and State ',A3,' data with J > JTRUNC=',I4, 2 ' or v outside range',i3,' to',i4) 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 all read-in Bv's for ISTATE=",i2,' ISOT=', 1 i2/32x,' must be input as a single "band" or data group') cc612 FORMAT(/" *** STOP INPUT *** and put all read-in Bv's for ISTATE cc 1=",i2,' ISOT=',i2/ 10x,'into one "band" or data 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 ') Bv values treated as independent data'/1x,24('--')/ 2 ' #values v(min) v(max) Avge.Unc. Max.Unc.'/ 3 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) 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,NPARM,VMAX,NTVALL) c*********************************************************************** c** Subroutine to sort through global data file, and for each isotopomer 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 NPARM 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 NPARM 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 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 DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c INTEGER I,J,P,IBAND,ISOT,ISTATE,NPARM,LOWEST,VMAX(NSTATEMX), 1 NLV(0:NVIBMX,0:NROTMX,-1:1),NTVS(NSTATEMX,NISTPMX), 2 NTVALL(0:NSTATEMX) c c** Type statements & common block for data cc cc REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX), cc 1 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), cc 2 RMUP(0:9,NISTPMX) cc INTEGER COUNTOT,NISTP,NFSTOT,NBANDTOT,AN(2),MN(2,NISTPMX), cc 1 IB(NDATAMX),JP(NDATAMX),JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX), cc 2 EFP(NDATAMX),EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX), cc 3 FSBAND(NBANDMX),NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX), cc 4 ISTP(NBANDMX),IFIRST(NBANDMX),ILAST(NBANDMX), cc 5 NTV(NSTATEMX,NISTPMX) cc CHARACTER*2 NAME(2),SLABL(-3:NSTATEMX) cc COMMON /DATABLK/FREQ,UFREQ,DFREQ,ZMASS,RSQMU,RSQMUP,RMUP,COUNTOT, cc 1 NISTP,NFSTOT,NBANDTOT,AN,MN,IB,JP,JPP,EFP,EFPP,TVUP,TVLW,VP,VPP, cc 2 FSBAND,NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= WRITE(6,600) SLABL(ISTATE) LOWEST= 1 IF(ISTATE.GT.1) LOWEST= 0 NTVALL(ISTATE)= 0 DO ISOT= 1, NISTP c** First ... zero transition counter array for this isotopomer DO I= 0, VMAX(ISTATE) DO J= 0, NROTMX DO P= -1,1 NLV(I,J,P)= 0 ENDDO ENDDO ENDDO DO IBAND= 1, NBANDTOT c** Then ... search for bands involving isotopomer 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.NROTMX) THEN c ... check for array dimension overruns WRITE(6,602) ISTATE,ISOT,JP(I),NROTMX STOP ENDIF NLV(VP(IBAND),JP(I),EFP(I))= 1 NLV(VP(IBAND),JP(I),EFP(I))+ 1 ENDIF IF(IEPP(ISTATE).EQ.ISTATE) THEN IF(JPP(I).GT.NROTMX) THEN WRITE(6,604) ISTATE,ISOT,JPP(I),NROTMX 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) DO J= 0, NROTMX DO P= -1,1 IF(NLV(I,J,P).GT.0) THEN 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 WRITE(6,606) I,J,P,ISOT,SLABL(ISTATE) LOWEST= 0 NLV(I,J,P)= 0 GOTO 20 ENDIF NPARM= NPARM+ 1 NTV(ISTATE,ISOT)= NTV(ISTATE,ISOT)+ 1 IF(NLV(I,J,P).EQ.1) NTVS(ISTATE,ISOT)= 1 NTVS(ISTATE,ISOT) +1 WRITE(7,700) SLABL(ISTATE),I,J,P,ISOT c ... reset NLV(v,J,p) as the parameter index for that term value NLV(I,J,P)= NPARM ENDIF 20 CONTINUE ENDDO ENDDO ENDDO c 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),EFP(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) ENDDO 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 NROTMX=',i4) 604 FORMAT(/' *** ARRAY DIMENSION PROBLEM *** JPP(ISTATE=',i2, 1 ',ISOT=',I2,')=',i3,' greater than NROTMX=',i4) 606 FORMAT(/' Absolute zero of energy is fixed at level {v=',i3, 1 ', J=',i3,', p=',i2,'}'/1x,12('**'),10x,'of isotopomer ',i2, 2 ' of State ',A3) 608 FORMAT(' For ',A2,'(',i3,')-',A2,'(',I3,') fit to',i4, 1 ' T(v,J,p) term values,'/20x,'of which',i4,' are involved in only 2 one transition') 700 FORMAT('Tv(',A2,':',i3,',',i3,',',SP,i2,';',SS,i2,')=') END 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 isotopomer-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 21 August 2004 c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c CHARACTER*2 LABLP,LABLPP INTEGER I,J,J2,JD,J2DL,J2DU,J2DD,JMAXX,PP,PPP,NTRANS,COUNT, 1 IBAND,JMAX(NBANDMX),JMIN(NBANDMX), 1 VMX(NSTATEMX),ISOT,ESP,ESPP,ISTATE,MN1,MN2 INTEGER NSTATES,NDAT(0:NVIBMX,NISTPMX,NSTATEMX) c c** Type statements & common block for data cc cc REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX), cc 1 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), cc 2 RMUP(0:9,NISTPMX) cc INTEGER COUNTOT,NISTP,NFSTOT,NBANDTOT,AN(2),MN(2,NISTPMX), cc 1 IB(NDATAMX),JP(NDATAMX),JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX), cc 2 EFP(NDATAMX),EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX), cc 3 FSBAND(NBANDMX),NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX), cc 4 ISTP(NBANDMX),IFIRST(NBANDMX),ILAST(NBANDMX), cc 5 NTV(NSTATEMX,NISTPMX) cc CHARACTER*2 NAME(2),SLABL(-3:NSTATEMX),LABLP,LABLPP cc COMMON /DATABLK/FREQ,UFREQ,DFREQ,ZMASS,RSQMU,RSQMUP,RMUP,COUNTOT, cc 1 NISTP,NFSTOT,NBANDTOT,AN,MN,IB,JP,JPP,EFP,EFPP,TVUP,TVLW,VP,VPP, cc 2 FSBAND,NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV, NAME,SLABL c c** Type statements & common blocks for characterizing transitions c REAL*8 AVEUFREQ(NBANDMX),MAXUFREQ(NBANDMX) 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 NBVPP(NISTPMX,NSTATEMX),NWIDTH(NISTPMX,NSTATEMX), 6 NEBPAS(NISTPMX,NSTATEMX),NBANDS(NISTPMX), 7 YPR(NISTPMX,NSTATEMX,7,6,NBANDMX) c COMMON /TYPEBLK/AVEUFREQ,MAXUFREQ,NTRANSFS,NTRANSVIS,NTRANSIR, 1 NTRANSMW,NBANDFS,NBANDEL,NBANDVIS,NBANDIR,NBANDMW,NBVPP,NWIDTH, 2 NEBPAS,NBANDS,YPR 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 NBVPP(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 10 IBAND= IBAND+ 1 IF(IBAND.GT.NBANDMX) THEN WRITE(6,609) IBAND,NBANDMX 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 the rotational parity of the upper and lower levels c** MN1 & MN2 identify the isotopomer 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 isotopomer-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 JMAX(IBAND)= JMAXX JMIN(IBAND)= 0 NTRANS= 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," '",A2,"' '",A2,"' ",2I4) 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 NTRANS= ILAST(IBAND)-IFIRST(IBAND)+1 GOTO 10 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 NDEXM(ISTATE,SLABL,NLR,DLIMIT,VD,CN,NSIG,ZMU,NDEORD, 1 NISTP,RSQMU,PNDE,XM) c** If using NDE functions to represent vib. energies & rot. and/or CDC c constants, use NLR and initial trial CN value to calculate limiting c ND-theory scaling factor XM(IORDR,ISTATE,ISOT) of orders IORDR up to c NDEORD, with values for ISOT=1 rounded off to NSIG signif. digits. c If NSIG.le.0 do NO rounding. Version date: 21/08/04 c*********************************************************************** cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c CHARACTER*2 SLABL INTEGER I,M,ISTATE,NLR,NSIG,NISTP,NDEORD,ISOT REAL*8 XBAR(3:6,0:9),PNDE(0:9,NSTATEMX),XM(0:9,NSTATEMX,NISTPMX), 1 RSQMU(NISTPMX),ZMU,DLIMIT,VD,CN,ZN,PWNDE,FCT,FCT1,FCT2 c DATA XBAR/36410.D0, 13433.D0, 9170.9D0, 7932.0D0, 1 60221.03D0, 4275.748D0, 1178.287D0, 546.6391D0, 2 -24901.D0, -205.65D0, -15.377D0, -2.7539D0, 3 1348.0D0, -3.7691D0, -1.7742D-1, -1.9186D-2, 4 -73.367D0, -2.9067D-1, -5.3435D-3, -2.9942D-4, 5 -60.674D0, -.29837D-1, -.21680D-3, -.62117D-5, 6 -38.694D0, -.35686D-2, -.10281D-4, -.15002D-6, c ** RJL's guesses for limiting N-D theory constants defining Ov & Pv c 7 -20.D0, -4.6D-4, -5.2D-7, -0.39D-8, c Fudged Ov for n=5 7 -20.D0, -4.6D-4, -4.151888D-7, -0.39D-8, 8 -10.d0, -5.5d-5, -2.4d-8, -0.94d-10, 9 -0.d0, 0.d0, 0.d0, 0.d0/ c----------------------------------------------------------------------- ZN= DFLOAT(NLR) PWNDE= 2.d0*ZN/(ZN- 2.d0) FCT= 1.d0/(ZMU**NLR *CN**2)**(1.d0/(ZN-2.d0)) DO M= 0,NDEORD PNDE(M,ISTATE)= PWNDE PWNDE= PWNDE- 2.d0 FCT2= XBAR(NLR,M)*FCT XM(M,ISTATE,1)= FCT2 IF(NSIG.GT.0) THEN c** If desired, round off the XM constant for Isotopomer-1 to NSIG digits FCT1= 1.d0 IF(FCT2.LT.0.d0) FCT1= -FCT1 FCT2= DABS(FCT2) I= IDINT(DLOG10(FCT2))+1 IF(FCT2.LT.1.d0) I= I-1 XM(M,ISTATE,1)= FCT1*DFLOAT(IDINT(FCT2* 1 10.d0**(NSIG-I)+0.5d0))*10.d0**(I-NSIG) ENDIF IF(NISTP.GT.1) THEN FCT2= 2.d0*ZN/(ZN- 2.d0) DO ISOT= 2,NISTP XM(M,ISTATE,ISOT)= XM(M,ISTATE,1)*RSQMU(ISOT)**FCT2 ENDDO ENDIF ENDDO WRITE(6,610) SLABL,CN,NLR,DLIMIT,VD DO M= 0, NDEORD WRITE(6,612) (M,ISOT,XM(M,ISTATE,ISOT),ISOT=1,NISTP) ENDDO RETURN 610 FORMAT(/' NDE function(s) for State ',A3,' which has potential tai 1l:',' D -',1PD13.6,'/R**',i1/4x,'& initial parameters: D(limit 2) =',0PF12.4,' and '/4x,'vD(ISOT=1)=',f13.8,5x, 3 'based on factors XM(m,ISOT):') 612 FORMAT(4x,3(' XM(',i1,',',i1,')=',1pD14.6:)/ 1 (31x,2(' XM(',i1,',',i1,')=',1pD14.6:))) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 c*********************************************************************** SUBROUTINE NDEDGB(ISTATE,NISTP,NEWGv,NEWBv,RSQMU,VMAXX) c** Subroutine to prepare various contributions to NDE partial c derivatives for later use in DYIDPJ; If NDEBv.le.0 only for Gv. c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% REAL*8 VDMV,VDMVP,RSQMU(NISTPMX),GFCT,BFCT,SNUM,DNUM,SDEN,DDEN, 1 EB,BV INTEGER I,ISOT,ISTATE,IV,NISTP,NEWGv,NEWBv,VMAXX c c** Type statements and common block for case (type of representation) c REAL*8 XM(0:9,NSTATEMX,NISTPMX),PNDE(0:9,NSTATEMX) c INTEGER NSTATES,IBAND,VMIN(NSTATEMX),VMAX(NSTATEMX), 1 NCDC(NSTATEMX),IOMEG(NSTATEMX),NLDMX(NSTATEMX),efREF(NSTATEMX), 2 MULTPLT(NSTATEMX),NDEGv(NSTATEMX),NDEBv(NSTATEMX), 3 NDECDC(NSTATEMX),NDELD(NSTATEMX),IFXGv(NSTATEMX),IFXBv(NSTATEMX), 4 IFXCDC(NSTATEMX),IFXLD(NSTATEMX),BOBORD(NSTATEMX), 5 NUMNDE(NSTATEMX),IFXD(NSTATEMX),IFXVD(NSTATEMX),ITYPE(NSTATEMX), 6 NP0(NSTATEMX),NQ0(NSTATEMX),IP0(NSTATEMX),IQ0(NSTATEMX), 7 ITYPB(NSTATEMX),NP1(NSTATEMX),NQ1(NSTATEMX),IP1(NSTATEMX), 8 IQ1(NSTATEMX),LMAX(0:9,NSTATEMX),LDMAX(9,NSTATEMX), 9 IFXVS(NSTATEMX),IFXDVS(NSTATEMX),BOB00,LAMAX(2,0:9,NSTATEMX), a IPSTATE(NSTATEMX),NPAR(0:NVIBMX,NSTATEMX,NISTPMX), b NQPAR(0:NVIBMX,NSTATEMX,NISTPMX), c FITGV(0:NVIBMX,NSTATEMX,NISTPMX),NRC(0:NVIBMX,NSTATEMX,NISTPMX), d NQC(0:NVIBMX,NSTATEMX,NISTPMX),NEBC(NSTATEMX) c COMMON /CASEBLK/XM,PNDE, NSTATES,IBAND,VMIN,VMAX,NCDC,IOMEG,NLDMX, 1 efREF,MULTPLT,NDEGv,NDEBv,NDECDC,NDELD,IFXGv,IFXBv,IFXCDC,IFXLD, 2 IFXVS,IFXDVS,BOBORD,NUMNDE,IFXD,IFXVD,ITYPE,NP0,NQ0,IP0,IQ0, 3 ITYPB,NP1,NQ1,IP1,IQ1,LMAX,LDMAX,BOB00,LAMAX,IPSTATE,NPAR,NQPAR, 4 FITGV,NRC,NQC,NEBC c c** Type statements and common block for actual parameter values c REAL*8 Te(NSTATEMX),VPHPW(0:NVIBMX,0:NDUNMX), 1 YLM(0:NDUNMX,0:9,NSTATEMX),DELTA(2,0:NDUNMX,0:9,NSTATEMX), 2 QLM(0:NDUNMX,9,NSTATEMX),DLIMIT(NSTATEMX),VD(NSTATEMX), 3 PM0(NDUNMX,NSTATEMX),QM0(NDUNMX,NSTATEMX),PM1(NDUNMX,NSTATEMX), 4 QM1(NDUNMX,NSTATEMX),VS(NSTATEMX),DVS(NSTATEMX), 5 VSISO(NSTATEMX,NISTPMX),DVSISO(NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 6 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX), 6 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /PARMBLK/Te,VPHPW,YLM,DELTA,QLM,DLIMIT,VD,PM0,QM0,PM1,QM1, 1 VS,DVS,VSISO,DVSISO,ORIGIN,ZK,ZQ c c** Type statement and common block for NDE partial derivative stuff c REAL*8 DGPM(-1:NVIBMX,NSTATEMX,NISTPMX), 1 DGQM(-1:NVIBMX,NSTATEMX,NISTPMX), 2 DGVD(-1:NVIBMX,NSTATEMX,NISTPMX), 3 DBPM(-1:NVIBMX,NSTATEMX,NISTPMX), 4 DBQM(-1:NVIBMX,NSTATEMX,NISTPMX), 5 DBVD(-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /DERVBLK/DGPM,DGQM,DGVD,DBPM,DBQM,DBVD c----------------------------------------------------------------------- DO ISOT= 1,NISTP GFCT= 1.d0 BFCT= 1.d0 IF(ITYPE(ISTATE).EQ.2) GFCT= PNDE(0,ISTATE) IF(ITYPB(ISTATE).EQ.2) BFCT= PNDE(1,ISTATE) DO IV= -1,VMAXX IF(IV.LT.0) THEN VDMV= (VD(ISTATE)+ 0.5d0)*RSQMU(ISOT) ELSE VDMV= (VD(ISTATE) - IV)*RSQMU(ISOT) ENDIF IF(NEWGv.GT.0) THEN c** First get vib. energy numerator/exponent polynomial & its vD deriv. SNUM= 1.d0 DNUM= 0.d0 SDEN= 1.d0 DDEN= 0.d0 IF(NP0(ISTATE).GT.0) THEN VDMVP= VDMV**IP0(ISTATE) DO I= 1,NP0(ISTATE) DNUM= DNUM+(IP0(ISTATE)+I)*PM0(I,ISTATE)*VDMVP VDMVP= VDMVP*VDMV SNUM= SNUM+ PM0(I,ISTATE)*VDMVP ENDDO ENDIF IF(NQ0(ISTATE).GT.0) THEN c ... then get vib. energy denominator polynomial & its vD derivative VDMVP= VDMV**IQ0(ISTATE) DO I= 1,NQ0(ISTATE) DDEN= DDEN+(IQ0(ISTATE)+I)*QM0(I,ISTATE)*VDMVP VDMVP= VDMVP*VDMV SDEN= SDEN+ QM0(I,ISTATE)*VDMVP ENDDO ENDIF c ... and now, store values & derivative components for use in DYIDPJ EB= XM(0,ISTATE,ISOT)*VDMV**PNDE(0,ISTATE) IF(ITYPE(ISTATE).EQ.3) THEN EB= EB*DEXP(SNUM- 1.d0) DGPM(IV,ISTATE,ISOT)= -EB DGVD(IV,ISTATE,ISOT)= -EB*(PNDE(0,ISTATE)/VDMV 1 + DNUM) ELSE EB= EB*(SNUM/SDEN)**GFCT DGPM(IV,ISTATE,ISOT)= -EB*GFCT/SNUM DGQM(IV,ISTATE,ISOT)= EB*GFCT/SDEN DGVD(IV,ISTATE,ISOT)= -EB*(PNDE(0,ISTATE)/VDMV 1 + GFCT*DNUM/SNUM- GFCT*DDEN/SDEN) ENDIF ZK(0,IV,ISTATE,ISOT)= DLIMIT(ISTATE)- EB ENDIF c====== End of vibrational energy/derivative calculations ============= c IF((NDEBv(ISTATE).GT.0).AND.(NEWBv.GT.0)) THEN c*** Now ... derivatives of Bv w.r.t. expansion coefficients & vD c First get Rotational NDE numerator/exponent polynomial & its vD deriv. SNUM= 1.d0 DNUM= 0.d0 SDEN= 1.d0 DDEN= 0.d0 IF(NP1(ISTATE).GT.0) THEN VDMVP= VDMV**IP1(ISTATE) DO I= 1,NP1(ISTATE) DNUM= DNUM+(IP1(ISTATE)+I)*PM1(I,ISTATE)*VDMVP VDMVP= VDMVP*VDMV SNUM= SNUM+ PM1(I,ISTATE)*VDMVP ENDDO ENDIF IF(NQ1(ISTATE).GT.0) THEN c ... then get Rotational NDE denominator polynomial & its vD derivative VDMVP= VDMV**IQ1(ISTATE) DO I= 1,NQ1(ISTATE) DDEN= DDEN+(IQ1(ISTATE)+I)*QM1(I,ISTATE)*VDMVP VDMVP= VDMVP*VDMV SDEN= SDEN+ QM1(I,ISTATE)*VDMVP ENDDO ENDIF c ... and now, store values & derivative components for use in DYIDPJ BV= XM(1,ISTATE,ISOT)*VDMV**PNDE(1,ISTATE) IF(ITYPB(ISTATE).EQ.3) THEN BV= BV*DEXP(SNUM- 1.d0) DBPM(IV,ISTATE,ISOT)= BV DBVD(IV,ISTATE,ISOT)=BV*(PNDE(1,ISTATE)/VDMV+DNUM) ELSE BV= BV*(SNUM/SDEN)**BFCT DBPM(IV,ISTATE,ISOT)= BV*BFCT/SNUM DBQM(IV,ISTATE,ISOT)= -BV*BFCT/SDEN DBVD(IV,ISTATE,ISOT)= BV*(PNDE(1,ISTATE)/VDMV 1 + BFCT*(DNUM/SNUM- DDEN/SDEN)) ENDIF ZK(1,IV,ISTATE,ISOT)= BV IF(NEWBv.GT.0) ZK(1,IV,ISTATE,ISOT)= BV ENDIF ENDDO ENDDO END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE NDEDUN(ISTATE,NISTP,ZMASS,RSQMU,PU,CM) c** Subroutine to calculate conventional Dunham parameters we, wexe, Be c and alpha_e (=AE) and their derivatives w.r.t. NDE parameters, from c input NDE-expansion functions. c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% REAL*8 VDPH,VDPHI,VDPHP,FCT,FCT1,FCT2,FCT3, 1 PWG,PWB,PU(NPARMX),CM(NPARMX,NPARMX),ZMASS(3,NISTPMX), 2 RSQMU(NISTPMX),PFCT,SNUM,DNUM,D2NUM,D3NUM,SDEN,DDEN,D2DEN, 3 D3DEN,EB,S1,S2,S3,S4 REAL*8 WE(NISTPMX),XE(NISTPMX),BE(NISTPMX),AE(NISTPMX), 1 RE(NISTPMX),UWE(NISTPMX),UXE(NISTPMX),UBE(NISTPMX), 2 UAE(NISTPMX),DWE(2*NDUNMX,NISTPMX),DXE(2*NDUNMX,NISTPMX), 3 URE(NISTPMX),DBE(2*NDUNMX,NISTPMX),DAE(2*NDUNMX,NISTPMX) INTEGER I,I1,ISOT,ISTATE,ICMS,ICMF,J,J1,NISTP,IP0I,IQ0I c c** Type statements and common block for case (type of representation) c REAL*8 XM(0:9,NSTATEMX,NISTPMX),PNDE(0:9,NSTATEMX) c INTEGER NSTATES,IBAND,VMIN(NSTATEMX),VMAX(NSTATEMX), 1 NCDC(NSTATEMX),IOMEG(NSTATEMX),NLDMX(NSTATEMX),efREF(NSTATEMX), 2 MULTPLT(NSTATEMX),NDEGv(NSTATEMX),NDEBv(NSTATEMX), 3 NDECDC(NSTATEMX),NDELD(NSTATEMX),IFXGv(NSTATEMX),IFXBv(NSTATEMX), 4 IFXCDC(NSTATEMX),IFXLD(NSTATEMX),BOBORD(NSTATEMX), 5 NUMNDE(NSTATEMX),IFXD(NSTATEMX),IFXVD(NSTATEMX),ITYPE(NSTATEMX), 6 NP0(NSTATEMX),NQ0(NSTATEMX),IP0(NSTATEMX),IQ0(NSTATEMX), 7 ITYPB(NSTATEMX),NP1(NSTATEMX),NQ1(NSTATEMX),IP1(NSTATEMX), 8 IQ1(NSTATEMX),LMAX(0:9,NSTATEMX),LDMAX(9,NSTATEMX), 9 IFXVS(NSTATEMX),IFXDVS(NSTATEMX),BOB00,LAMAX(2,0:9,NSTATEMX), a IPSTATE(NSTATEMX),NPAR(0:NVIBMX,NSTATEMX,NISTPMX), b NQPAR(0:NVIBMX,NSTATEMX,NISTPMX), c FITGV(0:NVIBMX,NSTATEMX,NISTPMX),NRC(0:NVIBMX,NSTATEMX,NISTPMX), d NQC(0:NVIBMX,NSTATEMX,NISTPMX),NEBC(NSTATEMX) c COMMON /CASEBLK/XM,PNDE, NSTATES,IBAND,VMIN,VMAX,NCDC,IOMEG,NLDMX, 1 efREF,MULTPLT,NDEGv,NDEBv,NDECDC,NDELD,IFXGv,IFXBv,IFXCDC,IFXLD, 2 IFXVS,IFXDVS,BOBORD,NUMNDE,IFXD,IFXVD,ITYPE,NP0,NQ0,IP0,IQ0, 3 ITYPB,NP1,NQ1,IP1,IQ1,LMAX,LDMAX,BOB00,LAMAX,IPSTATE,NPAR,NQPAR, 4 FITGV,NRC,NQC,NEBC c c** Type statements and common block for actual parameter values c REAL*8 Te(NSTATEMX),VPHPW(0:NVIBMX,0:NDUNMX), 1 YLM(0:NDUNMX,0:9,NSTATEMX),DELTA(2,0:NDUNMX,0:9,NSTATEMX), 2 QLM(0:NDUNMX,9,NSTATEMX),DLIMIT(NSTATEMX),VD(NSTATEMX), 3 PM0(NDUNMX,NSTATEMX),QM0(NDUNMX,NSTATEMX),PM1(NDUNMX,NSTATEMX), 4 QM1(NDUNMX,NSTATEMX),VS(NSTATEMX),DVS(NSTATEMX), 5 VSISO(NSTATEMX,NISTPMX),DVSISO(NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 6 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX), 6 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /PARMBLK/Te,VPHPW,YLM,DELTA,QLM,DLIMIT,VD,PM0,QM0,PM1,QM1, 1 VS,DVS,VSISO,DVSISO,ORIGIN,ZK,ZQ c----------------------------------------------------------------------- c** First ... zero uncertainties and partial derivatives DO ISOT= 1,NISTP UWE(ISOT)= 0.d0 UXE(ISOT)= 0.d0 UBE(ISOT)= 0.d0 UAE(ISOT)= 0.d0 DO I= 1,2*NDUNMX DWE(I,ISOT)= 0.d0 DXE(I,ISOT)= 0.d0 DBE(I,ISOT)= 0.d0 DAE(I,ISOT)= 0.d0 ENDDO ENDDO PWG= PNDE(0,ISTATE) PWB= PNDE(1,ISTATE) IP0I= IP0(ISTATE) IQ0I= IQ0(ISTATE) ICMS= IPSTATE(ISTATE)+ 1 IF(IFXD(ISTATE).LE.0) ICMS= ICMS+ 1 ICMF= ICMS- 1 IF(IFXVD(ISTATE).LE.0) ICMF= ICMF+1 DO ISOT= 1,NISTP c** Loop over all isotopomers PFCT= 1.d0 IF(ITYPE(ISTATE).EQ.2) PFCT= PWG VDPH= (VD(ISTATE)+0.5D0)*RSQMU(ISOT) VDPHI= RSQMU(ISOT)/VDPH c** First get vib. energy numerator/exponent polynomial & its first c three derivatives w.r.t. vD SNUM= 1.d0 DNUM= 0.d0 D2NUM= 0.d0 D3NUM= 0.d0 SDEN= 1.d0 DDEN= 0.d0 D2DEN= 0.d0 D3DEN= 0.d0 IF(NP0(ISTATE).GT.0) THEN VDPHP= VDPH**IP0I DO I= 1,NP0(ISTATE) ICMF= ICMF+ 1 VDPHP= VDPHP*VDPH FCT= PM0(I,ISTATE)*VDPHP SNUM= SNUM+ FCT FCT=(IP0I+ I)*FCT*VDPHI DNUM= DNUM+ FCT FCT= (IP0I+ I- 1)*FCT*VDPHI D2NUM= D2NUM+ FCT D3NUM= D2NUM+ (IP0I+ I- 2)*FCT*VDPHI ENDDO ENDIF IF(NQ0(ISTATE).GT.0) THEN c ... then get vib. energy denominator polynomial & its first three c derivatives w.r.t. vD VDPHP= VDPH**IQ0(ISTATE) DO I= 1,NQ0(ISTATE) ICMF= ICMF+ 1 VDPHP= VDPHP*VDPH FCT= QM0(I,ISTATE)*VDPHP SDEN= SDEN+ FCT FCT=(IQ0I+ I)*FCT*VDPHI DDEN= DDEN+ FCT FCT= (IQ0I+ I- 1)*FCT*VDPHI D2DEN= D2DEN+ FCT D3DEN= D3DEN+ (IQ0I+ I- 2)*FCT*VDPHI ENDDO ENDIF c** Now generate we, wexe & their deriv's w.r.t. vD & the p_i's c [derivative (0) w.r.t. vD; (i) w.r.t. p_i ] EB= XM(0,ISTATE,ISOT)*VDPH**PWG J= 0 IF(ITYPE(ISTATE).EQ.3) THEN c** First, for exponential vibrational NDE EB= EB*DEXP(SNUM- 1.d0) WE(ISOT)= EB*(PWG*VDPHI + DNUM) XE(ISOT)= 0.5d0*EB*(PWG*(PWG-1.d0)*VDPHI**2 + 1 DNUM*(2.d0*PWG*VDPHI+ DNUM) +D2NUM) c ... first ... derivative w.r.t. vD IF(IFXVD(ISTATE).LE.0) THEN J= J+1 DWE(J,ISOT)= XE(ISOT) DXE(J,ISOT)= 0.5d0*EB*(PWG*VDPHI*(3.d0*(DNUM**2+ 1 D2NUM) + (PWG-1.d0)*VDPHI*(3.d0*DNUM+(PWG-2.d0)*VDPHI)) 2 + DNUM**3+ 3.d0*DNUM*D2NUM+ D3NUM) ENDIF IF(NP0(ISTATE).GT.0) THEN c ... and then derivatives w.r.t. p_i's FCT= VDPH**IP0I DO I= 1,NP0(ISTATE) J= J+1 FCT= FCT*VDPH DWE(J,ISOT)= EB*FCT*((PWG+ I+ IP0I)*VDPHI + DNUM) DXE(J,ISOT)= FCT*(XE(ISOT)+ 0.5d0*EB*(I+IP0I)* 1 VDPHI*(VDPHI*(2.d0*PWG+i+IP0I-1) + 2.d0*DNUM)) ENDDO ENDIF ELSE c** Now for rational polynomial vibrational NDE's: ITYPE= 1 & 2 EB= EB*(SNUM/SDEN)**PFCT FCT= PWG*VDPHI + PFCT*(DNUM/SNUM - DDEN/SDEN) FCT1= -PWG*VDPHI**2 + PFCT*(D2NUM/SNUM - (DNUM/SNUM)**2 1 - D2DEN/SDEN + (DDEN/SDEN)**2) WE(ISOT)= EB*FCT XE(ISOT)= 0.5d0*EB*(FCT**2 + FCT1) c ... now ... derivative w.r.t. vD IF(IFXVD(ISTATE).LE.0) THEN J= J+1 DWE(J,ISOT)= 2.d0*XE(ISOT) DXE(J,ISOT)= 0.5d0*WE(ISOT)*(FCT**2 + FCT1) + 1 0.5d0*EB*(2.d0*FCT*FCT1 + 2.d0*PWG*VDPHI**3 2 + PFCT*(D3NUM/SNUM -D3DEN/SDEN 3 - 3.d0*(D2NUM*DNUM/SNUM**2 - D2DEN*DDEN/SDEN**2) 4 + 2.d0*((DNUM/SNUM)**3 - (DDEN/SDEN)**3))) ENDIF IF(NP0(ISTATE).GT.0) THEN c ... and then derivatives w.r.t. p_i's FCT2= PFCT*EB*VDPH**IP0I/SNUM DO I= 1, NP0(ISTATE) J= J+1 FCT2= FCT2*VDPH FCT3= (I+IP0I)*VDPHI - DNUM/SNUM DWE(J,ISOT)= FCT2*(FCT + FCT3) DXE(J,ISOT)= 0.5d0*FCT2*(FCT**2 + FCT1+ 1 2.d0*FCT*FCT3 + (I+IP0I)*(I+IP0I-1)*VDPHI**2 - D2NUM/SNUM 2 - 2.d0*FCT3*DNUM/SNUM) ENDDO ENDIF IF(NQ0(ISTATE).GT.0) THEN c ... and then derivativesw.r.t. q_i's FCT2= PFCT*EB*VDPH**IQ0I/SDEN DO I= 1, NQ0(ISTATE) J= J+1 FCT2= FCT2*VDPH FCT3= (I+IQ0I)*VDPHI - DDEN/SDEN DWE(J,ISOT)= -FCT2*(FCT + FCT3) DXE(J,ISOT)= -0.5d0*FCT2*(FCT**2+ FCT1+ 1 2.d0*FCT*FCT3 + (I+IQ0I)*(I+IQ0I-1)*VDPHI**2 - D2DEN/SDEN 2 - 2.d0*FCT3*DDEN/SDEN) ENDDO ENDIF 1 ENDIF c c** Now get Bv exponent polynomial & its derivative w.r.t. vD IF(NDEBv(ISTATE).GT.0) THEN VDPHP= 1.d0 SNUM= 0.d0 DNUM= 0.d0 D2NUM= 0.d0 IF(NP1(ISTATE).GT.0) THEN DO I= 1,NP1(ISTATE) ICMF= ICMF+ 1 VDPHP= VDPHP*VDPH FCT= PM1(I,ISTATE)*VDPHP SNUM= SNUM+ FCT FCT= FCT*I*VDPHI DNUM= DNUM+ FCT D2NUM= D2NUM+ (I-1)*FCT*VDPHI ENDDO ENDIF IF(NQ1(ISTATE).GT.0) THEN DO I= 1,NQ1(ISTATE) c???????? unfinished !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 ENDDO ENDIF BE(ISOT)= XM(1,ISTATE,ISOT)*VDPH**PWB*DEXP(SNUM) AE(ISOT)= BE(ISOT)*(PWB*VDPHI+ DNUM) c ... first, derivatives w.r.t. vD IF(IFXVD(ISTATE).LE.0) THEN DBE(1,ISOT)= AE(ISOT) DAE(1,ISOT)= AE(ISOT)*(PWB*VDPHI+ DNUM) 1 + BE(ISOT)*(D2NUM- PWB*VDPHI**2) ENDIF IF(NP1(ISTATE).GT.0) THEN FCT= 1.d0 DO I= 1,NP1(ISTATE) J= J+1 FCT= FCT*VDPH DBE(J,ISOT)= BE(ISOT)*FCT DAE(J,ISOT)= DBE(J,ISOT)*(VDPHI*(PWB+I) + DNUM) ENDDO ENDIF IF(NQ1(ISTATE).GT.0) THEN c???????? unfinished !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 ENDIF ENDIF c** Finally ... use correlation matrix and uncertainties in fitted c parameter to calculate uncertainties in our Dunham constants. I1= 0 DO I= ICMS,ICMF I1= I1+1 J1= 0 S1= 0.d0 S2= 0.d0 S3= 0.d0 S4= 0.d0 DO J= ICMS,ICMF J1= J1+1 S1= S1+ CM(I,J)*PU(J)*DWE(J1,ISOT) S2= S2+ CM(I,J)*PU(J)*DXE(J1,ISOT) IF(NDEBv(ISTATE).GT.0) THEN S3= S3+ CM(I,J)*PU(J)*DBE(J1,ISOT) S4= S4+ CM(I,J)*PU(J)*DAE(J1,ISOT) ENDIF ENDDO UWE(ISOT)= UWE(ISOT)+ PU(I)*DWE(I1,ISOT)*S1 UXE(ISOT)= UXE(ISOT)+ PU(I)*DXE(I1,ISOT)*S2 IF(NDEBv(ISTATE).GT.0) THEN UBE(ISOT)= UBE(ISOT)+ PU(I)*DBE(I1,ISOT)*S3 UAE(ISOT)= UAE(ISOT)+ PU(I)*DAE(I1,ISOT)*S4 ENDIF ENDDO UWE(ISOT)= DSQRT(UWE(ISOT)) UXE(ISOT)= DSQRT(UXE(ISOT)) IF(NDEBv(ISTATE).GT.0) THEN UBE(ISOT)= DSQRT(UBE(ISOT)) UAE(ISOT)= DSQRT(UAE(ISOT)) RE(ISOT)= DSQRT(16.85762908D0/(BE(ISOT)*ZMASS(3,ISOT))) URE(ISOT)= RE(ISOT)*0.5d0*UBE(ISOT)/BE(ISOT) ENDIF ENDDO WRITE(6,600) ISTATE 600 FORMAT(/' State-',i1,' isotopic Dunham parameters generated from N 1DE functions:'/1x,64('-')) WRITE(6,602) (WE(ISOT),UWE(ISOT),ISOT= 1,NISTP) WRITE(6,604) (XE(ISOT),UXE(ISOT),ISOT= 1,NISTP) WRITE(6,606) (ZK(0,0,ISTATE,ISOT),ISOT= 1,NISTP) WRITE(6,608) (ZK(0,-1,ISTATE,ISOT),ISOT= 1,NISTP) WRITE(6,610) (BE(ISOT),UBE(ISOT),ISOT= 1,NISTP) WRITE(6,612) (AE(ISOT),UAE(ISOT),ISOT= 1,NISTP) WRITE(6,614) (RE(ISOT),URE(ISOT),ISOT= 1,NISTP) 602 FORMAT(' we =',3(F11.5,' (',F9.5,')':)/ 1 (10x,3(F11.5,' (',F9.5,')':))) 604 FORMAT(' wexe =',3(F11.5,' (',F9.5,')':)/ 1 (10x,3(F11.5,' (',F9.5,')':))) 606 FORMAT(' T(v= 0)=',3(F14.5,9x:)/(10x,3(F14.5,9x:))) 608 FORMAT(' T(v= -1/2)=',3(F14.5,9x:)/(10x,3(F14.5,9x:))) 610 FORMAT(' B(v= -1/2)=',3(1PD12.5,' (',D8.1,')':)/ 1 (10x,3(D12.5,' (',D8.1,')':))) 612 FORMAT(' alpha_e =',3(1PD12.5,' (',D8.1,')':)/ 1 (10x,3(D12.5,' (',D8.1,')':))) 614 FORMAT(' Re(v= -1/2)=',3(F11.6,' (',F9.6,')':)/ 1 (10x,3(F11.6,' (',F9.6,')':))) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE DYIDPJ(IDAT,NDATA,NPTOT,YC,PV,PD,PS) c** Partial derivative subroutine called by general least-squares fitting c subroutine NLLSSRR for use in parameter-fits to diatomic molecule c spectroscopic data by R.J. Le Roy's program DParFit. c Version of 02 April 2016 c 0701/13 Removed IFXP & RMSR as unused input parameters c----------------------------------------------------------------------- c** Input parameters PS (& RMSR) are used in cases when determine partial c derivatives by first differences (e.g., BCONT); DUMMY variables here. c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c INTEGER IVPP,IVP,M,NDATA,NPTOT,IDAT,IPAR,IPX,I,IBB,ESP,ESPP,ISOT, 1 ISTATE,IPARVD,MQ0,MQM,ATOM,ATOM2,L,LAMIN REAL*8 ZATOM,JJPW,JJPPW,DER,PDVD,VDMVP,VDMVPP,VDMVPW,VDMVPPW, 1 JJP,JJPI,JJPQ,JJPP,JJPPI,JJPPQ,YC,PV(NPTOT),PD(NPTOT),PS(NPTOT), 2 SwP,SwPLR,SwPP,SwPPLR,dSwPVS,dSwPdVS,dSwPPVS,dSwPPdVS,YYDun c c** Type statements and common block for case (type of representation) c REAL*8 XM(0:9,NSTATEMX,NISTPMX),PNDE(0:9,NSTATEMX) INTEGER NSTATES,IBAND,VMIN(NSTATEMX),VMAX(NSTATEMX), 1 NCDC(NSTATEMX),IOMEG(NSTATEMX),NLDMX(NSTATEMX),efREF(NSTATEMX), 2 MULTPLT(NSTATEMX),NDEGv(NSTATEMX),NDEBv(NSTATEMX), 3 NDECDC(NSTATEMX),NDELD(NSTATEMX),IFXGv(NSTATEMX),IFXBv(NSTATEMX), 4 IFXCDC(NSTATEMX),IFXLD(NSTATEMX),BOBORD(NSTATEMX), 5 NUMNDE(NSTATEMX),IFXD(NSTATEMX),IFXVD(NSTATEMX),ITYPE(NSTATEMX), 6 NP0(NSTATEMX),NQ0(NSTATEMX),IP0(NSTATEMX),IQ0(NSTATEMX), 7 ITYPB(NSTATEMX),NP1(NSTATEMX),NQ1(NSTATEMX),IP1(NSTATEMX), 8 IQ1(NSTATEMX),LMAX(0:9,NSTATEMX),LDMAX(9,NSTATEMX), 9 IFXVS(NSTATEMX),IFXDVS(NSTATEMX),BOB00,LAMAX(2,0:9,NSTATEMX), a IPSTATE(NSTATEMX),NPAR(0:NVIBMX,NSTATEMX,NISTPMX), b NQPAR(0:NVIBMX,NSTATEMX,NISTPMX), c FITGV(0:NVIBMX,NSTATEMX,NISTPMX),NRC(0:NVIBMX,NSTATEMX,NISTPMX), d NQC(0:NVIBMX,NSTATEMX,NISTPMX),NEBC(NSTATEMX) c COMMON /CASEBLK/XM,PNDE, NSTATES,IBAND,VMIN,VMAX,NCDC,IOMEG,NLDMX, 1 efREF,MULTPLT,NDEGv,NDEBv,NDECDC,NDELD,IFXGv,IFXBv,IFXCDC,IFXLD, 2 IFXVS,IFXDVS,BOBORD,NUMNDE,IFXD,IFXVD,ITYPE,NP0,NQ0,IP0,IQ0, 3 ITYPB,NP1,NQ1,IP1,IQ1,LMAX,LDMAX,BOB00,LAMAX,IPSTATE,NPAR,NQPAR, 4 FITGV,NRC,NQC,NEBC c c** Type statements and common block for actual parameter values c REAL*8 Te(NSTATEMX),VPHPW(0:NVIBMX,0:NDUNMX), 1 YLM(0:NDUNMX,0:9,NSTATEMX),DELTA(2,0:NDUNMX,0:9,NSTATEMX), 2 QLM(0:NDUNMX,9,NSTATEMX),DLIMIT(NSTATEMX),VD(NSTATEMX), 3 PM0(NDUNMX,NSTATEMX),QM0(NDUNMX,NSTATEMX),PM1(NDUNMX,NSTATEMX), 4 QM1(NDUNMX,NSTATEMX),VS(NSTATEMX),DVS(NSTATEMX), 5 VSISO(NSTATEMX,NISTPMX),DVSISO(NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 6 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX), 6 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /PARMBLK/Te,VPHPW,YLM,DELTA,QLM,DLIMIT,VD,PM0,QM0,PM1,QM1, 1 VS,DVS,VSISO,DVSISO,ORIGIN,ZK,ZQ c c** Type statement and common block for NDE partial derivative stuff c REAL*8 DGPM(-1:NVIBMX,NSTATEMX,NISTPMX), 1 DGQM(-1:NVIBMX,NSTATEMX,NISTPMX), 2 DGVD(-1:NVIBMX,NSTATEMX,NISTPMX), 3 DBPM(-1:NVIBMX,NSTATEMX,NISTPMX), 4 DBQM(-1:NVIBMX,NSTATEMX,NISTPMX), 5 DBVD(-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /DERVBLK/DGPM,DGQM,DGVD,DBPM,DBQM,DBVD c c** For the first datum, call subroutine MAPPAR to map current NLLSSRR c values of fitted parameters PV onto "internal" molecular parameters IF(IDAT.EQ.1) CALL MAPPAR(NPTOT,PV) c** Call subroutine to return current predicted value of datum-IDAT CALL PREDICT(IDAT,YC,NCDC,NLDMX,IOMEG,efREF,DLIMIT,ORIGIN,PV, 1 ZK,ZQ) c IBB= IB(IDAT) ISOT= ISTP(IBB) ESP= IEP(IBB) ESPP= IEPP(IBB) IVP= VP(IBB) IVPP= VPP(IBB) IF(ESP.LE.0) IVPP= JP(IDAT) JJPP= JPP(IDAT)*(JPP(IDAT)+ 1.d0) JJPPQ= JJPP IF(IOMEG(ESPP).GT.0) JJPP= JJPP - IOMEG(ESPP)**2 JJPPI= JJPP c** Lower level isotope scaling ... as required ... IF((ISOT.GT.1).AND.(NDEGv(ESPP).GE.0)) JJPPI= JJPP*RMUP(1,ISOT) IF(ESP.GT.0) THEN JJP= JP(IDAT)*(JP(IDAT)+ 1.d0) JJPQ= JJP IF(IOMEG(ESP).GT.0) JJP= JJP - IOMEG(ESP)**2 JJPI= JJP c** Upper level isotope scaling ... as required ... IF((ISOT.GT.1).AND.(NDEGv(ESP).GE.0)) JJPI= JJP*RMUP(1,ISOT) ENDIF c** Zero all partial derivatives ... DO I= 1,NPTOT PD(I)= 0.d0 ENDDO IF((ESP.EQ.-3).AND.(NDEBv(ESPP).EQ.-1).AND.(IFXBv(ESPP).LE.0))THEN c** If Datum is a Bv value for a state being fitted by band constants .. IPX= NPAR(IVPP,ESPP,ISOT) IF(NRC(IVPP,ESPP,ISOT).GT.0) THEN IF(FITGV(IVPP,ESPP,ISOT).GT.0) IPX= IPX+ 1 PD(IPX+ 1)= 1.d0 ENDIF RETURN ENDIF c DO 90 ISTATE= 1,NSTATES c** Begin loop over states, accumulating parameter count & partial derivs. IF((ISTATE.NE.ESP).AND.(ISTATE.NE.ESPP)) GO TO 90 IPAR= IPSTATE(ISTATE) IF((NDEGv(ISTATE).EQ.2).OR.(NDEBv(ISTATE).EQ.2)) THEN c* If use MXS for Gv or Bv, generate switching functions & partial der. IF(ISTATE.EQ.ESP) THEN SwPLR= dexp((IVP- VSISO(ESP,ISOT))/DVSISO(ESP,ISOT)) SwP= 1.d0/(1.d0+ SwPLR) SwPLR= SwPLR*SwP IF(IFXVS(ISTATE).LE.0) THEN dSwPVS= SwPLR/DVS(ISTATE) dSwPdVS= dSwPVS*(IVP- VSISO(ESP,ISOT))/ 1 DVSISO(ESP,ISOT) ENDIF ENDIF IF(ISTATE.EQ.ESPP) THEN SwPPLR= dexp((IVPP- VSISO(ESPP,ISOT))/ 1 DVSISO(ESPP,ISOT)) SwPP= 1.d0/(1.d0+ SwPPLR) SwPPLR= SwPPLR*SwPP IF(IFXVS(ISTATE).LE.0) THEN dSwPPVS= SwPPLR/DVS(ISTATE) dSwPPdVS= dSwPPVS*(IVP- VSISO(ESP,ISOT))/ 1 DVSISO(ESP,ISOT) ENDIF ENDIF ENDIF c c** If fitting to parameters defining Gv's for this state .............. c======================================================================= IF(IFXGv(ISTATE).LE.0) THEN IF(NDEGv(ISTATE).EQ.-2) THEN c** If fitting to individual term values for this state ... c========================================================== IF((ISTATE.EQ.ESP).AND.(TVUP(IDAT).GT.0)) 1 PD(TVUP(IDAT))= 1.d0 IF((ISTATE.EQ.ESPP).AND.(TVLW(IDAT).GT.0)) 1 PD(TVLW(IDAT))= -1.d0 GOTO 90 ENDIF IF(NDEGv(ISTATE).EQ.-1) THEN c** If fitting Gv (& rotational constants) as band constants ... c================================================================ IF(ISTATE.EQ.ESPP) THEN c ... derivatives for ISTATE being the lower state IPX= NPAR(IVPP,ESPP,ISOT) IF(FITGV(IVPP,ESPP,ISOT).GT.0) THEN IPX= IPX+ 1 PD(IPX)= PD(IPX) - 1.d0 ENDIF IF(NRC(IVPP,ESPP,ISOT).GT.0) THEN JJPPW= 1.d0 DO M= 1,NRC(IVPP,ESPP,ISOT) IPX= IPX+ 1 JJPPW= JJPPW*JJPP PD(IPX)= PD(IPX) - JJPPW ENDDO ENDIF ENDIF IF(ISTATE.EQ.ESP) THEN c ... then ... derivatives for ISTATE being the upper state IPX= NPAR(IVP,ESP,ISOT) IF(FITGV(IVP,ESP,ISOT).GT.0) THEN IPX= IPX+ 1 PD(IPX)= PD(IPX)+ 1.d0 ENDIF IF(NRC(IVP,ESP,ISOT).GT.0) THEN JJPW= 1.d0 DO M= 1,NRC(IVP,ESP,ISOT) IPX= IPX+ 1 JJPW= JJPW*JJP PD(IPX)= PD(IPX)+ JJPW ENDDO ENDIF ENDIF IPAR= IPX GO TO 60 ENDIF c c** If Gv's for this state fitted to Dunham or mixed (MXS) function .. c======================================================================= IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).EQ.2)) THEN IF(((ESP.EQ.ESPP).AND.(IVP.EQ.IVPP)).OR. 1 (ESP.EQ.-3)) THEN c** For MW data or "experimental" Bv's ... skip vib. derivatives IF(ISTATE.GT.1) IPAR= IPAR+1 IF(LMAX(0,ISTATE).GT.0) IPAR= IPAR+ LMAX(0,ISTATE) GO TO 30 ENDIF IF(ISTATE.GT.1) THEN c** First ... derivative w.r.t. Te for this state IPAR= IPAR+ 1 IF(ESP.NE.ESPP) THEN IF(ISTATE.EQ.ESP) THEN IF(NDEGv(ISTATE).EQ.0) PD(IPAR)= 1.d0 IF(NDEGv(ISTATE).GE.2) PD(IPAR)= SwP ENDIF IF(ISTATE.EQ.ESPP) THEN IF(NDEGv(ISTATE).EQ.0) PD(IPAR)=-1.d0 IF(NDEGv(ISTATE).GE.2) PD(IPAR)=-SwPP ENDIF ENDIF ENDIF c ... Now ... derivatives w.r.t. Dunham vibrational coefficients IF(LMAX(0,ISTATE).GT.0) THEN YYDun= YLM(0,0,ISTATE) DO L= 1,LMAX(0,ISTATE) IPAR= IPAR+ 1 IF(ISTATE.EQ.ESP) THEN PD(IPAR)= VPHPW(IVP,L)*RSQMUP(L,ISOT) IF(NDEGv(ISTATE).GE.2) THEN PD(IPAR)= PD(IPAR)*SwP YYDun= YYDun+ PD(IPAR)*YLM(L,0,ISTATE) ENDIF ENDIF IF(ISTATE.EQ.ESPP) THEN IF(NDEGv(ISTATE).EQ.0) PD(IPAR)= PD(IPAR)- 1 VPHPW(IVPP,L)*RSQMUP(L,ISOT) IF(NDEGv(ISTATE).GE.2) PD(IPAR)= PD(IPAR)- 1 VPHPW(IVPP,L)*RSQMUP(L,ISOT)*SwPP ENDIF ENDDO ENDIF ENDIF c c** If Gv's for this state fitted to NDE or MXS functions ... c============================================================= IF(NDEGv(ISTATE).GE.1) THEN IF(((ESP.EQ.ESPP).AND.(IVP.EQ.IVPP)).OR. 1 (ESP.EQ.-3)) THEN c** For MW data or "experimental" Bv's ... skip vib. derivatives IF(IFXD(ISTATE).LE.0) IPAR= IPAR+ 1 IF(IFXVD(ISTATE).LE.0) THEN IPAR= IPAR+ 1 IPARVD= IPAR PDVD= 0.d0 IPAR= IPAR+ NP0(ISTATE)+ NQ0(ISTATE) ENDIF GO TO 20 ENDIF IF(IFXD(ISTATE).LE.0) THEN c** First ... derivative w.r.t. DLIMIT for this state (if appropriate) c** Note that DLIMIT's for multiple NDE-represented states are coupled IPAR= IPAR+ 1 IF(ESP.NE.ESPP) THEN IF(ISTATE.EQ.ESP) THEN IF(NDEGv(ISTATE).EQ.1) PD(IPAR)= 1.d0 IF(NDEGv(ISTATE).GE.2) PD(IPAR)= SwPLR ENDIF IF(ISTATE.EQ.ESPP) THEN IF(NDEGv(ISTATE).EQ.1) PD(IPAR)= -1.d0 IF(NDEGv(ISTATE).GE.2) PD(IPAR)= -SwPPLR c ... for PAS data - no dependence on DLIMIT ... IF(ESP.EQ.-1) PD(IPAR)= 0.d0 ENDIF ENDIF ENDIF IF(IFXVD(ISTATE).LE.0) THEN c** Now ... vibrational derivative w.r.t. vD IPAR= IPAR+ 1 IPARVD= IPAR PDVD= 0.d0 IF(ISTATE.EQ.ESP) THEN PDVD= DGVD(IVP,ISTATE,ISOT) IF(NDEGv(ISTATE).GE.2) PDVD= PDVD*SwPLR ENDIF IF(ISTATE.EQ.ESPP) THEN IF(NDEGv(ESPP).EQ.1) 1 PDVD= PDVD - DGVD(IVPP,ISTATE,ISOT) IF(NDEGv(ESPP).GE.2) 1 PDVD= PDVD - DGVD(IVPP,ISTATE,ISOT)*SwPPLR ENDIF PD(IPAR)= PDVD ENDIF IF(ISTATE.EQ.ESP) THEN c ... prepare for numerator/denominator term sums ... VDMVP= (VD(ISTATE)-IVP)*RSQMU(ISOT) VDMVPW= VDMVP**IP0(ISTATE) ENDIF IF(ISTATE.EQ.ESPP) THEN VDMVPP= (VD(ISTATE)-IVPP)*RSQMU(ISOT) VDMVPPW= VDMVPP**IP0(ISTATE) ENDIF IF(NP0(ISTATE).GT.0) THEN c ... then w.r.t. NDE Gv numerator polynomial coefficients DO I= 1,NP0(ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ISTATE.EQ.ESP) THEN VDMVPW= VDMVPW* VDMVP DER= DGPM(IVP,ISTATE,ISOT)*VDMVPW IF(NDEGv(ESP).GE.2) DER= DER*SwPLR ENDIF IF(ISTATE.EQ.ESPP) THEN VDMVPPW= VDMVPPW* VDMVPP IF(NDEGv(ESPP).EQ.1) DER= DER - 1 DGPM(IVPP,ISTATE,ISOT)*VDMVPPW IF(NDEGv(ESPP).GE.2) DER= DER - 1 DGPM(IVPP,ISTATE,ISOT)*VDMVPPW*SwPPLR ENDIF PD(IPAR)= DER ENDDO ENDIF IF(NQ0(ISTATE).GT.0) THEN c ... then w.r.t. NDE Gv denominator polynomial coefficients IF(ISTATE.EQ.ESP) VDMVPW= VDMVP**IQ0(ISTATE) IF(ISTATE.EQ.ESPP) VDMVPPW= VDMVPP**IQ0(ISTATE) DO I= 1,NQ0(ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ISTATE.EQ.ESP) THEN VDMVPW= VDMVPW* VDMVP DER= DGQM(IVP,ISTATE,ISOT)*VDMVPW IF(NDEGv(ESP).GE.2) DER= DER*SwPPLR ENDIF IF(ISTATE.EQ.ESPP) THEN VDMVPPW= VDMVPPW* VDMVPP IF(NDEGv(ESPP).EQ.1) DER= DER- 1 DGQM(IVPP,ISTATE,ISOT)*VDMVPPW IF(NDEGv(ESPP).GE.2) DER= DER- 1 DGQM(IVPP,ISTATE,ISOT)*VDMVPPW*SwPPLR ENDIF PD(IPAR)= DER ENDDO ENDIF c ... now include Bv contribution in the derivative w.r.t. vD 20 IF((IFXVD(ISTATE).LE.0).AND.(NDEBv(ISTATE).GT.0)) THEN IF(ISTATE.EQ.ESP) THEN IF(NDEBv(ESP).EQ.1) 1 PDVD= PDVD+ DBVD(IVP,ESP,ISOT)*JJPI IF(NDEBv(ESP).GE.2) 1 PDVD= PDVD+ DBVD(IVP,ESP,ISOT)*JJPI*SwPLR ENDIF IF(ISTATE.EQ.ESPP) THEN IF(NDEBv(ESPP).EQ.1) PDVD= PDVD- 1 DBVD(IVPP,ESPP,ISOT)*JJPPI IF(NDEBv(ESPP).GE.2) PDVD= PDVD- 1 DBVD(IVPP,ESPP,ISOT)*JJPPI*SwPPLR ENDIF PD(IPARVD)= PDVD ENDIF ENDIF c ... end of fit to vibrational NDE ENDIF c ... end of fit to vibrational parameters c======================================================================= c** Begin treatment of fitted Bv parameters ........................... c======================================================================= 30 IF(IFXBv(ISTATE).LE.0) THEN IF(NDEBv(ISTATE).EQ.-1) THEN c----------------------------------------------------------------------- c** If fitting to band-constant rotational (and hence CDC) constants c while Gv's represented by a Dunham, NDE or MXS analytic function ... c----------------------------------------------------------------------- IF(ISTATE.EQ.ESPP) THEN c ... derivatives for ISTATE being the lower state IPX= NPAR(IVPP,ESPP,ISOT) IF(NRC(IVPP,ESPP,ISOT).GT.0) THEN JJPPW= 1.d0 DO M= 1,NRC(IVPP,ESPP,ISOT) IPX= IPX+ 1 JJPPW= JJPPW*JJPP PD(IPX)= PD(IPX) - JJPPW ENDDO ENDIF ENDIF IF(ISTATE.EQ.ESP) THEN c ... then ... derivatives for ISTATE being the upper state IPX= NPAR(IVP,ESP,ISOT) IF(NRC(IVP,ESP,ISOT).GT.0) THEN JJPW= 1.d0 DO M= 1,NRC(IVP,ESP,ISOT) IPX= IPX+ 1 JJPW= JJPW*JJP PD(IPX)= PD(IPX)+ JJPW ENDDO ENDIF ENDIF c** Set counter in case wishing to fit to BOB corrn. for Gv ... IPAR= NEBC(ISTATE) GO TO 60 ENDIF c** If fitting Bv's to a Dunham or NDE or MXS function ... c--------------------------------------------------------- IF((NDEBv(ISTATE).EQ.0).OR.(NDEBv(ISTATE).EQ.2)) THEN c* If Bv's for this state fitted to a Dunham or MXS function ... c--------------------------------------------------------------- DO L= 0,LMAX(1,ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ESP.EQ.-3) THEN DER= VPHPW(IVPP,L) IF(NDEBv(ISTATE).EQ.2) DER= DER*SwPP ELSE IF(ISTATE.EQ.ESP) THEN DER= VPHPW(IVP,L)*JJPI IF(NDEBv(ISTATE).GE.2) DER= DER*SwP ENDIF IF(ISTATE.EQ.ESPP) THEN IF(NDEBv(ISTATE).EQ.0) DER= DER- 1 VPHPW(IVPP,L)*JJPPI IF(NDEBv(ISTATE).GE.2) DER= DER- 1 VPHPW(IVPP,L)*JJPPI*SwPP ENDIF ENDIF PD(IPAR)= DER*RSQMUP(L,ISOT) ENDDO IF((ESP.EQ.-3).AND.(NDEBv(ISTATE).EQ.0)) RETURN ENDIF IF(NDEBv(ISTATE).GT.0) THEN c c** If Bv's for this state fitted to pure NDE or MXS functions ... c----------------------------------------------------------------- IF(IFXGv(ISTATE).GT.0) THEN c ... if NDE Gv's not being fitted, define expansions variables here ... IF(ISTATE.EQ.ESP) 1 VDMVP= (VD(ISTATE)-IVP)*RSQMU(ISOT) IF(ISTATE.EQ.ESPP) 1 VDMVPP= (VD(ISTATE)-IVPP)*RSQMU(ISOT) ENDIF IF(NP1(ISTATE).GT.0) THEN c ... for numerator/exponent polynomial coefficients ... IF(ISTATE.EQ.ESP) VDMVPW= JJPI*VDMVP**IP1(ISTATE) IF(ISTATE.EQ.ESPP) VDMVPPW= 1 JJPPI*VDMVPP**IP1(ISTATE) IF(ESP.EQ.-3) VDMVPPW= VDMVP**IP1(ISTATE) DO I= 1,NP1(ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ISTATE.EQ.ESP) THEN VDMVPW= VDMVPW* VDMVP DER= DBPM(IVP,ISTATE,ISOT)*VDMVPW IF(NDEBv(ISTATE).GE.2) DER= DER*SwPLR ENDIF IF(ISTATE.EQ.ESPP) THEN VDMVPPW= VDMVPPW* VDMVPP IF(NDEBv(ISTATE).EQ.1) DER= DER- 1 DBPM(IVPP,ISTATE,ISOT)*VDMVPPW IF(NDEBv(ISTATE).GE.2) DER= DER- 1 DBPM(IVPP,ISTATE,ISOT)*VDMVPPW*SwPPLR ENDIF PD(IPAR)= DER ENDDO ENDIF IF(NQ1(ISTATE).GT.0) THEN IF(ISTATE.EQ.ESP) VDMVPW= JJPI*VDMVP**IQ1(ISTATE) IF(ISTATE.EQ.ESPP) VDMVPPW= 1 JJPPI*VDMVPP**IQ1(ISTATE) IF(ESP.LT.-3) VDMVPPW= VDMVPP**IQ1(ISTATE) DO I= 1,NQ1(ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ISTATE.EQ.ESP) THEN VDMVPW= VDMVPW* VDMVP DER= DBQM(IVP,ISTATE,ISOT)*VDMVPW IF(NDEBv(ISTATE).GE.2) DER= DER*SwPLR ENDIF IF(ISTATE.EQ.ESPP) THEN VDMVPPW= VDMVPPW* VDMVPP IF(NDEBv(ISTATE).EQ.1) DER= DER- 1 DBQM(IVPP,ISTATE,ISOT)*VDMVPPW IF(NDEBv(ISTATE).GE.2) DER= DER- 1 DBQM(IVPP,ISTATE,ISOT)*VDMVPPW*SwPPLR ENDIF PD(IPAR)= DER ENDDO ENDIF IF(ESP.EQ.-3) RETURN ENDIF ENDIF c c======================================================================= c** Begin treatment of fitted CDC parameters ........................... c======================================================================= IF(IFXCDC(ISTATE).LE.0) THEN IF(NDECDC(ISTATE).EQ.-1) THEN c---------------------------------------------------------------------- c** If fitting CDCs to band constants (while Gv & Bv are Dunham or ...) c---------------------------------------------------------------------- IF(ISTATE.EQ.ESPP) THEN c ... derivatives for ISTATE being the lower state IPX= NPAR(IVPP,ESPP,ISOT) IF(NRC(IVPP,ESPP,ISOT).GT.0) THEN JJPPW= JJPP DO M= 2,NRC(IVPP,ESPP,ISOT) IPX= IPX+ 1 JJPPW= JJPPW*JJPP PD(IPX)= PD(IPX) - JJPPW ENDDO ENDIF ENDIF IF(ISTATE.EQ.ESP) THEN c ... then ... derivatives for ISTATE being the upper state IPX= NPAR(IVP,ESP,ISOT) IF(NRC(IVP,ESP,ISOT).GT.0) THEN JJPW= JJP DO M= 2,NRC(IVP,ESP,ISOT) IPX= IPX+ 1 JJPW= JJPW*JJP PD(IPX)= PD(IPX)+ JJPW ENDDO ENDIF ENDIF c** Set counter in case wishing to fit to BOB corrn. for Gv or Bv ... IPAR= NEBC(ISTATE) GO TO 60 ENDIF c IF(NDECDC(ISTATE).EQ.0) THEN c------------------------------------------------------- c** If fitting to Dunham expansions for the CDC's ...... c------------------------------------------------------- JJPW= JJPI JJPPW= JJPPI DO 50 M= 2,NCDC(ISTATE)+1 IF(ESP.EQ.-3) THEN IPAR= IPAR+ LMAX(M,ISTATE)+ 1 GO TO 50 ENDIF JJPW= JJPW*JJPI JJPPW= JJPPW*JJPPI DO L= 0,LMAX(M,ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ISTATE.EQ.ESP) DER= DER+ VPHPW(IVP,L) 1 *RSQMUP(L,ISOT)*JJPW IF(ISTATE.EQ.ESPP) DER= DER- VPHPW(IVPP,L) 1 *RSQMUP(L,ISOT)*JJPPW PD(IPAR)= DER ENDDO 50 CONTINUE ENDIF ENDIF c======================================================================= c** Now ... derivatives w.r.t. any Lambda or ^2\Sigma doubling constants c======================================================================= 60 IF((IOMEG(ISTATE).NE.0).AND.(IFXLD(ISTATE).LE.0) 1 .AND.(NLDMX(ISTATE).GE.1)) THEN c ... if fitting to Band-Constant values for doubling constants ... c------------------------------------------------------------------ MQ0= MAX0(0,IOMEG(ISTATE)-1) IF(NDELD(ISTATE).LT.0) THEN IF(ISTATE.EQ.ESPP) THEN c ... derivatives for ISTATE being the lower state ..... IF(NQC(IVPP,ESPP,ISOT).GT.0) THEN IF(IOMEG(ISTATE).LT.0) THEN JJPPW= JPP(IDAT)-MIN(0,EFPP(IDAT)) ELSE JJPPW= JJPPQ**IOMEG(ISTATE) ENDIF IPAR= NQPAR(IVPP,ESPP,ISOT) DO M= 1,NQC(IVPP,ESPP,ISOT) IPAR= IPAR+ 1 c ... NOTE ... neglect derivative if EFPP(idat)= 0 IF(EFPP(IDAT).NE.0) PD(IPAR)= PD(IPAR) 1 - (0.5D0*(EFPP(IDAT)- efREF(ISTATE))*JJPPW) JJPPW= JJPPW*JJPP ENDDO ENDIF ENDIF IF(ISTATE.EQ.ESP) THEN c ... derivatives for ISTATE being the upper state ..... IF(NQC(IVP,ISTATE,ISOT).GT.0) THEN IF(IOMEG(ISTATE).LT.0) THEN JJPW= JP(IDAT)-MIN(0,EFP(IDAT)) ELSE JJPW= JJPQ**IOMEG(ISTATE) ENDIF IPAR= NQPAR(IVP,ISTATE,ISOT) DO M= 1,NQC(IVP,ESP,ISOT) IPAR= IPAR+ 1 IF(EFP(IDAT).NE.0) PD(IPAR)= PD(IPAR) 1 + 0.5D0*(EFP(IDAT)- efREF(ISTATE))*JJPW JJPW= JJPW*JJP ENDDO ENDIF ENDIF IPAR= NQPAR(VMAX(ISTATE)+1,ISTATE,NISTP) ENDIF c c ... if using Dunham-type expansions for doubling constants ... c------------------------------------------------------------------ IF(NDELD(ISTATE).GE.0) THEN c ... First, define rotational q.No. factors ... IF(ISTATE.EQ.ESPP) THEN IF(IOMEG(ISTATE).LT.0) 1 JJPPW= (JPP(IDAT)-MIN(0,EFPP(IDAT)))*RMUP(1,ISOT) IF(IOMEG(ISTATE).GT.0) 1 JJPPW= (JJPPQ * RMUP(2,ISOT))**IOMEG(ISTATE) ENDIF IF(ISTATE.EQ.ESP) THEN IF(IOMEG(ISTATE).LT.0) 1 JJPW= (JP(IDAT)-MIN(0,EFP(IDAT)))*RMUP(1,ISOT) IF(IOMEG(ISTATE).GT.0) 1 JJPW= (JJPQ * RMUP(2,ISOT))**IOMEG(ISTATE) ENDIF IPAR= NQPAR(0,ISTATE,1) DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M IF(LDMAX(MQM,ISTATE).GE.0) THEN DO L= 0,LDMAX(MQM,ISTATE) IPAR= IPAR+ 1 DER= 0.d0 c ... Note - neglect if EFP(idat)= 0 IF((ISTATE.EQ.ESP).AND.(EFP(IDAT).NE.0)) 1 DER= DER + VPHPW(IVP,L)*RSQMUP(L,ISOT) 2 *(EFP(IDAT)- efREF(ISTATE))*JJPW IF((ISTATE.EQ.ESPP).AND.(EFPP(IDAT).NE.0)) 1 DER= DER- VPHPW(IVPP,L)*RSQMUP(L,ISOT) 2 *(EFPP(IDAT)- efREF(ISTATE))*JJPPW PD(IPAR)= 0.5d0*DER ENDDO ENDIF JJPW= JJPW*JJPI JJPPW= JJPPW*JJPPI ENDDO ENDIF ENDIF c====================================================== c** Partial derivatives w.r.t. B-O-B delta parameters c====================================================== IF((BOBORD(ISTATE).GE.0).AND.(IFXGv(ISTATE).LE.0)) THEN c ... loop over atoms ... then over M ... & then over L ZATOM= 1.d0 - ZMASS(1,1)/ZMASS(1,ISOT) ATOM2= 2 IF(AN(1).EQ.AN(2)) THEN c ... and for a homonuclear species, add contributions for the two atoms ATOM2= 1 ZATOM= ZATOM+ 1.d0 - ZMASS(2,1)/ZMASS(2,ISOT) ENDIF DO ATOM= 1,ATOM2 JJPW= 1.d0 JJPPW= 1.d0 LAMIN= 0 IF((ISTATE.EQ.1).AND.(BOB00.LE.0)) LAMIN= 1 DO 80 M= 0,BOBORD(ISTATE) IF(LAMAX(ATOM,M,ISTATE).GE.LAMIN) THEN IF(ESP.EQ.-3) THEN IPAR= IPAR+ LAMAX(ATOM,M,ISTATE)+ 1-LAMIN GO TO 80 ENDIF DO L= LAMIN,LAMAX(ATOM,M,ISTATE) IPAR= IPAR+ 1 DER= 0.d0 IF(ISTATE.EQ.ESP) THEN DER= ZATOM*VPHPW(IVP,L)* 1 RSQMUP(L,ISOT)*JJPW ENDIF IF(ISTATE.EQ.ESPP) THEN DER= DER- ZATOM*VPHPW(IVPP,L)* 1 RSQMUP(L,ISOT)*JJPPW ENDIF PD(IPAR)= DER ENDDO ENDIF JJPW= JJPW*JJPI JJPPW= JJPPW*JJPPI 80 LAMIN= 0 ZATOM= 1.d0 - ZMASS(2,1)/ZMASS(2,ISOT) ENDDO ENDIF 90 CONTINUE c c** And finally ... derivatives w.r.t. to Fluorescence series origin c=================================================================== IF(ESP.EQ.0) PD(NPTOT- NFSTOT+ NFS(IBB))= 1.d0 c if(idat.eq.300) write(9,901) nparm,(pd(i),i=1,nparm) c 901 format(/i6/(4(1Pd20.11))) RETURN c** End of Partial Derivatives for fit to Dunham and/or ND expansions c======================================================================= END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE MAPPAR(NPTOT,PV) c** Subroutine to MAP PARameters PV(i) worked with inside NLLSSRR onto c the NPTOT free parameters of the actual model. c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c INTEGER ATOM,ATOM2,I,IV,IPARDLIM,IFS,IPAR,ISTATE,ISOT, 1 L,LAMIN,M,MQ0,MQM,MMIN,MMAX,NPTOT, NEWGv,NEWBv REAL*8 PV(NPTOT),XX,XXP,YY, ZATOM, Sw, SwLR c c** Type statements and common block for case (type of representation) c REAL*8 XM(0:9,NSTATEMX,NISTPMX),PNDE(0:9,NSTATEMX) c INTEGER NSTATES,IBAND,VMIN(NSTATEMX),VMAX(NSTATEMX), 1 NCDC(NSTATEMX),IOMEG(NSTATEMX),NLDMX(NSTATEMX),efREF(NSTATEMX), 2 MULTPLT(NSTATEMX),NDEGv(NSTATEMX),NDEBv(NSTATEMX), 3 NDECDC(NSTATEMX),NDELD(NSTATEMX),IFXGv(NSTATEMX),IFXBv(NSTATEMX), 4 IFXCDC(NSTATEMX),IFXLD(NSTATEMX),BOBORD(NSTATEMX), 5 NUMNDE(NSTATEMX),IFXD(NSTATEMX),IFXVD(NSTATEMX),ITYPE(NSTATEMX), 6 NP0(NSTATEMX),NQ0(NSTATEMX),IP0(NSTATEMX),IQ0(NSTATEMX), 7 ITYPB(NSTATEMX),NP1(NSTATEMX),NQ1(NSTATEMX),IP1(NSTATEMX), 8 IQ1(NSTATEMX),LMAX(0:9,NSTATEMX),LDMAX(9,NSTATEMX), 9 IFXVS(NSTATEMX),IFXDVS(NSTATEMX),BOB00,LAMAX(2,0:9,NSTATEMX), a IPSTATE(NSTATEMX),NPAR(0:NVIBMX,NSTATEMX,NISTPMX), b NQPAR(0:NVIBMX,NSTATEMX,NISTPMX), c FITGV(0:NVIBMX,NSTATEMX,NISTPMX),NRC(0:NVIBMX,NSTATEMX,NISTPMX), d NQC(0:NVIBMX,NSTATEMX,NISTPMX),NEBC(NSTATEMX) c COMMON /CASEBLK/XM,PNDE, NSTATES,IBAND,VMIN,VMAX,NCDC,IOMEG,NLDMX, 1 efREF,MULTPLT,NDEGv,NDEBv,NDECDC,NDELD,IFXGv,IFXBv,IFXCDC,IFXLD, 2 IFXVS,IFXDVS,BOBORD,NUMNDE,IFXD,IFXVD,ITYPE,NP0,NQ0,IP0,IQ0, 3 ITYPB,NP1,NQ1,IP1,IQ1,LMAX,LDMAX,BOB00,LAMAX,IPSTATE,NPAR,NQPAR, 4 FITGV,NRC,NQC,NEBC c c** Type statements and common block for actual parameter values c REAL*8 Te(NSTATEMX),VPHPW(0:NVIBMX,0:NDUNMX), 1 YLM(0:NDUNMX,0:9,NSTATEMX),DELTA(2,0:NDUNMX,0:9,NSTATEMX), 2 QLM(0:NDUNMX,9,NSTATEMX),DLIMIT(NSTATEMX),VD(NSTATEMX), 3 PM0(NDUNMX,NSTATEMX),QM0(NDUNMX,NSTATEMX),PM1(NDUNMX,NSTATEMX), 4 QM1(NDUNMX,NSTATEMX),VS(NSTATEMX),DVS(NSTATEMX), 5 VSISO(NSTATEMX,NISTPMX),DVSISO(NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 6 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX), 6 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /PARMBLK/Te,VPHPW,YLM,DELTA,QLM,DLIMIT,VD,PM0,QM0,PM1,QM1, 1 VS,DVS,VSISO,DVSISO,ORIGIN,ZK,ZQ c c** Type statement and common block for NDE partial derivative stuff c REAL*8 DGPM(-1:NVIBMX,NSTATEMX,NISTPMX), 1 DGQM(-1:NVIBMX,NSTATEMX,NISTPMX), 2 DGVD(-1:NVIBMX,NSTATEMX,NISTPMX), 3 DBPM(-1:NVIBMX,NSTATEMX,NISTPMX), 4 DBQM(-1:NVIBMX,NSTATEMX,NISTPMX), 5 DBVD(-1:NVIBMX,NSTATEMX,NISTPMX) COMMON /DERVBLK/DGPM,DGQM,DGVD,DBPM,DBQM,DBVD c IPAR= 0 IPARDLIM= -1 NEWGv= 0 NEWBv= 0 DO 50 ISTATE= 1,NSTATES c** Now - identify and update parameters from the fit c c** If use all Term Value representation for this state ... c========================================================== IF((NDEGv(ISTATE).EQ.-2).AND.(IFXGv(ISTATE).LE.0)) THEN c ... need to loop over isotopomers ... DO ISOT= 1,NISTP c ... and cumulatively count parameters ... IPAR= IPAR+ NTV(ISTATE,ISOT) ENDDO GOTO 50 ENDIF c c** If use band-constants to represent vib/rot term values of this state c======================================================================= IF((NDEGv(ISTATE).EQ.-1).AND.(IFXGv(ISTATE).LE.0)) THEN c ... first do outer loop over isotopomers ... DO ISOT= 1,NISTP c ... and then inner loop over vibrational levels. DO IV= VMIN(ISTATE), VMAX(ISTATE) IF(FITGV(IV,ISTATE,ISOT).GT.0) THEN IPAR= IPAR+ 1 ZK(0,IV,ISTATE,ISOT)= PV(IPAR) ENDIF IF(NRC(IV,ISTATE,ISOT).GT.0) THEN DO M= 1,NRC(IV,ISTATE,ISOT) IPAR= IPAR+ 1 ZK(M,IV,ISTATE,ISOT)= PV(IPAR) ENDDO ENDIF ENDDO ENDDO GO TO 30 ENDIF c====end of section for fit to term values or vib-rot band constants==== c c*** First ... update Gv expansion parameters c============================================ c*** If using Dunham or NDE or MXS Gv function for this state MMIN= -1 IF(IFXGv(ISTATE).LE.0) THEN IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).GE.2)) THEN c ... First ... for upper (ISTATE > 1) electronic state, update Te for c pure Dunham or MXS case IF(ISTATE.GT.1) THEN IPAR= IPAR+ 1 Te(ISTATE)= PV(IPAR) YLM(0,0,ISTATE)= Te(ISTATE) ENDIF c ... next update Dunham Gv parameters for MXS or pure Dunham cases ... IF(LMAX(0,ISTATE).GE.1) THEN DO L= 1, LMAX(0,ISTATE) IPAR= IPAR+ 1 YLM(L,0,ISTATE)= PV(IPAR) ENDDO ENDIF MMIN= 0 MMAX= 0 ENDIF c c*** If using MXS function for Gv - update VS & DVS if they are fitted IF((NDEGv(ISTATE).GE.2).AND.(IFXVS(ISTATE).LE.0)) THEN IPAR= IPAR+ 1 VS(ISTATE)= PV(IPAR) IPAR= IPAR+ 1 DVS(ISTATE)= PV(IPAR) XX= VS(ISTATE)+ 0.5d0 DO ISOT= 1, NISTP VSISO(ISTATE,ISOT)= XX/RSQMU(ISOT)- 0.5d0 DVSISO(ISTATE,ISOT)= DVS(ISTATE)/RSQMU(ISOT) ENDDO ENDIF c c*** If using NDE or MXS functions, update NDE parameters for Gv IF(NDEGv(ISTATE).GE.1) THEN NEWGv= 1 IF(IFXD(ISTATE).LE.0) THEN c ... First the value of DLIM (if it was floated) IPAR= IPAR+1 DLIMIT(ISTATE)= PV(IPAR) ENDIF IF(IFXVD(ISTATE).LE.0) THEN c ... then the value of vD for this state (if free) IPAR= IPAR+ 1 VD(ISTATE)= PV(IPAR) ENDIF c ... then the vibrational numerator polynomial coefficients IF(NP0(ISTATE).GT.0) THEN DO I= 1,NP0(ISTATE) IPAR= IPAR+ 1 PM0(I,ISTATE)= PV(IPAR) ENDDO ENDIF IF(NQ0(ISTATE).GT.0) THEN c ... then the vibrational denominator polynomial coefficients DO I= 1,NQ0(ISTATE) IPAR= IPAR+ 1 QM0(I,ISTATE)= PV(IPAR) ENDDO ENDIF ENDIF ENDIF c========================================= c** Now ... update Bv expansion parameters c========================================= IF(IFXBv(ISTATE).LE.0) THEN IF(NDEBv(ISTATE).EQ.-1) THEN c** If use band constants for Rotational (including CDC) constants, but c NOT for Gv ... first do outer loop over isotopomers ... DO ISOT= 1,NISTP c ... and then inner loop over vibrational levels. DO IV= VMIN(ISTATE), VMAX(ISTATE) IF(NRC(IV,ISTATE,ISOT).GT.0) THEN DO M= 1,NRC(IV,ISTATE,ISOT) IPAR= IPAR+ 1 ZK(M,IV,ISTATE,ISOT)= PV(IPAR) ENDDO ENDIF ENDDO ENDDO ENDIF IF((NDEBv(ISTATE).EQ.0).OR.(NDEBv(ISTATE).GE.2)) THEN c ... First Dunham Bv parameters for MXS or pure Dunham cases ... IF(LMAX(1,ISTATE).GE.0) THEN DO L= 0, LMAX(1,ISTATE) IPAR= IPAR+ 1 YLM(L,1,ISTATE)= PV(IPAR) ENDDO ENDIF MMAX= 1 MMIN= 0 IF((NDEGv(ISTATE).EQ.1).OR.(NDEGv(ISTATE).LT.0).OR. 1 (IFXGv(ISTATE).GT.0)) MMIN=1 ENDIF IF(NDEBv(ISTATE).GT.0) THEN NEWBv= 1 IF(NP1(ISTATE).GT.0) THEN c ... if appropriate, update the Bv NDE numerator polynomial coeffts. DO I= 1, NP1(ISTATE) IPAR= IPAR+ 1 PM1(I,ISTATE)= PV(IPAR) ENDDO ENDIF IF(NQ1(ISTATE).GT.0) THEN c... if appropriate, update the Bv NDE denominator polynomial coeffts. DO I= 1, NQ1(ISTATE) IPAR= IPAR+ 1 QM1(I,ISTATE)= PV(IPAR) ENDDO ENDIF ENDIF ENDIF c** Call subroutine to generate updated NDE-type Gv & Bv values AND to c generate core of partial derivatives for next cycle. IF(((NDEGv(ISTATE).GT.0).AND.(IFXGv(ISTATE).LE.0)).OR. 1 ((NDEBv(ISTATE).GT.0).AND.(IFXBv(ISTATE).LE.0))) THEN CALL NDEDGB(ISTATE,NISTP,NEWGv,NEWBv,RSQMU,VMAX(ISTATE)) IF(NDEGv(ISTATE).EQ.1) Te(ISTATE)= ZK(0,-1,ISTATE,1) ENDIF c============================================= c** If fitting to CDC's, update parameters ... c============================================= IF(IFXCDC(ISTATE).LE.0) THEN IF((NDECDC(ISTATE).EQ.-1).AND.(NDEBv(ISTATE).GE.0)) THEN c** If use band constants for CDCs, but NOT for Bv (or Gv) c ... first do outer loop over isotopomers ... DO ISOT= 1,NISTP c ... and then inner loop over vibrational levels. DO IV= VMIN(ISTATE), VMAX(ISTATE) IF(NRC(IV,ISTATE,ISOT).GT.1) THEN DO M= 2,NRC(IV,ISTATE,ISOT) IPAR= IPAR+ 1 ZK(M,IV,ISTATE,ISOT)= PV(IPAR) ENDDO ENDIF ENDDO ENDDO c=====end of section for fit to band constants for CDCs & doubling====== ENDIF IF(NDECDC(ISTATE).EQ.0) THEN c** If fitting to Dunham expansions for the CDCs IF(MMIN.LT.0) MMIN= 2 MMAX= NCDC(ISTATE)+ 1 DO M= 2,MMAX IF(LMAX(M,ISTATE).GE.0) THEN DO L= 0, LMAX(M,ISTATE) IPAR= IPAR+ 1 YLM(L,M,ISTATE)= PV(IPAR) ENDDO ENDIF ENDDO ENDIF ENDIF c IF(MMIN.GE.0) THEN c======================================================================= c** Now generate all relevant Dunham band constants ZK(M,v,ISTATE,ISOT) c======================================================================= DO IV=VMIN(ISTATE), VMAX(ISTATE) DO ISOT= 1,NISTP XX= (IV+ 0.5d0)*RSQMU(ISOT) IF(NDEGv(ISTATE).GE.2) THEN SwLR= dexp((IV- VSISO(ISTATE,ISOT))/ 1 DVSISO(ISTATE,ISOT)) Sw= 1.d0/(1.d0+ SwLR) SwLR= SwLR*Sw ENDIF DO M= MMIN,MMAX IF(LMAX(M,ISTATE).GE.0) THEN YY= 0.d0 DO L= LMAX(M,ISTATE),0,-1 YY= YY*XX + YLM(L,M,ISTATE) ENDDO YY= YY*RMUP(M,ISOT) IF(((M.EQ.0).AND.(NDEGv(ISTATE).GE.2)) 1 .OR.((M.EQ.1).AND.(NDEBv(ISTATE).GE.2))) THEN ZK(M,IV,ISTATE,ISOT)= YY*Sw + 1 SwLR*ZK(M,IV,ISTATE,ISOT) ELSE ZK(M,IV,ISTATE,ISOT)= YY ENDIF ENDIF ENDDO ENDDO ENDDO ENDIF c===================================================================== c*** If appropriate, update Lambda/Gamma doubling expansion parameters c===================================================================== 30 IF((IOMEG(ISTATE).NE.0).AND.(IFXLD(ISTATE).LE.0) 1 .AND.(NLDMX(ISTATE).GE.1)) THEN MQ0= MAX0(0,IOMEG(ISTATE)-1) IF(NDELD(ISTATE).EQ.-1) THEN c ... if using Band Constant form for doubling constants DO ISOT= 1,NISTP c ... first do outer loop over isotopomers ... DO IV= VMIN(ISTATE), VMAX(ISTATE) c ... and then inner loop over vibrational levels. IF(NQC(IV,ISTATE,ISOT).GT.0) THEN DO M= 1,NQC(IV,ISTATE,ISOT) IPAR= IPAR+ 1 ZQ(M+MQ0,IV,ISTATE,ISOT)= PV(IPAR) ENDDO ENDIF ENDDO ENDDO ENDIF IF(NDELD(ISTATE).GE.0) THEN c ... if using Dunham-type representation for doubling constants ... DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M IF(LDMAX(MQM,ISTATE).GE.0) THEN DO L= 0, LDMAX(MQM,ISTATE) IPAR= IPAR+ 1 QLM(L,MQM,ISTATE)= PV(IPAR) ENDDO c ... then generate values of the resulting Lambda doubling coeffts. for c each vibrational level of each isotopomer. DO IV= VMIN(ISTATE),VMAX(ISTATE) DO ISOT= 1,NISTP XX= (IV+ 0.5d0)*RSQMU(ISOT) YY= QLM(0,MQM,ISTATE) IF(LDMAX(MQM,ISTATE).GE.1) THEN XXP= 1.d0 DO L= 1,LDMAX(MQM,ISTATE) XXP= XXP*XX YY= YY+ QLM(L,MQM,ISTATE)*XXP ENDDO ENDIF IF(IOMEG(ISTATE).LT.0) 1 ZQ(M,IV,ISTATE,ISOT)= YY*RMUP(M,ISOT) IF(IOMEG(ISTATE).GT.0) 1 ZQ(MQM,IV,ISTATE,ISOT)= YY*RMUP(1,ISOT)**(MQ0+MQM+1) ENDDO ENDDO ENDIF ENDDO ENDIF ENDIF c c** If appropriate, update B-O-B delta expansion parameters c======================================================================= IF((BOBORD(ISTATE).GE.0).AND.(IFXGv(ISTATE).LE.0)) THEN c ... first ... for atom-A ATOM2= 2 IF(AN(1).EQ.AN(2)) ATOM2= 1 DO ATOM= 1,ATOM2 LAMIN= 0 IF((ISTATE.EQ.1).AND.(BOB00.LE.0)) LAMIN= 1 DO M= 0,BOBORD(ISTATE) IF(LAMAX(ATOM,M,ISTATE).GE.LAMIN) THEN DO L= LAMIN, LAMAX(ATOM,M,ISTATE) IPAR= IPAR+ 1 DELTA(ATOM,L,M,ISTATE)= PV(IPAR) ENDDO ENDIF LAMIN= 0 ENDDO ENDDO c ... & then use these delta's to update the isotopomeric band constants CONTINUE DO ISOT= 1,NISTP DO IV= 0, VMAX(ISTATE) LAMIN= 0 IF((ISTATE.EQ.1).AND.(BOB00.LE.0)) LAMIN= 1 DO M= 0,BOBORD(ISTATE) YY= 0.d0 ZATOM= 1.d0 - ZMASS(1,1)/ZMASS(1,ISOT) IF(AN(1).EQ.AN(2)) ZATOM= ZATOM+ 1.d0 - 1 ZMASS(2,1)/ZMASS(2,ISOT) DO ATOM= 1,ATOM2 IF(LAMAX(ATOM,M,ISTATE).GE.LAMIN) THEN DO L= LAMIN,LAMAX(ATOM,M,ISTATE) YY= YY+VPHPW(IV,L)*RSQMUP(L,ISOT)* 1 DELTA(ATOM,L,M,ISTATE)*ZATOM ENDDO ENDIF ZATOM= 1.d0 - ZMASS(2,1)/ZMASS(2,ISOT) ENDDO ZK(M,IV,ISTATE,ISOT)= ZK(M,IV,ISTATE,ISOT) + 1 YY*RMUP(M,ISOT) LAMIN= 0 ENDDO ENDDO ENDDO ENDIF 50 CONTINUE IF(NFSTOT.GT.0) THEN c** If appropriate, map onto values of fluorescence series band origins. DO IFS= 1,NFSTOT IPAR= IPAR+ 1 ORIGIN(IFS)= PV(IPAR) ENDDO ENDIF RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE PREDICT(IDAT,YC,NCDC,NLDMX,IOMEG,efREF,DLIMIT,ORIGIN, 1 PV,ZK,ZQ) c** Subroutine using existing band constants ZK, lambda doubling c constants ZQ to calculate the value of datum-IDAT. 19/04/05 c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c REAL*8 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 1 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX),DLIMIT(NSTATEMX),PV(NPARMX), 2 YC,JJP,JJPQ,JJPP,JJPPQ,JJPW,JJPPW INTEGER IDAT,IBB,ESP,ESPP,IVP,IVPP,ISOT,M,MMAX,MQ0, 1 NCDC(NSTATEMX),NLDMX(NSTATEMX),IOMEG(NSTATEMX),efREF(NSTATEMX) c c** Type statements & common block for data cc cc REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX), cc 1 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), cc 2 RMUP(0:9,NISTPMX) cc INTEGER COUNTOT,NISTP,NFSTOT,NBANDTOT,AN(2),MN(2,NISTPMX), cc 1 IB(NDATAMX),JP(NDATAMX),JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX), cc 2 EFP(NDATAMX),EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX), cc 3 FSBAND(NBANDMX),NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX), cc 4 ISTP(NBANDMX),IFIRST(NBANDMX),ILAST(NBANDMX), cc 5 NTV(NSTATEMX,NISTPMX) cc CHARACTER*2 NAME(2),SLABL(-3:NSTATEMX) cc COMMON /DATABLK/FREQ,UFREQ,DFREQ,ZMASS,RSQMU,RSQMUP,RMUP,COUNTOT, cc 1 NISTP,NFSTOT,NBANDTOT,AN,MN,IB,JP,JPP,EFP,EFPP,TVUP,TVLW,VP,VPP, cc 2 FSBAND,NFS,IEP,IEPP,ISTP,IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= IBB= IB(IDAT) ESP= IEP(IBB) ESPP= IEPP(IBB) IVP= VP(IBB) IVPP= VPP(IBB) IF(ESP.LE.0) IVPP= JP(IDAT) ISOT= ISTP(IBB) IF(ESP.EQ.-3) THEN c** For input state s=ESPP Bv value, return current predicted value ... YC = ZK(1,IVPP,ESPP,ISOT) RETURN ENDIF c c** First treat lower level of the transition ......... c======================================================================= IF(TVLW(IDAT).GT.0) THEN c ... if it is represented by an individual fitted term value c [TVLW is parameter counter: Lower level term value for transition IDAT] c------------------------------------------------------------ YC= - PV(TVLW(IDAT)) IF(ESP.EQ.0) YC= YC+ ORIGIN(NFS(IBB)) IF(ESP.EQ.-1) YC= YC+ DLIMIT(ESPP) IF(ESP.LE.0) RETURN ELSE c Otherwise - first define the lower state centrifugal factor JJPPQ= JPP(IDAT)*(JPP(IDAT)+ 1) IF(IOMEG(ESPP).LE.0) THEN JJPP= JJPPQ ELSE JJPP= JJPPQ - IOMEG(ESPP)**2 ENDIF YC= 0.d0 c ... then, for FS or PAS datum or term-value upper level, sum c------------------------------- lower-level mechanical rotation terms IF((ESP.LE.0).OR.(TVUP(IDAT).GT.0)) THEN MMAX= NCDC(ESPP)+ 1 JJPPW= 1.d0 YC= - ZK(0,IVPP,ESPP,ISOT) DO M= 1,MMAX JJPPW= JJPPW*JJPP YC= YC - ZK(M,IVPP,ESPP,ISOT)*JJPPW ENDDO ENDIF ENDIF c c** Now ... treat upper level or origin of transition ... c======================================================================= IF(TVUP(IDAT).GT.0) THEN c ... if it is represented by an individual fitted term value YC= YC+ PV(TVUP(IDAT)) IF(IOMEG(ESPP).NE.0) GOTO 20 RETURN ENDIF IF((ESP.EQ.0).OR.(ESP.EQ.-1)) THEN c ... if it is a fluorescence series or PAS datum ... IF(ESP.EQ.0) YC= YC + ORIGIN(NFS(IBB)) IF(ESP.EQ.-1) YC= YC + DLIMIT(ESPP) ENDIF IF(ESP.GT.0) THEN c** For mechanical upper-state level, first define rotational factor ... JJPQ= JP(IDAT)*(JP(IDAT)+ 1) IF(IOMEG(ESP).LE.0) THEN JJP=JJPQ ELSE JJP= JJPQ - IOMEG(ESP)**2 ENDIF IF(TVLW(IDAT).GT.0) THEN c ... sum mechanical rotation terms if lower level given by term value MMAX= NCDC(ESP)+ 1 JJPW= 1.d0 YC= YC+ ZK(0,IVP,ESP,ISOT) DO M= 1, MMAX JJPW= JJPW* JJP YC= YC+ ZK(M,IVP,ESP,ISOT)*JJPW ENDDO ELSE c ... else minimize truncation errors using joint upper/lower rot. sums MMAX= MAX(NCDC(ESP),NCDC(ESPP))+ 1 JJPW= 1.d0 JJPPW= 1.d0 YC= ZK(0,IVP,ESP,ISOT)- ZK(0,IVPP,ESPP,ISOT) IF(MMAX.GE.1) THEN DO M= 1,MMAX JJPW= JJPW*JJP JJPPW= JJPPW*JJPP YC= YC+ ZK(M,IVP,ESP,ISOT)*(JJPW- JJPPW) - 1 (ZK(M,IVPP,ESPP,ISOT)- ZK(M,IVP,ESP,ISOT))*JJPPW ENDDO ENDIF ENDIF ENDIF cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c** If appropriate include lower-level Lambda or ^2\Sigma doubling shift c----------------------------------------------------------------------- c If considering doublet Sigma e/f splitting (gamma-doubling) c e par is +1/2 N { g1 + g2 N(N+1) + g3 [N(N+1)]^2 + ...} c f par is -1/2 (N+1) { g1 + g2 N(N+1) + g3 [N(N+1)]^2 + ...} c while for Lambda doubling, for both parities (EFPP= +/-1 for e/f) c Delta(E)= (1/2)(EFPP - efREF) [J(J+1)] { q1 + q2[J(J+1) - OMEGA^2] c + q3 [J(J+1) - OMEGA^2]^2 + ...} cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 20 IF((IOMEG(ESPP).NE.0).AND.(EFPP(IDAT).NE.0).AND. 1 (NLDMX(ESPP).GE.1)) THEN MQ0= MAX0(0,IOMEG(ESPP)-1) IF(IOMEG(ESPP).LT.0) THEN JJPPW= JPP(IDAT)- MIN(0,EFPP(IDAT)) ELSE JJPPW= JJPPQ**IOMEG(ESPP) ENDIF DO M= 1,NLDMX(ESPP) YC= YC - 0.5d0*(EFPP(IDAT) - efREF(ESPP))* 1 ZQ(M+MQ0,IVPP,ESPP,ISOT)*JJPPW JJPPW= JJPPW*JJPP ENDDO ENDIF c ... then deal with upper state Lambda or ^2\Sigma doubling, if present IF(ESP.GT.0) THEN IF((IOMEG(ESP).NE.0).AND.(EFP(IDAT).NE.0) 1 .AND.(NLDMX(ESP).GE.1)) THEN MQ0= MAX0(0,IOMEG(ESP)-1) IF(IOMEG(ESP).LT.0) THEN JJPW= JP(IDAT)- MIN(0,EFP(IDAT)) ELSE JJPW= JJPQ**IOMEG(ESP) ENDIF DO M= 1,NLDMX(ESP) YC= YC + 0.5d0*(EFP(IDAT)- efREF(ESP))* 1 ZQ(M+MQ0,IVP,ESP,ISOT)*JJPW JJPW= JJPW*JJP ENDDO ENDIF ENDIF RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE PPISOT(NISTP,AN,MN,PV,PU,PS,CM,ZMASS,RSQMUP,RMUP,NAME, 1 SLABL,NAMEPARM) c** Subroutine to create and print maximally rounded (to Sensitivity) c Dunham Ylm or NDE parameters for minority isotopomers (ISOT>1) . c** While this subroutine only (currently) works with Dunham-type YLM c (or qLM) parameters, the looping must consider ALL parameters, to c get the count/labelling correct. Version date: 15/05/05 c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c REAL*8 ZMASS(3,NISTPMX),RSQMUP(0:NDUNMX,NISTPMX),RMUP(0:9,NISTPMX) REAL*8 PYLM(0:NDUNMX,0:9,NISTPMX),UYLM(0:NDUNMX,0:9,NISTPMX), 1 SYLM(0:NDUNMX,0:9,NISTPMX),PqLM(0:NDUNMX,0:9,NISTPMX), 2 UqLM(0:NDUNMX,0:9,NISTPMX),SqLM(0:NDUNMX,0:9,NISTPMX),PV(NPARMX), 3 PU(NPARMX),PS(NPARMX),CM(NPARMX,NPARMX),PFCT,FMU,FMU1,D10,D20, 4 D01,D11, Y00SC(NISTPMX),U00SC(NISTPMX),UZPE(NISTPMX) real*8 tst INTEGER I,ILM,IPAR,ISTATE,ISOT,IVIB,IROT,L,LMIN,LAMIN,M,MQ0,MQM, 1 MMIN,MMAX,MN(2,NISTPMX),NISTP,ATOM,ATOM2,AN(2) INTEGER IYLM(0:NDUNMX,0:9),IqLM(0:NDUNMX,0:9),IDLM(0:NDUNMX,0:9) CHARACTER*20 NAMEPARM(NPARMX),NAMEY00 CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c c** Type statements and common block for case (type of representation) c REAL*8 XM(0:9,NSTATEMX,NISTPMX),PNDE(0:9,NSTATEMX) c INTEGER NSTATES,IBAND,VMIN(NSTATEMX),VMAX(NSTATEMX), 1 NCDC(NSTATEMX),IOMEG(NSTATEMX),NLDMX(NSTATEMX),efREF(NSTATEMX), 2 MULTPLT(NSTATEMX),NDEGv(NSTATEMX),NDEBv(NSTATEMX), 3 NDECDC(NSTATEMX),NDELD(NSTATEMX),IFXGv(NSTATEMX),IFXBv(NSTATEMX), 4 IFXCDC(NSTATEMX),IFXLD(NSTATEMX),BOBORD(NSTATEMX), 5 NUMNDE(NSTATEMX),IFXD(NSTATEMX),IFXVD(NSTATEMX),ITYPE(NSTATEMX), 6 NP0(NSTATEMX),NQ0(NSTATEMX),IP0(NSTATEMX),IQ0(NSTATEMX), 7 ITYPB(NSTATEMX),NP1(NSTATEMX),NQ1(NSTATEMX),IP1(NSTATEMX), 8 IQ1(NSTATEMX),LMAX(0:9,NSTATEMX),LDMAX(9,NSTATEMX), 9 IFXVS(NSTATEMX),IFXDVS(NSTATEMX),BOB00,LAMAX(2,0:9,NSTATEMX), a IPSTATE(NSTATEMX),NPAR(0:NVIBMX,NSTATEMX,NISTPMX), b NQPAR(0:NVIBMX,NSTATEMX,NISTPMX), c FITGV(0:NVIBMX,NSTATEMX,NISTPMX),NRC(0:NVIBMX,NSTATEMX,NISTPMX), d NQC(0:NVIBMX,NSTATEMX,NISTPMX),NEBC(NSTATEMX) c COMMON /CASEBLK/XM,PNDE, NSTATES,IBAND,VMIN,VMAX,NCDC,IOMEG,NLDMX, 1 efREF,MULTPLT,NDEGv,NDEBv,NDECDC,NDELD,IFXGv,IFXBv,IFXCDC,IFXLD, 2 IFXVS,IFXDVS,BOBORD,NUMNDE,IFXD,IFXVD,ITYPE,NP0,NQ0,IP0,IQ0, 3 ITYPB,NP1,NQ1,IP1,IQ1,LMAX,LDMAX,BOB00,LAMAX,IPSTATE,NPAR,NQPAR, 4 FITGV,NRC,NQC,NEBC c c** Type statements and common block for actual parameter values c REAL*8 Te(NSTATEMX),VPHPW(0:NVIBMX,0:NDUNMX), 1 YLM(0:NDUNMX,0:9,NSTATEMX),DELTA(2,0:NDUNMX,0:9,NSTATEMX), 2 QLM(0:NDUNMX,9,NSTATEMX),DLIMIT(NSTATEMX),VD(NSTATEMX), 3 PM0(NDUNMX,NSTATEMX),QM0(NDUNMX,NSTATEMX),PM1(NDUNMX,NSTATEMX), 4 QM1(NDUNMX,NSTATEMX),VS(NSTATEMX),DVS(NSTATEMX), 5 VSISO(NSTATEMX,NISTPMX),DVSISO(NSTATEMX,NISTPMX),ORIGIN(NBANDMX), 6 ZK(0:9,-1:NVIBMX,NSTATEMX,NISTPMX), 6 ZQ(9,-1:NVIBMX,NSTATEMX,NISTPMX) c COMMON /PARMBLK/Te,VPHPW,YLM,DELTA,QLM,DLIMIT,VD,PM0,QM0,PM1,QM1, 1 VS,DVS,VSISO,DVSISO,ORIGIN,ZK,ZQ c DATA NAMEY00/' Delta{T(v=-1/2)}'/ c----------------------------------------------------------------------- IPAR= 0 ccc IPARDLIM= -1 DO 50 ISTATE= 1,NSTATES c** Treat one electronic state at a time. Skip over band constant fit c cases or cases when Gv & Bv held fixed. DO ISOT= 1, NISTP PYLM(0,0,ISOT)= 0.d0 UYLM(0,0,ISOT)= 0.d0 SYLM(0,0,ISOT)= 0.d0 ENDDO IF(NDEGv(ISTATE).LT.0) GO TO 50 IPAR= IPSTATE(ISTATE) DO M= 0,9 DO L= 0,NDUNMX IYLM(L,M)= 0 ENDDO ENDDO c** Alternately, if use Dunham or NDE functions for this state ... MMIN= -1 IF(IFXGv(ISTATE).LE.0) THEN IF((NDEGv(ISTATE).EQ.0).OR.(NDEGv(ISTATE).GE.2)) THEN c*** If Dunham parameters are used in pure Dunham or MXS for Gv ... c ... first - for upper (ISTATE > 1) electronic states, count Te IF(ISTATE.GT.1) IPAR= IPAR+ 1 IVIB= IPAR+ 1 DO L= 1, LMAX(0,ISTATE) c ... then generate minority isotopomer YLM's IPAR= IPAR+ 1 IYLM(L,0)= IPAR DO ISOT= 1,NISTP PFCT= RMUP(0,ISOT)*RSQMUP(L,ISOT) PYLM(L,0,ISOT)= PV(IPAR)*PFCT UYLM(L,0,ISOT)= (PU(IPAR)*PFCT)**2 SYLM(L,0,ISOT)= (PS(IPAR)*PFCT)**2 ENDDO ENDDO MMIN= 0 MMAX= 0 ENDIF c IF(NDEGv(ISTATE).GT.0) THEN c** If NDE expressions used (in MXS or pure NDE) functions for Gv ... IF(IFXD(ISTATE).LE.0) IPAR= IPAR+1 c ... first, count free D & vD, if appropriate IF(IFXVD(ISTATE).LE.0) IPAR= IPAR+ 1 c ... then count any vibrational numerator polynomial coefficients IF(NP0(ISTATE).GT.0) THEN DO I= 1,NP0(ISTATE) IPAR= IPAR+ 1 ENDDO ENDIF IF(NQ0(ISTATE).GT.0) THEN c ... then count any vibrational denominator polynomial coefficients DO I= 1,NQ0(ISTATE) IPAR= IPAR+ 1 ENDDO ENDIF ENDIF ENDIF c IF(IFXBv(ISTATE).LE.0) THEN c** Now ... consider/count Bv parameters ... IF(NDEBv(ISTATE).EQ.-1) THEN c** If using band constants for Bv's but not Gv, count to get BOB c corrections right. DO ISOT= 1, NISTP DO I= VMIN(ISTATE), VMAX(ISTATE) IF(NRC(I,ISTATE,ISOT).GE.1) IPAR= IPAR + 1 ENDDO ENDDO ENDIF IF((NDEBv(ISTATE).EQ.0).OR.(NDEBv(ISTATE).GE.2)) THEN c*** If Dunham parameters are used in pure Dunham or MXS for Bv ... IROT= IPAR+ 1 DO L= 0, LMAX(1,ISTATE) IPAR= IPAR+ 1 IYLM(L,1)= IPAR DO ISOT= 1,NISTP PFCT= RMUP(1,ISOT)*RSQMUP(L,ISOT) PYLM(L,1,ISOT)= PV(IPAR)*PFCT UYLM(L,1,ISOT)= (PU(IPAR)*PFCT)**2 SYLM(L,1,ISOT)= (PS(IPAR)*PFCT)**2 ENDDO ENDDO MMIN= 0 IF((NDEGv(ISTATE).EQ.1).OR.(IFXGv(ISTATE).GT.0))MMIN=1 MMAX= 1 ENDIF IF(NDEBv(ISTATE).GT.0) THEN c ... and if NDE function is used for Bv's ... IF(NP1(ISTATE).GT.0) THEN c ... then count any rotational NDE numerator polynomial coefficients DO I= 1, NP1(ISTATE) IPAR= IPAR+ 1 ENDDO ENDIF IF(NQ1(ISTATE).GT.0) THEN c ... then count any rotational NDE denominator polynomial coefficients DO I= 1, NQ1(ISTATE) IPAR= IPAR+ 1 ENDDO ENDIF ENDIF ENDIF c IF(IFXCDC(ISTATE).LE.0) THEN IF(NDECDC(ISTATE).EQ.-1) THEN c** If using band constants for CDC's but not Bv and/or Gv, need c count to get BOB corrections right. DO ISOT= 1, NISTP DO I= VMIN(ISTATE),VMAX(ISTATE) IF(NRC(I,ISTATE,ISOT).GE.2) 1 IPAR= IPAR+ NRC(I,ISTATE,ISOT) - 1 ENDDO ENDDO ENDIF IF(NDECDC(ISTATE).EQ.0) THEN c** If fitting to CDC's using Dunham form, count parameters & prepare .. IF(MMIN.LT.0) MMIN= 2 MMAX= NCDC(ISTATE)+ 1 DO M= 2,MMAX DO L= 0, LMAX(M,ISTATE) IPAR= IPAR+ 1 IYLM(L,M)= IPAR DO ISOT= 1,NISTP PFCT= RMUP(M,ISOT)*RSQMUP(L,ISOT) PYLM(L,M,ISOT)= PV(IPAR)*PFCT UYLM(L,M,ISOT)= (PU(IPAR)*PFCT)**2 SYLM(L,M,ISOT)= (PS(IPAR)*PFCT)**2 ENDDO ENDDO ENDDO ENDIF ENDIF c IF((IOMEG(ISTATE).NE.0).AND.(NDELD(ISTATE).GE.0).AND. 1 (NLDMX(ISTATE).GT.0).AND.(IFXLD(ISTATE).LE.0)) THEN c** If fitting to Dunham-type Lambda/Gamma doubling expansion parameters MQ0= MAX0(0,IOMEG(ISTATE)-1) DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M IF(LDMAX(MQM,ISTATE).GE.0) THEN DO L= 0, LDMAX(MQM,ISTATE) IPAR= IPAR+ 1 IqLM(L,MQM)= IPAR DO ISOT= 1, NISTP IF(IOMEG(ISTATE).LT.0) 1 PFCT= RSQMUP(L,ISOT)* RMUP(M,ISOT) IF(IOMEG(ISTATE).GT.0) 1 PFCT= PFCT* RMUP(1,ISOT)* RMUP(MQ0,ISOT)**2 PqLM(L,MQM,ISOT)= PV(IPAR)*PFCT UqLM(L,MQM,ISOT)= PU(IPAR)*PFCT SqLM(L,MQM,ISOT)= PS(IPAR)*PFCT ENDDO ENDDO ENDIF ENDDO ENDIF c IF((BOBORD(ISTATE).GE.0).AND.(IFXGv(ISTATE).LE.0)) THEN c** If appropriate, count B-O-B delta expansion parameters, correct c mass-scaled YLM's and generate appropriate fully correlated uncert. DO M= 0,9 DO L= 0,NDUNMX IDLM(L,M)= 0 ENDDO ENDDO ATOM2= 2 c** If both atoms are the same chemical species ... IF(AN(1).EQ.AN(2)) ATOM2= 1 DO ATOM= 1,ATOM2 LAMIN= 0 IF((ISTATE.EQ.1).AND.(BOB00.LE.0)) LAMIN= 1 DO M= 0,BOBORD(ISTATE) IF(LAMAX(ATOM,M,ISTATE).GE.LAMIN) THEN DO L= LAMIN, LAMAX(ATOM,M,ISTATE) IPAR= IPAR+ 1 ILM= IYLM(L,M) IF(ATOM.EQ.1) IDLM(L,M)= IPAR c ... correct isotopomeric YLM's for delta contributions DO ISOT= 1, NISTP PFCT= RMUP(M,ISOT)*RSQMUP(L,ISOT) FMU= PFCT*(1.d0- ZMASS(ATOM,1)/ 1 ZMASS(ATOM,ISOT)) c ... using a combined mass scaling factor for the homonuclear case IF(ATOM2.EQ.1) FMU= FMU+ PFCT* 1 (1.d0- ZMASS(2,1)/ZMASS(2,ISOT)) PYLM(L,M,ISOT)= PYLM(L,M,ISOT)+ 1 FMU*PV(IPAR) c ... and generate corrected correlated uncertainties & sensitivities UYLM(L,M,ISOT)= UYLM(L,M,ISOT)+ 1 (FMU*PU(IPAR))**2 SYLM(L,M,ISOT)= SYLM(L,M,ISOT)+ 1 (FMU*PS(IPAR))**2 IF(ILM.GT.0) THEN UYLM(L,M,ISOT)= UYLM(L,M,ISOT)+ 1 2.d0*FMU*PU(IPAR)*PFCT*PU(ILM)*CM(IPAR,ILM) ENDIF IF((ATOM.EQ.2).AND.(IDLM(L,M).GT.0)) 1 THEN c ... including, if appropriate, the Atom-1/Atom-2 cross term FMU1= (1.d0- ZMASS(1,1)/ 1 ZMASS(1,ISOT)) UYLM(L,M,ISOT)= UYLM(L,M,ISOT)+ 1 2.d0*FMU*PU(IPAR)*FMU1*PU(IDLM(L,M))*CM(IPAR,IDLM(L,M)) ENDIF ENDDO ENDDO ENDIF LAMIN= 0 ENDDO ENDDO ENDIF c** Now ... round and print the resulting isotopomeric YLM's IF((IFXGv(ISTATE).GT.0).OR.(IFXBv(ISTATE).GT.0)) GO TO 50 IF(NISTP.GT.1) WRITE(6,600) SLABL(ISTATE),((NAME(ATOM), 1 MN(ATOM,ISOT),ATOM=1,2),ISOT= 2,NISTP) IF(LMAX(0,ISTATE).GT.0) WRITE(6,604) SLABL(1), 1 (ZK(0,0,ISTATE,ISOT),ISOT= 1,NISTP) c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c** Calculate & print uncertainties in [G(v=0)-G(v=-1/2)] ccc RJL should re-think what this is supposed to be doing, and why! ccc ccc IF(LMAX(0,ISTATE).GT.0) THEN ccc DO ISOT= 1,NISTP ccc UZPE(ISOT)= 0.d0 ccc DO L= 1, LMAX(0,ISTATE) ccc PFCT= 0.d0 ccc DO I= 1, LMAX(0,ISTATE) ccc PFCT= PFCT + VPHPW(0,I)*RSQMUP(I,ISOT)* ccc 1 UYLM(I,0,ISOT)*CM(IVIB+L-1,IVIB+I-1) ccc ENDDO ccc UZPE(ISOT)= UZPE(ISOT) ccc 1 + PFCT*VPHPW(0,L)*RSQMUP(L,ISOT)*UYLM(I,0,ISOT) ccc ENDDO ccc UZPE(ISOT)= DSQRT(UZPE(ISOT)) ccc ENDDO ccc WRITE(6,606) (UZPE(ISOT), ISOT= 1,NISTP) ccc 606 FORMAT(/' Uncertainty in [G(v=0)-G(v=-1/2)] for reference isotop ccc 1omer:',F10.6:/5x,'and others:',6F10.6:/(16x,6F10.6:)) ccc ENDIF ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c** Calculate & print Y00(semiclassical) & its uncertainties IF((LMAX(0,ISTATE).GE.2).AND.(LMAX(1,ISTATE).GE.1)) THEN DO ISOT= 1, NISTP PFCT= PYLM(1,0,ISOT)*PYLM(1,1,ISOT)/ 1 (12.d0*PYLM(0,1,ISOT)) Y00SC(ISOT)= 0.25D0*(PYLM(0,1,ISOT)+ PYLM(2,0,ISOT)) 1 - PFCT + PFCT**2/PYLM(0,1,ISOT) D10= (-PFCT + 2.d0*PFCT**2/PYLM(0,1,ISOT)) D11= DSQRT(UYLM(1,1,ISOT))*(D10/PYLM(1,1,ISOT)) 1 *RSQMUP(3,ISOT) D10= DSQRT(UYLM(1,0,ISOT))*D10/PYLM(1,0,ISOT) 1 *RSQMUP(1,ISOT) D20= 0.25d0*RMUP(1,ISOT)*DSQRT(UYLM(2,0,ISOT)) D01= (0.25d0 + PFCT/PYLM(0,1,ISOT) - 3.d0*(PFCT/ 1 PYLM(0,1,ISOT))**2)*RMUP(1,ISOT)*DSQRT(UYLM(0,1,ISOT)) PFCT= D10*(D10+ D20*CM(IVIB,IVIB+1)+ D01*CM(IVIB,IROT) 1 + D11*CM(IVIB,IROT+1)) + D20*(D10*CM(IVIB,IVIB+1) + D20 2 + D01*CM(IVIB+1,IROT) + D11*CM(IVIB+1,IROT+1)) 3 + D01*(D10*CM(IVIB,IROT) + D20*CM(IVIB+1,IROT) + D01 4 + D11*CM(IROT,IROT+1)) + D11*(D10*CM(IVIB,IROT+1) 5 + D20*CM(IVIB+1,IROT+1) + D01*CM(IROT,IROT+1) + D11) U00SC(ISOT)= DSQRT(PFCT) ENDDO WRITE(6,608) (Y00SC(ISOT),U00SC(ISOT),ISOT= 1,NISTP) ENDIF WRITE(6,603) c c** Now print overall isotopomer Ylm's and their uncertainties! IF((MMIN.GE.0).AND.(NISTP.GE.2)) THEN DO M= MMIN,MMAX LMIN= 0 IF((M.EQ.0).AND.(ISTATE.EQ.1)) LMIN= 1 IF((M.EQ.0).AND.(ISTATE.GT.1).AND. 1 (BOBORD(ISTATE).GE.0)) WRITE(6,612) DO L= LMIN,LMAX(M,ISTATE) DO ISOT= 1,NISTP UYLM(L,M,ISOT)= SQRT(UYLM(L,M,ISOT)) SYLM(L,M,ISOT)= SQRT(SYLM(L,M,ISOT)) IF(ISOT.GT.1) THEN IF(DABS(PYLM(L,M,ISOT)).GT.0.d0) 1 CALL ROUNDSEN(PYLM(L,M,ISOT),SYLM(L,M,ISOT)) ENDIF ENDDO IF((M.EQ.0).AND.(L.EQ.0)) THEN WRITE(6,602) NAMEY00,(PYLM(L,M,ISOT), 1 UYLM(L,M,ISOT),ISOT= 2,NISTP) WRITE(9,902) NAMEY00,PYLM(L,M,1), 1 UYLM(L,M,1),(PYLM(L,M,ISOT),ISOT= 2,NISTP) ELSE WRITE(6,602) NAMEPARM(IYLM(L,M)), 1 (PYLM(L,M,ISOT),UYLM(L,M,ISOT),ISOT= 2,NISTP) WRITE(9,902) NAMEPARM(IYLM(L,M)),PYLM(L,M,1), 1 UYLM(L,M,1),(PYLM(L,M,ISOT),ISOT= 2,NISTP) ENDIF ENDDO WRITE(6,603) ENDDO ENDIF c c** If appropriate ... round and print the resulting isotopomeric qLM's IF((IOMEG(ISTATE).NE.0).AND.(NDELD(ISTATE).GE.0).AND. 1 (NLDMX(ISTATE).GT.0).AND.(IFXLD(ISTATE).LE.0).AND. 2 (NISTP.GE.2)) THEN WRITE(6,610) SLABL(ISTATE),((NAME(ATOM),MN(ATOM,ISOT), 1 ATOM=1,2),ISOT= 2,NISTP) WRITE(6,603) DO M= 1,NLDMX(ISTATE) MQM= MQ0+ M IF(LDMAX(MQM,ISTATE).GE.0) THEN DO L= 0,LDMAX(MQM,ISTATE) DO ISOT= 1,NISTP IF(ISOT.GT.1) THEN IF(DABS(PqLM(L,MQM,ISOT)).GT.0.d0) 1 CALL ROUNDSEN(PqLM(L,MQM,ISOT),SqLM(L,MQM,ISOT)) ENDIF ENDDO WRITE(6,602) NAMEPARM(IqLM(L,MQM)), 1 (PqLM(L,MQM,ISOT),UqLM(L,MQM,ISOT),ISOT= 2,NISTP) WRITE(9,902) NAMEPARM(IqLM(L,MQM)), 1 PqLM(L,MQM,1),UqLM(L,MQM,1),(PqLM(L,MQM,ISOT),ISOT= 2,NISTP) ENDDO ENDIF ENDDO WRITE(6,603) ENDIF 50 CONTINUE RETURN 600 FORMAT(/" State-",A3," Sensitivity-Rounded parameters's for Minori 1ty Isotopomers:"/1x,32('==')/(4(4x,a2,"(",i3,")-",a2,"(",i3,")":) 2 )) 602 FORMAT(a20,2(1PD19.11,' (',D7.1,')':)/ 1 (20x,2(1PD19.11,' (',D7.1,')':))) 603 FORMAT(' ') 604 FORMAT(/' Zero point level T(v=0) relative to v= -1/2 of the first 1 state considered (',A2,')'/4x,'for the reference isotopomer is:', 2 F15.6:/4x,'and for the others:',4F14.6:/(16x,4F14.6:)) 608 FORMAT(/' Semiclassical Y00 of the reference isotopomer is:', 1 F10.6,'(',F9.6,')':/4x,'& of others:',3(F10.6,'(',F9.6,')':)/ 2 (16x,3(F10.6,'(',F9.6,')':))) 610 FORMAT(/" State-",A3," Sensitivity-Rounded qLM's for Minority Isot 1opomers:"/(4(4x,a2,"(",i3,")-",a2,"(",i3,")":))) 612 FORMAT(2x,'Delta{T(v=-1/2)} = [T(v=-1/2;{this isotopomer}) - T(v=- 11/2;{ref.isotopomer})]') c 901 FORMAT(A20,10(' &',1PD19.11,' (',D7.1,')')) 902 FORMAT('10^{0} &',A20,' &',1PD19.11,' (',D7.1,')',9(' &', 1 1PD19.11:)) END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c*********************************************************************** SUBROUTINE ROUNDSEN(PV,PS) c** Subroutine to round off parameter with value PV at the c IROUND'th significant digit of the quantity [its sensitivity] PS . c** On return, the rounded value replaced the initial value PV. 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,IRND,KRND REAL*8 PV,PS,CRND,XRND,FCT,UU,CNST XRND= 0.d0 IROUND= 1 CNST= PV UU= CNST XRND= DLOG10(PS) 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/FCT XRND= 0.d0 IF(DABS(CRND).GE.1.D+8) THEN c ... if rounding goes past REAL*8 precision, retain unrounded constant IF(DABS(CRND).GE.2.D+17) THEN WRITE(6,601) IROUND 601 FORMAT(1x,39('==')/' Caution:',i3,'-digit rounding would exceed (a 1assumed) REAL*8'/' ******** precision overflow at 1.D+16, so kee 2p unrounded constant') RETURN ENDIF 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= CNST c WRITE(6,614) UU,PS,PV c 614 FORMAT(1x,30('==')/' Round Off PV=',1PD22.14,' with PS=', c 1 d9.2/3x,'fixing it as ',D22.14) RETURN END c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 *********************************************************************** SUBROUTINE DIFFSTATS(NSTATES,ROBUST,MKPRED) 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 15 May 2005 c----------------------------------------------------------------------- cc INCLUDE 'arrsizes.h' c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c** BLOCK DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= c INTEGER I,IBB,ISOT,ISTATE,ISTATEE,J,NSTATES,MKPRED,ROBUST REAL*8 AVE,AVETOT,DIV,RMSR,RMSTOT,SSQTOT CHARACTER*3 MARKER,NEF(-1:1) c c** Type statements & common blocks for characterizing transitions c REAL*8 AVEUFREQ(NBANDMX),MAXUFREQ(NBANDMX) 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 NBVPP(NISTPMX,NSTATEMX),NWIDTH(NISTPMX,NSTATEMX), 6 NEBPAS(NISTPMX,NSTATEMX),NBANDS(NISTPMX), 7 YPR(NISTPMX,NSTATEMX,7,6,NBANDMX) c COMMON /TYPEBLK/AVEUFREQ,MAXUFREQ,NTRANSFS,NTRANSVIS,NTRANSIR, 1 NTRANSMW,NBANDFS,NBANDEL,NBANDVIS,NBANDIR,NBANDMW,NBVPP,NWIDTH, 2 NEBPAS,NBANDS,YPR c DATA NEF/' f',' ef',' e'/ c======================================================================== ISOT= 1 SSQTOT= 0.d0 IF(MKPRED.GT.0) WRITE(6,600) c** Summarize data discrepancies for one isotopomer 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) IBB= YPR(ISOT,ISTATE,4,4,I) IF(MKPRED.LE.0) THEN CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE,RMSR, 1 SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ YPR(ISOT,ISTATE,4,3,I)*RMSR**2 AVETOT= AVETOT+ YPR(ISOT,ISTATE,4,3,I)*AVE WRITE(6,606)YPR(ISOT,ISTATE,4,2,I), 1 YPR(ISOT,ISTATE,4,1,I),YPR(ISOT,ISTATE,4,3,I), 2 YPR(ISOT,ISTATE,4,5,I),YPR(ISOT,ISTATE,4,6,I), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR ENDIF WRITE(8,605) IF(MKPRED.LE.0) WRITE(8,606) YPR(ISOT,ISTATE,4,2,I), 1 YPR(ISOT,ISTATE,4,1,I),YPR(ISOT,ISTATE,4,3,I), 2 YPR(ISOT,ISTATE,4,5,I),YPR(ISOT,ISTATE,4,6,I), 4 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR IF(MKPRED.GT.0) WRITE(8,606) YPR(ISOT,ISTATE,4,2,I), 1 YPR(ISOT,ISTATE,4,1,I),YPR(ISOT,ISTATE,4,3,I), 2 YPR(ISOT,ISTATE,4,5,I),YPR(ISOT,ISTATE,4,6,I) CALL PBNDERR(IBB,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) IBB= YPR(ISOT,ISTATE,3,4,I) IF(MKPRED.LE.0) THEN CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE,RMSR, 1 SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ YPR(ISOT,ISTATE,3,3,I)*RMSR**2 AVETOT= AVETOT+ YPR(ISOT,ISTATE,3,3,I)*AVE WRITE(6,606) YPR(ISOT,ISTATE,3,2,I), 1 YPR(ISOT,ISTATE,3,1,I),YPR(ISOT,ISTATE,3,3,I), 2 YPR(ISOT,ISTATE,3,5,I),YPR(ISOT,ISTATE,3,6,I), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR ENDIF WRITE(8,605) IF(MKPRED.LE.0) WRITE(8,606) YPR(ISOT,ISTATE,3,2,I), 1 YPR(ISOT,ISTATE,3,1,I),YPR(ISOT,ISTATE,3,3,I), 2 YPR(ISOT,ISTATE,3,5,I),YPR(ISOT,ISTATE,3,6,I), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR IF(MKPRED.GT.0) WRITE(8,606) YPR(ISOT,ISTATE,3,2,I), 1 YPR(ISOT,ISTATE,3,1,I),YPR(ISOT,ISTATE,3,3,I), 2 YPR(ISOT,ISTATE,3,5,I),YPR(ISOT,ISTATE,3,6,I) CALL PBNDERR(IBB,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) IBB= YPR(ISOT,ISTATE,2,4,I) IF(IEP(IBB).EQ.ISTATEE) THEN IF(MKPRED.LE.0) THEN CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE, 1 RMSR,SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ YPR(ISOT,ISTATE,2,3,I)*RMSR**2 AVETOT= AVETOT+ YPR(ISOT,ISTATE,2,3,I)*AVE WRITE(6,606) YPR(ISOT,ISTATE,2,2,I), 1 YPR(ISOT,ISTATE,2,1,I),YPR(ISOT,ISTATE,2,3,I), 2 YPR(ISOT,ISTATE,2,5,I),YPR(ISOT,ISTATE,2,6,I), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR ENDIF WRITE(8,605) IF(MKPRED.LE.0) WRITE(8,606) 1 YPR(ISOT,ISTATE,2,2,I),YPR(ISOT,ISTATE,2,1,I), 2 YPR(ISOT,ISTATE,2,3,I),YPR(ISOT,ISTATE,2,5,I), 3 YPR(ISOT,ISTATE,2,6,I),AVEUFREQ(IBB),MAXUFREQ(IBB), 4 AVE,RMSR IF(MKPRED.GT.0) WRITE(8,606) 1 YPR(ISOT,ISTATE,2,2,I),YPR(ISOT,ISTATE,2,1,I), 2 YPR(ISOT,ISTATE,2,3,I),YPR(ISOT,ISTATE,2,5,I), 3 YPR(ISOT,ISTATE,2,6,I) CALL PBNDERR(IBB,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) IBB= YPR(ISOT,ISTATE,1,4,I) CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE,RMSR, 1 SSQTOT,DFREQ,UFREQ) RMSTOT= RMSTOT+ YPR(ISOT,ISTATE,1,3,I)*RMSR**2 AVETOT= AVETOT+ YPR(ISOT,ISTATE,1,3,I)*AVE WRITE(6,614) YPR(ISOT,ISTATE,1,1,I), 1 YPR(ISOT,ISTATE,1,2,I),NEF(EFP(IFIRST(IBB))), 2 YPR(ISOT,ISTATE,1,3,I),YPR(ISOT,ISTATE,1,5,I), 3 YPR(ISOT,ISTATE,1,6,I), 4 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR WRITE(8,617) WRITE(8,614) YPR(ISOT,ISTATE,1,1,I), 1 YPR(ISOT,ISTATE,1,2,I),NEF(EFP(IFIRST(IBB))), 2 YPR(ISOT,ISTATE,1,3,I),YPR(ISOT,ISTATE,1,5,I), 3 YPR(ISOT,ISTATE,1,6,I), 4 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR CALL PBNDERR(IBB,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 IBB= YPR(ISOT,ISTATE,7,4,1) CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) WRITE(6,626) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),YPR(ISOT,ISTATE,7,3,1),YPR(ISOT,ISTATE,7,5,1), 2 YPR(ISOT,ISTATE,7,6,1),AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR WRITE(8,626) NEBPAS(ISOT,ISTATE),SLABL(ISTATE),(NAME(I), 1 MN(I,ISOT),I=1,2),YPR(ISOT,ISTATE,7,3,1),YPR(ISOT,ISTATE,7,5,1), 2 YPR(ISOT,ISTATE,7,6,1),AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR WRITE(8,627) DO I= IFIRST(IBB),ILAST(IBB) DIV= DABS(DFREQ(I)/UFREQ(I)) marker=' ' IF( (DIV.GE.2.d0).AND.(DIV.LT.5.d0) ) marker='* ' IF( (DIV.GE.5.d0).AND.(DIV.LT.10.d0) ) marker='** ' IF( (DIV.GE.10.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(NBVPP(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Bv data IBB= YPR(ISOT,ISTATE,5,4,1) CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) WRITE(6,616) NBVPP(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),YPR(ISOT,ISTATE,5,3,1), 2 YPR(ISOT,ISTATE,5,5,1),YPR(ISOT,ISTATE,5,6,1), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR WRITE(8,616) NBVPP(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),YPR(ISOT,ISTATE,5,3,1), 2 YPR(ISOT,ISTATE,5,5,1),YPR(ISOT,ISTATE,5,6,1), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR DO J= IFIRST(IBB),ILAST(IBB) WRITE(6,618) JP(J),NEF(EFPP(J)),FREQ(J),UFREQ(J), 1 DFREQ(J),DFREQ(J)/UFREQ(J) WRITE(8,618) JP(J),NEF(EFPP(J)),FREQ(J),UFREQ(J), 1 DFREQ(J),DFREQ(J)/UFREQ(J) ENDDO ENDIF c IF(NWIDTH(ISOT,ISTATE).GT.0) THEN c** Book-keeping for Tunneling Width data IBB= YPR(ISOT,ISTATE,6,4,1) CALL BNDERR(IFIRST(IBB),ILAST(IBB),ROBUST,AVE,RMSR,SSQTOT, 1 DFREQ,UFREQ) WRITE(6,620) NWIDTH(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),YPR(ISOT,ISTATE,6,3,1), 2 YPR(ISOT,ISTATE,6,5,1),YPR(ISOT,ISTATE,6,6,1), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR WRITE(8,620) NWIDTH(ISOT,ISTATE),SLABL(ISTATE), 1 (NAME(I),MN(I,ISOT),I=1,2),YPR(ISOT,ISTATE,6,3,1), 2 YPR(ISOT,ISTATE,6,5,1),YPR(ISOT,ISTATE,6,6,1), 3 AVEUFREQ(IBB),MAXUFREQ(IBB),AVE,RMSR DO J= IFIRST(IBB),ILAST(IBB) 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** 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 isotopomers ISOT= ISOT+1 GO TO 10 ENDIF RMSR= DSQRT(SSQTOT/COUNTOT) WRITE(6,624) COUNTOT,RMSR RETURN 600 FORMAT(/1x,36('**')/' Write to Channel-8 Predictions From Complet 1e Set of Input Parameters!'/1x,36('**')) 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) 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) 616 FORMAT(/1x,66('=')/1x,I3,' State ',A3,1x,A2,'(',I3,')-',A2,'(', 1 I3,') Bv values treated as independent data'/1x,20('=='), 2 ' Avge. ',17('=')/' #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,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/ 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,2D13.2) 624 FORMAT(/1x,29('==')/' For overall fit to',i6,' data, DRMS(deviati 1ons)=',G11.4/1x,30('==')) 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) 627 FORMAT(1x,48('='),' calc-obs'/' v j p PAS(Eb) u(Eb) 1 calc-obs /u(FREQ)'/1x,29('--')) 628 FORMAT(2I4,A3,F14.6,1PD10.1,D13.2,0PF11.4,1X,A3) 629 FORMAT(1x,29('==')) 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) 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 DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) 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(IBB,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 DATE Utility routine 'arrsizes.h' governing array dimensioning c in dParFiT that MUST be installed under this name in the same c (sub)directory containing the folowing FORTRAN file for Program c dParFit16 when it is being compiled, c----------------------------------------------------------------- INTEGER NISTPMX,NPARMX,NDATAMX,NBANDMX,NVIBMX,NSTATEMX,NDUNMX, 1 NROTMX c* NISTPMX is the maximum number of isotopomers allowed for PARAMETER (NISTPMX = 10) c* NSTATEMX is maximum no. of electronic states which can be c simultaneously fitted to PARAMETER (NSTATEMX = 5) c* NPARMX is the largest number of free parameters allowed for PARAMETER (NPARMX = 3000) c* NDATAMX is largest No. of individual data which may be considered PARAMETER (NDATAMX = 22000) c* NBANDMX is largest No. of bands/series which may be considered PARAMETER (NBANDMX = 2700) c* NDUNMX is the maximum number of Dunham/NDE power series coeffts. PARAMETER (NDUNMX = 20) c* NVIBMX is the maximum number of vibrational levels of a single c state for which data are to be considered PARAMETER (NVIBMX = 155) c** NROTMX is the maximum number of rotational (J or N) values for a c given vib level. Required for term-value fit data counting PARAMETER (NROTMX = 200) c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% cc INCLUDE 'BLKISOT.h' c======================================================================= c** Isotope/isotopologue numbers, masses & BOB mass scaling factors INTEGER NISTP,AN(2),MN(2,NISTPMX) c** NDUNMX is a dummy parameter reqd. for portability of READATA cc PARAMETER (NDUNMX=0) % when used wity DPotFit c REAL*8 ZMASS(3,NISTPMX),RSQMU(NISTPMX),RSQMUP(0:NDUNMX,NISTPMX), 1 RMUP(0:9,NISTPMX) c** Differs from PotFit version because these factors not needed. cc 2 ,ZMUA(NISTPMX,NSTATEMX),ZMUB(NISTPMX,NSTATEMX), cc 3 ZMTA(NISTPMX,NSTATEMX),ZMTB(NISTPMX,NSTATEMX) c COMMON /BLKISOT/ZMASS,RSQMU,RSQMUP,RMUP,AN,MN,NISTP c======================================================================= cc INCLUDE 'BLKDATA.h' c======================================================================= c** Type statements & common block for data c REAL*8 FREQ(NDATAMX),UFREQ(NDATAMX),DFREQ(NDATAMX) c INTEGER COUNTOT,NFSTOT,NBANDTOT,IB(NDATAMX),JP(NDATAMX), 1 JPP(NDATAMX),VP(NBANDMX),VPP(NBANDMX),EFP(NDATAMX), 2 EFPP(NDATAMX),TVUP(NDATAMX),TVLW(NDATAMX),FSBAND(NBANDMX), 3 NFS(NBANDMX),IEP(NBANDMX),IEPP(NBANDMX),ISTP(NBANDMX), 4 IFIRST(NBANDMX),ILAST(NBANDMX),NTV(NSTATEMX,NISTPMX) c CHARACTER*2 NAME(2) CHARACTER*3 SLABL(-6:NSTATEMX) c COMMON /DATABLK/FREQ,UFREQ,DFREQ,COUNTOT,NFSTOT,NBANDTOT, 1 IB,JP,JPP,VP,VPP,EFP,EFPP,TVUP,TVLW,FSBAND,NFS,IEP,IEPP,ISTP, 2 IFIRST,ILAST,NTV, NAME,SLABL c======================================================================= REAL*8 DIV INTEGER IBB,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(IBB),ILAST(IBB) 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(IBB).GT.0) WRITE(8,602) VP(IBB),JP(I),NEF(EFP(I)), 1 VPP(IBB),JPP(I),NEF(EFPP(I)),FREQ(I),UFREQ(I),DFREQ(I), 2 DFREQ(I)/UFREQ(I),marker IF(IEP(IBB).EQ.0) WRITE(8,602) VP(IBB),VPP(IBB), 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(IBB),JP(I),NEF(EFP(I)),VPP(IBB),JPP(I), 1 NEF(EFPP(I)),DFREQ(I) c* Print predictions in alternate (Lyon) format c WRITE(11,606)VP(IBB),VPP(IBB),JPP(I),JP(I)-JPP(I),DFREQ(I) c 606 FORMAT(2I4,I5,I4,f13.4) ENDIF ENDDO WRITE(8,604) RETURN 600 FORMAT(1x,59('='),' 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,2f12.6,f10.4,1x,A3) 604 FORMAT(1x,69('-')) 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,NPARM,IRND,KRND,LPRINT INTEGER IFXP(NPTOT) REAL*8 PV(NPMAX),PU(NPMAX),CNST,CRND,XRND,FCT,XX,YY,UNC c c** Loop over & round off the parameters # NPAR1 to NPAR2 IF(LPRINT.GE.2) WRITE(6,602) NPAR2-NPAR1+1,NPTOT,NPAR1,NPAR2 UNC= 99.d99 DO NPARM= NPAR1, NPAR2 IF(PU(NPARM).LT.UNC) UNC= PU(NPARM) ENDDO DO NPARM= NPAR1, NPAR2 c** First ... fiddle with log's to perform the rounding XRND= DLOG10(UNC) IRND= INT(XRND) IF(XRND.GT.0) IRND=IRND+1 IRND= IRND- IROUND FCT= 10.D0**IRND CNST= PV(NPARM) YY= CNST CRND= PV(NPARM)/FCT XRND= 0.d0 c ... if rounding goes past REAL*8 precision, retain unrounded constant IF(DABS(CRND).GE.1.D+16) THEN WRITE(6,600) IROUND,NPARM RETURN ENDIF IF(DABS(CRND).GE.1.D+8) THEN c ... to avoid problems from overflow of I*4 integers ... KRND= NINT(CRND/1.D+8) XRND= KRND*1.D+8 CRND= CRND-XRND XRND= XRND*FCT END IF IRND= NINT(CRND) CNST= IRND*FCT+ XRND PV(NPARM) = CNST IFXP(NPARM)= 1 IF(LPRINT.GE.2) WRITE(6,604) NPARM,YY,PV(NPARM) 604 FORMAT(5x,'Round parameter #',i4,' from',G20.12,' to',G20.12) ENDDO NPARM= NPARM- 1 RETURN 600 FORMAT(' =',39('==')/' Caution:',i3,'-digit rounding of parameter- 1',i2,' would exceed (assumed) REAL*8'/' ******** precision overf 2low at 1.D+16, so keep unrounded constant') 602 FORMAT(' Rounding off ',i5,' of the ',i5,' parameters #:',i5, 1 ' to',i5) 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)]. 25/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 (NPTOT=0), simply return RMS(residuals) as c calculated from the input parameter values {PV(j)}. c** A user MUST SUPPLY subroutine DYIDPJ to generate the predicted c value of each datum and the partial derivatives of each datum w.r.t. c each parameter (see below) from the current trial parameters. c c** On entry: c NDATA is the number of data to be fitted c NPTOT the 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 < 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 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 MXPdim !! internal limit on max # parameters PARAMETER (MXPdim=3000) !! must be .GE. external max # NPMAX 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(MXPdim) REAL*8 YO(NDATA), YU(NDATA), YD(NDATA), PV(NPTOT), PU(NPTOT), 1 PS(NPTOT),PSS(MXPdim),PC(MXPdim),PCS(MXPdim),PX(MXPdim), 2 PY(MXPdim),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.MXPdim).OR.(NPTOT.GT.NDATA) 1 .OR.(NPMAX.GT.MXPdim)) THEN c** If array dimensioning inadequate, print warning & then STOP WRITE(6,602) NPTOT,MXPdim,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 CYCMAX cycles DO 50 ITER= 1, CYCMAX ISCAL= 0 NITER= NITER+ 1 DSE= 0.d0 TSTPSB= TSTPS RMSRB= RMSR c** Zero out various arrays 10 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) c** PCS is the saved array of parameter changes from previous iteration c to be used (if necessary) to attempt to stablize fit PCS(I)= PC(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========Beginning of core linear least-squares step==================== 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,YC,PV,PC,PSS) 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 special constrained-parameter POTFIT case cc IF(JFXP(J).GT.1) THEN cc write(6,666) I,J,PC(J),JFXP(J),PC(JFXP(J)) cc PC(JFXP(J))= PC(JFXP(J))+ PC(J) cc666 FORMAT(' For IDAT=',I5,' add PC(',I3,') =',1pD15.8, cc 1 ' to PC(',0pI3,') =',1pD15.8) cc 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** 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** 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** 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** 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%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% IF((ITER.GT.1).AND.(RMSR.GT.2.0d0*RMSRB).AND.(ISCAL.LE. 3)) 1 THEN c** LeRoy's Marquardt-like scheme to damp changes if RMSR increases ... ISCAL= ISCAL+ 1 IF(LPRINT.GE.0) THEN WRITE(6,620) ITER,RMSR,RMSR/RMSRB,ISCAL 620 FORMAT(' At Iteration',i3,' RMSD=',1PD8.1,' RMSD/RMSDB=',D8.1, 1 " Scale PC by (1/4)**",i1) ccc WRITE(6,612) (J,PV(J),PU(J),PS(J),PC(J),J=1,NPTOT) ENDIF DO J= 1,NPTOT PC(J)= 0.25d0*PCS(J) PV(J)= PV(J)- 3.d0*PC(J) ENDDO GOTO 10 ENDIF c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 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.GE.4) WRITE(6,604) ITER,RMSR,TSTPS,TSTPU c** Now ... update parameters (careful about rounding) DO J= 1,NPTOT IF(JFXP(J).GT.0) THEN cc IF(JFXP(J).GT.1) THEN !! a special PotFit option c** If this parameter constrained to equal some earlier parameter .... cc PV(J)= PV(JFXP(J)) cc WRITE(6,668) J,JFXP(J),PV(J),ITER cc ENDIF cc668 FORMAT(' Constrain PV('i3,') = PV(',I3,') =',1pd15.8, cc 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.5) 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 requires RMSD to be constant to 1 part in 10^7 c in adjacent cycles (unlikely to occur by accident!) c** Replaces less severe requirement that TSTPS < 1.0 IF(ABS((RMSR/RMSRB)-1.d0).LT.1.d-07) THEN IF(LPRINT.GE.3) WRITE(6,607) ITER, 1 ABS(RMSR/RMSRB-1.d0),TSTPS GO TO 54 ENDIF ENDIF cc CALL FLUSH(6) 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{MXPdim=', 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 c???????????????? c** Zero parameters more aggressively ... if unc. > 2* value if(dabs(PU(IPAR)/PV(IPAR)).GT.2.d0) then CNST= 0.d0 endif c???????????????? 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,IFXP,YC,PV,PD,PS) 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