C Hello Greg C C This function returns the most recent 1sg and 3su Born-Oppenheimer c potential of Na_2. c r is the internuclear separation in a0. c nv=1 or 2 for 1sg and 3su respectively c sys_ss_pot returns the potential in au c v returns the potential in cm-1 c c NOTE the logical variable lsetup should be set to .false. c This variable allows some additional initialization, c which in this version of the Na potentials is not used. c NOTE that internally this routine uses Angstrom and c cm-1. c c If your are going to use these potentials please acknowledge that c they were constructed by Prof. E. Tiemann et al. There are two recent c publications in Phys. Rev. A. Look for either my name or c that of Prof. E. Tiemann. c c Regards, c Eite c======================================================================= C Na+Na V 3.8.99 c with new triplet measurements C last changes 17.09.2000 c This is a modified analytic version of syspot, where C12 and C14 C are used for connecting the inner and outer parts with no kinks. C It should be smooth, also for the first derivative. C Thus C12 and C14 have no physical meaning. C exponential branch at short internuclear separation was adjusted to fit the observation C according to close coupling calculations C We copied all data from our fit output to the program source, C so they should be correct. c CC !!! The internal units are angstroem and cm-1, and they are CC !!! translated to bohr and the energy unit a.u. where necessary c real*8 function sys_ss_pot(r,v,nv,lsetup) implicit none logical, intent(IN) :: lsetup integer, intent(IN) :: nv real*8, intent(IN) :: r real*8, intent(OUT) :: v C C C *** These parameters should be set based on the degeneracy of C atomic and molecular quantum numbers. C integer, parameter :: nmx_ss=20, nmx=nmx_ss, num_ABOS=2 C C *** Fundamental Constants and Conversion Factors C The fundamental constants are taken from the August issue C of Physics Today and are compatible with the 1986 CODATA C task group. C C Fine Structure Constant in au real*8, parameter :: alpha = 137.03598950d0 C C Bohr Radius in Angstroms and cm real*8, parameter :: BohrA = 0.5291772490d0 real*8, parameter :: Bohr = 0.5291772490d-08 C C Hartree in cm-1 (Kaiser) real*8, parameter :: Hartree = 219474.630680d0 C C Speed of Light conversion from cm-1 to GHz real*8, parameter :: SOL = 29.97924580d0 C C Atomic Mass Units in atomic units (m_e=1) real*8, parameter :: amu = 1822.8885060d0 C C Pi real*8, parameter :: pi = 3.14159265358979323846264330d0 C C Unit of Atomic Time in seconds real*8, parameter :: time = 2.4188843320d-17 C C Conversion from K to au real*8, parameter :: KtoAU = 3.1668293D-6 C C Bohr Magneton and Nuclear Bohr Magneton in au/Gauss real*8, parameter :: bmag = 2.127190603d-10 real*8, parameter :: bnmag = 1.158504193d-13 C c c short range exponential parameters A_sr*exp(-b_sr*(r-rs)) c real*8, save, dimension(Num_ABOS) :: A_sr = X (/ 0.503545241D+04, 0.595700295D+04 /) real*8, save, dimension(Num_ABOS) :: b_sr = X (/ 0.29073876D+01, 0.71801075D-01 /) C original (/ 0.29073876D+01, 0.71601075D-01 /) c transition point from short range exponential form to c analytic expression, c dimensions angstroem and cm-1!! real*8, save, dimension(Num_ABOS) :: rs = X (/ 2.240000D0, 4.4d0 /) c c analytic form c real*8, parameter :: De = 6022.03779200D0 integer, parameter :: Max_Num_anal=50 integer, save, dimension(Num_ABOS) :: X Num_anal=(/ 40, 8 /) real*8, save, dimension(Num_ABOS) :: X fac=(/-.4D0,-0.2D0/), R_e=(/3.07857466D0,5.09110000D0/) real*8, save, dimension(40,Num_ABOS) :: c first data for 1sigma X a = reshape((/ 0.0000000000D-00, 1-0.149002441154628151D+01, 2 0.147297313687108744D+05, 3 0.121477594603700909D+05, 4 0.941116851679288857D+03, 5-0.989747692800168079D+04, 6-0.894429408296810652D+04, 7-0.276236600872660565D+05, 8-0.255627714845453796D+06, 9 0.226169826385345892D+06, X 0.538843925734205171D+07, 1-0.510575613956866413D+07, 2-0.964363043009740412D+08, 3 0.397842754718110561D+08, 4 0.120638158560416675D+10, 5 0.135115813749302983D+09, 6-0.105481785660651703D+11, 7-0.577602573660786533D+10, 8 0.655110695059836960D+11, 9 0.601611120896137314D+11, X-0.291981622029539490D+12, 1-0.369890125462120117D+12, 2 0.931341683729132202D+12, 3 0.153825346765448828D+13, 4-0.207002754417737207D+13, 5-0.452860991462818945D+13, 6 0.293752239181208057D+13, 7 0.955650226913696289D+13, 8-0.176550075858049683D+13, 9-0.143185459100996895D+14, X-0.222433768475411035D+13, 1 0.147122134846837090D+14, 2 0.640989986264004004D+13, 3-0.955519484920069531D+13, 4-0.688834959268847852D+13, 5 0.312161800984062695D+13, 6 0.377637982075348389D+13, 7 0.242656918938222771D+11, 8-0.872613116534944336D+12, 9-0.236755791026801300D+12, c here come data for 3sigma # 5849.331494300000000D+00, 1-0.694500760128302659D+02, 2 0.184374588067099035D+04, 3-0.857720735334105711D+03, 4-0.176231976725804407D+04, 5-0.201435756613776211D+05, 6 0.599524180039276325D+05, 7-0.460157084429315582D+05, 7 0.D0,0.D0,0.D0,0.D0,0.D0, 7 0.D0,0.D0,0.D0,0.D0,0.D0, 7 0.D0,0.D0,0.D0,0.D0,0.D0, 7 0.D0,0.D0,0.D0,0.D0,0.D0, 7 0.D0,0.D0,0.D0,0.D0,0.D0, 7 0.D0,0.D0,0.D0,0.D0,0.D0, 7 0.0D0,0.0D0/) , (/ 40,2 /) ) c c transition point from analytic expression to long range c polarization form. c real*8, save, dimension(Num_ABOS) :: rl = X (/ 9.000d0, 9.000d0 /) c c the long-range coefficients C C C6 from Derevianko et al, Phys.Rev.Lett 82, 3589 (1999) C C C8,C10 is from Marinescu,Sadeghpour, Dalgarno, C PRA 49, 982(1994) C C The exchange is from new real*8, save :: c6=0.7499052D+07, c8=0.1509850D+09, X c10=0.4181980D+10, X aex=0.5096300D+05, bex=2.36594D0 C Attention, there is an additional r**gamma_x before the C exponential! C real*8, dimension(Num_ABOS), save :: X gamma_x=(/4.59105D0, 4.59105D0/), X C12=(/ 0.3843216D+12,0.2853583D+12/), X C14=(/-0.2232341D+14,-0.2859594D+14/) C c local variables c real*8 :: long_range_SS real*8, parameter :: ZERO=0d0, ONE=1d0 integer :: i real*8 :: x0,x, ra C C --- Section For Potential Setup -------------------------------------- C C translate r to angstroems: ra=r*BohrA C IF(lsetup) THEN IF (nv.eq.1) THEN C c to do whatever initialization you like I don't like continue ENDIF sys_ss_pot=ZERO RETURN ENDIF C C --- Generate Potential for NV=1 or NV=2 or STOP if NV is out of Bounds C C NV=1: Calculate 1SIGMA(g) Potential C NV=2: Calculate 3SIGMA(u) Potential C if ( NV.lt.1.or.NV.gt.2 ) then write(6,*) "NV OUT OF RANGE -- NV:",NV, + " Program HALTED in Potential SYS_SS_POT " STOP endif c if(ra.gt.rl(NV)) then v=long_range_SS(RA,NV,c6,c8,c10,c12(NV),c14(NV), + gamma_x(NV),aex,bex,0) elseif (ra.lt.rs(NV) ) then v=A_sr(NV)*EXP(-b_sr(NV)*(ra-rs(NV)))-De else v=0.0D0 x0=(ra-r_e(NV))/(ra+fac(NV)*r_e(NV)) DO i=Num_Anal(NV),2,-1 v=(v+a(i,NV))*x0 ENDDO v=v+a(1,NV)-De endif C C De refers energy zero to center of gravity of asymtotic hyperfine C structure C C convert cm-1 to au C C sys_ss_pot = v/HARTREE C RETURN end C C======================================================================= real*8 function long_range_SS(R,NV,c6,c8,c10,c12,c14,gamma_x, + aex,bex,NCALL) c c homonuclear ^2S + ^2S c c This function evaluates the long-range form at R for ABO c potential NV c NCALL=0 : value c NCALL=1 : derivative c implicit none C integer :: NV,NCALL real*8 :: R, gamma_x1, gamma_x3 real*8 :: c6,c8,c10,aex,bex c real*8 :: R6INV,R2INV real*8, parameter :: ONE=1d0, SIX=6d0, EIGHT=8d0, + TEN=10d0 real*8 gamma_x,C12,C14 c R2INV=ONE/R**2 R6INV=R2INV**3 select case(NCALL) case(0) long_range_SS=-((((C14*R2INV+C12)*R2INV+c10)*R2INV+c8) * *R2INV + c6)*R6INV select case (NV) case(1) long_range_SS=long_range_SS-aex*(R**gamma_x)*dexp(-bex*R) case(2) long_range_SS=long_range_SS+aex*(R**gamma_x)*dexp(-bex*R) case DEFAULT write(6,*) "long_range_SS: NV is not 1 or 2, wrong potential" stop end select case(1) long_range_SS=((((14D0*C14*R2INV+12D0*C12)*R2INV+TEN # *c10)*R2INV+EIGHT*c8)*R2INV+ SIX*c6 )*R6INV/R select case (NV) case(1) long_range_SS=long_range_SS+aex*R**gamma_x*dexp(-bex*R)* X (gamma_x/R-bex) case(2) long_range_SS=long_range_SS-aex*R**gamma_x*dexp(-bex*R)* X (gamma_x/R-bex) case DEFAULT write(6,*) "long_range_SS: NV is not 1 or 2, wrong potential" stop end select end select return end