program guvcde c c polarizability from TDDFT by SOS c implicit none character*80 fo,fov,s80,output character*10 s10 integer*4 n,ie,i,j,k,l,np,nmo,ix,jx,ia,nat,grid(3),iep,icpl, 1oa,ob,idum,io,iz,nmo2,na,nb,nd0,iy,ii,nw,npx,isum,nnm, 2nt,nst,ifix,iclose,igiao,ntr,nc0,npp,istart,iend,nmms, 2ncmm,n22,nroot,LEXCL,np0,iwr,LEXCF,mmap(1000),nmap,ns0,nproc, 1LEXCI,nexc,icw parameter (nd0=21,nc0=4,ns0=19) c nd0 .. number of elements c 1.. 3 el. dipole, c 4.. 6 gradient, c 7.. 9 magnetic dipole, c 10..12 magnetic "GIAO" c 13..18 quadrupole c 19..21 GIAO c nc0 .. number of dipole elements correlated c ncmm ... maximal number of CI coefficients in one state c ns0 .. number of ROA spectra real*8 uux,uuy,uuz,DD,xp,yp,zp,px,py,pz,ddu(3),p0,dw,w, 1p1,p2,p3,de1,de2,de3,rorw,roiw,e00,Gnj(9),winm,wanm,fwnm, 1dg1,dg2,dg3,ucx,ucy,ucz,cijc,wrax,wrin,fwhh,kelvin, 1ax,ay,az,wden,sum,wmin,wmax,gammaau,troa,ktlim, 1fr,ds1,rs,angle,fi,bohr,djg(nd0),fkj,fkg,ejg,fjg,gammanm, 1rx,ry,rz,dx,dy,dz, 1rsr1,rsv1,rsr2,rsv2,un(3),u0(nd0),dsr,dsv,dkg(nd0),djk(nd0),ekj, 1ekg,rsv,rsr,debye,rsr3,rsv3,pi,dsm,dsq, 1rsa_4,rsa1_4,rsa2_4,rsa3_4, 1rsa_5,rsa1_5,rsa2_5,rsa3_5, 1rsa_6,rsa1_6,rsa2_6,rsa3_6, 1rsa_7,rsa1_7,rsa2_7,rsa3_7, 1degper,degper0,deglim,ecm,u0d(nd0),n3,cc,dst,lambda, 1xx(nc0),xy(nc0),yy(nc0),xa(nc0),ya(nc0),ar(nc0),reg(nc0), 1qxx,qxy,qxz,qyy,qyz,sumt, 1qzz,qi1,qi2,cd2,d2,sumr,sumi,u1kg,u2kg,u3kg,u1kj,u2kj,u3kj, 1qx,qy,qz,hx,hy,hz,com1,com2,com3,org1,org2,org3,org11,org22,org33, 1dif1,dif2,dif3,ecdo,ugx,ugy,ugz,fne,dj1,dj2,dj3,ujx,ujy,ujz, 2brx,bry,brz,qqx,qqy,qqz,ecda, 3org1c,org11c,org2c,org22c,THRC,th1,th2 c x atomic coordinates c v atomic weights c iz atomic number logical lden,lzmat,lw,lrds,lpx,lmcd,lcub,ldeg,lopen,lgnm, 1lwrt,lnorm,lgamma,lort,lgau,lwwe,lturbo,ltda,mcdv,LQ1,LDD, 1lgnj,LDE,rgnj,lbck,rroa,lvert,ltab,lglg,ldusch,LUE,LUM, 1ldis,vrroa,anroa,mroa,lpolder,ltgauss,ecdv,lspec,loit,lbolt, 1lhyde,frroa,lwten,lover,lvel,lrro,lusea,luseg,lqi,ldo(ns0) real*8, allocatable::cij(:),rrx(:),orb(:),rry(:),rrz(:),ror(:), 1rix(:),riy(:),riz(:),roi(:),rot(:),cmmg(:),cmme(:), 1rrxw(:),rryw(:),rrzw(:),rixw(:),riyw(:),rizw(:), 1bp(:),dij(:),bpd(:),pre(:),pred(:),dl(:,:),dv(:,:),r(:,:),ut(:,:), 1e(:),ev(:),r0v(:),r0l(:),qv(:,:,:),eau(:),x(:,:), 1xau(:,:),wr(:),wi(:),dlrec(:,:),dvrec(:,:),rrec(:,:),cijb(:), 1hd(:),pre6(:),pred6(:),dlg(:),qvrec(:,:,:),wt(:),dijb(:), 1reram(:),reroa(:),sr(:,:,:),wes(:) c cij - alpha orbitals c cijb - alpha orbitals, backward excitations c dij - beta orbitals integer*4, allocatable::ni(:),aij(:),bij(:),ind(:),jnd(:), 1daij(:),dbij(:),nid(:),qq(:),nib(:),aijb(:),bijb(:),daijb(:), 1dbijb(:),nibd(:),immg(:),imme(:) character*1 s1 c MCDV variables: integer*4 ndim,nvib,NQ1,NQBUF,nb0,mmax,mmaxi,mmaxf c NQ1 .. naximum number of excited centers c ndim -- 3nat, dimension of vib. matrices, even when c number of modes is smaller c nvib -- number of the actual normal modes real*8 vu0(3),f00,g0(9),mu0(3),q0(6),v0(3),wzero logical lwzero,lprog real*8,allocatable::VC(:,:),VD(:),VG(:,:),VGP(:,:),ddi(:), 1gnji(:),aai(:),vvi(:),qqi(:) c RROA additional variables: real*8,allocatable::VB(:),VA(:,:),VE(:,:),ltens(:),gtens(:), 1atens(:),enr(:) c pi=4.0d0*datan(1.0d0) bohr=0.529177d0 debye=2.541765d0 nmo=0 write(6,6000) 6000 format(/,' This program reads TDDFT Gaussian output,',/, 1 ' produces UVCD abd absorption spectral tables,',/, 1 ' MCD spectrum by SOS computation,',/, 1 ' and SOS polarizabilities.',/) call readoptions(lden,lmcd,lrds,lw,wden,fo,icpl, 1lzmat,ldeg,lwrt,DD,degper0,deglim,lnorm,nst,ifix,nmo,igiao, 2gammaau,wmin,wmax,np,lgamma,lort,gammanm,lgnm,lgau,lwwe,nmms, 3mcdv,nroot,fov,LEXCL,LQ1,np0,iwr,THRC,LDD,lgnj,LDE,rgnj,lbck, 4rroa,LEXCF,wzero,lwzero,NQ1,lvert,wrax, 5wrin,npx,lglg,fwhh,ltab,kelvin,ldusch,NQBUF,LUE,LUM, 6ldis,troa,vrroa,anroa,mroa,lpolder,ltgauss,isum,ecdv,e00, 7winm,wanm,fwnm,lspec,nnm,loit,lbolt,lhyde,nmap,mmap,frroa, 7lwten,nproc,lover,lvel,lrro,nb0,th1,th2,mmax,mmaxi,mmaxf, 1ktlim,LEXCI,nexc,lusea,luseg,lqi,icw,lprog,ldo) allocate(wes(nexc)) call readopt2(nexc,wes) allocate(cmmg(nmms),cmme(nmms),immg(nmms),imme(nmms)) c call dimensions(n,fo,nmo,nmo2,nat,lzmat,lturbo,ltda,ncmm) write(6,*)n,' transitions' c remember number of excitations: ntr=n if(n.eq.0)call report('Stop') write(6,*)nmo,' molecular orbitals' if(nmo.eq.0)call report('Stop') write(6,*)nat,' atoms' if(nat.eq.0)call report('Stop') c for cij and ni, allocate also space for deexcitations c allocate for the maximal (ntr) dimension, not to nst: if(ncmm.eq.0)then n22=nmo2 else n22=ncmm endif write(6,*)2*nmo2*n write(6,*)2*n22*n allocate(cij(2*n22*n),aij(n22*n),bij(n22*n),dij(n22*n), 1daij(n22*n),dbij(n22*n),cijb(n22*n),aijb(n22*n),bijb(n22*n), 1daijb(n22*n),dbijb(n22*n),dijb(2*n22*n), 1nib(n),nibd(n),ni(2*n),nid(n),dl(n,3),dv(n,3),r(n,3),e(n),ev(n), 1r0v(n),r0l(n),eau(n),x(3,nat),xau(3,nat),qq(nat),qv(n,3,3), 1ut(3,n),dlrec(n,3),dvrec(n,3),rrec(n,3),qvrec(n,3,3)) if(lturbo)then call readtm(qq,x,bohr,xau,na,nb,nmo2,n,nmo,nst, 1 dl,dv,qv,r,r0v,r0l,e,ev,eau,ni,nid,nat,cij,lopen, 1 aij,bij,ifix,nib,cijb,aijb,bijb,lnorm,lort,lwrt) else call readfile(lzmat,qq,x,bohr,xau,na,nb,nmo2,n,nmo,nst, 1 dl,dv,qv,r,r0v,r0l,e,ev,eau,ni,lden,nid,nat,cij,lopen, 1 aij,bij,dij,daij,dbij,fo,ifix,nib,cijb,aijb,bijb,lnorm,lort,lwrt, 1 dijb,daijb,dbijb,nibd,ltda,lbck) if(ltda)call readtda(na,nb,nmo2,n,nmo,nst,e,ev,eau,ni,lden, 1 nid,cij,lopen,aij,bij,dij,daij,dbij,ifix,nib,lnorm,lort,lwrt, 1 nibd,ncmm) endif c c limit number of excited states: if(nst.gt.0.and.nst.lt.n)then write(6,*)' Number of excited states limited to ',nst n=nst endif c c if desired, arbitrarily perturb degeneracy if(ldeg)then k=0 do 12 i=1,n-1 degper=degper0 do 12 j=i+1,n if(dabs(eau(i)-eau(j)).lt.deglim)then eau(j)=eau(j)+degper ev(j)=eau(j)*27.211384205943d0 ecm=ev(j)*8065.54476345045d0 e(j)=1.0d7/ecm write(6,6003)i,j,e(i),e(j) 6003 format(2i4,f8.2,' -> ',f8.2) degper=degper+degper0 k=k+1 endif 12 continue write(6,6008)k 6008 format('Degeneracy perturbed ',i3,' times.') do 13 i=1,n ev(i)=eau(i)*27.211384205943d0 ecm=ev(i)*8065.54476345045d0 13 e(i)=1.0d7/ecm endif c check the orbital range if(lden)then do 14 i=1,n do 141 j=1,ni(i) if(aij(n22*(i-1)+j).gt.nmo.or.aij(n22*(i-1)+j).lt.1)then write(6,*)' i:',i,' j:',j,' aij:',aij(n22*(i-1)+j),'nmo:',nmo call report('wrong orbital a') endif 141 if(bij(n22*(i-1)+j).gt.nmo.or.bij(n22*(i-1)+j).lt.1) 1 call report('wrong orbital b') do 14 j=1,nid(i) if(daij(n22*(i-1)+j).gt.nmo.or.daij(n22*(i-1)+j).lt.1)then write(6,*)' i:',i,' j:',j,' daij:',daij(n22*(i-1)+j) call report('wrong orbital da') endif if(dbij(n22*(i-1)+j).gt.nmo.or.dbij(n22*(i-1)+j).lt.1)then write(6,*)' i:',i,' j:',j,' dbij:',dbij(n22*(i-1)+j) call report('wrong orbital db') endif 14 continue endif c c record spectral tables: c tttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt write(6,*)n,' energies' call titles(fo,'.l.tab',output) call inispec(31,output,'UVCD spectrum in length formalism') write(6,*)output call titles(fo,'.v.tab',output) call inispec(32,output,'UVCD spectrum in velocity formalism') write(6,*)output c do 6 i=1,n call getv(ntr,dl,ds1,r0l,angle,rs,r,i) write(31,3001)i,e(i),ds1,rs,angle 3001 format(i4,f12.2,2f20.10,f8.1) call getv(n,dv,ds1,r0v,angle,rs,r,i) 6 write(32,3001)i,e(i),ds1,rs,angle write(31,3002) write(32,3002) 3002 format(80(1h-)) close(31) close(32) write(6,*) if(mroa.and.ltgauss)then call gmroa(ntr,n,gammaau,wes(1),eau,dl,r,qv) stop endif c c computation of polarizabilities from Gaussian transition dipoles: call cpolar('SOS.TTT','spav.prn','spal.prn','spgv.prn','spgl.prn', 1wmax,wmin,np,debye,pi,eau,gammaau,gammanm,lgnm,lgau,dl,dv,r, 2qv,ntr,n) c VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV c input parameters for vibrational resolution: if(ecdv.or.rroa.or.mcdv)then ndim=3*nat allocate(VA(ndim,ndim),VB(ndim),VC(ndim,ndim),VD(ndim), 1 VE(ndim,ndim),VG(ndim,ndim),VGP(ndim,ndim),ddi(9*nat), 1 aai(9*nat),vvi(9*nat),qqi(18*nat),gnji(27*nat)) call imcdv(fov,iwr,LDD,nroot,nat,VA,VB,VC,VD,VE,VG,VGP, 1 ndim,f00,e00,gnji,lgnj,LDE,g0,nvib,ddi,aai,vvi,qqi, 2 vu0,mu0,q0,v0,lwzero,wzero,lvert,ldusch,lqi) endif c VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV allocate(ltens(ndim*9),gtens(ndim*9),atens(ndim*27),enr(ndim)) c load normal mode derivatives of alpha, Gp and A tensors): if(vrroa.or.anroa) 1call inpder(nvib,ndim,ltens,gtens,atens,enr) if(.not.lrds)then c use gaussian dipole elements c dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd if(ecdv)then if(isum.lt.0.or.isum.gt.2)call report('unknown isum') c excited states around zero: if(isum.eq.0)then if(lbolt)then call ecdb(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE,VG,VGP,LEXCL, 1 vu0,mu0,LQ1,THRC,nvib,ddi,aai,NQ1, 1 winm,wanm,fwnm,kelvin,nnm,ltab,lspec,lglg) else if(mmax.gt.0)then call ecdic(e00,f00,ndim,VC,VD,VGP,nproc, 1 vu0,mu0,LQ1,THRC,lwrt,nvib,ddi,aai,NQ1, 1 winm,wanm,fwnm,kelvin,nnm,ltab,lspec,lglg,mmax,th1,th2,icw) else call ecdi(e00,f00,np0,iwr,ndim,VC,VD,VGP,LEXCL, 1 vu0,mu0,LQ1,LDD,THRC,lwrt,nvib,ddi,aai,NQ1,LUE,LUM, 1 winm,wanm,fwnm,kelvin,nnm,ltab,lspec,lglg) endif endif endif c excited states around PSTATE/LEXCL: if(isum.eq.1)call ecdid(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE,VGP, 1 LEXCL,vu0,mu0,LQ1,LDD,THRC,lwrt,nvib,ddi,aai,NQ1,LUE,LUM, 1 winm,wanm,fwnm,kelvin,nnm,ltab,lspec,lglg,loit) c excited states around PSTATE/systematic: if(isum.eq.2)call ecdis(e00,f00,np0,ndim,VC,VD,VGP,LEXCL,vu0, 1 mu0,LDD,THRC,nvib,ddi,aai, 1 winm,wanm,fwnm,kelvin,nnm,ltab,lspec,lglg) endif if(rroa)then if(frroa.and.lwten)then open(77,file='TTT.OUT') open(78,file='INV.TXT') endif if(ltab)then call inispec(44,'RROA.TAB','RROA vibrational') if(frroa)call initab(ldo) endif allocate(reram(npx),reroa(npx)) reram=0.0d0 reroa=0.0d0 allocate(sr(npx,2,ns0)) sr=0.0d0 c fast algorithm, selected states: c excited states around zero: if(isum.eq.0)then if(lover)then c selection of states based on overlap: if(lrro)then call rrrq(e00,f00,ndim,VA,VB,VC,VD,VE,VG,VGP,sr,vu0,mu0, 1 v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,nvib,LEXCF,gammaau, 1 wrax,wrin,npx,lglg,fwhh,ltab,lwten,nproc,lvel,nb0,lwrt, 1 th1,th2,mmax,mmaxi,mmaxf,ktlim,kelvin,LEXCI,nexc,wes,lusea, 1 luseg,lqi,icw,lprog,ldo) else call rrrp(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE, 1 VG,VGP,vu0,mu0,v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,nvib, 2 LEXCL,LEXCF,wes(1),gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 1 reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1 vrroa,troa,ltens,gtens,atens,enr,anroa,lhyde,nmap,mmap,frroa, 1 sr,lwten,nproc,lvel,ldo) endif else c selection of states based on dipole: call rrrf(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE, 1 VG,VGP,vu0,mu0,v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,lwrt,nvib, 2 LEXCL,LEXCF,wes(1),gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 1 reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1 vrroa,troa,ltens,gtens,atens,enr,anroa,lhyde,nmap,mmap,frroa, 1 sr,lwten,nproc,lvel,ldo) endif endif c excited states around PSTATE/LEXCL: if(isum.eq.1)call rrrd(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE, 1 VG,VGP,vu0,mu0,v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,lwrt,nvib, 2 LEXCL,LEXCF,wes(1),gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 1 reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1 vrroa,troa,ltens,gtens,atens,enr,anroa,frroa,sr,lwten,nproc, 1 lvel,ldo) c excited states around PSTATE/systematic: if(isum.eq.2)call rrri(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE, 1 VG,VGP,vu0,mu0,v0,q0,ddi,aai,qqi,vvi,LDD,THRC,nvib, 2 LEXCF,wes(1),gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 1 reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1 vrroa,anroa,frroa,sr,lwten,lvel,ldo) if(isum.lt.0.or.isum.gt.2)call report('unknown isum') if(ltab)then write(44,3002) close(44) if(frroa)call closetab(ldo) endif c write the spectra: call c4546(wrin,wrax,npx,reram,kelvin,'rram',3) call c4546(wrin,wrax,npx,reroa,kelvin,'rroa',8) if(frroa)call c33(wrin,wrax,npx,sr,kelvin,ldo) if(frroa.and.lwten)then close(77) close(78) endif endif c rroa else c recalculate transition dipole strengths c dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd if(.not.lden)call report('lden needed for lrds') inquire(file='PX.MO.SCR.TXT',exist=lpx) if(.not.lpx)call report('*SCR.TXT files needed for lrds') allocate(bp(nd0*nmo2),bpd(nd0*nmo2)) call rwm(bp,nmo,nd0) if(lopen)call rwmd(bpd,nmo) write(6,*) write(6,*)'Transition moment check: r grad m q' call zerstat(xa,ya,xx,yy,xy,ar,nc0) n3=dble(3*n) do 301 ie=1,n c call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,ie,lopen,djg,bp,bpd,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb,nd0,n22) do 312 j=1,nd0 312 djg(j)=-djg(j) do 3121 j=4,6 3121 djg(j)=-djg(j)/eau(ie) do 3122 j=13,18 3122 djg(j)=djg(j) ii=0 do 313 j=1,3 call cstat(djg(j ),dl(ie,j),xy(1),xa(1),ya(1),ar(1),xx(1),yy(1)) call cstat(djg(j+3),dv(ie,j),xy(2),xa(2),ya(2),ar(2),xx(2),yy(2)) call cstat(djg(j+6), r(ie,j),xy(3),xa(3),ya(3),ar(3),xx(3),yy(3)) dlrec(ie,j)=djg(j ) dvrec(ie,j)=djg(3+j) rrec( ie,j)=djg(6+j) do 313 k=j,3 ii=ii+1 c 'XX','XY','XZ','YY','YZ','ZZ' call cstat(djg(12+ii),qv(ie,j,k), 1 xy(4),xa(4),ya(4),ar(4),xx(4),yy(4)) qvrec( ie,j,k)=djg(12+ii) 313 qvrec( ie,k,j)=djg(12+ii) 301 if(lwrt)write(6,3006)e(ie),(djg(j),j=1,9),(djg(j),j=13,18), 1 (dl(ie,j),j=1,3),(dv(ie,j),j=1,3),(r(ie,j),j=1,3), 1 ((qv(ie,j,k),k=j,3),j=1,3) 3006 format(f6.1,15f8.4,/,6x,15f8.4) do 107 j=1,3 107 call stn(n*3,ar(j),xa(j),ya(j),reg(j),yy(j),xy(j)) call stn(n*6,ar(4),xa(4),ya(4),reg(4),yy(4),xy(4)) do 1071 j=1,4 write(6,*) if(j.eq.1)write(6,*)'electric:' if(j.eq.2)write(6,*)'gradient:' if(j.eq.3)write(6,*)'magnetic:' if(j.eq.4)write(6,*)'quadrupole:' 1071 write(6,3009)cc(xy(j),n3,xa(j),ya(j),xx(j),yy(j)),reg(j),ar(j) 3009 format(' Correlation coefficient:',f12.6,/, 1 ' Regression :',f12.6,/, 1 ' :',f12.6,/) c dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd c c computation of polarizabilities from recalculated dipoles: call cpolar('SOS.r.TTT','spav.r.prn','spal.r.prn','spgv.r.prn', 1 'spgl.r.prn',wmax,wmin,np,debye,pi,eau,gammaau,gammanm, 2 lgnm,lgau,dlrec,dvrec,rrec,qvrec,ntr,n) c call inispec(31,'ECDL.TAB','UVCD spectrum in length formalism') call inispec(32,'ECDV.TAB','UVCD spectrum in velocity formalism') call zerstat(xa,ya,xx,yy,xy,ar,2) n3=dble(n) do 314 i=1,n call getv(n,dlrec,dsr,r0l,angle,rs,rrec,i) rsr=-(dlrec(i,1)*rrec(i,1)+dlrec(i,2)*rrec(i,2) 1 +dlrec(i,3)*rrec(i,3)) 1 *2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 write(31,3001)i,e(i),dsr,rsr,angle call getv(n,dvrec,dsv,r0v,angle,rs,rrec,i) rsv=-(dvrec(i,1)*rrec(i,1)+dvrec(i,2)*rrec(i,2) 1 +dvrec(i,3)*rrec(i,3)) 1 *2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 call cstat(dsv,dsr,xy(1),xa(1),ya(1),ar(1),xx(1),yy(1)) call cstat(rsv,rsr,xy(2),xa(2),ya(2),ar(2),xx(2),yy(2)) 314 write(32,3001)i,e(i),dsv,rsv,angle write(31,3002) write(32,3002) close(31) close(32) call stn(n,ar(1),xa(1),ya(1),reg(1),yy(1),xy(1)) call stn(n,ar(2),xa(2),ya(2),reg(2),yy(2),xy(2)) write(6,3011)' Grad vs length:', 1 cc(xy(1),n3,xa(1),ya(1),xx(1),yy(1)),' ECD:', 1 cc(xy(2),n3,xa(2),ya(2),xx(2),yy(2)), 1 reg(1) ,' ECD:',reg(2), 1 ar(1) ,' ECD:',ar(2) 3011 format(/,A16,/, 1 ' Correlation coefficients absorption:',f12.6,A5,f12.6,/, 1 ' Regression coefficients absorption:',f12.6,A5,f12.6,/, 1 ' absorption:',f12.6,A5,f12.6,/) if(icpl.ne.0)then c cplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcpl write(6,*)' CPL requested from state ',icpl c nuclear dipole moment: call uun(un,nat,xau,qq) c electric dipole moment: do 4015 j=1,nd0 u0(j)=0.0d0 u0d(j)=0.0d0 if(lopen)then do 4016 i=1,na 4016 u0( j)=u0( j)+bp( i+nmo*(i-1)+nmo2*(j-1)) do 4017 i=1,nb 4017 u0d(j)=u0d(j)+bpd(i+nmo*(i-1)+nmo2*(j-1)) else c u0 = 2 sum(i,occ) : do 4018 i=1,na 4018 u0( j)=u0(j) +bp( i+nmo*(i-1)+nmo2*(j-1))*2.0d0 endif 4015 continue write(6,3101)(un(j),j=1,3),(-u0(j)-u0d(j),j=1,3), 1 (-u0(j)-u0d(j)+un(j),j=1,3) 1 ,((-u0(j)-u0d(j)+un(j))*debye,j=1,3) write(s10,'(i10)')icpl do 4001 istart=1,len(s10) 4001 if(s10(istart:istart).ne.' ')goto 4002 4002 do 4003 iend=len(s10),1,-1 4003 if(s10(iend:iend).ne.' ')goto 4004 4004 call inispec(30,'CPLR.'//s10(istart:iend)//'.TAB', 1 'CPL from state '//s10(istart:iend)//' -length form') call inispec(31,'CPLV.'//s10(istart:iend)//'.TAB', 1 'CPL from state '//s10(istart:iend)//' -velocity form') call inispec(32,'CPLT.'//s10(istart:iend)//'.TAB', 1 'CPL from state '//s10(istart:iend)//' -length+magnetic ') c precalculate b>: allocate (pre(nd0*nmo2),pred(nd0*nmo2)) call getieab(pre,pred,lopen,na,nb,nmo,ni,nid,icpl,aij,bij, 1 cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,nd0,n22) c calculate state dipole again and check CI: call getdipole(ut,n,cij,nmo,ni,aij,bij, 1 dij,nid,daij,dbij,lopen,pre,pred,icpl,nd0,3,n22) sum=0.0d0 do 4008 i=1,ni(icpl) 4008 sum=sum+cij(n22*(icpl-1)+i)**2 do 4009 i=1,nid(icpl) 4009 sum=sum+dij(n22*(icpl-1)+i)**2 do 4010 i=1,nib(icpl) 4010 sum=sum-cijb(n22*(icpl-1)+i)**2 write(6,3004)icpl,(un(ia)-ut(ia,icpl),ia=1,3),sum c transitions to ground: c djg=: " singlet (dsqrt(2)) call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,icpl,lopen,djg,bp,bpd,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb,nd0,n22) ejg=eau(icpl) do 4011 ia=4,6 4011 djg(ia)=-djg(ia)/ejg c dsv: dsv=djg(3+1)*djg(3+1)+djg(3+2)*djg(3+2)+djg(3+3)*djg(3+3) c dsr: dsr=djg( 1)*djg( 1)+djg( 2)*djg( 2)+djg( 3)*djg( 3) c rsr: rsr=djg(6+1)*djg( 1)+djg(6+2)*djg( 2)+djg(6+3)*djg( 3) c rsv: rsv=djg(6+1)*djg(3+1)+djg(6+2)*djg(3+2)+djg(6+3)*djg(3+3) rsr=rsr*2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 rsv=rsv*2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 lambda=e(icpl)*10.0d0/bohr dsm= 1 (2.0d0*pi/lambda/eau(icpl))**2*(djg(7)**2+djg(8)**2+djg(9)**2) lambda=1.0d7/(219474.63d0*ejg) write(30,3008)0,lambda,dsr*debye**2,rsr write(31,3008)0,lambda,dsv*debye**2,rsv de1=0.0d0 if(dsr+dsm.ne.0.0d0)de1=rsr/((dsr+dsm)*debye**2) write(32,3008)0,lambda,(dsr+dsm)*debye**2,rsr,de1 c transitions to other states: do 4012 iep=1,n if(iep.ne.icpl)then c djk==> call dodjk(djk,nd0,ni,iep,aij,bij,n22,cij,pre,lopen,daij,dbij, 1 pred,nmo,dij,nid) c transform gradient to dipole: ekj=eau(iep)-ejg if(lgamma)then fkj=ekj/(ekj**2+gammaau**2) else fkj=1.0d0/ekj endif do 4013 ia=4,6 4013 djk(ia)=-djk(ia)*(-fkj) c dsv: dsr=djk(3+1)*djk(3+1)+djk(3+2)*djk(3+2)+djk(3+3)*djk(3+3) c dsr: dsr=djk( 1)*djk( 1)+djk( 2)*djk( 2)+djk( 3)*djk( 3) c rsr: rsr=djk(6+1)*djk( 1)+djk(6+2)*djk( 2)+djk(6+3)*djk( 3) c rsv: rsv=djk(6+1)*djk(3+1)+djk(6+2)*djk(3+2)+djk(6+3)*djk(3+3) rsr=rsr*2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 rsv=rsv*2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 lambda=-1.0d7/(219474.63d0*ekj)*10.0d0/bohr dsm= 1 (2.0d0*pi/lambda/ekj)**2*(djk(7)**2+djk(8)**2+djk(9)**2) lambda=-1.0d7/(219474.63d0*ekj) write(30,3008)iep,lambda,dsr*debye**2,rsr write(31,3008)iep,lambda,dsv*debye**2,rsv de1=0.0d0 if(dsr+dsm.ne.0.0d0)de1=rsr/((dsr+dsm)*debye**2) write(32,3008)iep,lambda,(dsr+dsm)*debye**2,rsr,de1 endif 4012 continue do 4014 i=30,32 write(i,3002) 4014 close(i) deallocate(pre,pred) endif c cplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcplcpl c mroamroamroamroamroamroamroamroamroamroamroamroamroa if(mroa.and..not.ltgauss)then call cmroa(nd0,nmo,n,lopen,na,nb,ni,nid,aij,bij, 1 cij,daij,dbij,dij,bp,bpd,nmo2,n22,djg,ifix,nib, 1 cijb,aijb,bijb,djk,lgamma,gammaau,wes(1),eau,nat,xau,qq,dkg) endif c mroamroamroamroamroamroamroamroamroamroamroamroamroa c lpolderlpolderlpolderlpolderlpolderlpolderlpolderlpolder if(lpolder)call sospol(nd0,nmo,n,lopen,na,nb,ni,nid,aij,bij, 1 cij,daij,dbij,dij,bp,bpd,nmo2,n22,djg,ifix,nib, 1 cijb,aijb,bijb,djk,gammaau,wes(1),eau,nat,xau,qq,dkg) c lpolderlpolderlpolderlpolderlpolderlpolderlpolderlpolder if(lmcd)then c mcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcd c nuclear dipole moment: call uun(un,nat,xau,qq) c c electric dipole, grad,r x grad/2 and (r-rul) x grad/2 etc.: do 310 j=1,nd0 u0(j)=0.0d0 u0d(j)=0.0d0 if(lopen)then do 327 i=1,na 327 u0( j)=u0( j)+bp( i+nmo*(i-1)+nmo2*(j-1)) do 329 i=1,nb 329 u0d(j)=u0d(j)+bpd(i+nmo*(i-1)+nmo2*(j-1)) else c u0 = 2 sum(i,occ) : do 330 i=1,na 330 u0( j)=u0(j) +bp( i+nmo*(i-1)+nmo2*(j-1))*2.0d0 endif 310 continue write(6,3101)(un(j),j=1,3),(-u0(j)-u0d(j),j=1,3), 1 (-u0(j)-u0d(j)+un(j),j=1,3) 1 ,((-u0(j)-u0d(j)+un(j))*debye,j=1,3) 3101 format(/,' Dipole nuclear :',/,3f10.3,/, 1 ' electronic:',/,3f10.3,/, 1 ' total :',/,3f10.3,' debyes:',3f10.3,/) open(28,file='TTENSOR.TAB') write(28,2828) 2828 format(' the MCD tensor, as in',/, 1 ' J. Chem. Theory COmput 2013, 9, 1557, equation (9),',/, 2 ' first index electric',/, 3 ' transition xx',10x,'xy',10x,'xz',10x,'yx',10x,'yy', 4 10x,'yz',10x,'zx',10x,'zy',10x,'zz',/, 4 60(1h-)) open(29,file='MOMENTS.TAB') write(29,*)' electric and effective magnetic moments' call inispec(30,'MCDL.TAB','MCD spectrum in length formalism') call inispec(31,'MCDV.TAB','MCD spectrum in velovity formalism') call inispec(32,'Q.TAB','quadrupole-allowed transitions') call inispec(33,'M.TAB','magnetic-allowed transitions') call inispec(34,'T.TAB','total transition probabilities') call inispec(35,'ECDO.TAB','ECD in LORG formulation') call inispec(36,'ECDA.TAB','ECD in LORGave formulation') if(igiao.eq.6)then call inispec(37,'MCD4.TAB','MCD IGIAO=4') call inispec(38,'MCD5.TAB','MCD IGIAO=5') call inispec(39,'MCD6.TAB','MCD IGIAO=6') call inispec(40,'MCD7.TAB','MCD IGIAO=7') open(41,file='MCD7.TXT') write(41,3014) 3014 format(' MCD7.TXT','MCD IGIAO=7 statistics',/, 1 ' n wavelength(nm)',10x,'Rg',13x,'Re',13x,'R0', 1 11x,'Rtot',/,80(1h-)) else write(s1,'(i1)')igiao call inispec(37,'MCD4.TAB','MCD IGIAO='//s1) endif if(mcdv)call inispec(42,'MCDI.TAB','MCD vibrational') if(mcdv)call inispec(43,'ECDI.TAB','ECD vibrational') write(6,3005) 3005 format(/,' State dipole sum cij**2-cijb**2:') write(6,3004)0,(un(ia)-u0(ia)-u0d(ia),ia=1,3),1.0d0 3004 format(i6,4f10.3) allocate (pre(nd0*nmo2),pred(nd0*nmo2)) c c if LORG (igiao=6), precalculate all and if(igiao.eq.6)then write(6,*)'pre-calculating , x=r,grad' allocate(hd(n*n*6),pre6(6*nmo2),pred6(6*nmo2),dlg(6*n)) call prep69(n,6,pre6,pred6,lopen,na,nb,nmo,ni,nid,aij,bij, 1 cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,n22,djg,ifix,nib, 2 cijb,aijb,bijb,djk,dlg,hd) deallocate(pre6,pred6) write(6,*)' ... done' endif c call zerstat(xa,ya,xx,yy,xy,ar,3) c 304304304304304304304304304304304304304304304304304304304304304 do 304 ie=1,n ejg=eau(ie) if(lgamma)then fjg=ejg/(ejg**2+gammaau**2) else fjg=1.0d0/ejg endif dsr=0.0d0 dsm=0.0d0 dsq=0.0d0 dst=0.0d0 dsv=0.0d0 rsv1=0.0d0 rsv2=0.0d0 rsr1=0.0d0 rsr2=0.0d0 rsa1_4=0.0d0 rsa2_4=0.0d0 rsa1_5=0.0d0 rsa2_5=0.0d0 com1=0.0d0 com2=0.0d0 com3=0.0d0 org1=0.0d0 org2=0.0d0 org3=0.0d0 org11=0.0d0 org22=0.0d0 org33=0.0d0 c MCD tensor for transition n-> j: c J. Chem. Theory COmput 2013, 9, 1557, equation (9): call vz(Gnj,9) c precalculate b>: call getieab(pre,pred,lopen,na,nb,nmo,ni,nid,ie,aij,bij, 1 cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,nd0,n22) c calculate state dipole: call getdipole(ut,n,cij,nmo,ni,aij,bij, 1 dij,nid,daij,dbij,lopen,pre,pred,ie,nd0,3,n22) sum=0.0d0 do 317 i=1,ni(ie) 317 sum=sum+cij(n22*(ie-1)+i)**2 do 326 i=1,nid(ie) 326 sum=sum+dij(n22*(ie-1)+i)**2 do 328 i=1,nib(ie) 328 sum=sum-cijb(n22*(ie-1)+i)**2 write(6,3004)ie,(un(ia)-ut(ia,ie),ia=1,3),sum c djg=: " singlet (dsqrt(2)) call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,ie,lopen,djg,bp,bpd,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb,nd0,n22) do 320 ia=4,6 320 djg(ia)=-djg(ia)/eau(ie) c maximum contributions to ground and excited MCD: do 336 i=1,nmms immg(i)=0 imme(i)=0 cmmg(i)=0.0d0 336 cmme(i)=0.0d0 do 307 iep=1,n if(iep.ne.ie)then ekg=eau(iep) ekj=ekg-ejg if(lgamma)then fkj=ekj/(ekj**2+gammaau**2) fkg=ekg/(ekg**2+gammaau**2) else fkj=1.0d0/ekj fkg=1.0d0/ekg endif c dkg=: "" singlet (dsqrt(2)) call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,iep,lopen,dkg,bp,bpd,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb,nd0,n22) c djk===> call dodjk(djk,nd0,ni,iep,aij,bij,n22,cij,pre,lopen,daij,dbij, 1 pred,nmo,dij,nid) c transform gradient to dipole: do 319 ia=4,6 djk(ia)=-djk(ia)*(-fkj) 319 dkg(ia)=-dkg(ia)*fkg c ukg: u1kg=djg(2)*djk(3)-djg(3)*djk(2) u2kg=djg(3)*djk(1)-djg(1)*djk(3) u3kg=djg(1)*djk(2)-djg(2)*djk(1) c ukj: u1kj=djg(2)*dkg(3)-djg(3)*dkg(2) u2kj=djg(3)*dkg(1)-djg(1)*dkg(3) u3kj=djg(1)*dkg(2)-djg(2)*dkg(1) c magnetic moment and dipole: p0=(dkg(6+1)*u1kg+dkg(6+2)*u2kg+dkg(6+3)*u3kg)*fkg rsr1=rsr1+p0 com1=com1+p0 p1=(djk(6+1)*u1kj+djk(6+2)*u2kj+djk(6+3)*u3kj)*fkj rsr2=rsr2+p1 com2=com2+p1 if(nroot.eq.ie)then do 15 ix=1,3 do 15 jx=1,3 c G=(J|u|k>/Ekg+/Ekj 15 Gnj(ix+3*(jx-1))=Gnj(ix+3*(jx-1)) 1 +djk(ix)*dkg(6+jx)*fkg+dkg(ix)*djk(6+jx)*fkj endif c c magnetic moment and velocity: rsv1=rsv1+(dkg(6+1)*(djg(2+3)*djk(3+3)-djg(3+3)*djk(2+3)) 1 + dkg(6+2)*(djg(3+3)*djk(1+3)-djg(1+3)*djk(3+3)) 1 + dkg(6+3)*(djg(1+3)*djk(2+3)-djg(2+3)*djk(1+3)))*fkg rsv2=rsv2+(djk(6+1)*(djg(2+3)*dkg(3+3)-djg(3+3)*dkg(2+3)) 1 + djk(6+2)*(djg(3+3)*dkg(1+3)-djg(1+3)*dkg(3+3)) 1 + djk(6+3)*(djg(1+3)*dkg(2+3)-djg(2+3)*dkg(1+3)))*fkj c c GIAO magnetic moment and dipole: if(igiao.ge.4)then c /(Ek-Eg) ~ c common origin terms - p0 c GIAO compensation term: p2=-dkg(9+1)*u1kg-dkg(9+2)*u2kg-dkg(9+3)*u3kg rsa1_4=rsa1_4+p0+p2 rsa1_5=rsa1_5+p0+p2 c c /(Ek-Ej) ~ c common origin terms - p1 c GIAO terms: p2= djk(18+1)*u1kj+djk(18+2)*u2kj+djk(18+3)*u3kj rsa2_4=rsa2_4+p1 rsa2_5=rsa2_5+p1+p2 else rsa1_4=rsa1_4+(dkg(9+1)*u1kg+dkg(9+2)*u2kg+dkg(9+3)*u3kg)*fkg rsa2_4=rsa2_4+(djk(9+1)*u1kj+djk(9+2)*u2kj+djk(9+3)*u3kj)*fkj endif if(igiao.eq.6)then c nonlocal "LORG" like trick: c sum(L,L<>g)x/(El-Eg) etc: call lsums(dx,dy,dz,rx,ry,rz,qx,qy,qz,hx,hy,hz, 1 n,eau,lgamma,gammaau,ie,iep,hd,dlg,na,nb, 2 brx,bry,brz,qqx,qqy,qqz,u0,u0d,ut) c x/(El-Eg)./2: org1c = rx *u1kg+ry *u2kg+rz *u3kg org1 = org1 + org1c c x/(Ek-El)./2: org11c = -brx*u1kg-bry*u2kg-brz*u3kg org11 = org11 + org11c c write(6,6038)'kk',ie,iep,ekg,dkg(9),rz/fkg,u3kg c seems to compensat eperfectly c x/(EK-EL)./2: org2c = qx*u1kj+qy*u2kj+qz*u3kj org2 = org2 +org2c c x/(El-Ej)./2: org22c = -qqx*u1kj-qqy*u2kj-qqz*u3kj org22 = org22 + org22c c write(6,6038)'qq',ie,iep,ekg,djk(9),qz/fkj,u3kj c seems to compensate perfectly if(nroot.eq.ie)then Gnj(1)=Gnj(1)-(djk(1)*(rx-brx)+dkg(1)*(qx-qqx))/2.0d0 Gnj(2)=Gnj(2)-(djk(2)*(rx-brx)+dkg(2)*(qx-qqx))/2.0d0 Gnj(3)=Gnj(3)-(djk(3)*(rx-brx)+dkg(3)*(qx-qqx))/2.0d0 Gnj(4)=Gnj(4)-(djk(1)*(ry-bry)+dkg(1)*(qy-qqy))/2.0d0 Gnj(5)=Gnj(5)-(djk(2)*(ry-bry)+dkg(2)*(qy-qqy))/2.0d0 Gnj(6)=Gnj(6)-(djk(3)*(ry-bry)+dkg(3)*(qy-qqy))/2.0d0 Gnj(7)=Gnj(7)-(djk(1)*(rz-brz)+dkg(1)*(qz-qqz))/2.0d0 Gnj(8)=Gnj(8)-(djk(2)*(rz-brz)+dkg(2)*(qz-qqz))/2.0d0 Gnj(9)=Gnj(9)-(djk(3)*(rz-brz)+dkg(3)*(qz-qqz))/2.0d0 endif endif c store the largest contributions: call dtm(iep,p0-(org1c+org11c)/2.0d0,immg,cmmg,nmms) call dtm(iep,p1-(org2c+org22c)/2.0d0,imme,cmme,nmms) endif c if(iep.ne.ie)then 307 continue c add parts dependent on permanent dipole moment: de1=ut(1,ie)-un(1) de2=ut(2,ie)-un(2) de3=ut(3,ie)-un(3) dg1=u0(1)+u0d(1)-un(1) dg2=u0(2)+u0d(2)-un(2) dg3=u0(3)+u0d(3)-un(3) c -: ddu(1)=de1-dg1 ddu(2)=de2-dg2 ddu(3)=de3-dg3 dif1=djg(2)*ddu(3)-djg(3)*ddu(2) dif2=djg(3)*ddu(1)-djg(1)*ddu(3) dif3=djg(1)*ddu(2)-djg(2)*ddu(1) rsv3=(djg(6+1)*(djg(2+3)*ddu(3)-djg(3+3)*ddu(2)) 1 +djg(6+2)*(djg(3+3)*ddu(1)-djg(1+3)*ddu(3)) 1 +djg(6+3)*(djg(1+3)*ddu(2)-djg(2+3)*ddu(1)))*fjg c .x(-): com3=(djg(6+1)*dif1+djg(6+2)*dif2+djg(6+3)*dif3)*fjg rsr3=com3 c c contribution to the MCD tensor c Gnj=Gnj+(uj-un)/Ejn if(nroot.eq.ie)then do 16 ix=1,3 do 16 iy=1,3 16 Gnj(ix+3*(iy-1))=Gnj(ix+3*(iy-1))+ddu(ix)*djg(6+iy)*fjg endif if(igiao.ge.4)then c GIAO parts: p3=-djg( 9+1)*dif1-djg( 9+2)*dif2-djg( 9+3)*dif3 rsa3_4=com3+p3 rsa3_5=com3+p3 else rsa3_4=(djg(9+1)*(djg(2)*ddu(3)-djg(3)*ddu(2)) 1 + djg(9+2)*(djg(3)*ddu(1)-djg(1)*ddu(3)) 1 + djg(9+3)*(djg(1)*ddu(2)-djg(2)*ddu(1)))*fjg endif if(igiao.eq.6)then call lsums(dx,dy,dz,rx,ry,rz,qx,qy,qz,hx,hy,hz, 1 n,eau,lgamma,gammaau,ie,ie,hd,dlg,na,nb, 2 brx,bry,brz,qqx,qqy,qqz,u0,u0d,ut) c x/(El-Eg).(-)/2/Ne: org3=rx*dif1+ry*dif2+rz*dif3 c x/(Ej-El).(-)/2/Ne: org33=-brx*dif1-bry*dif2-brz*dif3 c write(6,6038)'xx',ie,ie,ejg,djg(9),rz/fjg,dif3 rsa1_6=com1-org1 rsa2_6=com2-org2 rsa3_6=com3-org3 rsa1_7=com1-(org1+org11)/2.0d0 rsa2_7=com2-(org2+org22)/2.0d0 rsa3_7=com3-(org3+org33)/2.0d0 if(nroot.eq.ie)then Gnj(1)=Gnj(1)-ddu(1)*(rx-brx)/2.0d0 Gnj(2)=Gnj(2)-ddu(2)*(rx-brx)/2.0d0 Gnj(3)=Gnj(3)-ddu(3)*(rx-brx)/2.0d0 Gnj(4)=Gnj(4)-ddu(1)*(ry-bry)/2.0d0 Gnj(5)=Gnj(5)-ddu(2)*(ry-bry)/2.0d0 Gnj(6)=Gnj(6)-ddu(3)*(ry-bry)/2.0d0 Gnj(7)=Gnj(7)-ddu(1)*(rz-brz)/2.0d0 Gnj(8)=Gnj(8)-ddu(2)*(rz-brz)/2.0d0 Gnj(9)=Gnj(9)-ddu(3)*(rz-brz)/2.0d0 endif endif c <0|r|1>^2: dsr= djg(1)**2+djg(2)**2+djg(3)**2 lambda=e(ie)*10.0d0/bohr c <0|m|1>^2*4*pi/lambda^2/eau^2: dsm=(2.0d0*pi/lambda/eau(ie))**2*(djg(7)**2+djg(8)**2+djg(9)**2) c <0|q|1>^2*4*pi/lambda^2: qxx=djg(13) qxy=djg(14) qxz=djg(15) qyy=djg(16) qyz=djg(17) qzz=djg(18) qi1=qxx**2+qyy**2+qzz**2+2.0d0*(qxy**2+qxz**2+qyz**2) qi2=(qxx+qyy+qzz)**2 dsq=0.1d0*(2.0d0*pi/lambda)**2*(3.0d0*qi1-qi2) dst=dsr+dsq+dsm dsv= djg(4)**2+djg(5)**2+djg(6)**2 rsv=(rsv1+rsv2+rsv3)/2.0d0 rsr=(rsr1+rsr2+rsr3)/2.0d0 rsa_4=(rsa1_4+rsa2_4+rsa3_4)/2.0d0 rsa_5=(rsa1_5+rsa2_5+rsa3_5)/2.0d0 rsa_6=(rsa1_6+rsa2_6+rsa3_6)/2.0d0 rsa_7=(rsa1_7+rsa2_7+rsa3_7)/2.0d0 if(nroot.eq.ie)then Gnj(1)=Gnj(1)/2.0d0 Gnj(2)=Gnj(2)/2.0d0 Gnj(3)=Gnj(3)/2.0d0 Gnj(4)=Gnj(4)/2.0d0 Gnj(5)=Gnj(5)/2.0d0 Gnj(6)=Gnj(6)/2.0d0 Gnj(7)=Gnj(7)/2.0d0 Gnj(8)=Gnj(8)/2.0d0 Gnj(9)=Gnj(9)/2.0d0 endif call cstat(dsv,dsr,xy(1),xa(1),ya(1),ar(1),xx(1),yy(1)) call cstat(rsv,rsr,xy(2),xa(2),ya(2),ar(2),xx(2),yy(2)) call cstat(rsa_4,rsr,xy(3),xa(3),ya(3),ar(3),xx(3),yy(3)) fne=0.5d0/dble(na+nb)*eau(ie) dg1=-u0(1)-u0d(1) dg2=-u0(2)-u0d(2) dg3=-u0(3)-u0d(3) c (1/2) x /Nel: ugx=(dg2*djg(6)-dg3*djg(5))*fne ugy=(dg3*djg(4)-dg1*djg(6))*fne ugz=(dg1*djg(5)-dg2*djg(4))*fne ecdo=-(djg(1)*(djg(6+1)-ugx) 1 + djg(2)*(djg(6+2)-ugy) 1 + djg(3)*(djg(6+3)-ugz)) 1 *2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 dj1=-ut(1,ie) dj2=-ut(2,ie) dj3=-ut(3,ie) c (1/2) x /Nel: ujx=(dj2*djg(6)-dj3*djg(5))*fne ujy=(dj3*djg(4)-dj1*djg(6))*fne ujz=(dj1*djg(5)-dj2*djg(4))*fne ecda=-(djg(1)*(djg(6+1)-(ugx+ujx)/2.0d0) 1 + djg(2)*(djg(6+2)-(ugy+ujy)/2.0d0) 1 + djg(3)*(djg(6+3)-(ugz+ujz)/2.0d0)) 1 *2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 write(28,2829)ie,((Gnj(iy+3*(ix-1)),iy=1,3),ix=1,3) 2829 format(i4,9f12.6) write(29,3010)ie,e(ie),(djg(ia),ia=1,3),(djg(6+ia),ia=1,3) 3010 format(i4,f12.4,6G15.6) write(30,3008)ie,e(ie),dsr*debye**2,rsr write(31,3008)ie,e(ie),dsv*debye**2,rsv write(32,3008)ie,e(ie),dsq*debye**2 write(33,3008)ie,e(ie),dsm*debye**2 write(34,3008)ie,e(ie),dst*debye**2 write(35,3008)ie,e(ie),dsr*debye**2,ecdo write(36,3008)ie,e(ie),dsr*debye**2,ecda 3008 format(i4,f12.4,2f20.10,f12.5) if(nroot.eq.ie)then call wrgnj(ie,Gnj,djg) if(mcdv)then if(ldis)then c distrorted grometries - expansion around ground satte eq. if(isum.eq.0) 1 call mcdid(e00,f00,np0,iwr,ndim,VA,VB,VC,VD,VE,VGP,LEXCL, 1 vu0,mu0,g0,Gnj,LQ1,LDD,THRC,lwrt,lgnj,gnji,nvib, 1 ddi,aai,rgnj,NQ1,LUE,LUM) if(isum.eq.2) 1 call mcdis(e00,f00,np0,ndim,VC,VD,VGP,LEXCL,vu0,mu0,g0,Gnj, 1 LDD,THRC,lgnj,gnji,nvib,ddi,aai,rgnj,LUE,LUM) if(isum.ne.0.and.isum.ne.2)call report('unknown isum') else call mcdi(e00,f00,np0,iwr,ndim,VC,VD,VGP,LEXCL, 1 vu0,mu0,g0,Gnj,LQ1,LDD,THRC,lwrt,lgnj,gnji,nvib, 1 ddi,aai,rgnj,NQ1,LUE,LUM) endif endif endif if(igiao.eq.6)then write(37,3008)ie,e(ie),dsr*debye**2,rsa_4 write(38,3008)ie,e(ie),dsr*debye**2,rsa_5 write(39,3008)ie,e(ie),dsr*debye**2,rsa_6 write(40,3008)ie,e(ie),dsr*debye**2,rsa_7 write(41,3012)ie,e(ie),rsa1_7/2.0d0,rsa2_7/2.0d0, 1 rsa3_7/2.0d0,rsa_7 3012 format(i4,f12.4,4f15.8) do 337 i=1,nmms 337 write(41,3013)immg(i),cmmg(i),cmme(i),imme(i) 3013 format(10x,'g ->',i4,f13.8,f15.8,' e ->',i4) else write(37,3008)ie,e(ie),dsr*debye**2,rsa_4 endif 304 continue c 304304304304304304304304304304304304304304304304304304304304304 deallocate(pre,pred) if(igiao.eq.6)then j=41 else j=37 endif do 402 i=28,j write(i,3002) 402 close(i) if(mcdv)then write(42,3002) write(43,3002) close(42) close(43) endif do 109 j=1,3 109 call stn(n,ar(j),xa(j),ya(j),reg(j),yy(j),xy(j)) write(6,3011)' Grad vs length:', 1 cc(xy(1),n3,xa(1),ya(1),xx(1),yy(1)),' MCD:', 1 cc(xy(2),n3,xa(2),ya(2),xx(2),yy(2)), 1 reg(1) ,' MCD:',reg(2), 1 ar(1) ,' MCD:',ar(2) write(6,3011)' GIAO vs length:', 1 1.0d0,' MCD:',cc(xy(3),n3,xa(3),ya(3),xx(3),yy(3)), 1 1.0d0,' MCD:',reg(3), 1 1.0d0,' MCD:',ar(3) endif c mcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcdmcd c deallocate(bp,bpd) endif c dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd c c polarization density c pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp if(lden)then if(lopen)call report('lden only for closed shells') if(lw)then c initiate atomic weights if(lwwe)then npp=nat*NP else npp=nat endif allocate(wr(npp),wi(npp),wt(npp)) call vz(wi,npp) call vz(wr,npp) call vz(wt,npp) endif inquire(file='orbitals.cub',exist=lcub) if(.not.lcub)call report('orbitals.cub not present') write(6,*) 1 'Polarization density will be calculated with orbitals.cub' open(8,file='orbitals.cub') open(9,file='roi.cub') open(91,file='ror.cub') open(92,file='rot.cub') read(8,2000)s80 2000 format(a80) write(9,2000)s80 write(91,2000)s80 write(92,2000)s80 read(8,*) write(9,901) write(91,901) write(92,901) 901 format(' SCF Total Density') read(8,*)nat,ax,ay,az nat=iabs(nat) write(9,2001)nat,ax,ay,az write(91,2001)nat,ax,ay,az write(92,2001)nat,ax,ay,az 2001 format(i5,3f12.6) read(8,*)grid(1),px write(9 ,2001)grid(1),px,0.0d0,0.0d0 write(91,2001)grid(1),px,0.0d0,0.0d0 write(92,2001)grid(1),px,0.0d0,0.0d0 read(8,*)grid(2),py,py write(9 ,2001)grid(2),0.0d0,py,0.0d0 write(91,2001)grid(2),0.0d0,py,0.0d0 write(92,2001)grid(2),0.0d0,py,0.0d0 read(8,*)grid(3),pz,pz,pz write(9 ,2001)grid(3),0.0d0,0.0d0,pz write(91,2001)grid(3),0.0d0,0.0d0,pz write(92,2001)grid(3),0.0d0,0.0d0,pz do 902 ia=1,nat read(8,2000)s80 read(s80(18:80),*)(x(i,ia),i=1,3) write(9 ,2000)s80 write(91,2000)s80 902 write(92,2000)s80 read(8,905)j,(idum,i=1,j) 905 format(10i5) if(j.ne.nmo)call report('inconsistent number of orbitals') allocate(rrx(grid(3)),orb(grid(3)*nmo),rry(grid(3)),rrz(grid(3)), 1 rix(grid(3)),riy(grid(3)),riz(grid(3)), 1 roi(grid(3)),ror(grid(3)),rot(grid(3))) if(lwwe) 1 allocate(rrxw(grid(3)*np),rryw(grid(3)*np),rrzw(grid(3)*np), 1 rixw(grid(3)*np),riyw(grid(3)*np),rizw(grid(3)*np)) xp=ax-px do 906 ix=1,grid(1) write(6,*)ix,'of',grid(1) xp=xp+px yp=ay-py do 906 iy=1,grid(2) yp=yp+py c do 904 i=1,grid(3) rrx(i)=0.0d0 rry(i)=0.0d0 rrz(i)=0.0d0 rix(i)=0.0d0 riy(i)=0.0d0 904 riz(i)=0.0d0 if(lwwe)then do 9041 i=1,grid(3)*np rrxw(i)=0.0d0 rryw(i)=0.0d0 rrzw(i)=0.0d0 rixw(i)=0.0d0 riyw(i)=0.0d0 9041 rizw(i)=0.0d0 endif read(8,4000)((orb(nmo*(iz-1)+io),io=1,nmo),iz=1,grid(3)) c dw=(wmax-wmin)/dble(np-1) do 907 ie=1,n uux=dv(ie,1)*eau(ie) uuy=dv(ie,2)*eau(ie) uuz=dv(ie,3)*eau(ie) ii=nmo**2*(ie-1) do 907 j=1,ni(ie) cijc=cij(ii+j) ucx=cijc*uux ucy=cijc*uuy ucz=cijc*uuz oa=aij(ii+j) ob=bij(ii+j) c for all frequencies within wmin .. wmax - only |ro|: if(lwwe)then w=wmin-dw do 9071 k=1,np w=w+dw call setv(eau(ie),w,fr,fi,gammaau,gammanm,lgnm,lgau) 9071 call addro(eau(ie),fi,fr,ucx,ucy,ucz,grid(3),grid(3)*(k-1), 1 orb,oa,ob,nmo,rrxw,rryw,rrzw,rixw,riyw,rizw) endif c for requested wden: call setv(eau(ie),wden,fr,fi,gammaau,gammanm,lgnm,lgau) 907 call addro(eau(ie),fi,fr,ucx,ucy,ucz,grid(3),0, 1 orb,oa,ob,nmo,rrx,rry,rrz,rix,riy,riz) c zp=az-pz do 908 iz=1,grid(3) zp=zp+pz ror(iz)=2.0d0*(rrx(iz)**2+rry(iz)**2+rrz(iz)**2) roi(iz)=2.0d0*(rix(iz)**2+riy(iz)**2+riz(iz)**2) rot(iz)=dsqrt(ror(iz)+roi(iz)) roi(iz)=dsqrt(roi(iz)) ror(iz)=dsqrt(ror(iz)) if(lw)then c find closest atom iclose=1 cd2=(xp-x(1,1))**2+(yp-x(2,1))**2+(zp-x(3,1))**2 do 2007 l=2,nat d2 =(xp-x(1,l))**2+(yp-x(2,l))**2+(zp-x(3,l))**2 if(d2.lt.cd2)then cd2=d2 iclose=l endif 2007 continue c increment the real and imaginary weights by the densities: if(lwwe)then c all frequencies: w=wmin-dw do 9081 k=1,np w=w+dw ii=iz+grid(3)*(k-1) rorw=2.0d0*(rrxw(ii)**2+rryw(ii)**2+rrzw(ii)**2) roiw=2.0d0*(rixw(ii)**2+riyw(ii)**2+rizw(ii)**2) ii=iclose+nat*(k-1) wr(ii)=wr(ii)+dsqrt(rorw) wi(ii)=wi(ii)+dsqrt(roiw) 9081 wt(ii)=wt(ii)+dsqrt(rorw+roiw) else c just one frequency: wr(iclose)=wr(iclose)+ror(iz) wi(iclose)=wi(iclose)+roi(iz) wt(iclose)=wt(iclose)+rot(iz) endif endif 908 continue c density only for desired frequency: write(9 ,4000)(roi(iz),iz=1,grid(3)) write(91,4000)(ror(iz),iz=1,grid(3)) 906 write(92,4000)(rot(iz),iz=1,grid(3)) 4000 format(6E13.5) if(lw)then open(50,file='WEIGHTS.TXT') allocate(ind(nat),jnd(nat)) c normalize atomic weights: if(lwwe)then nw=np else nw=1 endif w=wmin-dw do 9082 k=1,nw w=w+dw if(.not.lwwe)w=wden sumr=0.0d0 sumi=0.0d0 sumt=0.0d0 do 2008 i=1,nat ii=i+nat*(k-1) sumi=sumi+wi(ii) sumr=sumr+wr(ii) 2008 sumt=sumt+wt(ii) do 2009 i=1,nat ii=i+nat*(k-1) if(sumi.ne.0.0d0)wi(ii)=wi(ii)/sumi if(sumr.ne.0.0d0)wr(ii)=wr(ii)/sumr 2009 if(sumt.ne.0.0d0)wt(ii)=wt(ii)/sumt write(6,6071)(100.0d0*wr(i+nat*(k-1)),i=1,nat) write(6,6071)(100.0d0*wi(i+nat*(k-1)),i=1,nat) write(6,6071)(100.0d0*wt(i+nat*(k-1)),i=1,nat) 6071 format(12f6.1) c recalculate to get rid of small contributions: write(6 ,28281)k,w write(50,28281)k,w 28281 format(i4,f12.3,' nm, Real weights:') write(6 ,6071)(100.0d0*wr(i+nat*(k-1)),i=1,nat) write(50,6071)(100.0d0*wr(i+nat*(k-1)),i=1,nat) write(6 ,*)'Imaginary weights:' write(50,*)'Imaginary weights:' write(6 ,6071)(100.0d0*wi(i+nat*(k-1)),i=1,nat) write(50,6071)(100.0d0*wi(i+nat*(k-1)),i=1,nat) write(6 ,*)'|ro| weights:' write(50,*)'|ro| weights:' write(6 ,6071)(100.0d0*wt(i+nat*(k-1)),i=1,nat) write(50,6071)(100.0d0*wt(i+nat*(k-1)),i=1,nat) call sort(wr,ind,jnd,nat,k) call trimv(wr,nat,nt,k) write(6 ,*)'Real weights trimmed:' write(50,*)'Real weights trimmed:' write(6 ,6071)(100.0d0*wr(jnd(i)+nat*(k-1)),i=1,nat) write(50,6071)(100.0d0*wr(jnd(i)+nat*(k-1)),i=1,nat) call sort(wi,ind,jnd,nat,k) call trimv(wi,nat,nt,k) write(6 ,*)'Imaginary weights trimmed:' write(50,*)'Imaginary weights trimmed:' write(6 ,6071)(100.0d0*wi(jnd(i)+nat*(k-1)),i=1,nat) write(50,6071)(100.0d0*wi(jnd(i)+nat*(k-1)),i=1,nat) call sort(wt,ind,jnd,nat,k) call trimv(wt,nat,nt,k) write(6 ,*)'|ro| weights trimmed:' write(50,*)'|ro| weights trimmed:' write(6 ,6071)(100.0d0*wt(jnd(i)+nat*(k-1)),i=1,nat) 9082 write(50,6071)(100.0d0*wt(jnd(i)+nat*(k-1)),i=1,nat) close(50) deallocate(ind,jnd) endif deallocate(orb,rrx,rry,rrz,rix,riy,riz,ror,roi) if(lwwe)deallocate(rrxw,rryw,rrzw,rixw,riyw,rizw) close(8) close(9) close(91) write(6,*)' roi.cub ror.cub written' endif c pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp end subroutine trimv(v,nat,nt,k) implicit none real*8 v(*),t integer*4 nat,i,nt,k,o o=nat*(k-1) t=0.0d0 do 1 nt=1,nat t=t+v(nt+o) 1 if(t.ge.0.5d0)goto 2 2 if(nt.gt.nat)nt=nat do 4 i=1,nt 4 v(i+o)=v(i+o)/t do 3 i=nt+1,nat 3 v(i+o)=0.0d0 return end subroutine sort(v,ind,jnd,nat,k) implicit none real*8 v(*),t integer*4 ind(*),nat,i,j,it,jnd(*),k,o o=nat*(k-1) do 1 i=1,nat jnd(i)=i 1 ind(i)=i do 2 i=1,nat-1 do 2 j=i+1,nat if(v(j+o).gt.v(i+o))then t=v(i+o) v(i+o)=v(j+o) v(j+o)=t it=ind(i) ind(i)=ind(j) ind(j)=it jnd(ind(j))=j jnd(ind(i))=i endif 2 continue return end c subroutine titles(ti,ext,out) character*(*) ti,ext character*80 out integer*4 i,k do 1 i=1,80 if (ti(i:i).eq.'.'.or.ti(i:i).eq.' ') then k=i-1 goto 2 endif 1 continue 2 out=ti(1:k)//ext return end subroutine setv(eau,w,fr,fi,g,gnm,lgnm,lgau) implicit none real*8 w,jm,fr,fi,g,wau,eau,gnm,a,pi,ln2,ff logical lgnm,lgau c nm to au:= c wau=(1.0d7/w)/219474.63d0 wau=45.5633528d0/w c set bandwidth, either constant in wavelength or energy: if(lgnm)then if(w.gt.gnm)then a=45.5633528d0*gnm/(w-gnm)/(w+gnm) else a=gnm*wau/w endif else a=g endif ff= (eau-wau)*(eau+wau) jm= ff**2+(a*eau)**2 fr= ff / jm if(lgau)then c Gaussian curve for dispersion pi=4.0d0*datan(1.0d0) ln2=log(2.0d0) if(dabs(eau-wau).gt.5.0d0*a)then fi=0.0d0 else fi=dsqrt(pi*ln2)/a/eau**2*exp(-4.0d0*ln2*((eau-wau)/a)**2) endif else c Lorentzian curve G /[(w^2-w0^2)^2 + G^2 w0^2] fi= a / jm endif fr=fr+fr fi=fi+fi return end subroutine getv(n,d,ds1,r0,angle,rs,r,i) implicit none integer*4 i,n real*8 d(n,3),ds1,r0(*),angle,de,dm,ds,r(n,3),rs ds1=(d(i,1)*d(i,1)+d(i,2)*d(i,2)+d(i,3)*d(i,3))*2.541765d0**2 c ds=2.12689677295232d-30*f(i)/ev(i)/8065.54476345045d0/1.0d-36 rs=r0(i)*1.0d-4 c rs1=(d(i,1)*r(i,1)+d(i,2)*r(i,2)+d(i,3)*r(i,3)) c 1*2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36 c c angle between electric and magnetic moment: de=dsqrt(d(i,1)*d(i,1)+d(i,2)*d(i,2)+d(i,3)*d(i,3)) dm=dsqrt(r(i,1)*r(i,1)+r(i,2)*r(i,2)+r(i,3)*r(i,3)) ds= (d(i,1)*r(i,1)+d(i,2)*r(i,2)+d(i,3)*r(i,3)) angle=0.0d0 if(de*dm.gt.0.0d0)angle=acos(ds/de/dm)*180.0d0/4.0d0/atan(1.0d0) return end subroutine report(s) character*(*) s write(6,*)s stop end subroutine ru(io,A,n,m) c matrix n x m implicit none REAL*8 A(n,m) INTEGER*4 io,n,m,N1,N3,LN,J N1=1 1 N3=MIN(N1+4,m) read(io,*) DO 130 LN=1,N 130 read(io,*)A(LN,N1),(A(LN,J),J=N1,N3) N1=N1+5 IF(N3.LT.m)GOTO 1 return end subroutine rmtr38(A,n0,n,ic) c ic=0 .. reads triangle of a supposedly symmetric matrix c ic=1 .. reads it all c IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER*4 (I-N) dimension A(n0,n) read(38,*) read(38,*) N1=1 1 N3=MIN(N1+4,N) read(38,*) lnst=n1 if(ic.eq.1)lnst=1 DO 130 LN=lnst,N IEND=MIN(LN,N3) if(ic.eq.1)iend=N3 130 read(38,*)J,(A(LN,J),J=N1,iend) N1=N1+5 IF(N3.LT.N)GOTO 1 read(38,*) return end subroutine rwm(b,n,nd0) implicit none integer*4 i,j,k,n,n2,nd00,nd0 real*8 b(*) real*8 ,allocatable::p(:,:) parameter (nd00=21) character*2 ss(nd00) character*15 fn data ss/'PX','PY','PZ','VX','VY','VZ','LX','LY','LZ', 1 'DX','DY','DZ','XX','XY','XZ','YY','YZ','ZZ', 1 'EX','EY','EZ'/ c 1 2 3 4 5 6 7 8 9 c 10 11 12 13 14 15 16 17 18 c 19 20 21 logical lex c D .. r x rj c E .. r x ri if(nd0.ne.nd00)call report('nd0 <> nd00') allocate(p(n,n)) n2=n**2 do 1 i=1,nd00 if(i.gt.12.and.i.le.18)then fn='Q'//ss(i)//'.MO.SCR.TXT' else fn=ss(i)//'.MO.SCR.TXT' endif inquire(file=fn,exist=lex) if(lex)then open(38,file=fn) call rmtr38(p,n,n,1) close(38) do 3 j=1,n do 3 k=1,n 3 b(n2*(i-1)+n*(k-1)+j)=p(k,j) write(6,8000)i,fn 8000 format(i4,2x,a15,'read') else write(6,*)ss(i)//'.MO.SCR.TXT not present' do 2 j=1,n do 2 k=1,n 2 b(n2*(i-1)+n*(k-1)+j)=0.0d0 stop endif 1 continue return end subroutine rwmd(b,n) implicit none integer*4 i,j,k,n,n2 real*8 b(*) real*8 ,allocatable::p(:,:) character*3 ss(18) data ss/'PBX','PBY','PBZ','VBX','VBY','VBZ','LBX','LBY','LBZ', 1'WBX','WBY','WBZ','BXX','BXY','BXZ','BYY','BYZ','BZZ'/ logical lex allocate(p(n,n)) n2=n**2 do 1 i=1,18 if(i.gt.12)then inquire(file='Q'//ss(i)//'.MO.SCR.TXT',exist=lex) else inquire(file=ss(i)//'.MO.SCR.TXT',exist=lex) endif if(lex)then if(i.gt.12)then open(38,file='Q'//ss(i)//'.MO.SCR.TXT') else open(38,file=ss(i)//'.MO.SCR.TXT') endif call rmtr38(p,n,n,1) close(38) do 3 j=1,n do 3 k=1,n 3 b(n2*(i-1)+n*(k-1)+j)=p(k,j) else write(6,*)ss(i)//'.MO.SCR.TXT not present' do 2 j=1,n do 2 k=1,n 2 b(n2*(i-1)+n*(k-1)+j)=0.0d0 endif 1 continue return end subroutine getdipole(ut,n,cij,nmo,ni,aij,bij, 1dij,nid,daij,dbij,lopen,pre,pred,ie,nd0,ic,n2) c electronic permanent dipoles of excite state ie implicit none integer*4 ie,j,ni(*),i,oa,ob,aij(*),bij(*),nmo, 1n2,nid(*),daij(*),dbij(*),n,nd0,ic real*8 ut(ic,n),cij(*),dij(*),pre(*),pred(*) logical lopen do 1 j=1,ic c =cie_ab b>: ut(j,ie)=0.0d0 do 2 i=1,ni(ie) oa=aij(n2*(ie-1)+i) ob=bij(n2*(ie-1)+i) 2 ut(j,ie)=ut(j,ie)+cij(n2*(ie-1)+i)*pre(j+(oa-1+(ob-1)*nmo)*nd0) if(lopen)then do 3 i=1,nid(ie) oa=daij(n2*(ie-1)+i) ob=dbij(n2*(ie-1)+i) 3 ut(j,ie)=ut(j,ie)+dij(n2*(ie-1)+i)*pred(j+(oa-1+(ob-1)*nmo)*nd0) endif 1 continue return end subroutine getdipole1(uee,cij,nmo,ni,aij,bij, 1dij,nid,daij,dbij,lopen,pre,pred,ie,nd0,n2) c electronic permanent dipoles of excite state ie implicit none integer*4 ie,j,ni(*),i,oa,ob,aij(*),bij(*),nmo, 1n2,nid(*),daij(*),dbij(*),nd0 real*8 uee(*),cij(*),dij(*),pre(*),pred(*) logical lopen do 1 j=1,nd0 c =cie_ab b>: uee(j)=0.0d0 do 2 i=1,ni(ie) oa=aij(n2*(ie-1)+i) ob=bij(n2*(ie-1)+i) 2 uee(j)=uee(j)+cij(n2*(ie-1)+i)*pre(j+(oa-1+(ob-1)*nmo)*nd0) if(lopen)then do 3 i=1,nid(ie) oa=daij(n2*(ie-1)+i) ob=dbij(n2*(ie-1)+i) 3 uee(j)=uee(j)+dij(n2*(ie-1)+i)*pred(j+(oa-1+(ob-1)*nmo)*nd0) endif 1 continue return end subroutine getieab(pre,pred,lopen,na,nb,nmo,ni,nid,ie,aij,bij, 1cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,nd0,n22) c b> c note that for singlets states the matrix elements are the same as c for Slater's determinants implicit none logical lopen integer*4 oa,ob,oc,od,na,nb,nmo,j,i,ni(*),nid(*),ie,nmo2, 1aij(*),bij(*),daij(*),dbij(*),nd0,jj,n22 real*8 pre(*),pred(*),cij(*),dij(*),ciji,bp(*),bpd(*), 1u0(*),u0d(*) do 1 oc=1,nd0*nmo*nmo pre(oc)=0.0d0 1 pred(oc)=0.0d0 if(lopen)then do 2 i=1,ni(ie) oa =aij(n22*(ie-1)+i) ob =bij(n22*(ie-1)+i) ciji=cij(n22*(ie-1)+i) do 2 j=1,nd0 jj=nmo2*(j-1) c (ABCD) .. note that A<>B and C<>D: c if(oc.eq.oa) c if(od.eq.ob) : pre(j+(oa-1+(ob-1)*nmo)*nd0)=pre(j+(oa-1+(ob-1)*nmo)*nd0) 1 +ciji*(u0(j)+u0d(j)-bp(oa+nmo*(oa-1)+jj) 1 + bp(ob+nmo*(ob-1)+jj)) c if(od.ne.ob)=: do 3 od=na+1,nmo if(ob.ne.od) 1 pre(j+(oa-1+(od-1)*nmo)*nd0)= 2 pre(j+(oa-1+(od-1)*nmo)*nd0)+ciji*bp(ob+nmo*(od-1)+jj) 3 continue c if(oc.ne.oa) =: do 2 oc=1,na 2 if(oc.ne.oa) 1 pre(j+(oc-1+(ob-1)*nmo)*nd0)= 2 pre(j+(oc-1+(ob-1)*nmo)*nd0)+ciji*bp(oa+nmo*(oc-1)+jj) do 42 i=1,nid(ie) oa =daij(n22*(ie-1)+i) ob =dbij(n22*(ie-1)+i) ciji=dij(n22*(ie-1)+i) c if(oa.ne.oc)then if(ob.eq.od)then: do 4 oc=1,nb if(oc.ne.oa)then do 22 j=1,nd0 22 pred(j+(oc-1+(ob-1)*nmo)*nd0)= 1 pred(j+(oc-1+(ob-1)*nmo)*nd0)+ciji*bpd(oa+nmo*(oc-1)+nmo2*(j-1)) endif 4 continue c if(oa.eq.oc)then if(ob.ne.od)then: do 5 od=nb+1,nmo if(ob.ne.od)then do 32 j=1,nd0 32 pred(j+(oa-1+(od-1)*nmo)*nd0)= 1 pred(j+(oa-1+(od-1)*nmo)*nd0)+ciji*bpd(ob+nmo*(od-1)+nmo2*(j-1)) endif 5 continue c if(oa.eq.oc)then if(ob.eq.od)then: do 42 j=1,nd0 42 pred(j+(oa-1+(ob-1)*nmo)*nd0)=pred(j+(oa-1+(ob-1)*nmo)*nd0) 1 +ciji*(u0(j)+u0d(j)-bpd(oa+nmo*(oa-1)+nmo2*(j-1)) 1 + bpd(ob+nmo*(ob-1)+nmo2*(j-1))) else c closed shell- note that rule is different than for open shell: do 6 i=1,ni(ie) oa =aij(n22*(ie-1)+i) ob =bij(n22*(ie-1)+i) ciji=cij(n22*(ie-1)+i) do 6 j=1,nd0 jj=nmo2*(j-1) c (ABCD) .. note that A<>B and C<>D: c if(oc.eq.oa) c if(od.eq.ob) : pre(j+(oa-1+(ob-1)*nmo)*nd0)=pre(j+(oa-1+(ob-1)*nmo)*nd0) 1 +ciji*(u0(j)+u0d(j)-bp(oa+nmo*(oa-1)+jj) 1 + bp(ob+nmo*(ob-1)+jj)) c if(od.ne.ob)=: do 6 od=na+1,nmo 6 if(ob.ne.od) 1 pre(j+(oa-1+(od-1)*nmo)*nd0)= 2 pre(j+(oa-1+(od-1)*nmo)*nd0)+ciji*bp(ob+nmo*(od-1)+jj) endif return end subroutine readopt2(nexc,wes) implicit none integer*4 nexc real*8 wes(nexc) character*4 key nexc=1 wes(1)=532.0d0 open(9,file='GUVCDE.OPT') 1001 read(9,90,err=109,end=109)key 90 format(a4) c read excitation frequencies in nm: if(key.eq.'NEXC')read(9,*)nexc,wes goto 1001 109 close(9) return end subroutine readoptions(lden,lmcd,lrds,lw,wden,fo,icpl, 1lzmat,ldeg,lwrt,DD,degper0,deglim,lnorm,nst,ifix,nmo,igiao, 1gammaau,wmin,wmax,np,lgamma,lort,gammanm,lgnm,lgau,lwwe,nmms, 1mcdv,nroot,fov,LEXCL,LQ1,np0,iwr,THRC,LDD,lgnj,LDE,rgnj,lbck, 1rroa,LEXCF,wzero,lwzero,NQ1,lvert,wrax, 1wrin,npx,lglg,fwhh,ltab,kelvin,ldusch,NQBUF,LUE,LUM, 1ldis,troa,vrroa,anroa,mroa,lpolder,ltgauss,isum,ecdv,e00, 7winm,wanm,fwnm,lspec,nnm,loit,lbolt,lhyde,nmap,mmap,frroa, 7lwten,nproc,lover,lvel,lrro,nb0,th1,th2,mmax,mmaxi,mmaxf, 7ktlim,LEXCI,nexc,lusea,luseg,lqi,icw,lprog,ldo) implicit none integer*4 nst,ifix,nmo,igiao,np,icpl,nmms,nroot,iwr,np0,LEXCL, 1LEXCF,NQ1,npx,NQBUF,isum,nnm,nmap,mmap(*),i,nproc,nb0,mmax, 1mmaxi,mmaxf,LEXCI,nexc,nk,icw,ns0,ie parameter (ns0=19) real*8 DD,degper0,deglim,wden,wmin,wmax,gammaau,gammanm,THRC, 1wzero,wrax,wrin,fwhh,kelvin,troa,e00,winm,wanm,fwnm, 1gammacm,th1,th2,ktlim logical lden,lmcd,lrds,lw,lzmat,ldeg,lwrt,lnorm,lgamma,lort, 1lgnm,lgau,lwwe,mcdv,LDD,LQ1,lgnj,LDE,rgnj,lbck,rroa,lwzero, 1lvert,lglg,ltab,ldusch,LUE,LUM,ldis,vrroa,anroa, 1mroa,lpolder,ltgauss,ecdv,lspec,loit,lbolt,lhyde,frroa,lwten, 1lover,lvel,lrro,lusea,luseg,lqi,lprog,ldo(ns0) character*11 key,kk character*4 k4 character*30 s30 character*(*) fo,fov character*11 st(ns0) data st/'ICP_0 ','ICPx_90 ','ICPz_90 ','ICPs_90 ', 1 'ICPu_90 ','ICP_180 ','SCP_0 ','SCPx_90 ', 1 'SCPz_90 ','SCPs_90 ','SCPu_90 ','SCP_180 ', 1 'DCPI_0 ','DCPI_90 ','DCPI_180 ','DCPII_0 ', 1 'DCPII_90 ','DCPII_180 ','FCTAB '/ c Vibrational structure options: c which kind of ROA spectrum to generate: ldo=.true. c investigate exc vib states from this quantum number: icw=1 c write intensities each class: lprog=.true. c use ground el state geometry transition integral derivatives lqi=.false. c number of oexcitation frequencies: nexc=1 c maximal excitation on one oscillator el. ground state initial LEXCI=1 c limit for initial states, exp (-E/kt) < ktlim ktlim=0.25d0 c maximal class included, initial intermediate,final: mmaxi=0 mmax=3 mmaxf=1 c use G and A tensors: luseg=.true. lusea=.true. c threshold for franck condon 1 class th1=1.0d-9 c threshold for franck condon 2 class th2=1.0d-9 c buffer size for rrro RROA states nb0=10000000 c use the rrro RROA algorithm lrro=.true. c selection of states based on overlaps: lover=.true. c velocity formalism for tensors lvel=.true. c number of processors nproc=1 c nmap- number of reduced modes, listed in mmap nmap=0 c Second set of Duschinsky's parameters for RROA in DUSCH2.OUT: lhyde=.false. c Boltzmann weights, vibr resolution: lbolt=.false. c iterate around the best suggested state: loit=.false. c 0-0 energy e00=0.0d0 c read guess of the excited vibrational state from PSTATE: ldis=.false. c dusch.f-dependent version of ldis isum=0 c read Duschinsky and other matrices from DUSCH.OUT ldusch=.false. c temperature for spectrum: kelvin=300.0d0 c minimal frequency for spectra plot (Raman) cm-1: wrin=40.0d0 c maximal Raman frequency cm-1: wrax=4000.0d0 c number of points in generated spectrum: npx=3961 c minimal wavelength for spectra plot (abs/cd) nm: winm=190.0d0 c maximal wavelength: wanm=800.0d0 c number of points in generated spectrum: nnm=691 c gaussian instead of lorentzian: lglg=.false. c bandwidth cm-1 fwhh=10.0d0 c bandwidth nm: fwnm=10.0d0 c make RROA.TAB,ECDI.TAB: ltab=.false. c make continuous rroa,ecdi spectra: lspec=.true. c vertical approximation for vibrations: lvert=.false. c Maximum number of excited centers: NQ1=0 c replace rotations and translations by wzero modes lwzero=.false. c lifetime (in cm-1) for VRROA: troa=10.0d0 c vibrational resonance ROA: vrroa=.false. c write RROA tensors for each transition into TTT.OUT lwten=.false. c full vibrational resonance ROA: frroa=.false. c add non-resonance polarizability anroa=.false. c frequency (cm-1) for zero modes: wzero=100.0d0 c read dipole derivatives from DE.TEN LDE=.false. c Herzberg-Teller contributions for dipoles (MCD,ECD),ele. magn: LUE=.true. LUM=.true. c read derivatives of the Gnj tensor from GNJD.TEN: lgnj=.false. c read Gnj tensor from GNJR.TEN (debug option): rgnj=.false. c invoke the calculation: mcdv=.false. c invoke the calculation of vibrational ABS/CD: ecdv=.false. c vibrational parameter file: fov='GV.OUT' c maximal degree of excitations ("class"): LEXCL=3 c maximal degree of excitations for final RROA state: LEXCF=1 c use first dipole derivatives: LQ1=.true. c dimension of the temporary list: np0=10000 c optional writing option: iwr=1 c threshold to consider Franck-Condon factors: THRC=1.0d-9 c read dipole derivatives: LDD=.true. c number of the excited state nroot=1 c read also backward excitations: lbck=.false. c Other options: c invoke resonance ROA calculation: rroa=.false. c invoke magnetic ROA calculation: mroa=.false. c SOS polarizability derivatives: lpolder=.false. c sos transition moments from gaussian: ltgauss=.true. c number of the largest dipoles considered NQBUF=100 c use only some Franck COndon terms if buffer overflows: degper0=0.0001d0 deglim=0.00001d0 lden=.false. nmms=3 ifix=3 nst=0 lnorm=.false. lort=.true. lgnm=.true. lgamma=.true. lwwe=.false. lgau=.false. lmcd=.true. icpl=0 lrds=.false. lw=.false. wden=532.0d0 fo='G.OUT' lzmat=.true. ldeg=.false. lwrt=.false. DD=2.0d0 nmo=0 igiao=0 gammacm=500.0d0 gammanm=10.0d0 wmin=50.0d0 wmax=500.0d0 np=901 nk=0 open(9,file='GUVCDE.OPT') 1001 read(9,90,err=109,end=109)key 90 format(a11) read(9,91,err=109,end=109)s30 91 format(a30) nk=nk+1 write(6,600)key,s30(1:15) 600 format(a11,2x,a15,$) if(mod(nk,2).eq.0)write(6,*) backspace 9 k4=key(1:4) c gaussian TDDFT output: if(k4.eq.'FILE')read(9,9010)fo 9010 format(a80) c GIAO experimenting: c igiao = 0 (r-Rb) c igiao = 1 (r-R(a+b)) c igiao = 2 (r-R( b))*Dab c igiao = 3 (r-R(a+b))*Dab if(k4.eq.'GIAO')read(9,*)igiao c use z-matrix orientation: if(k4.eq.'ZMAT')read(9,*)lzmat c remove degeneracy if present: if(k4.eq.'LDEG')read(9,*)ldeg c frequency to produce .cub file if(k4.eq.'WDEN')read(9,*)wden c produce .cub file: if(k4.eq.'LDEN')read(9,*)lden c produce atomic weights: if(k4.eq.'LWEI')read(9,*)lw c atomix extent for the weigths in A: if(k4.eq.'EXTE')read(9,*)DD c calculate MCD: if(k4.eq.'LMCD')read(9,*)lmcd c calculate circular polarized luminiscence from this state if(k4.eq.'ICPL')read(9,*)icpl c recalculate dipole strengths: if(k4.eq.'LRDS')read(9,*)lrds c degeneracy limit detection: if(k4.eq.'DEGL')read(9,*)deglim c degeneracy perturbation: if(k4.eq.'DEGP')read(9,*)degper0 c how many E G controbutions for MCD statistics: if(k4.eq.'NMMS')read(9,*)nmms c iterate around the best suggested state: if(k4.eq.'LOIT')read(9,*)loit c investigate exc vib states from this quantum: if(k4.eq.'IECW')read(9,*)icw c number of processors: if(k4.eq.'NPRO')read(9,*)nproc c extended writing if(k4.eq.'LWRT')read(9,*)lwrt c calculate weights for all NP points between WMIN and WMAX: if(k4.eq.'LWEE')read(9,*)lwwe c renormalize cij coefficients if(k4.eq.'LNOR')read(9,*)lnorm c renorthonormalize cij coefficients if(k4.eq.'LORT')read(9,*)lort c limit number of excited states (put zero to take all): if(k4.eq.'NSTA')read(9,*)nst if(key(1:3).eq.'NMO')read(9,*)nmo c fix for backward excitations c 0 .. none c 1 .. add to cij c 2 .. consider separately c 3 .. ad as extra transition c 4 .. ignore, probably same as 0 c 5 .. add complex (not implemented) if(k4.eq.'IFIX')read(9,*)ifix c bandwidth in cm-1, for computation of MCD and polarizabilities: if(k4.eq.'GACM')read(9,*)gammacm c bandwidth in nm, for computation of polarizabilities if required c by lgnm: if(k4.eq.'GANM')read(9,*)gammanm c limit for initial states, exp (-E/kt) < ktlim if(k4.eq.'KTLI')read(9,*)ktlim c frack condon maximal class included,inital,intermediate,final: if(k4.eq.'MMAI')read(9,*)mmaxi if(k4.eq.'MMAX')read(9,*)mmax if(k4.eq.'MMAF')read(9,*)mmaxf c use A and G tensors: if(k4.eq.'USEG')read(9,*)luseg if(k4.eq.'USEA')read(9,*)lusea c frack condon 1 slass threshold if(key(1:3).eq.'TH1')read(9,*)th1 c frack condon 2 slass threshold if(key(1:3).eq.'TH2')read(9,*)th2 c 0-0 energy in cm-1: if(key(1:3).eq.'E00')read(9,*)e00 c whether to use gammaau in MCD: if(k4.eq.'LGAM')read(9,*)lgamma c whether to use Gaussian dispersion curves: if(k4.eq.'LGAU')read(9,*)lgau c whether to use lgnm: if(k4.eq.'LGNM')read(9,*)lgnm c minimal and maximal frequency (nm) c for frequecny-dependent polarizabilities: if(k4.eq.'WMIN')read(9,*)wmin if(k4.eq.'WMAX')read(9,*)wmax c nmap- number of reduced modes, listed in mmap if(k4.eq.'NMAP')then read(9,*)nmap if(nmap.gt.1000)call report('too many nmap modes') read(9,*)(mmap(i),i=1,nmap) endif c number of points in the above frequency interval: if(key(1:3).eq.'NPO)')read(9,*)np c vertical approximation for vibrations: if(k4.eq.'LVER')read(9,*)lvert c make resonance ROA: if(k4.eq.'RROA')read(9,*)rroa c sos transition moments from gaussian: if(k4.eq.'LTGA')read(9,*)ltgauss c make magnetic ROA: if(k4.eq.'MROA')read(9,*)mroa c SOS polarizability derivatives: if(k4.eq.'SOSP')read(9,*)lpolder c number of the largest dipoles considered if(k4.eq.'NQBU')read(9,*)NQBUF c Boltzmann for vibrational resolution: if(k4.eq.'BOLT')read(9,*)lbolt c second set of Duschinsky's parameters in DUSCH.OUT for RROA: if(k4.eq.'LHYD')read(9,*)lhyde c temperature for spectrum: if(k4.eq.'KELV')read(9,*)kelvin c read Duschinsky and other matrices from DUSCH.OUT: if(k4.eq.'DUSC')read(9,*)ldusch c minimal Raman frequency cm-1: if(k4.eq.'WRIN')read(9,*)wrin c maximal Raman frequency cm-1: if(k4.eq.'WRAX')read(9,*)wrax c minimal wavelength,nm: if(k4.eq.'WINM')read(9,*)winm c maximal wavelength,nm: if(k4.eq.'WANM')read(9,*)wanm c number of points in generated spectrum: if(key(1:3).eq.'NPX')read(9,*)npx c number of points in generated spectrum,electronic: if(key(1:3).eq.'NNM')read(9,*)nnm c gaussian instead of lorentzian: if(k4.eq.'LGLG')read(9,*)lglg c bnadwidth cm-1 if(k4.eq.'FWHH')read(9,*)fwhh c bnadwidth nm: if(k4.eq.'FWNM')read(9,*)fwnm c make RROA.TAB: if(k4.eq.'LTAB')read(9,*)ltab c make continuous spectra: if(k4.eq.'LSPE')read(9,*)lspec c number of excitation frequencies: if(k4.eq.'NEXC')read(9,*)nexc c write intensities each class is done: if(k4.eq.'PROG')read(9,*)lprog c use transition integral derivatives at ground state geometry if(k4.eq.'EGRO')read(9,*)lqi c make the vibrationally resolved calculation: if(k4.eq.'MCDI')read(9,*)mcdv c make the vibrationally resolved calculation,CD only: if(k4.eq.'ECDI')read(9,*)ecdv c number of the excited state for MCDV: if(k4.eq.'NROO')read(9,*)nroot c filename with the parameters for MCDV: if(k4.eq.'FILV')read(9,*)fov c maximum number of initial excitations: if(k4.eq.'LEXI')read(9,*)LEXCI c maximum number of excitations: if(k4.eq.'LEXC')read(9,*)LEXCL c read guess of the excited vibrational state from PSTATE: if(k4.eq.'LDIS')read(9,*)ldis c Maximum number of excited centers: if(key(1:3).eq.'NQ1')read(9,*)NQ1 c maximum number of excitations for final RROA state: if(k4.eq.'LFXC')read(9,*)LEXCF c use fist dipole derivatives: if(key(1:3).eq.'LQ1')read(9,*)LQ1 c dimension of the expansion space for Franck Condon factors: if(key(1:3).eq.'NP0')read(9,*)np0 c additional writing option for MCDV: if(key(1:3).eq.'IWR')read(9,*)iwr c threshold for vibrational contributions: if(k4.eq.'THRC')read(9,*)THRC c read dipole derivatives: if(key(1:3).eq.'LDD')read(9,*)LDD c Herzberg-Teller for electric dipoles: if(key(1:3).eq.'LUE')read(9,*)LUE c Herzberg-Teller for magnetic dipoles: if(key(1:3).eq.'LUM')read(9,*)LUM c read dipole derivatives from DE.TEN: if(k4.eq.'LDEE')read(9,*)LDE c read Gnj tensor derivatives from GNJD.TEN: if(k4.eq.'LGNJ')read(9,*)lgnj c read also backward excitations if(k4.eq.'LBCK')read(9,*)lbck c read Gnj tensor from GNJR.TEN: if(k4.eq.'RGNJ')read(9,*)rgnj c replace rotations and translations by wzero modes if(k4.eq.'LWZE')read(9,*)lwzero c frequency (cm-1) for zero modes: if(k4.eq.'WZER')read(9,*)wzero c vibrational resonance ROA lifetime in hartree: if(k4.eq.'TROA')read(9,*)troa c velocity formalism for RROA tensors: if(k4.eq.'LVEL')read(9,*)lvel c buffer szie for e states in RROA rrro: if(key(1:3).eq.'NB0')read(9,*)nb0 c use the rrro RROA algorithm if(k4.eq.'LRRO')read(9,*)lrro c selection of states based on overlapsL if(k4.eq.'LOVE')read(9,*)lover c write RROA tensors into TTT.OUT for each transition if(k4.eq.'LWTE')read(9,*)lwten c full vibrational resonance ROA if(k4.eq.'FRRO')read(9,*)frroa c vibrational resonance ROA if(k4.eq.'VRRO')read(9,*)vrroa c add non-resonance polarizability if(k4.eq.'ANRO')read(9,*)anroa c isum=0 ... generate vib. states from zero excitation c isum=1 ... generate vib. states from mother state in PSTATE/LEXCL c isum=2 ... generate vib. states from mother state in c PSTATE PSTATE.TAB/systematic if(k4.eq.'ISUM')read(9,*)isum do 4 ie=1,len(key) 4 if(key(ie:ie).eq.' ')goto 3 3 ie=ie-1 do 5 i=1,ns0 5 if(key(1:ie).eq.st(i)(1:ie))read(9,*)ldo(i) backspace 9 read(9,90)kk if(kk.eq.key)then write(6,*) call report(kk//' - unknown keyword') endif goto 1001 109 close(9) write(6,*) gammaau=gammacm/219470.0d0 return end subroutine dimensions(n,fo,nmo,nmo2,nat,lzmat,lturbo,ltda,ncmm) c returns number of transitions and atoms implicit none integer*4 n,nat,l,I,q,nmo,nmo2,ncmm,it,nt real*8 axdum character*80 s80 character*70 st character*(*) fo logical lzmat,lturbo,le,ltda n=0 nat=0 ncmm=0 it=0 c Grimme's TDA output - (CI soefficients from cicond) inquire(file='ciss_a.co',exist=ltda) if(ltda)then open(2,file='ciss_a.co') n=0 10 read(2,2000,end=790,err=790)s80 if(s80(1:1).eq.'e'.or.s80(1:2).eq.' ')then n=n+1 c nt: number of expansion coefficients for this state nt=0 11 read(2,2000,end=690,err=690)s80 if(s80(1:1).ne.'e'.and.s80(1:2).ne.' ')then nt=nt+1 goto 11 else backspace 2 endif 690 if(nt.gt.ncmm)then ncmm=nt it=n endif endif goto 10 790 close(2) write(6,*)n,' transitions in ciss_a.co' write(6,*)ncmm,' coefficients for state ',it endif c Turbomole output: inquire(file='control',exist=lturbo) if(lturbo)then write(6,*)'control file from Turbomole found ....' open(2,file='control') nmo=0 100 read(2,2000,end=990,err=990)s80 IF(s80(4:10).EQ.'natoms=')read(s80(11:len(s80)),*)nat IF(s80(4:11).EQ.'nbf(AO)=')read(s80(12:len(s80)),*)nmo if(nat.eq.0.or.nmo.eq.0)goto 100 990 close(2) if(nat.eq.0.or.nmo.eq.0)call report('nat nmo not determined') nmo2=nmo**2 write(6,*)' ..... and read' inquire(file='escf.out',exist=le) if(le)then write(6,*)'escf.out found' open(2,file='escf.out') 200 read(2,2000,end=991,err=991)s80 IF(s80(2:40).EQ.'total number of roots to be determined:')then read(s80(41:len(s80)),*)n goto 991 endif goto 200 991 close(2) if(n.eq.0)call report('n not determined') else call report('escf.out not found') endif return endif c Gaussian output: open(2,file=fo) 1 read(2,2000,end=99,err=99)s80 2000 format(a80) IF((lzmat.and.(s80(19:39).EQ.'Z-Matrix orientation:'.OR. 1 s80(26:46).EQ.'Z-Matrix orientation:'.OR. 1 s80(20:37).EQ.'Input orientation:'.OR. 1 s80(27:44).EQ.'Input orientation:')) 1 .OR. 1 ((.not.lzmat).and. 2 (s80(20:40).EQ.'Standard orientation:'.OR. 2 s80(26:46).EQ.'Standard orientation:')))THEN write(6,2000)s80 DO 2004 I=1,4 2004 READ(2,*) l=0 2005 READ(2,2000)s80 IF(s80(2:4).NE.'---')THEN l=l+1 BACKSPACE 2 READ(2,*)q,q IF(q.EQ.-1)l=l-1 GOTO 2005 ENDIF nat=l ENDIF if(s80(31:49).eq.'primitive gaussians'.and.nmo.eq.0)then read(s80(1:6),*)nmo endif if(s80(2:44).eq.'Ground to excited state transition electric')then n=0 read(2,*) 3 read(2,3000,end=99,err=99)st 3000 format(10x,a70) read(st,*,end=99,err=99)axdum,axdum,axdum n=n+1 goto 3 endif goto 1 99 close(2) nmo2=nmo**2 return end subroutine readfile(lzmat,qz,x,bohr,xau,na,nb,nmo2,n,nmo,nst, 1dl,dv,qv,r,r0v,r0l,e,ev,eau,ni,lden,nid,nat,cij,lopen, 1aij,bij,dij,daij,dbij,fo,ifix,nib,cijb,aijb,bijb,lnorm,lort,lwrt, 1dijb,daijb,dbijb,nibd,ltda,lbck) implicit none character*80 s80 character*75 st character*(*) fo logical lzmat,lden,lopen,lnorm,lort,lwrt,ltda,lbck integer*4 ig98,I,l,qz(*),na,nb,nmo2,n,nd,k,ie,ni(*),ic,kk, 1nid(*),nat,aij(*),bij(*),dbij(*),daij(*),j,oa,ob,jj,nst, 1ifound,ifix,nib(*),aijb(*),bijb(*),amax,bmax,nmo,nort, 1daijb(*),dbijb(*),nibd(*),imax,ii real*8 x(3,nat),bohr,xau(3,nat),dl(n,3),dv(n,3),qv(n,3,3), 1r(n,3),r0v(*),r0l(*),e(*),ev(*),eau(*),cij(*),dij(*),cback,tq, 1ax,ay,az,cijb(*),cmax,skj,sum1,sum2,dijb(*) real*8,allocatable::obaj(:),obak(:),obajd(:),obakd(:) real*8 ska integer*4,allocatable::ipse(:) character*1 abmax nat=0 ie=0 lopen=.false. tq=dsqrt(2.0d0) open(2,file=fo) 1 read(2,2000,end=2,err=2)s80 2000 format(a80) IF((lzmat.and.(s80(19:39).EQ.'Z-Matrix orientation:'.OR. 1 s80(26:46).EQ.'Z-Matrix orientation:'.OR. 1 s80(20:37).EQ.'Input orientation:'.OR. 1 s80(27:44).EQ.'Input orientation:')) 1 .OR. 1 ((.not.lzmat).and. 2 (s80(20:40).EQ.'Standard orientation:'.OR. 2 s80(26:46).EQ.'Standard orientation:')))THEN ig98=0 if(s80(26:46).EQ.'Z-Matrix orientation:'.OR. 1 s80(27:44).EQ.'Input orientation:'.OR. 1 s80(26:46).EQ.'Standard orientation:')ig98=1 write(6,2000)s80 DO 2004 I=1,4 2004 READ(2,*) l=0 2005 READ(2,2000)s80 IF(s80(2:4).NE.'---')THEN l=l+1 BACKSPACE 2 if(ig98.eq.0)then READ(2,*)qz(l),qz(l),(x(i,l),i=1,3) else READ(2,*)qz(l),qz(l),x(1,l),(x(i,l),i=1,3) endif xau(1,l)=x(1,l)/bohr xau(2,l)=x(2,l)/bohr xau(3,l)=x(3,l)/bohr IF(qz(l).EQ.-1)l=l-1 GOTO 2005 ENDIF nat=l ENDIF if(s80(40:50).eq.'Pseudopoten')then allocate(ipse(nat)) call rdps(nat,ipse) do 335 i=1,nat if(ipse(i).ne.0)then write(6,6885)i,ipse(i) 6885 format(' atom ',i4,' atomic charge reduced to',i4) qz(i)=ipse(i) endif 335 continue endif if(s80(8:22).eq.'alpha electrons')then read(s80( 1: 6),*)na read(s80(25:31),*)nb write(6,2000)s80 if(ltda)then write(6,*)'leaving readfile because of tda' close(2) goto 999 endif endif if(s80(2:44).eq.'Ground to excited state transition electric')then n=0 write(6,2000)s80 read(2,*) 3 read(2,3000,end=21,err=21)st 3000 format(10x,a75) read(st,*,end=21,err=21)ax,ay,az n=n+1 dl(n,1)=ax dl(n,2)=ay dl(n,3)=az goto 3 21 backspace 2 write(6,*)n,' dipole length transitions' endif if(s80(2:51).eq. 1'Ground to excited state transition velocity dipole')then write(6,2000)s80 read(2,*) do 9 i=1,n read(2,3000)st 9 read(st,*)dv(i,1),dv(i,2),dv(i,3) write(6,*)n,' dipole velocity transitions' endif c if(s80(2:44).eq.'Ground to excited state transition magnetic')then write(6,2000)s80 read(2,*) do 10 i=1,n read(2,3000)st 10 read(st,*)(r(i,j),j=1,3) write(6,*)n,' magnetic transitions' endif if(s80(2:55).eq. 1'Ground to excited state transition velocity quadrupole')then write(6,2000)s80 read(2,*) do 7 i=1,n read(2,3000)st c gaussian # xx yy zz xy xz yz read(st,*)qv(i,1,1),qv(i,2,2),qv(i,3,3),qv(i,1,2),qv(i,1,3), 1 qv(i,2,3) qv(i,3,2)=qv(i,2,3) qv(i,3,1)=qv(i,1,3) 7 qv(i,2,1)=qv(i,1,2) write(6,*)n,' quadrupole velocity transitions' endif c if(s80(53:63).eq.'R(velocity)') then write(6,2000)s80 c Gaussian 98 does not write R(length) nor R(velocity) do 8 i=1,n read(2,3000)st read(st,*,err=99)r0v(i),r0v(i),r0v(i),r0v(i) goto 991 99 write(6,3000)st write(6,*)i stop 991 continue read(2,2000)s80 if(s80(2:6).eq.'Total')then do 81 k=1,4 81 read(2,2000)s80 else backspace 2 endif read(2,2000)s80 if(s80(2:3).eq.'R(')then do 82 k=1,4 82 read(2,2000)s80 else backspace 2 endif 8 continue endif if(s80(54:62).eq.'R(length)') then write(6,2000)s80 do 11 i=1,n read(2,3000)st 11 read(st,*,end=2,err=2)r0l(i),r0l(i),r0l(i),r0l(i) endif c if(s80(2:15).eq.'Excited State '.and.s80(16:16).ne.'s')then write(6,2000)s80 do 203 i=1,79 if(s80(i:i).eq.':')read(s80(15:i-1),*)nd if(s80(i:i+1).eq.'eV')read(s80(i-10:i-2),*)ev(nd) 203 if(s80(i:i+1).eq.'nm')read(s80(i- 9:i-2),*)e(nd) c ecm(i)=ev(i)*8065.54476345045d0 eau(nd)=ev(nd)/27.211384205943d0 ie=ie+1 if(ie.ne.nd)call report(' Inconsistent reading') cmax=0.0d0 amax=0 bmax=0 imax=0 abmax='x' if(lden)then ni(ie)=0 nib(ie)=0 nibd(ie)=0 nid(ie)=0 sum1=0.0d0 sum2=0.0d0 111 read(2,2000,end=299,err=299)s80 if(s80(10:11).eq.'->')then if(ni(ie).gt.nmo2)call report('too many coefficients') if(s80(8:8).eq.'A')then c open shell, alpha: lopen=.true. ni(ie)=ni(ie)+1 ii=nmo2*(ie-1)+ni(ie) read(s80( 1: 7),*)aij(ii) if(s80(15:15).eq.'A')then read(s80(12:14),*)bij(ii) else if(s80(16:16).eq.'A')then read(s80(12:15),*)bij(ii) else write(6,2000)s80 call report('Unknown format of excitations') endif endif read(s80(18:30),*)cij(ii) call setabmax(aij(ii),bij(ii),cij(ii), 2 amax,bmax,cmax,ii,imax,abmax,'A') sum1=sum1+cij(ii)**2 else if(s80(8:8).eq.'B')then c open shell, beta: nid(ie)=nid(ie)+1 ii=nmo2*(ie-1)+nid(ie) lopen=.true. read(s80( 1: 7),*)daij(ii) if(s80(15:15).eq.'B')then read(s80(12:14),*)dbij(ii) else if(s80(16:16).eq.'B')then read(s80(12:15),*)dbij(ii) else write(6,2000)s80 call report('Unknown format of excitations') endif endif read(s80(18:30),*) dij(ii) call setabmax(daij(ii),dbij(ii),dij(ii), 2 amax,bmax,cmax,ii,imax,abmax,'B') sum1=sum1+dij(ii)**2 else c closed shell: ni(ie)=ni(ie)+1 ii=nmo2*(ie-1)+ni(ie) read(s80( 1: 8),*) aij(ii) read(s80(12:15),*) bij(ii) read(s80(18:30),*) cij(ii) cij(ii)=cij(ii)*tq call setabmax(aij(ii),bij(ii),cij(ii), 2 amax,bmax,cmax,ii,imax,abmax,' ') sum1=sum1+cij(ii)**2 endif endif goto 111 endif if(s80(10:11).eq.'<-'.and.lbck)then if(s80(8:8).eq.'A')then nib(ie)=nib(ie)+1 read(s80( 1: 7),*)oa if(s80(15:15).eq.'A')then read(s80(12:14),*)ob else if(s80(16:16).eq.'A')then read(s80(12:15),*)ob else write(6,2000)s80 call report('Unknown format of excitations') endif endif read(s80(18:30),*)cback sum2=sum2+cback**2 cijb(nmo2*(ie-1)+nib(ie))=cback aijb(nmo2*(ie-1)+nib(ie))=oa bijb(nmo2*(ie-1)+nib(ie))=ob else if(s80(8:8).eq.'B')then nibd(ie)=nibd(ie)+1 read(s80( 1: 7),*)oa if(s80(15:15).eq.'B')then read(s80(12:14),*)ob else if(s80(16:16).eq.'B')then read(s80(12:15),*)ob else write(6,2000)s80 call report('Unknown format of excitations') endif endif read(s80(18:30),*)cback sum2=sum2+cback**2 dijb( nmo2*(ie-1)+nibd(ie))=cback daijb(nmo2*(ie-1)+nibd(ie))=oa dbijb(nmo2*(ie-1)+nibd(ie))=ob else nib(ie)=nib(ie)+1 read(s80( 1: 8),*)oa read(s80(12:15),*)ob read(s80(18:30),*)cback cback=cback*tq sum2=sum2+cback**2 cijb(nmo2*(ie-1)+nib(ie))=cback aijb(nmo2*(ie-1)+nib(ie))=oa bijb(nmo2*(ie-1)+nib(ie))=ob endif endif c experimental fix for the deexitations, closed shell only: if(ifix.eq.1.and..not.lopen)then ifound=0 do 315 j=1,ni(ie) if(oa.eq.aij(nmo2*(ie-1)+j).and.ob.eq.bij(nmo2*(ie-1)+j)) 1 then ifound=ifound+1 cij(nmo2*(ie-1)+j)=cij(nmo2*(ie-1)+j)+cback endif 315 continue if(ifound.eq.0)then ni(ie)=ni(ie)+1 cij(nmo2*(ie-1)+ni(ie))=cback aij(nmo2*(ie-1)+ni(ie))=oa bij(nmo2*(ie-1)+ni(ie))=ob endif endif c experimental fix,just add to excitations with switched orbitals: if(ifix.eq.3)then if(s80(8:8).ne.'B')then ni(ie)=ni(ie)+1 cij(nmo2*(ie-1)+ni(ie))=cback aij(nmo2*(ie-1)+ni(ie))=ob bij(nmo2*(ie-1)+ni(ie))=oa else nid(ie)=nid(ie)+1 dij(nmo2*(ie-1)+ni(ie))=cback daij(nmo2*(ie-1)+ni(ie))=ob dbij(nmo2*(ie-1)+ni(ie))=oa endif endif goto 111 endif 299 continue if(lwrt)then write(6,*)ni(ie),' alpha coefficients' if(ifix.eq.3)write(6,*)'(with backwards)' write(6,*)nid(ie),' beta coefficients' write(6,*)nib(ie),' backward coefficients' if(abmax.eq.'B')then write(6,6009)ie,amax,'B',bmax,'B',dij(imax),cmax**2*100.0d0 6009 format(i5,': Dominant transition from',i4,a1,' to ',i4,a1, 1 f8.3,' (',f6.2,' %)') else if(abmax.eq.'A')then write(6,6009)ie,amax,'A',bmax,'A',cij(imax),cmax**2*100.0d0 else write(6,6009)ie,amax,' ',bmax,' ',cij(imax),cmax**2*100.0d0 endif endif write(6,1234)sum1,sum2,sum1-sum2 1234 format('fnorm, bnorm,diff:',3f10.4) endif if(ifix.eq.4.and.lwrt)then nib(ie)=0 write(6,*)'backward ignored' endif c seems that fnorm-bnorm=1 if(lnorm)then c renormalize: call normcijo(ie,cij,dij,ni,nid,nmo2,lopen) write(6,*)' cij were normalized' endif endif if(nd.eq.n) goto 2 endif goto 1 c 2 close(2) if(lden.and.lort)then if(nst.gt.0.and.nst.lt.n)then nort=nst else nort=n endif c reorthonormalize: write(6,*)'orthogonalizing coefficients for ',nort,' states' allocate(obaj(nmo2),obak(nmo2)) if(lopen)allocate(obajd(nmo2),obakd(nmo2)) write(6,*)'temporary variables allocated' c run twice for better accuracy: do 318 ic=1,2 ska=0.0d0 do 3181 j=1,nort c transcript original cij to obaj: call vz(obaj,nmo2) do 324 jj=1,ni(j) oa=aij(nmo2*(j-1)+jj) ob=bij(nmo2*(j-1)+jj) if(ob+nmo*(oa-1)<1)then write(6,*)'oa',oa write(6,*)'ob',ob write(6,*)'j',j write(6,*)'jj',jj write(6,*)'ni',ni(j) write(6,*)'nort',nort write(6,*)'nmo2',nmo2 call report('negative index') endif 324 obaj(ob+nmo*(oa-1))=cij(nmo2*(j-1)+jj) if(lopen)then call vz(obajd,nmo2) do 3241 jj=1,nid(j) oa=daij(nmo2*(j-1)+jj) ob=dbij(nmo2*(j-1)+jj) 3241 obajd(ob+nmo*(oa-1))=dij(nmo2*(j-1)+jj) endif do 334 k=1,j-1 c transcript cij to obak: call vz(obak,nmo2) kk=nmo2*(k-1) do 3242 jj=1,ni(k) oa=aij(kk+jj) ob=bij(kk+jj) 3242 obak(ob+nmo*(oa-1))=cij(kk+jj) if(lopen)then call vz(obakd,nmo2) kk=nmo2*(k-1) do 3243 jj=1,nid(k) oa=daij(kk+jj) ob=dbij(kk+jj) 3243 obakd(ob+nmo*(oa-1))=dij(kk+jj) endif c : skj=0.0d0 do 323 oa=1,na do 323 ob=na+1,nmo c forward excitations: skj=skj+obaj(ob+nmo*(oa-1))*obak(ob+nmo*(oa-1)) c backward excitations: 323 skj=skj+obaj(oa+nmo*(ob-1))*obak(oa+nmo*(ob-1)) if(lopen)then do 331 oa=1,nb do 331 ob=nb+1,nmo skj=skj+obajd(ob+nmo*(oa-1))*obakd(ob+nmo*(oa-1)) 331 skj=skj+obajd(oa+nmo*(ob-1))*obakd(oa+nmo*(ob-1)) endif c |j'>=|j>-|k>: do 319 oa=1,na do 319 ob=na+1,nmo if(oa+nmo*(ob-1).gt.nmo2)write(6,*)'A',oa,ob,nmo2 if(ob+nmo*(oa-1).gt.nmo2)write(6,*)'B',oa,ob,nmo2 obaj(ob+nmo*(oa-1))=obaj(ob+nmo*(oa-1))-skj*obak(ob+nmo*(oa-1)) 319 obaj(oa+nmo*(ob-1))=obaj(oa+nmo*(ob-1))-skj*obak(oa+nmo*(ob-1)) if(lopen)then do 332 oa=1,nb do 332 ob=nb+1,nmo obajd(ob+nmo*(oa-1))= 1 obajd(ob+nmo*(oa-1))-skj*obakd(ob+nmo*(oa-1)) 332 obajd(oa+nmo*(ob-1))= 1 obajd(oa+nmo*(ob-1))-skj*obakd(oa+nmo*(ob-1)) endif 334 ska=ska+dabs(skj) c c transcript new obaj to new cij: if(lopen)then nid(j)=0 do 333 oa=1,nb do 333 ob=nb+1,nmo jj=ob+nmo*(oa-1) if(obajd(jj).ne.0.0d0)then nid(j)=nid(j)+1 dij( nmo2*(j-1)+nid(j))=obajd(jj) daij(nmo2*(j-1)+nid(j))=oa dbij(nmo2*(j-1)+nid(j))=ob endif jj=oa+nmo*(ob-1) if(obajd(jj).ne.0.0d0)then nid(j)=nid(j)+1 dij( nmo2*(j-1)+nid(j))=obajd(jj) daij(nmo2*(j-1)+nid(j))=ob dbij(nmo2*(j-1)+nid(j))=oa endif 333 continue endif ni(j)=0 do 325 oa=1,na do 325 ob=na+1,nmo jj=ob+nmo*(oa-1) if(obaj(jj).ne.0.0d0)then ni(j)=ni(j)+1 cij(nmo2*(j-1)+ni(j))=obaj(jj) aij(nmo2*(j-1)+ni(j))=oa bij(nmo2*(j-1)+ni(j))=ob endif jj=oa+nmo*(ob-1) if(obaj(jj).ne.0.0d0)then ni(j)=ni(j)+1 cij(nmo2*(j-1)+ni(j))=obaj(jj) aij(nmo2*(j-1)+ni(j))=ob bij(nmo2*(j-1)+ni(j))=oa endif 325 continue 3181 call normcijo(j,cij,dij,ni,nid,nmo2,lopen) write(6,*)ic,ska/dble(nort**2)/2.0d0 318 continue write(6,*)'double orthogonalization done' endif 999 continue do 5 i=1,n do 5 j=1,3 dv(i,j)=-dv(i,j)/eau(i) r( i,j)= r( i,j)/2.0d0 do 5 k=1,3 5 qv(i,j,k)=-qv(i,j,k)/eau(i) return end subroutine normcijo(ie,cij,dij,ni,nid,nmo2,lopen) implicit none real*8 anorm,cij(*),dij(*) integer*4 j,ni(*),ie,nmo2,nid(*) logical lopen anorm=0.0d0 do 315 j=1,ni(ie) 315 anorm=anorm+cij(nmo2*(ie-1)+j)**2 if(lopen)then do 316 j=1,nid(ie) 316 anorm=anorm+dij(nmo2*(ie-1)+j)**2 endif anorm=1.0d0/dsqrt(anorm) do 317 j=1,ni(ie) 317 cij(nmo2*(ie-1)+j)=cij(nmo2*(ie-1)+j)*anorm if(lopen)then do 318 j=1,nid(ie) 318 dij(nmo2*(ie-1)+j)=dij(nmo2*(ie-1)+j)*anorm endif return end subroutine normcij(ie,cij,ni,nmo2) implicit none real*8 anorm,cij(*) integer*4 j,ni(*),ie,nmo2 anorm=0.0d0 do 316 j=1,ni(ie) 316 anorm=anorm+cij(nmo2*(ie-1)+j)**2 anorm=1.0d0/dsqrt(anorm) do 317 j=1,ni(ie) 317 cij(nmo2*(ie-1)+j)=cij(nmo2*(ie-1)+j)*anorm return end subroutine me( 1ni,nid,cij,dij,aij,daij,bij,dbij,ie,lopen,djg,bp,bpd,nmo,nmo2, 1ifix,nib,cijb,aijb,bijb,nd0,n22) c element implicit none integer*4 ni(*),nid(*),j,oa,ob,aij(*),bij(*),daij(*),dbij(*), 1ie,i,nmo,nmo2,nib(*),aijb(*),bijb(*),ifix,nd0,n22 real*8 djg(*),cij(*),dij(*),bp(*),bpd(*),tq,cijb(*) logical lopen tq=dsqrt(2.0d0) do 303 j=1,nd0 djg(j)=0.0d0 do 301 i=1,ni(ie) oa=aij(n22*(ie-1)+i) ob=bij(n22*(ie-1)+i) 301 djg(j)=djg(j)+cij(n22*(ie-1)+i)*bp(ob+nmo*(oa-1)+nmo2*(j-1)) if(ifix.eq.2)then do 302 i=1,nib(ie) oa=aijb(n22*(ie-1)+i) ob=bijb(n22*(ie-1)+i) 302 djg(j)=djg(j)+cijb(n22*(ie-1)+i)*bp(oa+nmo*(ob-1)+nmo2*(j-1)) endif do 312 i=1,nid(ie) oa=daij(n22*(ie-1)+i) ob=dbij(n22*(ie-1)+i) 312 djg(j)=djg(j)+dij(n22*(ie-1)+i)*bpd(ob+nmo*(oa-1)+nmo2*(j-1)) c c for close shells, adjust for singlet-transition: 303 if(.not.lopen)djg(j)=djg(j)*tq return end function cc(xy,n,xa,ya,xx,yy) implicit none real*8 xy,n,xa,ya,xx,yy,cc,d d=(xx-n*xa**2)*(yy-n*ya**2) if(d.eq.0.0d0)then cc=0.0d0 else cc=(xy-n*xa*ya)**2/d endif return end subroutine cstat(v,r,xy,xa,ya,ar,xx,yy) implicit none real*8 v,r,xy,xa,ya,ar,xx,yy xy=xy+v*r xx=xx+v*v yy=yy+r*r xa=xa+v ya=ya+r if(dabs(r).gt.1.0d-4)then ar=ar+v/r else ar=ar+1.0d0 endif return end subroutine stn(n,ar,xa,ya,reg,yy,xy) implicit none integer*4 n real*8 ar,xa,ya,reg,yy,xy,n3 n3=dble(n) ar=ar/n3 xa=xa/n3 ya=ya/n3 reg=1.0d0 if(yy.ne.0.0d0)reg=xy/yy return end subroutine zerstat(xa,ya,xx,yy,xy,ar,n) implicit none real*8 xa(*),ya(*),xx(*),yy(*),xy(*),ar(*) integer*4 i,n do 107 i=1,n xa(i)=0.0d0 ya(i)=0.0d0 xx(i)=0.0d0 yy(i)=0.0d0 xy(i)=0.0d0 107 ar(i)=0.0d0 return end subroutine setabmax(a,b,c,amax,bmax,cmax,n,i,abmax,ab) implicit none integer*4 a,b,amax,bmax,n,i real*8 c,cmax character*1 abmax,ab if(dabs(c).gt.cmax)then cmax=dabs(c) amax=a bmax=b i=n abmax=ab endif return end subroutine dodjk(djk,nd0,ni,iep,aij,bij,n22,cij,pre,lopen, 1daij,dbij,pred,nmo,dij,nid) implicit none real*8 djk(*),cij(*),pre(*),pred(*),dij(*) logical lopen integer*4 j,nd0,ip,ni(*),iep,oc,od,aij(*),bij(*),n22, 1daij(*),dbij(*),nid(*),nmo do 309 j=1,nd0 djk(j)=0.0d0 do 308 ip=1,ni(iep) oc=aij(n22*(iep-1)+ip) od=bij(n22*(iep-1)+ip) 308 djk(j)=djk(j)+cij(n22*(iep-1)+ip)*pre(j+(oc-1+(od-1)*nmo)*nd0) if(lopen)then do 3071 ip=1,nid(iep) oc=daij(n22*(iep-1)+ip) od=dbij(n22*(iep-1)+ip) 3071 djk(j)=djk(j) 1 +dij(n22*(iep-1)+ip)*pred(j+(oc-1+(od-1)*nmo)*nd0) endif 309 continue return end subroutine lsums(dx,dy,dz,rx,ry,rz,qx,qy,qz,hx,hy,hz, 1n,eau,lgamma,gammaau,ie,iep,dd,dlg,na,nb, 1rrx,rry,rrz,qqx,qqy,qqz,u0,u0d,ut) implicit none real*8 dx,dy,dz,rx,ry,rz,qx,qy,qz,hx,hy,hz,elg,ekl, 1eau(*),gammaau,dd(*),dlg(*),flg,fkl,fne, 2rrx,rry,rrz,qqx,qqy,qqz,ejl,fjl,ejg,u0(*),u0d(*), 3ut(3,n),dg1,dg2,dg3,dk1,dk2,dk3, 4ekg,fkg,fkj,ekj logical lgamma integer*4 n,iel,kl,iep,ie,jl,lg,lk,na,nb,kg,jk dx=0.0d0 dy=0.0d0 dz=0.0d0 rx=0.0d0 ry=0.0d0 rz=0.0d0 qx=0.0d0 qy=0.0d0 qz=0.0d0 c permanent el moment (), ground state: dg1=u0(1)+u0d(1) dg2=u0(2)+u0d(2) dg3=u0(3)+u0d(3) c permanent el moment (), state k: dk1=ut(1,ie) dk2=ut(2,ie) dk3=ut(3,ie) kg=6*(iep-1) ekg=eau(iep) ekj=eau(iep)-eau(ie) if(lgamma)then fkg=ekg/(ekg**2+gammaau**2) fkj=ekj/(ekj**2+gammaau**2) else fkg=1.0d0/ekg fkj=1.0d0/ekj endif kg=6*(iep-1) c x/(Ek-Eg)/Nel: rrx=(dlg(5+kg)*dg3-dlg(6+kg)*dg2)*fkg rry=(dlg(6+kg)*dg1-dlg(4+kg)*dg3)*fkg rrz=(dlg(4+kg)*dg2-dlg(5+kg)*dg1)*fkg jk=(ie-1+n*(iep-1))*6 c x/(EK-EJ): qqx=(dd(5+jk)*dk3-dd(6+jk)*dk2)*fkj qqy=(dd(6+jk)*dk1-dd(4+jk)*dk3)*fkj qqz=(dd(4+jk)*dk2-dd(5+jk)*dk1)*fkj hx=0.0d0 hy=0.0d0 hz=0.0d0 fne=0.5d0/dble(na+nb) do 308 iel=1,n elg=eau(iel) ejg=eau(ie ) ekl=ekg-elg ejl=ejg-elg if(lgamma)then flg=elg/(elg**2+gammaau**2) fkl=ekl/(ekl**2+gammaau**2) else if(elg.eq.0.0d0)then call report('elg division by zero') write(6,*)iel,iep,elg,ekg,ekl stop endif fkl=1.0d0/ekl flg=1.0d0/elg endif kl=(iep-1+n*(iel-1))*6 lk=(iel-1+n*(iep-1))*6 lg=6*(iel-1) c sum(L<>n)x/(El-Eg)/Nel: rx=rx+(dd(2+kl)*dlg(6+lg)-dd(3+kl)*dlg(5+lg))*flg ry=ry+(dd(3+kl)*dlg(4+lg)-dd(1+kl)*dlg(6+lg))*flg rz=rz+(dd(1+kl)*dlg(5+lg)-dd(2+kl)*dlg(4+lg))*flg c x/(Ek-Eg)/Nel+ c sum(L<>k,L<>g)x/(Ek-EL)/Nel: if(iel.ne.iep)then rrx=rrx+(dd(5+kl)*dlg(3+lg)-dd(6+kl)*dlg(2+lg))*fkl rry=rry+(dd(6+kl)*dlg(1+lg)-dd(4+kl)*dlg(3+lg))*fkl rrz=rrz+(dd(4+kl)*dlg(2+lg)-dd(5+kl)*dlg(1+lg))*fkl endif c sum(L)x): dx=dx+dd(2+kl)*dlg(3+lg)-dd(3+kl)*dlg(2+lg) dy=dy+dd(3+kl)*dlg(1+lg)-dd(1+kl)*dlg(3+lg) dz=dz+dd(1+kl)*dlg(2+lg)-dd(2+kl)*dlg(1+lg) jl=(ie-1+n*(iel-1))*6 if(iel.ne.iep)then if(lgamma)then fkl=ekl/(ekl**2+gammaau**2) fjl=ejl/(ejl**2+gammaau**2) else if(ekl.eq.0.0d0)then write(6,*)iel,iep,elg,ekg,ekl call report('ekl division by zero') endif fkl=1.0d0/ekl fjl=1.0d0/ejl endif c sum(L)x/(EK-EL): qx=qx+(dd(2+jl)*dd(6+lk)-dd(3+jl)*dd(5+lk))*fkl qy=qy+(dd(3+jl)*dd(4+lk)-dd(1+jl)*dd(6+lk))*fkl qz=qz+(dd(1+jl)*dd(5+lk)-dd(2+jl)*dd(4+lk))*fkl c x/(EK-EJ)+ c sum(L<>j,L<>k)x/(EL-EJ): if(iel.ne.ie.and.iel.ne.iep)then qqx=qqx+(dd(5+jl)*dd(3+lk)-dd(6+jl)*dd(2+lk))*fjl qqy=qqy+(dd(6+jl)*dd(1+lk)-dd(4+jl)*dd(3+lk))*fjl qqz=qqz+(dd(4+jl)*dd(2+lk)-dd(5+jl)*dd(1+lk))*fjl endif c sum(L)x): hx=hx+dd(2+jl)*dd(3+lk)-dd(3+jl)*dd(2+lk) hy=hy+dd(3+jl)*dd(1+lk)-dd(1+jl)*dd(3+lk) hz=hz+dd(1+jl)*dd(2+lk)-dd(2+jl)*dd(1+lk) endif 308 continue dx=dx*fne dy=dy*fne dz=dz*fne rx=rx*fne ry=ry*fne rz=rz*fne qx=qx*fne qy=qy*fne qz=qz*fne rrx=rrx*fne rry=rry*fne rrz=rrz*fne qqx=qqx*fne qqy=qqy*fne qqz=qqz*fne hx=hx*fne hy=hy*fne hz=hz*fne return end c ============================================================ subroutine inispec(i,f,s) implicit none integer*4 i character*(*)f,s open(i,file=f) write(i,*)' '//s write(i,3000) 3000 format(' n wavelength (nm) dipole strength (D^2)', 1' rotatory strength (cgs/10**-36)',/,80(1h-)) return end c ============================================================ subroutine closetab(ldo) implicit none integer*4 i,ns0 parameter(ns0=19) logical ldo(ns0) do 1 i=1,ns0 if(ldo(i))then write(50+i,3000) 3000 format(60(1h-)) close(50+i) endif 1 continue return end c ============================================================ subroutine initab(ldo) implicit none integer*4 i,j,ns0 parameter(ns0=19) character*11 st(ns0) logical ldo(ns0) data st/'ICP_0 ','ICPx_90 ','ICPz_90 ','ICPs_90 ', 1 'ICPu_90 ','ICP_180 ','SCP_0 ','SCPx_90 ', 1 'SCPz_90 ','SCPs_90 ','SCPu_90 ','SCP_180 ', 1 'DCPI_0 ','DCPI_90 ','DCPI_180 ','DCPII_0 ', 1 'DCPII_90 ','DCPII_180 ','FCTAB '/ do 1 i=1,ns0 if(ldo(i))then do 2 j=len(st),1,-1 2 if(st(i)(j:j).ne.' ')goto 3 3 open(50+i,file=st(i)(1:j)//'.tab') write(50+i,3000)st(i) 3000 format(20x,a11,/,' n wavelength (cm) Raman ROA',/,80(1h-)) endif 1 continue return end c ============================================================ subroutine vz(v,n) implicit none integer*4 n,i real*8 v(*) do 1 i=1,n 1 v(i)=0.0d0 return end c ============================================================ subroutine cpolar(st,sav,sal,sgv,sgl,wmax,wmin,np,debye,pi,eau, 1gammaau,gammanm,lgnm,lgau,dl,dv,r,qv,ntr,n) implicit none integer*4 np,i,j,k,l,ie,ntr,n real*8 wmax,wmin,dw,cab,debye,pi,ccd,w,wau,al(3,3),ali(3,3), 1alit(3,3),allv(3,3),alilv(3,3),eau(*),gammaau,gammanm,t, 1dl(ntr,3),dv(ntr,3),r(ntr,3),qua,qv(ntr,3,3),fr,fi character*(*) st,sav,sal,sgv,sgl logical lgnm,lgau write(6,6009) 6009 format(/, 1 ' Cpolar',/, 1 ' ^^^^^^',/) dw=(wmax-wmin)/dble(np-1) c constants making tensor traces epsilon c (factor of two missing for cab - do not know why): cab=debye**2 *108.7d0/pi c ccd=2.0d0*2.541765d0*9.2740154d-21*1.0d-18/1.0d-36/pi ccd=debye**2*4.0d0*108.7d0/pi/137.5d0 open(44,file=st) c velocity-based trace: open(9,file=sav) c dipole-based trace: open(91,file=sal) write(44,446)np,wmin,wmax 446 format(i6,2f12.2) write(44,443) 443 format(' Dynamic polarizabilities') c alpha start ----------------------------------------------------- write(44,444) 444 format(10x,' Alpha ( f ) Alpha ( g) length-length ', 1'and length-velocity : ', 1/,'l(nm) Re ullx Re ully Re ullz Im ullx Im ully', 1' Im ullz Re ulvx Re ulvy Re ulvz Im ulvx Im ulvy', 1' Im ulvz') w=wmin-dw do 102 k=1,np w=w+dw wau=(1.0d7/w)/219474.63d0 do 101 i=1,3 do 101 j=1,3 al(i,j)=0.0d0 ali(i,j)=0.0d0 alit(i,j)=0.0d0 allv(i,j)=0.0d0 alilv(i,j)=0.0d0 do 101 ie=1,n call setv(eau(ie),w,fr,fi,gammaau,gammanm,lgnm,lgau) c a_ab = 2 sum wjn (1/(wjn**2-w**2)) Re ua ub c length-length: t=dl(ie,i)*dl(ie,j)*eau(ie) al(i,j) =al(i,j) +t*fr ali(i,j)=ali(i,j)+t*fi c length-velocity: t=dl(ie,i)*dv(ie,j)*eau(ie) allv(i,j) =allv(i,j) +t*fr alilv(i,j)=alilv(i,j)+t*fi c velocity-velocity (for spectra calculation only): 101 alit(i,j)=alit(i,j)+dv(ie,i)*dv(ie,j)*fi*eau(ie) write(9,69)w, 1wau**2*cab*(alit(1,1)+alit(2,2)+alit(3,3)), 1 al( 1,1)+al( 2,2)+al( 3,3) write(91,69)w, 1wau**2*cab*(ali(1,1)+ali(2,2)+ali(3,3)), 1 al(1,1)+al( 2,2)+al( 3,3) 69 format(f7.1,2f10.2) write(44,441)w,(al( 1,j),j=1,3),(ali( 1,j),j=1,3), 1 (allv(1,j),j=1,3),(alilv(1,j),j=1,3) write(44,442) (al( 2,j),j=1,3),(ali( 2,j),j=1,3), 1 (allv(2,j),j=1,3),(alilv(2,j),j=1,3) 102 write(44,442) (al( 3,j),j=1,3),(ali( 3,j),j=1,3), 1 (allv(3,j),j=1,3),(alilv(3,j),j=1,3) 441 format(f8.2,12f12.4) 442 format(8x ,12f12.4) close(9) write(6,*)sav//' (velocity) written' close(91) write(6,*)sal//' (length ) written' c alpha end ----------------------------------------------------- c Gp start ----------------------------------------------------- write(44,445) 445 format(10x,' Gp/w ( f) Gp/w ( g )', 1/,'l(nm) ux uy uz') open(9 ,file=sgv) open(91,file=sgl) w=wmin-dw do 103 k=1,np w=w+dw wau=(1.0d7/w)/219474.63d0 do 104 i=1,3 do 104 j=1,3 al( i,j)=0.0d0 ali( i,j)=0.0d0 do 104 ie=1,n call setv(eau(ie),w,fr,fi,gammaau,gammanm,lgnm,lgau) c length: t=dl(ie,i)*r(ie,j) al( i,j) =al(i,j) +t*fr ali(i,j)=ali(i,j) +t*fi c velocity: 104 alit(i,j)=alit(i,j) +dv(ie,i)*r(ie,j)*fi write(91,69)w,( -ali(1,1)-ali( 2,2)-ali( 3,3))*wau**3*ccd, 1 al(1,1)+al( 2,2)+al( 3,3) write(9 ,69)w,(-alit(1,1)-alit(2,2)-alit(3,3))*wau**3*ccd, 1 al( 1,1)+al( 2,2)+al( 3,3) write(44,441)w,(al(1,j),j=1,3),(ali(1,j),j=1,3) write(44,442) (al(2,j),j=1,3),(ali(2,j),j=1,3) 103 write(44,442) (al(3,j),j=1,3),(ali(3,j),j=1,3) close(9) close(91) write(6,*)sgv//' written' write(6,*)sgl//' written' c Gp end ----------------------------------------------------- c A start ----------------------------------------------------- write(44,447) 447 format(10x,' A ( f) A ( g) ', 1/,'l(nm) ux uy uz') w=wmin-dw do 105 k=1,np w=w+dw do 105 l=1,3 do 106 i=1,3 do 106 j=1,3 al( i,j)=0.0d0 ali(i,j)=0.0d0 do 106 ie=1,n if(i.eq.j)then qua=(3.0d0*qv(ie,i,j)-qv(ie,1,1)-qv(ie,2,2)-qv(ie,3,3))/2.0d0 else qua=1.5d0*qv(ie,i,j) endif call setv(eau(ie),w,fr,fi,gammaau,gammanm,lgnm,lgau) al(i,j) =al( i,j) +dl(ie,l)*qua*fr*eau(ie) 106 ali(i,j)=ali(i,j) +dl(ie,l)*qua*fi*eau(ie) if(l.eq.1)then write(44,441)w,(al(1,j),j=1,3),(ali(1,j),j=1,3) else write(44,442) (al(1,j),j=1,3),(ali(1,j),j=1,3) endif write(44,442) (al(2,j),j=1,3),(ali(2,j),j=1,3) 105 write(44,442) (al(3,j),j=1,3),(ali(3,j),j=1,3) close(44) c A end ----------------------------------------------------- write(6,*)st//' written' return end c ============================================================ subroutine addro(e,fi,fr,ucx,ucy,ucz,ng,jc, 1orb,oa,ob,nmo,rrxw,rryw,rrzw,rixw,riyw,rizw) implicit none real*8 e,fi,fr,ucx,ucy,ucz,ucxi,ucyi,uczi,ucxr,ucyr,uczr, 1orb(*),fab,rrxw(*),rryw(*),rrzw(*),rixw(*),riyw(*),rizw(*) integer*4 iz,ng,jc,oa,ob,nmo,ii fi=fi*e fr=fr*e ucxi=ucx*fi ucyi=ucy*fi uczi=ucz*fi ucxr=ucx*fr ucyr=ucy*fr uczr=ucz*fr do 9071 iz=1,ng fab=orb(nmo*(iz-1)+oa)*orb(nmo*(iz-1)+ob) ii=iz+jc rrxw(ii)=rrxw(ii)+ucxr*fab rryw(ii)=rryw(ii)+ucyr*fab rrzw(ii)=rrzw(ii)+uczr*fab rixw(ii)=rixw(ii)+ucxi*fab riyw(ii)=riyw(ii)+ucyi*fab 9071 rizw(ii)=rizw(ii)+uczi*fab return end c ============================================================ subroutine readtm(qz,x,bohr,xau,na,nb,nmo2,n,nmo,nst, 1dl,dv,qv,r,r0v,r0l,e,ev,eau,ni,nid,nat,cij,lopen, 1aij,bij,ifix,nib,cijb,aijb,bijb,lnorm,lort,lwrt) implicit none character*80 s80 logical lopen,lnorm,lort,lwrt integer*4 I,l,qz(*),na,nb,nmo2,n,k,ie,ni(*),ic,kk, 1nid(*),nat,aij(*),bij(*),j,oa,ob,jj,nst,ii,icc,it, 1ifix,nib(*),aijb(*),bijb(*),amax,bmax,nmo,nort,imax, 1ichek(100),nex,nf0,i1,i2,i3 parameter (nf0=64) integer*4 ifrom(nf0),ito(nf0),nff,iac,ns,nmosy(nf0), 1noccsy(nf0),ofrom(nf0),oto(nf0),syt(nf0,nf0),svec(nf0) logical lff character*50 ffn(nf0) character*1 abmax real*8 x(3,nat),xau(3,nat),dl(n,3),dv(n,3),qv(n,3,3), 1r(n,3),r0v(*),r0l(*),e(*),ev(*),eau(*),cij(*), 1cijb(*),cmax,skj,sum1,sum2,bohr real*8,allocatable::obaj(:),obak(:) real*8 ska do 3 i=1,100 3 ichek(i)=0 write(6,*)'re-reading escf.out' n=0 open(2,file='escf.out') 2001 read(2,2000,end=23,err=23)s80 2000 format(a80) if(s80(15:32).EQ.'atomic coordinates')then do 1001 l=1,nat read(2,2000,end=23,err=23)s80 read(s80(1:43),*)(xau(i,l),i=1,3) x(1,l)=xau(1,l)*bohr x(2,l)=xau(2,l)*bohr x(3,l)=xau(3,l)*bohr 1001 read(s80(58:60),*)qz(l) ichek(1)=1 endif if(s80(2:30).EQ.'number of occupied orbitals :')then read(s80(31:len(s80)),*)na nb=na ichek(2)=1 endif if(s80(2:24).EQ.'Excitation energy: ')then n=n+1 read(s80(25:len(s80)),*)eau(n) ichek(3)=1 endif if(s80(2:24).EQ.'Excitation energy / eV:')then read(s80(25:len(s80)),*)ev(n) ichek(4)=1 endif if(s80(2:24).EQ.'Excitation energy / nm:')then read(s80(25:len(s80)),*)e(n) ichek(5)=1 endif if(s80(2:39).eq.'Electric transition dipole moment (vel')then read(2,*) read(2,2009)dv(n,1) read(2,2009)dv(n,2) read(2,2009)dv(n,3) 2009 format(5x,f16.6) ichek(6)=1 endif if(s80(2:39).eq.'Electric transition dipole moment (len')then read(2,*) read(2,2009)dl(n,1) read(2,2009)dl(n,2) read(2,2009)dl(n,3) ichek(7)=1 endif if(s80(2:34).eq.'Magnetic transition dipole moment')then read(2,*) read(2,2009)r(n,1) read(2,2009)r(n,2) read(2,2009)r(n,3) ichek(8)=1 endif if(s80(2:31).eq.'Electric quadrupole transition')then read(2,*) read(2,2009)qv(n,1,1) read(2,2009)qv(n,2,2) read(2,2009)qv(n,3,3) read(2,2009)qv(n,1,2) read(2,2009)qv(n,1,3) read(2,2009)qv(n,2,3) qv(n,3,2)=qv(n,2,3) qv(n,3,1)=qv(n,1,3) qv(n,2,1)=qv(n,1,2) ichek(9)=1 endif if(s80(2:19).eq.'Rotatory strength:')then read(2,2000,end=23,err=23)s80 read(2,2000,end=23,err=23)s80 read(s80(39:len(s80)),*)r0v(n) read(2,2000,end=23,err=23)s80 read(2,2000,end=23,err=23)s80 read(2,2000,end=23,err=23)s80 read(2,2000,end=23,err=23)s80 read(s80(39:len(s80)),*)r0l(n) ichek(10)=1 endif if(s80(11:40).eq.'IRREP tensor space dimension')then nff=0 iac=0 read(2,*) 944 read(2,2000)s80 if(s80(11:13).ne.' ')then nff=nff+1 if(nff.gt.nf0)call report('nff.gt.nf0') read(s80(20:30),*)ii ifrom(nff)=iac+1 ito(nff)=iac+ii write(6,*)'symmetry',nff,' from state ', 1 ifrom(nff),' to ',ito(nff) iac=iac+ii goto 944 endif ichek(11)=1 endif if(s80(4:13).eq.'irrep mo')then nff=0 iac=0 945 read(2,2000)s80 if(s80(3:8).ne.' ')then nff=nff+1 if(nff.gt.nf0)call report('nff.gt.nf0') read(s80(8:len(s80)),*)ii,noccsy(nff) nmosy(nff)=ii ofrom(nff)=iac+1 oto(nff)=iac+ii write(6,*)'symmetry',nff,' from MO ',iac+1,' to ',oto(nff), 1 ' occ:',noccsy(nff) iac=iac+ii goto 945 endif ichek(12)=1 endif goto 2001 23 close(2) write(6,*)n,' excitations from escf.out' if(ichek( 1).eq.0)call report(' Atomic coordinates missing') if(ichek( 2).eq.0)call report(' Nocc missing') if(ichek( 3).eq.0)call report(' E missing') if(ichek( 4).eq.0)call report(' E-eV missing') if(ichek( 5).eq.0)call report(' E-nm missing') if(ichek( 6).eq.0)call report(' Dipole-v missing') if(ichek( 7).eq.0)call report(' Dipole-l missing') if(ichek( 8).eq.0)call report(' Magnet missing') if(ichek( 9).eq.0)call report(' Quadrupole missing') if(ichek(10).eq.0)call report(' Rotatory strength missing') if(ichek(11).eq.0)call report(' Number of symmetries missing') if(ichek(12).eq.0)call report(' Orbital symmetries missing') if(nff.ne.1)then open(2,file='sym',status='old') read(2,*)ie if(ie.ne.nff)call report('ie<>nff') do 556 i=1,nff 556 read(2,*)(syt(i,j),j=1,nff) write(6,*)'sym with symmetry table found' else syt(1,1)=1 endif ie=0 lopen=.false. inquire(file='F.LST',exist=lff) if(lff)then open(8,file='F.LST') do 800 i=1,nff 800 read(8,8000)ffn(i) 8000 format(a50) else if(nff.ne.1)call report('F.LST missing') ffn(1)='sing_a' ifrom(1)=1 ito(1)=nmo endif it=0 do 555 ic=1,nff write(6,*)'reading '//ffn(ic) open(2,file=ffn(ic),status='old') 1 read(2,2000,end=2,err=2)s80 if(s80(2:27).eq.'current subspace dimension') 1read(s80(28:36),*)ns if(s80(13:24).eq.'eigenvalue =')then write(6,2000)s80 read(s80(1:9),*)ie it=it+1 write(6,*)' total eigenvalue ',it ii=0 c occupied symmetries do 557 i1=1,nff c virtual symmetries do 557 i2=1,nff c does is give symmetry ic?: do 558 i3=1,nff 558 svec(i3)=syt(i1,i3)*syt(i2,i3) if(ie.eq.1)write(6,*)i1,i2,(svec(i3),i3=1,nff) icc=0 do 559 i3=1,nff do 5591 jj=1,nff 5591 if(syt(i3,jj).ne.svec(jj))goto 559 icc=i3 559 continue if(icc.eq.0)call report('symmetry calc. error') if(ie.eq.1)write(6,*)i1,'x',i2,'corresponds to ',icc,' want',ic if(icc.eq.ic)then do 300 i=ofrom(i1),ofrom(i1)+noccsy(i1)-1 do 300 j=ofrom(i2)+noccsy(i2),ofrom(i2)+nmosy(i2)-1 ii=ii+1 aij( nmo2*(it-1)+ii)=i aijb(nmo2*(it-1)+ii)=i bijb(nmo2*(it-1)+ii)=j if(j.gt.nmo.or.i.gt.nmo)then write(6,*)i1,i2,i,j,ofrom(i2),noccsy(i2),nmosy(i2) call report('overflow2') endif 300 bij( nmo2*(it-1)+ii)=j endif 557 continue if(ie.eq.1)write(6,*)ii,' states determined from orbitals' ni(it)=ns if(ii.ne.ns)then write(6,*)ic,ie,it,ni(ie),ns,noccsy(ic),nmosy(ic) call report('incosistent numbering') endif nib(it)=ni(it) nid(it)=0 cmax=0.0d0 amax=0 bmax=0 imax=0 sum1=0.0d0 sum2=0.0d0 read(2,900)(cij(nmo2*(it-1)+ii),ii=1,ni(it)), 1 (cijb(nmo2*(it-1)+ii),ii=1,nib(it)) 900 format(4d20.14) nex=0 do 301 ii=1,ni(it) call setabmax(aij(nmo2*(it-1)+ii),bij(nmo2*(it-1)+ii), 1 cij(nmo2*(it-1)+ii),amax,bmax,cmax,ii,imax,abmax,' ') sum1=sum1+cij(nmo2*(it-1)+ii)**2 sum2=sum2+cijb(nmo2*(it-1)+ii)**2 c experimental fix for the deexitations, closed shell only: if(ifix.eq.1) 1 cij(nmo2*(it-1)+ii)=cij(nmo2*(it-1)+ii)+cijb(nmo2*(it-1)+ii) c experimental fix,just add to excitations with switched orbitals: if(ifix.eq.3)then nex=nex+1 cij(nmo2*(it-1)+ni(it)+nex)=cijb(nmo2*(it-1)+ii) aij(nmo2*(it-1)+ni(it)+nex)=bijb(nmo2*(it-1)+ii) bij(nmo2*(it-1)+ni(it)+nex)=aijb(nmo2*(it-1)+ii) nib(it)=0 endif 301 continue ni(it)=ni(it)+nex if(lwrt)then write(6,*)ni(it),' alpha coefficitnts' if(ifix.eq.3)write(6,*)'(with backwards)' write(6,*)nid(it),' beta coefficitnts' write(6,*)nib(it),' backward coefficitnts' write(6,6009)amax,bmax,cij(nmo2*(it-1)+imax),cmax**2*100.0d0 6009 format(' Dominant transition from',i4,' to ',i4,f8.3, 1 ' (',f6.2,' %)') if(.not.lopen)write(6,1234)sum1,sum2 1234 format('fnorm, bnorm:',2f10.4) endif if(ifix.eq.4.and.lwrt)then nib(it)=0 write(6,*)'backward ignored' endif c seems that fnorm-bnorm=1 endif goto 1 c 2 close(2) 555 continue if(lnorm)then c renormalize: call normcij(it,cij,ni,nmo2) write(6,*)' cij were normalized' endif if(lort)then if(nst.gt.0.and.nst.lt.n)then nort=nst else nort=n endif if(lwrt)then do i=1,n write(6,6000)i,e(i) 6000 format(' state ',i4,f12.5) do ii=1,ni(i) j=nmo2*(i-1) if(dabs(cij(j+ii)).gt.0.1d0) 1 write(6,6001)aij(j+ii),bij(j+ii),cij(j+ii) 6001 format(2i4,f12.6) enddo enddo endif c reorthonormalize: write(6,*)'orthogonalizing coefficients for ',nort,' states' if(lopen)call report('lort for open shell not implemented') allocate(obaj(nmo2),obak(nmo2)) c run twice for better accuracy: do 318 ic=1,2 ska=0.0d0 do 3181 j=1,nort c transcript original cij to obaj: do 320 jj=1,nmo2 320 obaj(jj)=0.0d0 do 324 jj=1,ni(j) oa=aij(nmo2*(j-1)+jj) ob=bij(nmo2*(j-1)+jj) if(ob+nmo*(oa-1).gt.nmo2)then write(6,*)oa,ob,nmo2 call report('overflow') endif 324 obaj(ob+nmo*(oa-1))=cij(nmo2*(j-1)+jj) do 319 k=1,j-1 c transcript cij to obak: do 321 kk=1,nmo2 321 obak(kk)=0.0d0 kk=nmo2*(k-1) do 3241 jj=1,ni(k) oa=aij(kk+jj) ob=bij(kk+jj) 3241 obak(ob+nmo*(oa-1))=cij(kk+jj) c : skj=0.0d0 do 322 oa=1,na do 322 ob=na+1,nmo c forward excitations: skj=skj+obaj(ob+nmo*(oa-1))*obak(ob+nmo*(oa-1)) c backward excitations: 322 skj=skj+obaj(oa+nmo*(ob-1))*obak(oa+nmo*(ob-1)) c |j'>=|j>-|k>: do 319 oa=1,na do 319 ob=na+1,nmo obaj(ob+nmo*(oa-1))=obaj(ob+nmo*(oa-1))-skj*obak(ob+nmo*(oa-1)) 319 obaj(oa+nmo*(ob-1))=obaj(oa+nmo*(ob-1))-skj*obak(oa+nmo*(ob-1)) ska=ska+dabs(skj) c c transcript new obaj to new cij: ni(j)=0 do 325 oa=1,na do 325 ob=na+1,nmo jj=ob+nmo*(oa-1) if(obaj(jj).ne.0.0d0)then ni(j)=ni(j)+1 cij(nmo2*(j-1)+ni(j))=obaj(jj) aij(nmo2*(j-1)+ni(j))=oa bij(nmo2*(j-1)+ni(j))=ob endif jj=oa+nmo*(ob-1) if(obaj(jj).ne.0.0d0)then ni(j)=ni(j)+1 cij(nmo2*(j-1)+ni(j))=obaj(jj) aij(nmo2*(j-1)+ni(j))=ob bij(nmo2*(j-1)+ni(j))=oa endif 325 continue 3181 call normcij(j,cij,ni,nmo2) write(6,*)ic,ska/dble(nort**2)/2.0d0 318 continue write(6,*)'double orthogonalization done' deallocate(obaj,obak) endif return end subroutine uun(un,nat,xau,qq) implicit none real*8 un(*),xau(3,nat) integer*4 nat,j,l,qq(*) do 311 j=1,3 un(j)=0.0d0 do 311 l=1,nat 311 un(j)=un(j)+xau(j,l)*qq(l) return end subroutine rdps(nat,ipse) c read pseudopotential parameters implicit none character*29 s29 integer*4 i,nat,ipse(*) read(2,*) read(2,*) read(2,*) read(2,*) i=0 1 read(2,200)s29 200 format(a29) if(s29(15:16).eq.' ')goto 1 if(s29(15:16).eq.'==')return i=i+1 if(i.gt.nat)call report('pseudopotential reading error') if(s29(28:29).eq.' ')then ipse(i)=0 else read(s29(20:29),*)ipse(i) endif goto 1 end subroutine dtm(e,a,i,c,m) real*8 a,c(*) integer*4 e,i(*),m,k,j do 1 j=1,m if(dabs(a).gt.dabs(c(j)))then do 2 k=m,j+1,-1 i(k)=i(k-1) 2 c(k)=c(k-1) i(j)=e c(j)=a return endif 1 continue return end subroutine readtda(na,nb,nmo2,n,nmo,nst,e,ev,eau,ni,lden,nid,cij, 1lopen,aij,bij,dij,daij,dbij,ifix,nib,lnorm,lort,lwrt,nibd,ncmm) implicit none character*80 s80 logical lden,lopen,lnorm,lort,lwrt integer*4 na,nb,nmo2,n,nd,k,ie,ni(*),ic,kk,nid(*),aij(*),bij(*), 1dbij(*),daij(*),j,oa,ob,jj,nst,ifix,nib(*),amax,bmax,nmo,nort, 1nibd(*),ii,n22,ncmm,imax real*8 e(*),ev(*),eau(*),cij(*),dij(*),cmax,skj,sum1,sum2,ecm,ska real*8,allocatable::obaj(:),obak(:),obajd(:),obakd(:) character*1 abmax if(ncmm.ne.0)then n22=ncmm else n22=nmo2 endif ie=0 lopen=.false. open(2,file='ciss_a.co') 1 read(2,2000,end=2,err=2)s80 write(6,2000)s80 2000 format(a80) c if(s80(1:1).eq.'e'.or.s80(1:2).eq.' ')then ie=ie+1 read(s80(3:len(s80)),*)nd,eau(nd) ev(nd)=eau(nd)*27.211384205943d0 ecm=ev(nd)*8065.54476345045d0 e(nd)=1.0d7/ecm if(ie.ne.nd)call report(' Inconsistent reading') cmax=0.0d0 amax=0 bmax=0 imax=0 if(lden)then ni(ie)=0 nib(ie)=0 nibd(ie)=0 nid(ie)=0 sum1=0.0d0 sum2=0.0d0 111 read(2,2000,end=299,err=299)s80 if(s80(1:1).ne.'e'.and.s80(1:2).ne.' ')then if(ni(ie).gt.n22)call report('too many coefficients') c closed shell: ni(ie)=ni(ie)+1 ii=n22*(ie-1)+ni(ie) read(s80,*)cij(ii),aij(ii),bij(ii) call setabmax(aij(ii),bij(ii),cij(ii),amax,bmax,cmax, 1 ii,imax,abmax,' ') sum1=sum1+cij(ii)**2 goto 111 else backspace 2 endif 299 continue if(lwrt)then write(6,*)ni(ie),' alpha coefficients' if(ifix.eq.3)write(6,*)'(with backwards)' write(6,*)nid(ie),' beta coefficients' write(6,*)nib(ie),' backward coefficients' write(6,6009)amax,bmax,cij(imax),cmax**2*100.0d0 6009 format(' Dominant transition from',i4,' to ',i4,2f8.3) write(6,1234)sum1,sum2,sum1-sum2 1234 format('fnorm, bnorm,diff:',3f10.4) endif if(lnorm)then c renormalize: call normcijo(ie,cij,dij,ni,nid,n22,lopen) write(6,*)' cij were normalized' endif endif if(nd.eq.n) goto 2 endif goto 1 c 2 close(2) if(lort)then if(nmo2.ne.n22)call report('cannot re-orthogonalize' 1 //'within limited coefficient space') if(nst.gt.0.and.nst.lt.n)then nort=nst else nort=n endif c reorthonormalize: write(6,*)'orthogonalizing coefficients for ',nort,' states' allocate(obaj(nmo2),obak(nmo2)) if(lopen)allocate(obajd(nmo2),obakd(nmo2)) write(6,*)'temporary variables allocated' c run twice for better accuracy: do 318 ic=1,2 ska=0.0d0 do 3181 j=1,nort c transcript original cij to obaj: call vz(obaj,nmo2) do 324 jj=1,ni(j) oa=aij(n22*(j-1)+jj) ob=bij(n22*(j-1)+jj) 324 obaj(ob+nmo*(oa-1))=cij(n22*(j-1)+jj) if(lopen)then call vz(obajd,nmo2) do 3241 jj=1,nid(j) oa=daij(n22*(j-1)+jj) ob=dbij(n22*(j-1)+jj) 3241 obajd(ob+nmo*(oa-1))=dij(n22*(j-1)+jj) endif do 334 k=1,j-1 c transcript cij to obak: call vz(obak,nmo2) kk=n22*(k-1) do 3242 jj=1,ni(k) oa=aij(kk+jj) ob=bij(kk+jj) 3242 obak(ob+nmo*(oa-1))=cij(kk+jj) if(lopen)then call vz(obakd,nmo2) kk=n22*(k-1) do 3243 jj=1,nid(k) oa=daij(kk+jj) ob=dbij(kk+jj) 3243 obakd(ob+nmo*(oa-1))=dij(kk+jj) endif c : skj=0.0d0 do 323 oa=1,na do 323 ob=na+1,nmo c forward excitations: skj=skj+obaj(ob+nmo*(oa-1))*obak(ob+nmo*(oa-1)) c backward excitations: 323 skj=skj+obaj(oa+nmo*(ob-1))*obak(oa+nmo*(ob-1)) if(lopen)then do 331 oa=1,nb do 331 ob=nb+1,nmo skj=skj+obajd(ob+nmo*(oa-1))*obakd(ob+nmo*(oa-1)) 331 skj=skj+obajd(oa+nmo*(ob-1))*obakd(oa+nmo*(ob-1)) endif c |j'>=|j>-|k>: do 319 oa=1,na do 319 ob=na+1,nmo if(oa+nmo*(ob-1).gt.nmo2)write(6,*)'A',oa,ob,nmo2 if(ob+nmo*(oa-1).gt.nmo2)write(6,*)'B',oa,ob,nmo2 obaj(ob+nmo*(oa-1))=obaj(ob+nmo*(oa-1))-skj*obak(ob+nmo*(oa-1)) 319 obaj(oa+nmo*(ob-1))=obaj(oa+nmo*(ob-1))-skj*obak(oa+nmo*(ob-1)) if(lopen)then do 332 oa=1,nb do 332 ob=nb+1,nmo obajd(ob+nmo*(oa-1))= 1 obajd(ob+nmo*(oa-1))-skj*obakd(ob+nmo*(oa-1)) 332 obajd(oa+nmo*(ob-1))= 1 obajd(oa+nmo*(ob-1))-skj*obakd(oa+nmo*(ob-1)) endif 334 ska=ska+dabs(skj) c c transcript new obaj to new cij: if(lopen)then nid(j)=0 do 333 oa=1,nb do 333 ob=nb+1,nmo jj=ob+nmo*(oa-1) if(obajd(jj).ne.0.0d0)then nid(j)=nid(j)+1 dij( n22*(j-1)+nid(j))=obajd(jj) daij(n22*(j-1)+nid(j))=oa dbij(n22*(j-1)+nid(j))=ob endif jj=oa+nmo*(ob-1) if(obajd(jj).ne.0.0d0)then nid(j)=nid(j)+1 dij( n22*(j-1)+nid(j))=obajd(jj) daij(n22*(j-1)+nid(j))=ob dbij(n22*(j-1)+nid(j))=oa endif 333 continue endif ni(j)=0 do 325 oa=1,na do 325 ob=na+1,nmo jj=ob+nmo*(oa-1) if(obaj(jj).ne.0.0d0)then ni(j)=ni(j)+1 cij(n22*(j-1)+ni(j))=obaj(jj) aij(n22*(j-1)+ni(j))=oa bij(n22*(j-1)+ni(j))=ob endif jj=oa+nmo*(ob-1) if(obaj(jj).ne.0.0d0)then ni(j)=ni(j)+1 cij(n22*(j-1)+ni(j))=obaj(jj) aij(n22*(j-1)+ni(j))=ob bij(n22*(j-1)+ni(j))=oa endif 325 continue 3181 call normcijo(j,cij,dij,ni,nid,n22,lopen) write(6,*)ic,ska/dble(nort**2)/2.0d0 318 continue write(6,*)'double orthogonalization done' endif return end subroutine mcdi(e00,fac,np0,iwr,N,C,D,GP,LEXCL, 1u0,m0,g0,Gnj,LQ1,LDD,THRC,HW,lgnj,gnji,NQ, 1ddi,aai,rgnj,NQ1,LUE,LUM) c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c Gnj ... "MCD tensor" for this transition c gnji ... MCD tensor derivatives c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ real*8 pp,FC,e00,fac,ut(3),u0(*),ddi(*),Gnj(*),C(N,N),D(N), 1GP(N,N),proc,ds,enm,EJ,CM,THRC,qk,rs,gnji(*),gt(9),g0(*), 1m0(*),aai(*),mt(3),mcd,vt(3),q0(6),v0(3),qkf,ejs logical LQ1,LDD,HW,lgnj,rgnj,LUE,LUM integer,allocatable::si(:),sit(:) CM=219474.63d0 proc=0.0d0 nt=0 c <0|0*>: nt=nt+1 proc=proc+100.0d0*fac**2 allocate(si(LEXCL+1),sit(LEXCL+2)) call viz(si,LEXCL+1) call viz(sit,LEXCL+2) open(70,file='MCDI.MOM.TXT') if(rgnj)call rdgnj(Gnj,u0,m0,q0,v0) c transition el and magn dipole <0|u|*>=u0<0|*>+du/dQk <0|Qk|*>,etc do 12 ix=1,3 mt(ix)=m0(ix)*fac 12 ut(ix)=u0(ix)*fac if(lgnj)then c transition tensor <0|G|*>=G0<0|*>+dG/dQk <0|Qk|*> do 1 ix=1,9 1 Gt(ix)=g0(ix)*fac else do 101 ix=1,9 101 Gt(ix)=Gnj(ix)*fac endif if(LQ1)then do 10 kk=1,NQ si(1)=kk c <0|Q*k|0*>=sqrt(h/(2*wk)) <0|1*k> pp=FC(fac,si,1,np0,iwr,C,D,N)/dsqrt(2.0d0*GP(kk,kk)) if(LDD)then if(lgnj)then do 2 ix=1,9 2 Gt(ix)=Gt(ix)+gnji(ix+9*(kk-1))*pp endif if(LUE)then do 131 ix=1,3 131 ut(ix)=ut(ix)+ ddi(ix+3*(kk-1))*pp endif if(LUM)then do 132 ix=1,3 132 mt(ix)=mt(ix)+ aai(ix+3*(kk-1))*pp endif endif 10 write(6,1600)kk,pp 1600 format('<0|Q_',i3,'|0*> = ',g13.4) endif vt(1)=Gt(2+3*(3-1))-Gt(3+3*(2-1)) vt(2)=Gt(3+3*(1-1))-Gt(1+3*(3-1)) vt(3)=Gt(1+3*(2-1))-Gt(2+3*(1-1)) ds =ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3) rs =ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3) mcd=ut(1)*vt(1)+ut(2)*vt(2)+ut(3)*vt(3) c cm-1 to nm: enm=1.0d7/e00 write(42,550)nt,enm,ds,mcd,proc write(43,550)nt,enm,ds,rs ,proc 550 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',10i3) write(70,700)nt,enm,(ut(I),I=1,3),(mt(I),I=1,3),(vt(I),I=1,3) 700 format(i8,f10.2,9g13.4) c states Nexc excited if(NQ1.eq.0)NQ1=LEXCL do 30000 Nexc=1,LEXCL c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c EJ=ejs(si,Nexc,GP,N) if(iwr.gt.1)write(6,604)ii,(si(iex),iex=1,NExc) 604 format(' state ',i2,':',10i3) c <0|*> pp=FC(fac,si,Nexc,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0 if(HW)then write(6,599) 599 format('<0|',$) do 107 I=1,Nexc 107 write(6,601)si(I) 601 format(i3,$) write(6,598) 598 format('>: ',$) write(6,602)pp,proc,EJ*CM 602 format(g12.4,' (',f10.3,'%), E= ',F10.2) endif c <0|u|*>=u0<0|*>+du/dQk<0|Qk|*> c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) do 14 ix=1,3 ut(ix)=u0(ix)*pp 14 mt(ix)=m0(ix)*pp if(lgnj)then do 3 ix=1,9 3 Gt(ix)=g0(ix)*pp endif if(LQ1)then if(LDD)then do 15 kk=1,NQ qk=qkf(si,Nexc,kk,fac,sit,iwr,C,D,N,np0,GP) if(lgnj)then do 4 ix=1,9 4 Gt(ix)=Gt(ix)+gnji(ix+9*(kk-1))*qk endif if(LUE)then ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif if(LUM)then mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk endif 15 continue endif c LDD endif c LQ1 vt(1)=Gt(2+3*(3-1))-Gt(3+3*(2-1)) vt(2)=Gt(3+3*(1-1))-Gt(1+3*(3-1)) vt(3)=Gt(1+3*(2-1))-Gt(2+3*(1-1)) ds =ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3) rs =ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3) mcd=ut(1)*vt(1)+ut(2)*vt(2)+ut(3)*vt(3) if(dabs(ds).gt.THRC)then nt=nt+1 enm=1.0d7/(e00+EJ*CM) write(42,550)nt,enm,ds,mcd,proc,(si(i),i=1,Nexc) write(43,550)nt,enm,ds,rs ,proc,(si(i),i=1,Nexc) write(70,700)nt,enm,(ut(I),I=1,3),(mt(I),I=1,3),(vt(I),I=1,3) endif c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue close(70) return end c ============================================================ subroutine rdgs(NQ,sd,qt,EK,NB) implicit none integer*4 NQ,i,NB logical lex real*8 qt(*),EK(*) integer*4 sd(*) inquire(file='PSTATE',exist=lex) if(lex)then open(9,file='PSTATE') read(9,*) read(9,*) do 19 i=1,NQ 19 read(9,*)qt(NQ),qt(NQ),qt(NQ),qt(NQ),sd(i),sd(i),EK(i) read(9,*)NB close(9) write(6,*)'Excited vibration guess read from PSTATE' else call report('PSTATE not found') endif return end c ============================================================ subroutine fmaxo(NQ,t0,sdn,LEXP,fac,si,Ni,Nj,np0,iwr,N, 1A,B,C,D,E) c find state providing maximal overlap to si from initial c guess sdn implicit none integer*4 NQ,ic,i,sdn(*),LEXP,si(*),Ni,Nj,np0,iwr,les,N real*8 tp,tm,FC1,fac,A(N,N),B(*),C(N,N),D(N),E(N,N),t0 integer*4,allocatable::sj(:) write(6,*)' Iterating:' 2525 ic=0 do 24 i=1,NQ tp=t0 tm=t0 if(sdn(i).gt.0)then sdn(i)=sdn(i)-1 LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) tm=FC1(fac,si,sj,Ni,Nj-1,np0,iwr,A,B,C,D,E,N)**2 sdn(i)=sdn(i)+1 deallocate(sj) endif sdn(i)=sdn(i)+1 LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) tp=FC1(fac,si,sj,Ni,Nj+1,np0,iwr,A,B,C,D,E,N)**2 sdn(i)=sdn(i)-1 deallocate(sj) if(tm.gt.t0.and.tm.gt.tp)then sdn(i)=sdn(i)-1 Nj=Nj-1 write(6,607)'T',100.0d0*tm 607 format(' <0|',A1,'>: ',g12.4,' %') ic=ic+1 t0=tm else if(tp.gt.t0.and.tp.gt.tm)then sdn(i)=sdn(i)+1 Nj=Nj+1 write(6,607)'T',100.0d0*tp ic=ic+1 t0=tp endif endif 24 continue if(ic.gt.0)goto 2525 write(6,609)(sdn(i),i=1,NQ) 609 format(20i3) LEXP=les(NQ,sdn) return end c ============================================================ subroutine mcdid(e00,fac,np0,iwr,N,A,B,C,D,E,GP,LEXCL, 1u0,m0,g0,Gnj,LQ1,LDD,THRC,HW,lgnj,gnji,NQ, 1ddi,aai,rgnj,NQ1,LUE,LUM) c mdci, but not 0->0', but 0->P c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c Gnj ... "MCD tensor" for this transition c gnji ... MCD tensor derivatives c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ,LEXP,Ni,Nj,les,ias,NB real*8 pp,FC,e00,fac,ut(3),u0(*),ddi(*),Gnj(*),ejs, 1proc,ds,enm,EJ,CM,THRC,pm,qk,rs,gnji(*),gt(9),g0(*), 1m0(*),aai(*),mt(3),mcd,vt(3),q0(6),v0(3),FC1, 1A(N,N),B(*),C(N,N),D(*),E(N,N),GP(N,N), 1t0,t,ed(3),md(3),gd(9),procold,qkf logical LQ1,LDD,HW,lgnj,rgnj,LUE,LUM integer*4,allocatable::si(:),sit(:),sd(:),sj(:),sdn(:),sl(:),st(:) real*8,allocatable::qt(:),EK(:) CM=219474.63d0 proc=0.0d0 procold=0.0d0 nt=0 c <0|0*>: nt=nt+1 proc=proc+100.0d0*fac**2 Ni=0 allocate(si(LEXCL+1),sl(NQ),st(NQ)) call viz(si,LEXCL+1) c read guess of the principal excited state: allocate(sd(NQ),sdn(NQ),qt(NQ),EK(NQ)) call rdgs(NQ,sd,qt,EK,NB) LEXP=les(NQ,sd) write(6,*)LEXP,' - times excited' write(6,609)(sd(kk),kk=1,NQ) 609 format(20i3) allocate(sj(LEXP+1)) call viz(sj,LEXP+1) call puts(NQ,sd,sj) Nj=LEXP t0=FC1(fac,si,sj,Ni,Nj,np0,iwr,A,B,C,D,E,N)**2 write(6,607)'0',100.0d0*fac**2 write(6,607)'P',100.0d0*t0 607 format(' <0|',A1,'>: ',g12.4,' %') deallocate(sj) c rewrite initial guess to sdn: do 25 kk=1,NQ 25 sdn(kk)=sd(kk) c find maximum overlap state: call fmaxo(NQ,t0,sdn,LEXP,fac,si,Ni,Nj,np0,iwr,N, 1A,B,C,D,E) c : LEXP=les(NQ,sdn) Nj=LEXP allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) EJ=ejs(sj,Nj,GP,N) t=FC1(fac,si,sj,Ni,Nj+1,np0,iwr,A,B,C,D,E,N) deallocate(sj) open(70,file='MCDI.MOM.TXT') if(rgnj)call rdgnj(Gnj,u0,m0,q0,v0) c pre-calculate u - du/dQ Qt do 121 ix=1,3 ed(ix)=u0(ix) md(ix)=m0(ix) do 121 kk=1,NQ ed(ix)=ed(ix)-ddi(ix+3*(kk-1))*qt(kk) 121 md(ix)=md(ix)-aai(ix+3*(kk-1))*qt(kk) c MCD tensor: do 124 ix=1,9 if(lgnj)then gd(ix)=g0(ix) else gd(ix)=Gnj(ix) endif do 124 kk=1,NQ 124 gd(ix)=gd(ix)-gnji(ix+9*(kk-1))*qt(kk) c >>>>>>>>>>>> <0|T'> <<<<<<<<<<<<<<<<<<<<<<<<<<<<< c transition el and magn dipole c <0|u|*>= (u0 - du/dQk Qtk) <0|*>+du/dQk <0|Qk|*>,etc do 12 ix=1,3 ut( ix)=ed( ix)*t mt( ix)=md( ix)*t Gt( ix)=gd( ix)*t Gt(3+ix)=gd(3+ix)*t 12 Gt(6+ix)=gd(6+ix)*t if(LQ1)then do 10 kk=1,NQ c <0|Q*k|*>=sqrt(h/(2*wk)) [ sqrt(vk) <0|k-1> + sqrt(vk+1) <0|k+1> ]: sdn(kk)=sdn(kk)+1 LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) pp=sqrt(dble(sdn(kk)+1))*FC(fac,sj,LEXP,np0,iwr,C,D,N) sdn(kk)=sdn(kk)-1 deallocate(sj) if(sdn(kk).gt.0)then sdn(kk)=sdn(kk)-1 LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) pm=sqrt(dble(sdn(kk)+1))*FC(fac,sj,LEXP,np0,iwr,C,D,N) sdn(kk)=sdn(kk)+1 deallocate(sj) else pm=0.0d0 endif pp=(pp+pm)/dsqrt(2.0d0*GP(kk,kk)) if(LDD)then if(lgnj)then do 2 ix=1,9 2 Gt(ix)=Gt(ix)+gnji(ix+9*(kk-1))*pp endif if(LUE)then do 131 ix=1,3 131 ut(ix)=ut(ix)+ ddi(ix+3*(kk-1))*pp endif if(LUM)then do 132 ix=1,3 132 mt(ix)=mt(ix)+ aai(ix+3*(kk-1))*pp endif endif write(6,1600)kk,pp 1600 format('<0|Q_',i3,'|*> = ',g13.4) 10 continue endif vt(1)=Gt(2+3*(3-1))-Gt(3+3*(2-1)) vt(2)=Gt(3+3*(1-1))-Gt(1+3*(3-1)) vt(3)=Gt(1+3*(2-1))-Gt(2+3*(1-1)) ds =ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3) rs =ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3) mcd=ut(1)*vt(1)+ut(2)*vt(2)+ut(3)*vt(3) c cm-1 to nm: enm=1.0d7/(e00+EJ*CM) write(42,550)nt,enm,ds,mcd,proc write(43,550)nt,enm,ds,rs ,proc 550 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',10i3) write(70,700)nt,enm,(ut(I),I=1,3),(mt(I),I=1,3),(vt(I),I=1,3) 700 format(i8,f10.2,9g13.4) c >>>>>>>>>>>> <0|T'> (end) c >>>>>>>>>>>> Other transitions:' do 99999 ias=1,-1,-2 if(ias.eq.1)then write(6,*)'Adding excitations' else write(6,*)'Subtracting excitations' endif c ias= 1 ... add excitations c ias=-1 ... subtract excitations c states les(sdn)+/Nexc excited do 30000 Nexc=1,LEXCL write(6,*)NExc c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(NQ1.ne.0.and.icen.gt.NQ1)goto 12000 c transcript si (short notation) to sl (long) call trl(si,Nexc,sl,NQ) if(ias.eq.1)then c add this arbitrary state to sdn do 26 ii=1,NQ 26 st(ii)=sdn(ii)+sl(ii) else c subtract this state if possible do 27 ii=1,NQ st(ii)=sdn(ii)-sl(ii) 27 if(st(ii).lt.0)goto 12000 endif c rewrite final state st into short form in sj: LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sit,LEXCL+2) call puts(NQ,st,sj) c EJ=ejs(sj,LEXP,GP,N) if(iwr.gt.1)write(6,604)ii,(sj(iex),iex=1,LEXP) 604 format(' state ',i2,':',10i3) c <0|*> pp=FC(fac,sj,LEXP,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0 if(proc.gt.procold+1.0d0)then write(6,602)pp,proc,EJ*CM procold=proc endif if(HW.and.iwr.gt.1)then write(6,599) 599 format('<0|',$) do 107 I=1,LEXP 107 write(6,601)sj(I) 601 format(i3,$) write(6,598) 598 format('>: ',$) write(6,602)pp,proc,EJ*CM 602 format(g12.4,' (',f10.3,'%), E= ',F10.2) endif c <0|u|*>=u0<0|*>+du/dQk<0|Qk-Qt|*> c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) do 14 ix=1,3 ut(ix)=ed(ix)*pp 14 mt(ix)=md(ix)*pp if(lgnj)then do 3 ix=1,9 3 Gt(ix)=gd(ix)*pp endif if(LQ1)then if(LDD)then do 15 kk=1,NQ qk=qkf(sj,LEXP,kk,fac,sit,iwr,C,D,N,np0,GP) if(LUE)then ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif if(LUM)then mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk endif if(lgnj)then Gt(1)=Gt(1)+gnji(1+9*(kk-1))*qk Gt(2)=Gt(2)+gnji(2+9*(kk-1))*qk Gt(3)=Gt(3)+gnji(3+9*(kk-1))*qk Gt(4)=Gt(4)+gnji(4+9*(kk-1))*qk Gt(5)=Gt(5)+gnji(5+9*(kk-1))*qk Gt(6)=Gt(6)+gnji(6+9*(kk-1))*qk Gt(7)=Gt(7)+gnji(7+9*(kk-1))*qk Gt(8)=Gt(8)+gnji(8+9*(kk-1))*qk Gt(9)=Gt(9)+gnji(9+9*(kk-1))*qk endif 15 continue endif c LDD endif c LQ1 vt(1)=Gt(2+3*(3-1))-Gt(3+3*(2-1)) vt(2)=Gt(3+3*(1-1))-Gt(1+3*(3-1)) vt(3)=Gt(1+3*(2-1))-Gt(2+3*(1-1)) ds =ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3) rs =ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3) mcd=ut(1)*vt(1)+ut(2)*vt(2)+ut(3)*vt(3) if(dabs(ds).gt.THRC)then nt=nt+1 enm=1.0d7/(e00+EJ*CM) write(42,5501)nt,enm,ds,mcd,proc 5501 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',$) do 42 i=1,LEXP 42 write(42,5502)sj(i) 5502 format(i3,$) write(42,*) write(43,5501)nt,enm,ds,rs ,proc do 43 i=1,LEXP 43 write(43,550)sj(i) write(43,*) write(70,700)nt,enm,(ut(I),I=1,3),(mt(I),I=1,3),(vt(I),I=1,3) endif deallocate(sj,sit) c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue 99999 continue write(6,602)pp,proc,EJ*CM c >>>>>>>>>>>> Other transitions:' close(70) return end subroutine rrrf(e00,fac,np0,iwr,N,A,B,C,D,E,G,GP, 1u0,m0,v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,HW,NQ, 2LEXCL,LEXCF,EXCNM,gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 3reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1vrroa,troa,ltens,gtens,atens,enr,anroa,lhyde,nmap,mmap,frroa, 1sr,lwten,nproc,lvel,ldo) c resonance Raman and ROA spectra - optimized routine c e00 ... energy of the 0-0 transition in cm-1 c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ,LEXCF,npx,nroot,NQBUF,IQBUF,TQ,nmap,mmap(*),ns0,nproc, 1NEXC0,no,nd parameter (ns0=19,NEXC0=100) real*8 pp,FC,e00,fac,ut(15),u0(*),ddi(*),A(N,N),B(*),C(N,N),D(N), 1E(N,N),G(N,N),GP(N,N),proc,EJ,CM,THRC,qk,m0(*),aai(*), 1gammaau,q0(*),v0(*),qqi(*),vvi(*),EXCNM,wrax,wrin,tb, 1fwhh,reram(*),reroa(*),wzero,kelvin,qt(1),troa,ltens(*),gtens(*), 1atens(*),enr(*),e00au,qkf,ejs,sr(npx,2,ns0),maxo,maxd logical LQ1,HW,lglg,ltab,lvert,lwzero,anroa,vrroa,lhyde,frroa, 1lwten,lvel,ldo(ns0) integer,allocatable::si(:),sit(:),s0(:),sto(:),std(:) integer,allocatable::sib(:,:),Nexcb(:) real*8,allocatable::utb(:,:),tbb(:),eb(:) CM=219474.63d0 proc=0.0d0 nt=0 maxo=0.0d0 maxd=0.0d0 e00au=e00/CM c dummy variable (for ldis option), not used here: qt(1)=0.0d0 c <0|0*>: nt=nt+1 proc=proc+100.0d0*fac**2 write(6,1601)proc 1601 format(' <0|0*> = ',g13.4,' %') allocate(si(LEXCL+1),sit(LEXCL+2),s0(1)) allocate(sto(LEXCL+1),std(LEXCL+1)) s0(1)=0 call viz(si,LEXCL+1) call viz(sit,LEXCL+2) sto=0 no=0 std=0 nd=0 write(6,600)nroot, N,NQ,NQBUF,nproc, 0,LEXCL,LEXCF, 1lwzero,vrroa,anroa,lvert, lhyde,lglg,ltab,frroa, 1lwten, 1wzero,wrin,wrax,npx,fwhh,kelvin,gammaau*CM, 1EXCNM,e00,THRC,troa 600 format(/,' rrrf',/, 1' Resonance ROA calculation-fast routine',/, 1' --------------------------------------',/, 1' Root #',i3,/, 1' N =',i4,' NQ =',i4,' NQBUF =',i4,' NPROC =',i4,/, 1' Maximal exc. start/intermediate/final: ',3i3,/, 1' lwzero =',l2,' vrroa =',l2,' anrroa =',l2,' lvert =',l2,/, 1' lhyde =',l2,' lglg =',l2,' ltab =',l2,' frroa =',l2,/, 1' lwten =',l2,/, 1' wzero =',f12.3,' wmin =',f12.3,' wmax =',f12.3,' cm-1',/, 1' Number of points =',i12 ,' FWHH / cm-1 =',f12.3,/, 1' Temperature / K =',f12.3,' gamma / cm-1 =',f12.3,/, 1' w_exc nm =',f12.3,' e00 / cm-1 =',f12.3,/, 1' threshold =',g12.2,' troa =',g12.2,/, 1' ',60(1h-)) c initialize the buffer with the |*> states providing the c largest <0|u|*> dipole: allocate(sib(NQBUF,NEXC0),utb(NQBUF,15),tbb(NQBUF),Nexcb(NQBUF), 1eb(NQBUF)) utb=0.0d0 do 4 kk=1,NQBUF Nexcb(kk)=0 eb(kk)=0.0d0 tbb(kk)=0.0d0 do 4 ix=1,LEXCL+1 4 sib(kk,ix)=0 c number of transitions in the buffer: IQBUF=0 c total number of 0->* transitions: TQ=0 c add 0->0': c ut ... electric dipole, length c <0|u|*>=u0<0|*>+du/dQk <0|Qk|*>,etc do 101 ii=1,3 101 ut( ii)=u0(ii)*fac if(LQ1)then do 10 kk=1,NQ si(1)=kk c <0|Q*k|0*>=sqrt(h/(2*wk)) <0|1*k> pp=FC(fac,si,1,np0,iwr,C,D,N)/dsqrt(2.0d0*GP(kk,kk)) do 102 ii=1,3 102 ut( ii)=ut( ii)+ddi(ii +3*(kk-1))*pp 10 if(iwr.gt.1)write(6,1600)kk,pp 1600 format('<0|Q_',i3,'|0*> = ',g13.4) si(1)=0 endif IQBUF=IQBUF+1 TQ=TQ+1 do 103 ii=1,3 103 utb(1,ii)=ut(ii) tbb(1)=ut(1)**2+ut(2)**2+ut(3)**2 eb(1)=e00au call invm(maxo,maxd,LEXCL+1,fac,tbb(1),sto,no,std,nd,si,0) c Generate other states Nexc>0 excited: if(NQ1.eq.0)NQ1=LEXCL do 30000 Nexc=1,LEXCL c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc c check that the state is allowed: icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c EJ=ejs(si,Nexc,GP,N) if(iwr.gt.1)write(6,604)ii,(si(iex),iex=1,NExc) 604 format(' state ',i2,':',10i3) c <0|*> pp=FC(fac,si,Nexc,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0 if(HW)then write(6,599) 599 format('<0|',$) do 107 I=1,Nexc 107 write(6,601)si(I) 601 format(i3,$) write(6,598) 598 format('>: ',$) write(6,602)pp,proc,EJ*CM 602 format(g12.4,' (',f10.3,'%), E= ',F10.2) endif c <0|u|*>=u0<0|*>+du/dQk<0|Qk|*> c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) ut(1)=u0(1)*pp ut(2)=u0(2)*pp ut(3)=u0(3)*pp if(LQ1)then do 15 kk=1,NQ qk=qkf(si,Nexc,kk,fac,sit,iwr,C,D,N,np0,GP) ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk 15 ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif tb=ut(1)**2+ut(2)**2+ut(3)**2 TQ=TQ+1 call invm(maxo,maxd,LEXCL+1,pp,tb,sto,no,std,nd,si,Nexc) if(tb.gt.THRC)then c add states with large dipole moments to the buffer: if(IQBUF.lt.NQBUF)IQBUF=IQBUF+1 do 7 kk=1,NQBUF if(tb.gt.tbb(kk))then do 5 ic=NQBUF,kk+1,-1 eb (ic)=eb (ic-1) tbb (ic)=tbb (ic-1) utb (ic,1)=utb (ic-1,1) utb (ic,2)=utb (ic-1,2) utb (ic,3)=utb (ic-1,3) Nexcb(ic)=Nexcb (ic-1) do 5 ix=1,Nexcb (ic-1) 5 sib (ic,ix)=sib(ic-1,ix) eb (kk)=e00au+EJ tbb (kk)=tb utb (kk,1)=ut(1) utb (kk,2)=ut(2) utb (kk,3)=ut(3) Nexcb(kk)=Nexc do 3 ix=1,Nexc 3 sib (kk,ix)=si(ix) goto 12000 endif 7 continue endif c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue write(6,*)IQBUF,' |0> -> |e> transitions of ',TQ write(6,506)' Maximal overlap:',maxo 506 format(a17,e12.4,' state:',$) call wrs(6,sto,no) write(6,*) write(6,506)' Maximal dipole :',dsqrt(maxd) call wrs(6,std,nd) write(6,*) c add magnetic dipoles and quadrupoles call addmq(NQBUF,N,NQ,np0,IQBUF,iwr,NExcb,LEXCL,sib,LQ1, 1sit,C,D,fac,GP,utb,v0,m0,q0,vvi,aai,qqi,NEXC0) c Use selected states for 0 -> * -> f polarizabilities: if(lhyde)then call downexcfh(s0,0,sib,Nexcb,LEXCF,utb,IQBUF,u0,m0,q0,v0, 1np0,iwr,N,LQ1,NQ,G,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1vrroa,anroa,NQBUF,LEXCL+1,eb,nmap,mmap,lvert,frroa,sr,lwten, 1lvel,ldo) else call downexcf(s0,0,sib,Nexcb,LEXCF,utb,IQBUF,u0,m0,q0,v0, 1fac,np0,iwr,A,B,C,D,E,N,LQ1,NQ,G,GP,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1qt,.false.,vrroa,troa,ltens,gtens,atens,enr,anroa, 1NQBUF,LEXCL+1,eb,frroa,sr,lwten,nproc,lvel,ldo) endif return end subroutine rrrp(e00,fac,np0,iwr,N,A,B,C,D,E,G,GP, 1u0,m0,v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,NQ, 2LEXCL,LEXCF,EXCNM,gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 3reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1vrroa,troa,ltens,gtens,atens,enr,anroa,lhyde,nmap,mmap,frroa, 1sr,lwten,nproc,lvel,ldo) c resonance Raman and ROA spectra - optimized routine c FC selection only c e00 ... energy of the 0-0 transition in cm-1 c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ,LEXCF,npx,nroot,NQBUF,IQBUF,TQ,nmap,mmap(*),ns0,nproc, 1NEXC0,no,imin parameter (ns0=19,NEXC0=100) real*8 pp,FC,e00,fac,u0(*),ddi(*),A(N,N),B(*),C(N,N),D(N), 1E(N,N),G(N,N),GP(N,N),proc,CM,THRC,m0(*),aai(*), 1gammaau,q0(*),v0(*),qqi(*),vvi(*),EXCNM,wrax,wrin, 1fwhh,reram(*),reroa(*),wzero,kelvin,qt(1),troa,ltens(*),gtens(*), 1atens(*),enr(*),e00au,sr(npx,2,ns0),maxo,omin logical LQ1,lglg,ltab,lvert,lwzero,anroa,vrroa,lhyde,frroa, 1lwten,lvel,ldo(ns0) integer,allocatable::si(:),sit(:),s0(:),sto(:) integer,allocatable::sib(:,:),Nexcb(:) real*8,allocatable::utb(:,:),tbb(:),eb(:) CM=219474.63d0 proc=0.0d0 nt=0 e00au=e00/CM c dummy variable (for ldis option), not used here: qt(1)=0.0d0 c <0|0*>: nt=nt+1 proc=proc+100.0d0*fac**2 write(6,1601)proc 1601 format(' <0|0*> = ',g13.4,' %') allocate(si(LEXCL+1),sit(LEXCL+2),s0(1),sto(LEXCL+1)) s0(1)=0 call viz(si,LEXCL+1) call viz(sit,LEXCL+2) write(6,600)nroot, N,NQ,NQBUF,nproc, 0,LEXCL,LEXCF, 1lwzero,vrroa,anroa,lvert, lhyde,lglg,ltab,frroa, 1lwten, 1wzero,wrin,wrax,npx,fwhh,kelvin,gammaau*CM, 1EXCNM,e00,THRC,troa 600 format(/,' rrrp',/, 1' Resonance ROA calculation-fast routine, FC only',/, 1' --------------------------------------',/, 1' Root #',i3,/, 1' N =',i4,' NQ =',i4,' NQBUF =',i4,' NPROC =',i4,/, 1' Maximal exc. start/intermediate/final: ',3i3,/, 1' lwzero =',l2,' vrroa =',l2,' anrroa =',l2,' lvert =',l2,/, 1' lhyde =',l2,' lglg =',l2,' ltab =',l2,' frroa =',l2,/, 1' lwten =',l2,/, 1' wzero =',f12.3,' wmin =',f12.3,' wmax =',f12.3,' cm-1',/, 1' Number of points =',i12 ,' FWHH / cm-1 =',f12.3,/, 1' Temperature / K =',f12.3,' gamma / cm-1 =',f12.3,/, 1' w_exc nm =',f12.3,' e00 / cm-1 =',f12.3,/, 1' threshold =',g12.2,' troa =',g12.2,/, 1' ',60(1h-)) c initialize the buffer with the |*> states providing the c largest <0|u|*> dipole: allocate(sib(NQBUF,NEXC0),utb(NQBUF,15),tbb(NQBUF),Nexcb(NQBUF), 1eb(NQBUF)) utb=0.0d0 Nexcb=0 eb=0.0d0 tbb=0.0d0 sib=0 c number of transitions in the buffer: IQBUF=0 c total number of 0->* transitions: TQ=0 c add 0->0': TQ=TQ+1 IQBUF=IQBUF+1 maxo=dabs(fac) no=0 sto=0 c minimal value in the buffer: omin=fac imin=IQBUF Nexcb(IQBUF)=0 c Generate other states Nexc>0 excited: if(NQ1.eq.0)NQ1=LEXCL do 30000 Nexc=1,LEXCL write(6,*)Nexc,' excited' c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc c check that the state is allowed: icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c c <0|*> pp=dabs(FC(fac,si,Nexc,np0,iwr,C,D,N)) proc=proc+pp*pp*100.0d0 TQ=TQ+1 c add states with large overlap to the buffer: if(pp.gt.THRC)then if(IQBUF.lt.NQBUF)then c just add it: IQBUF=IQBUF+1 tbb (IQBUF)=pp Nexcb(IQBUF)=Nexc do 3 ix=1,Nexc 3 sib(IQBUF,ix)=si(ix) if(pp.lt.omin)then omin=pp imin=IQBUF endif else if(pp.gt.omin)then c replace minimal value: tbb (imin)=pp Nexcb(imin)=Nexc do 33 ix=1,Nexc 33 sib(imin,ix)=si(ix) omin=pp do 7 kk=1,NQBUF if(tbb(kk).lt.omin)then omin=tbb(kk) imin=kk endif 7 continue endif endif endif c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue do 333 kk=1,IQBUF if(tbb(kk).gt.maxo)then maxo=tbb(kk) no=Nexcb(kk) do 3333 ix=1,no 3333 sto(ix)=sib(kk,ix) endif 333 continue write(6,*)IQBUF,' |0> -> |e> transitions of ',TQ write(6,506)proc,' Maximal overlap:',maxo 506 format(f12.5,'%',a17,e12.4,' state:',$) call wrs(6,sto,no) write(6,*) c add energies electric and magnetic dipoles and quadrupoles call addumq(NQBUF,N,NQ,np0,IQBUF,iwr,NExcb,LEXCL,sib,LQ1, 1sit,C,D,fac,GP,utb,u0,v0,m0,q0,ddi,vvi,aai,qqi,NEXC0, 1eb,e00au) c Use selected states for 0 -> * -> f polarizabilities: if(lhyde)then call downexcfh(s0,0,sib,Nexcb,LEXCF,utb,IQBUF,u0,m0,q0,v0, 1np0,iwr,N,LQ1,NQ,G,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1vrroa,anroa,NQBUF,LEXCL+1,eb,nmap,mmap,lvert,frroa,sr,lwten, 1lvel,ldo) else call downexcf(s0,0,sib,Nexcb,LEXCF,utb,IQBUF,u0,m0,q0,v0, 1fac,np0,iwr,A,B,C,D,E,N,LQ1,NQ,G,GP,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1qt,.false.,vrroa,troa,ltens,gtens,atens,enr,anroa, 1NQBUF,LEXCL+1,eb,frroa,sr,lwten,nproc,lvel,ldo) endif return end c ============================================================ subroutine rrrq(e00,fac,N,A,B,C,D,E,G,GP,sr,u0,m0,v0,q0, 1ddi,aai,qqi,vvi,LQ1,THRC,NQ,LEXCF,gammaau, 1wrax,wrin,npx,lglg,fwhh,ltab,lwten,nproc,lvel,nb0,lwrt, 1th1,th2,mmax,mmaxi,mmaxf,ktlim,kelvin,LEXCI,nexc,wes,lusea,luseg, 1lqi,icw,lprog,ldo) implicit none integer*4 LEXCF,ix,NExf,N,NQ,kk,iif,il,iw,k1,kg,maxt,I,II,npx, 1nwp,ni0,nt,m,mmf,jf,LNQf,ng,iwf,nb0,ns0,nproc,j,nkt,nsf,ni, 1ns,LNQ,mmax,mmaxi,mmaxf,LEXCI,mfc,nexc,ilm,icw,ial,nif, 1iof,j1,j2 c nm30 ... maximal excitation on one mode parameter (ns0=19,ni0=13) real*8 uf(3),mf(3),qf(6),vf(3),ei,ef,u(3,3),inv(ni0),qi(6), 1fac,A(N,N),B(*),C(N,N),D(*),E(N,N),pp,GP(N,N),prc,qq,prc_, 1G(N,N),gammaau,THRC,u0(3),m0(3),q0(6),v0(3),ddi(*),aai(*), 1vvi(*),qqi(*),CM,wrax,wrin,fwhh,eavf,emax, 1ee,wei,e00au,e00,th1,th2,FCOvI0,eavi_,eavf_,eavi,eds(15), 1ui(3),pi(3),mi(3),uu(3,3),wef,ktlim,enq,nav,wes(nexc),nav_, 1lr(3,3),li(3,3),vr(3,3),vi(3,3),gr(3,3),gi(3,3), 1ar(3,3,3),ai(3,3,3),gcr(3,3),gci(3,3),acr(3,3,3),aci(3,3,3), 1lr_(3,3),li_(3,3),vr_(3,3),vi_(3,3),gr_(3,3),gi_(3,3), 1ar_(3,3,3),ai_(3,3,3),gcr_(3,3),gci_(3,3),acr_(3,3,3),aci_(3,3,3), 1sr_,si_, 1kelvin,kt,FCOvI,vqkvp,sr(npx,2,ns0),qpar,qred,vqivp logical LQ1,ltab,lglg,lwten,lvel,lwrt,InCl,lt,lusea,luseg,lqi, 1lprog,ldo(ns0) integer*4,allocatable::sf(:),wmi(:),wmf(:),jif(:), 1wkl(:,:),sm(:),wmax(:),NQs(:),smf(:), 1wmaxf(:),NQsf(:),idf(:),idi(:),si(:) real*8,allocatable::cred(:,:),dred(:),FCI1(:),bf(:),eib(:),efb(:), 1lr3(:,:,:,:,:),li3(:,:,:,:,:),vr3(:,:,:,:,:),vi3(:,:,:,:,:), 1gr3(:,:,:,:,:),gi3(:,:,:,:,:),ar3(:,:,:,:,:,:),ai3(:,:,:,:,:,:), 1gcr3(:,:,:,:,:),gci3(:,:,:,:,:),acr3(:,:,:,:,:,:), 1aci3(:,:,:,:,:,:),dds(:),scr3(:,:,:),sci3(:,:,:), 1eredf(:,:),ees(:),efs(:), 1FF(:,:),aredf(:,:),bredf(:),FCIf(:), 1wesau(:), 1lrw(:,:,:),liw(:,:,:),vrw(:,:,:),viw(:,:,:),grw(:,:,:),giw(:,:,:), 1arw(:,:,:,:),aiw(:,:,:,:),gcrw(:,:,:),gciw(:,:,:),acrw(:,:,:,:), 1aciw(:,:,:,:),uff(:,:,:),srw(:),siw(:) logical,allocatable::doe(:),dof(:),doi(:),doif(:) CM=219474.63d0 kt=kelvin*0.6950356d0 e00au=e00/CM emax=(wrax-kt*log(ktlim))/CM write(6,6700)lvel,LQ1,lqi,nproc,lwten,luseg,lusea,mmaxi,LEXCI, 1mmax,mmaxf, 1LEXCF,e00,gammaau*CM,wrin,wrax 6700 format(/,' rrrq',/, 1' Use the velocity formalism :',l4,/, 1' Include transition first derivatives:',l4,/, 1' Derivatives at ground geometry :',l4,/, 1' Number of processors requested :',i4,/, 1' Write TTT.OUT and INV.TXT :',l4,/, 1' Use G tensor :',l4,/, 1' Use A tensor :',l4,/, 1' MMAXI :',i4,/, 1' LEXCI :',i4,/, 1' MMAX :',i4,/, 1' MMAXF :',i4,/, 1' LEXCF :',i4,/, 1' E00 / cm-1 :',f12.2,/, 1' Gamma / cm-1 :',f12.2,/, 1' Spectrum plot:',/, 1' wmin / cm-1 :',f12.2,/, 1' wrax / cm-1 :',f12.2) write(6,*)'Excitation frequencies / nm:' write(6,602)wes 602 format(6f12.1) write(6,*)' cm-1:' write(6,602)1.0d7/wes allocate(wesau(nexc)) wesau=1.0d7/CM/wes write(6,*)' / au:' write(6,603)wesau 603 format(6f12.6) allocate(lrw(nexc,3,3),liw(nexc,3,3),vrw(nexc,3,3),srw(nexc), 1viw(nexc,3,3),grw(nexc,3,3),giw(nexc,3,3),siw(nexc), 1arw(nexc,3,3,3),aiw(nexc,3,3,3),gcrw(nexc,3,3), 1gciw(nexc,3,3),acrw(nexc,3,3,3),aciw(nexc,3,3,3)) if(nproc.ne.0)then nwp=nproc else nwp=1 endif do 1 ix=1,3 eds(ix )=u0(ix ) eds(ix+ 3)=v0(ix ) eds(ix+ 6)=m0(ix ) eds(ix+ 9)=q0(ix ) 1 eds(ix+12)=q0(ix+3) allocate(dds(NQ*(3+3+3+6))) do 2 kk=1,NQ do 2 ix=1,3 dds(ix +15*(kk-1))=ddi(ix +3*(kk-1)) dds(ix+ 3+15*(kk-1))=vvi(ix +3*(kk-1)) dds(ix+ 6+15*(kk-1))=aai(ix +3*(kk-1)) dds(ix+ 9+15*(kk-1))=qqi(ix +6*(kk-1)) 2 dds(ix+12+15*(kk-1))=qqi(ix+3+6*(kk-1)) prc=fac**2 write(6,1601)100.0d0*prc 1601 format(' <0|0*> = ',g13.4,' %') c threshold estimation allocate(wkl(NQ,NQ)) prc=0.0d0 call estw(th1,th2,NQ,N,C,D,fac,wkl,prc,lwrt,icw) c try all classes: call testcl(N,NQ,mmax,fac,wkl,C,D,nwp) call omp_set_num_threads(nwp) write(6,*) allocate(wmi(NQ),wmf(NQ)) maxt=max(mmaxf,mmaxi) iwf=max(LEXCF+1,LEXCI+1) c number of states, partition function: call nkti(nb0,nkt,ktlim,maxt,iwf,NQ,N,G,CM,kt,0,qpar, 1emax,mmaxi,mmaxf,LEXCI,LEXCF,qred,wmi,wmf,nif) c number of states, probabilities: call nkti(nb0,nkt,ktlim,maxt,iwf,NQ,N,G,CM,kt,1,qpar, 1emax,mmaxi,mmaxf,LEXCI,LEXCF,qred,wmi,wmf,nif) c number of states with reduced excitations: call nktr(nb0,nkt,ng,ktlim,maxt,NQ,N,G,CM,kt, 1emax,mmaxi,mmaxf,LEXCI,LEXCF,wmi,nif) c nb0: number of states with exp(-E/kT): FCI1(1)=fac ees(1)=e00au if(m.eq.0)then doe(1)=.true. prc_=prc_+fac**2 else doe(1)=.false. endif c make <0|e>: do 62 i=2,ns call FCA2NQ(m,i,wmax,InCl,LNQ,NQs) ees(i)=e00au+enq(LNQ,N,sm,GP,NQs) FCI1(i)=FCOvI0(m,LNQ,i,NQs,wmax,DRed,CRed,FCI1) doe(i)=InCl 62 if(doe(i))prc_=prc_+FCI1(i)**2 c ground states, = <1|2>, and increment polarizability c fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff kg=0 iof=0 do 88888 mmf=0,maxt il=max(1,mmf) allocate(smf(il),NQsf(il),wmaxf(il),eredf(il,m), 1aredf(il,il),bredf(il)) do 33333 iif=1,mfc(NQ,mmf) call getdis(iif,smf,NQ,mmf,il) do 5 j=1,mmf bredf(j)=B(smf(j)) do 67 i=1,m c E(exc,ground), but here ered opposite: 67 eredf(j,i)=E(sm(i),smf(j)) do 5 i=1,mmf 5 aredf(i,j)=A(smf(i),smf(j)) nsf=1 do 681 j=1,mmf wmaxf(j)=wmi(smf(j)) 681 nsf=nsf*wmaxf(j) allocate(FF(nsf,ns),FCIf(nsf)) c <0|0'>: FF(1,1) = fac FCIf(1) = fac c : Call FCA2NQ(m,1,wmax,InCl,LNQ,NQs) Do 100 j = 2, nsf Call FCA2NQ(mmf,j,wmaxf,lt,LNQf,NQsf) FCIf(j)=FCOvI0(mmf,LNQf,j,NQsf,wmaxf,bredf,aredf,FCIf) 100 FF(j,1)=FCIf(j) c : Do 200 i = 2,ns c <0|e>: FF(1,i) = FCI1(i) Call FCA2NQ(m,i,wmax,lt,LNQ,NQs) Do 200 j = 2, nsf c =: Call FCA2NQ(mmf,j,wmaxf,lt,LNQf,NQsf) 200 FF(j,i)=FCOvI(nsf,mmf,LNQ,LNQf,i,j,NQs,NQsf,wmax,wmaxf,bredf, $aredf,eredf,FF) c transition moments Do 201 j = 1, nsf Call FCA2NQ(mmf,j,wmaxf,lt,LNQf,NQsf) if(lt)then kg=kg+1 if(doif(kg))then iof=iof+1 jif(iof)=kg Do 203 i = 1, ns if(doe(i))then pp=FF(j,i) do 202 ix=1,15 202 uff(ix,i,iof)=eds(ix)*pp uff(16,i,iof)=pp if(LQ1)then if(lqi)then c expansion in ground states modes do 15 kk=1,NQ qq=vqivp(kk,N,mmf,m,G,A,B,E,FF,nsf,ns,wmaxf,wmax,j,i,smf,sm) k1=15*(kk-1) do 15 ix=1,15 15 uff(ix,i,iof)=uff(ix,i,iof)+dds(ix+k1)*qq else c expansion in excited states modes do 16 kk=1,NQ qq=vqkvp(kk,N,mmf,m,GP,C,D,E,FF,nsf,ns,wmaxf,wmax,j,i,smf,sm) k1=15*(kk-1) do 16 ix=1,15 16 uff(ix,i,iof)=uff(ix,i,iof)+dds(ix+k1)*qq endif endif endif 203 continue endif endif 201 continue 33333 deallocate(FF,FCIf) 88888 deallocate(smf,wmaxf,aredf,bredf,eredf,NQsf) c ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff c make all transitions c iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii eavi_=0.0d0 eavf_=0.0d0 nav_=0 Do 204 j1 = 1, nif j=jif(j1) if(doi(j))then ei=efs(j1) Do 205 j2 = 1, nif jf=jif(j2) if(dof(jf))then ef=efs(j2) call bzw(nexc,lrw,liw,vrw,viw,grw,giw,arw,aiw,gcrw,gciw,acrw, 1 aciw,srw,siw) do 9 i=1,ns if(doe(i))then ee=ees(i) wei=ee-ei wef=ee-ef eavi_=eavi_+wei eavf_=eavf_+wef nav_=nav_+1.0d0 do 207 ix=1,3 ui(ix )=uff(ix ,i,j1) pi(ix )=uff(ix +3,i,j1) mi(ix )=uff(ix +6,i,j1) qi(ix )=uff(ix +9,i,j1) qi(ix+3)=uff(ix+12,i,j1) uf(ix )=uff(ix ,i,j2) vf(ix )=uff(ix +3,i,j2) mf(ix )=uff(ix +6,i,j2) qf(ix )=uff(ix +9,i,j2) 207 qf(ix+3)=uff(ix+12,i,j2) call tqq(qi,uu) call tqq(qf,u) c compose these moments to pol. components: do 41 iw=1,nexc call dzc(ui,pi,mi,uu,uf,vf,mf,u,lr_,li_,vr_,vi_,gr_,gi_,gcr_, 1 gci_,ar_,ai_,acr_,aci_, wei,wef,wesau(iw),gammaau,lvel,sr_,si_, 1 uff(16,i,j1),uff(16,i,j2)) c add this to the polarizabilities: 41 call azc(nexc,iw,lr_,li_,vr_,vi_,gr_,gi_,gcr_,gci_,ar_,ai_, 1 acr_,aci_,sr_,si_,lrw,liw,vrw,viw,grw,giw,gcrw, 1 gciw,arw,aiw,acrw,aciw,srw,siw) endif 9 continue c add polarizabilities to the j -> jf transition C$OMP Critical eavi=eavi+eavi_ eavf=eavf+eavf_ nav=nav+nav_ call azw(nexc,nb0,nkt,lrw,liw,vrw,viw,grw,giw,gcrw,gciw,arw, 1 aiw,acrw,aciw,lr3,li3,vr3,vi3,gr3,gi3,gcr3,gci3,ar3,ai3,acr3, 1 aci3,idi(j),idf(jf),scr3,sci3,srw,siw) C$OMP End critical endif 205 continue endif 204 continue C$OMP Critical prc=prc+prc_ C$OMP End critical 22222 deallocate(FCI1,doe,uff,ees,jif) c end pralallel do c write something so see the progress: call wlr3(1,nexc,nb0,nkt,lr3,li3,vr3,vi3,eib(1),efb(1),wesau(1)) eavi=eavi/nav eavf=eavf/nav write(6,601)eavi,eavi*CM,1.0d7/(eavi*CM), 1 eavf,eavf*CM,1.0d7/(eavf*CM),100.0d0*prc 601 format(/,' Average energy i - e:',f12.4,' eV',f12.1,' cm-1', 1f12.1,' nm',/, 1 ' f - e:',f12.4,' eV',f12.1,' cm-1', 1f12.1,' nm',/,/, 1' sum(e)<0|e> = ',g12.3,' %',/) if(lprog.or.m.eq.mmax)then c make invariants and intensities for all transitions c cannot use si,sf, make some fakes so far: write(6,604)m 604 format(' Class',i3,', writing intensities') open(99,file='tem.txt') write(99,604)m close(99) allocate(sf(1)) Nexf=0 allocate(si(1)) ni=0 do 881 iw=1,nexc c nt ... number of transitions: nt=0 sr=0.0d0 if(lwten.and.m.eq.mmax)call initen(wes(iw)) do 87 i=1,nb0 ei=eib(i) do 87 jf=1,nkt ef=efb(jf) if(ef.gt.ei)then nt=nt+1 c pick up tensors of frequency iw: call czz(nexc,iw,nb0,nkt,i,jf,lr,li,vr,vi,gr,gi,gcr,gci,ar,ai, 1 acr,aci,lr3,li3,vr3,vi3,gr3,gi3,gcr3,gci3,ar3,ai3,acr3,aci3, 1 scr3,sci3,sr_,si_) c make invariants and intensities, add to spectrum: if(lvel)then call wrram3(wesau(iw),ei,ef,THRC,nt,si,ni,Nexf,sf,wes(iw),wrin, 1 wrax,npx,lglg,fwhh,ltab.and.iw.eq.1.and.m.eq.mmax,inv,vr,vi, 1 gr,gi,gcr,gci,ar,ai,acr,aci,sr,bf(i),lusea,luseg,ldo,sr_,si_) else call wrram3(wesau(iw),ei,ef,THRC,nt,si,ni,Nexf,sf,wes(iw),wrin, 1 wrax,npx,lglg,fwhh,ltab.and.iw.eq.1.and.m.eq.mmax,inv,lr,li, 1 gr,gi,gcr,gci,ar,ai,acr,aci,sr,bf(i),lusea,luseg,ldo,sr_,si_) endif c write invariants and tensors: if(lwten.and.mmax.eq.m) 1 call wz1(wesau(iw),ei,ef,lr,li,gr,gi,gcr,gci, 1 ar,ai,acr,aci,vr,vi,inv,110,bf(i)) endif 87 continue close(110) c write spectra for this frequency: 881 call c33w(wrin,wrax,npx,sr,wes(iw),ldo) deallocate(sf,si) endif 77777 deallocate(sm,wmax,NQs,cred,dred) c eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee return end subroutine azc(nexc,iw,lr_,li_,vr_,vi_,gr_,gi_,gcr_,gci_,ar_,ai_, 1acr_,aci_,sr_,si_,lrw,liw,vrw,viw,grw,giw,gcrw,gciw,arw,aiw, 1acrw,aciw,srw,siw) implicit none integer*4 nexc,iw,i,j,k real*8 lrw(nexc,3,3),liw(nexc,3,3),vrw(nexc,3,3),sr_,si_, 1viw(nexc,3,3),grw(nexc,3,3),giw(nexc,3,3),srw(nexc),siw(nexc), 1arw(nexc,3,3,3),aiw(nexc,3,3,3),gcrw(nexc,3,3), 1gciw(nexc,3,3),acrw(nexc,3,3,3),aciw(nexc,3,3,3), 1lr_(3,3),li_(3,3),vr_(3,3),vi_(3,3),gr_(3,3),gi_(3,3), 1ar_(3,3,3),ai_(3,3,3),gcr_(3,3),gci_(3,3),acr_(3,3,3),aci_(3,3,3) do 1 i=1,3 do 1 j=1,3 lrw(iw, i,j )=lrw(iw, i,j )+lr_( i,j) liw(iw, i,j )=liw(iw, i,j )+li_( i,j) vrw(iw, i,j )=vrw(iw, i,j )+vr_( i,j) viw(iw, i,j )=viw(iw, i,j )+vi_( i,j) grw(iw, i,j )=grw(iw, i,j )+gr_( i,j) giw(iw, i,j )=giw(iw, i,j )+gi_( i,j) gcrw(iw,i,j )=gcrw(iw,i,j )+gcr_(i,j) gciw(iw,i,j )=gciw(iw,i,j )+gci_(i,j) do 1 k=1,3 arw(iw, i,j,k)=arw(iw, i,j,k)+ar_( i,j,k) aiw(iw, i,j,k)=aiw(iw, i,j,k)+ai_( i,j,k) acrw(iw,i,j,k)=acrw(iw,i,j,k)+acr_(i,j,k) 1 aciw(iw,i,j,k)=aciw(iw,i,j,k)+aci_(i,j,k) srw(iw)=srw(iw)+sr_ siw(iw)=siw(iw)+si_ return end subroutine czz(nexc,iw,nb0,nkt,a,b, 1lr ,li ,vr ,vi ,gr ,gi ,gcr ,gci ,ar ,ai ,acr ,aci , 1lr3,li3,vr3,vi3,gr3,gi3,gcr3,gci3,ar3,ai3,acr3,aci3, 1scr3,sci3,sr,si) implicit none integer*4 nb0,nkt,a,b,i,j,k,nexc,iw real*8 lr(3,3),li(3,3),vr(3,3),vi(3,3),gr(3,3),gi(3,3), 1ar(3,3,3),ai(3,3,3),gcr(3,3),gci(3,3),acr(3,3,3),aci(3,3,3), 1lr3(nexc,nb0,nkt,3,3),li3(nexc,nb0,nkt,3,3),vr3(nexc,nb0,nkt,3,3), 1vi3(nexc,nb0,nkt,3,3),gr3(nexc,nb0,nkt,3,3),gi3(nexc,nb0,nkt,3,3), 1ar3(nexc,nb0,nkt,3,3,3),ai3(nexc,nb0,nkt,3,3,3), 1gcr3(nexc,nb0,nkt,3,3),gci3(nexc,nb0,nkt,3,3), 1acr3(nexc,nb0,nkt,3,3,3),aci3(nexc,nb0,nkt,3,3,3), 1scr3(nexc,nb0,nkt),sci3(nexc,nb0,nkt),sr,si do 1 i=1,3 do 1 j=1,3 lr(i,j)=lr3(iw,a,b,i,j) li(i,j)=li3(iw,a,b,i,j) vr(i,j)=vr3(iw,a,b,i,j) vi(i,j)=vi3(iw,a,b,i,j) gr(i,j)=gr3(iw,a,b,i,j) gi(i,j)=gi3(iw,a,b,i,j) gcr(i,j)=gcr3(iw,a,b,i,j) gci(i,j)=gci3(iw,a,b,i,j) do 1 k=1,3 ar(i,j,k)=ar3(iw,a,b,i,j,k) ai(i,j,k)=ai3(iw,a,b,i,j,k) acr(i,j,k)=acr3(iw,a,b,i,j,k) 1 aci(i,j,k)=aci3(iw,a,b,i,j,k) sr=scr3(iw,a,b) si=sci3(iw,a,b) return end subroutine getdis(i,sm,N,m,ns) implicit none integer*4 i,ns,sm(ns),N,m,mfc,j,jj,mr,ip,is,Na,js,jt integer*4,allocatable::um(:) c ip: number of placed excitations c is: when the nex series starts c mr: rest excitations that need to be placed c js:at which center we start actually allocate(um(N)) sm=0 ip=0 is=1 Na=N js=1 99 ip=ip+1 mr=m-ip if(mr.ge.0)then do 1 j=1,Na-mr um(j)=0 do 1 jj=1,j 1 um(j)=um(j)+mfc(Na-jj,mr) sm(ip)=js jt=1 do 2 j=2,Na-mr if(i.gt.is+um(j-1)-1.and.i.le.is+um(j)-1)then is=is+um(j-1) sm(ip)=js+j-1 jt=j endif 2 continue js=js+jt Na=N-js+1 endif if(mr.ge.1)goto 99 return end function mfc(N,m) c N! c mfc = -------- c m!(N-m)! implicit none integer*4 N,m,mf,u,mfc,i mf=1 do 1 i=1,m 1 mf=mf*i u=1 do 2 i=N-m+1,N 2 u=u*i mfc=u/mf return end subroutine azw(nexc,nb0,nkt,lr_,li_,vr_,vi_,gr_,gi_,gcr_,gci_, 1ar_,ai_,acr_,aci_,lr3,li3,vr3,vi3,gr3,gi3,gcr3,gci3,ar3,ai3, 1acr3,aci3,a,b,scr3,sci3,sr_,si_) implicit none integer*4 nb0,nkt,i,j,k,a,b,nexc,iw real*8 lr3(nexc,nb0,nkt,3,3),li3(nexc,nb0,nkt,3,3), 1vr3(nexc,nb0,nkt,3,3),vi3(nexc,nb0,nkt,3,3),gr3(nexc,nb0,nkt,3,3), 1gi3(nexc,nb0,nkt,3,3),ar3(nexc,nb0,nkt,3,3,3), 1ai3(nexc,nb0,nkt,3,3,3),gcr3(nexc,nb0,nkt,3,3), 1gci3(nexc,nb0,nkt,3,3),acr3(nexc,nb0,nkt,3,3,3), 1aci3(nexc,nb0,nkt,3,3,3),lr_(nexc,3,3),li_(nexc,3,3), 1vr_(nexc,3,3),vi_(nexc,3,3),gr_(nexc,3,3),gi_(nexc,3,3), 1ar_(nexc,3,3,3),ai_(nexc,3,3,3),gcr_(nexc,3,3),gci_(nexc,3,3), 1acr_(nexc,3,3,3),aci_(nexc,3,3,3),scr3(nexc,nb0,nkt), 1sci3(nexc,nb0,nkt),sr_(nexc),si_(nexc) do 1 i=1,3 do 1 j=1,3 do 1 iw=1,nexc lr3(iw, a,b,i,j)=lr3(iw, a,b,i,j)+lr_(iw,i,j) li3(iw, a,b,i,j)=li3(iw, a,b,i,j)+li_(iw,i,j) vr3(iw, a,b,i,j)=vr3(iw, a,b,i,j)+vr_(iw,i,j) vi3(iw, a,b,i,j)=vi3(iw, a,b,i,j)+vi_(iw,i,j) gr3(iw, a,b,i,j)=gr3(iw, a,b,i,j)+gr_(iw,i,j) gi3(iw, a,b,i,j)=gi3(iw, a,b,i,j)+gi_(iw,i,j) gcr3(iw,a,b,i,j)=gcr3(iw,a,b,i,j)+gcr_(iw,i,j) gci3(iw,a,b,i,j)=gci3(iw,a,b,i,j)+gci_(iw,i,j) do 1 k=1,3 ar3(iw, a,b,i,j,k)=ar3(iw, a,b,i,j,k)+ar_(iw, i,j,k) ai3(iw, a,b,i,j,k)=ai3(iw, a,b,i,j,k)+ai_(iw, i,j,k) acr3(iw,a,b,i,j,k)=acr3(iw,a,b,i,j,k)+acr_(iw,i,j,k) 1 aci3(iw,a,b,i,j,k)=aci3(iw,a,b,i,j,k)+aci_(iw,i,j,k) do 2 iw=1,nexc scr3(iw, a,b)=scr3(iw,a,b)+sr_(iw) 2 sci3(iw, a,b)=sci3(iw,a,b)+si_(iw) return end c ============================================================ subroutine testcl(N,NQ,mmax,fac,wkl,C,D,nwp) implicit none integer*4 m,ii,j,N,NQ,i,ns,wkl(NQ,NQ),LNQ,mmax,mfc,il,is, 1nsm,nwp integer*4 ,allocatable::sm(:),wmax(:),NQs(:) real*8 D(N),C(N,N),prc,fac,pp,FCOvI0,prc_ logical InCl real*8,allocatable::cred(:,:),dred(:),FCI1(:) prc=0.0d0 nsm=0 write(6,*) write(6,601) 601 format(' Class: Combinations:',8x,'States: sum(e)<0|e>(%):') do 58 m=0,mmax il=max(1,m) allocate(sm(il),wmax(il),cred(il,il),dred(il),NQs(il)) is=0 call omp_set_num_threads(nwp) C$OMP Parallel do Default(Shared) C$OMP+ Private(ii,sm,i,j,dred,cred,wmax,ns,NQs,FCI1,prc_,InCl, C$OMP+ LNQ,pp) do 222 ii=1,mfc(NQ,m) prc_=0.0d0 call getdis(ii,sm,NQ,m,il) do 65 i=1,m dred(i)=D(sm(i)) do 65 j=1,m 65 cred(i,j)=C(sm(i),sm(j)) do 60 i=1,m c maximal excitation for oscillator i in this class: wmax(i)=wkl(sm(i),sm(i)) do 61 j=1,m 61 if(j.ne.i.and. 1wkl(sm(i),sm(j)).lt.wmax(i))wmax(i)=wkl(sm(i),sm(j)) c 0-excited correspnds to wmax=1 60 wmax(i)=wmax(i)+1 ns=1 do 68 j=1,m 68 ns=ns*wmax(j) if(ns.eq.1.and.m.gt.0)goto 222 allocate(FCI1(ns)) FCI1(1)=fac if(m.eq.0)prc_=prc_+fac**2 do 62 i=2,ns call FCA2NQ(m,i,wmax,InCl,LNQ,NQs) pp = FCOvI0(m,LNQ,i,NQs,wmax,DRed,CRed,FCI1) FCI1(i) = pp 62 if(InCl)prc_=prc_+pp**2 C$OMP Critical is=is+ns if(ns.gt.nsm)nsm=ns prc=prc+prc_ C$OMP End Critical deallocate(FCI1) 222 continue write(6,604)m,mfc(NQ,m),is,100.0d0*prc 604 format(i6,2i15,g25.4) 58 deallocate(sm,wmax,cred,dred,NQs) write(6,605)nsm 605 format(/,' Maximal e-batch dimension:',i10) return end c ============================================================ subroutine bww(l,n,m,lr,li,vr,vi,gr,gi,ar,ai,gcr,gci,acr,aci,sr, 1si) implicit none integer*4 n,m,l real*8 lr(l,n,m,3,3),li(l,n,m,3,3),vr(l,n,m,3,3),vi(l,n,m,3,3), 1gr(l,n,m,3,3),gi(l,n,m,3,3),ar(l,n,m,3,3,3),ai(l,n,m,3,3,3), 1gcr(l,n,m,3,3),gci(l,n,m,3,3),acr(l,n,m,3,3,3),aci(l,n,m,3,3,3), 1sr(l,n,m),si(l,n,m) lr=0.0d0 li=0.0d0 vr=0.0d0 vi=0.0d0 gr=0.0d0 gi=0.0d0 ar=0.0d0 ai=0.0d0 gcr=0.0d0 gci=0.0d0 acr=0.0d0 aci=0.0d0 sr=0.0d0 si=0.0d0 return end c ============================================================ subroutine mz(A,M) implicit none integer*4 i,j,M real*8 A(M,M) do 3 i=1,M do 3 j=1,M 3 A(i,j)=0.0d0 return end subroutine INV(a,ai,n,e,IERR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) dimension ai(n,n),a(n,n),e(n,2*n) C TOL=1.0d-10 10000 IERR=0 DO 1 ii=1,n DO 1 jj=1,n e(ii,jj)=a(ii,jj) 1 e(ii,jj+n)=0.0D0 do 13 ii=1,n 13 e(ii,ii+n)=1.0D0 c DO 2 ii=1,n-1 if (ABS(e(ii,ii)).LE.TOL) then DO 3 io=ii+1,n 3 if (ABS(e(io,ii)).GT.TOL) goto 11 IERR=1 write(6,*)ii write(6,*)'tol = ',tol tol=tol*0.50d0 if(tol.gt.1.0d-20)goto 10000 RETURN c 11 CONTINUE DO 4 kk=1,2*n w=e(ii,kk) e(ii,kk)=e(io,kk) 4 e(io,kk)=w ENDIF eii=e(ii,ii) DO 5 jj=ii+1,n e1=e(jj,ii)/eii DO 6 kk=ii+1, 2*n 6 e(jj,kk)=e(jj,kk)-e(ii,kk)*e1 5 e(jj,ii)=0.0D0 2 CONTINUE c DO 7 i2=n,2,-1 eii=e(i2,i2) DO 7 j2=i2-1,1,-1 e1=e(j2,i2)/eii DO 9 kk=1, n 9 e(j2,kk+n)=e(j2,kk+n)-e(i2,kk+n)*e1 7 e(j2,i2)=0.0d0 c DO 10 ii=1,n ei=1.0d0/e(ii,ii) DO 12 jj=1,n 12 ai(ii,jj)=e(ii,jj+n)*ei 10 CONTINUE c RETURN END subroutine mm(A,B,C,NQ) c matrix multiplication A = B x C implicit none integer*4 NQ,i,j,k real*8 A(NQ,NQ),B(NQ,NQ),C(NQ,NQ) do 1 i=1,NQ do 1 j=1,NQ A(i,j)=0.0d0 do 1 k=1,NQ 1 A(i,j)=A(i,j)+B(i,k)*C(k,j) return end subroutine mv(A,B,C,N,NQ) c multiplication of matrix B by vector C, A = B . C implicit none integer*4 N,i,k,NQ real*8 A(*),B(N,N),C(*) do 1 i=1,NQ A(i)=0.0d0 do 1 k=1,NQ 1 A(i)=A(i)+B(i,k)*C(k) return end function sp(A,C,N) c scalar product of two vectors implicit none integer*4 N,k real*8 A(*),C(*),sp sp=0.0d0 do 1 k=1,N 1 sp=sp+A(k)*C(k) return end subroutine ms(A,B,C,NQ) c matrix sum A = B + C implicit none integer*4 NQ,i,j real*8 A(NQ,NQ),B(NQ,NQ),C(NQ,NQ) do 1 i=1,NQ do 1 j=1,NQ 1 A(i,j)=B(i,j)+C(i,j) return end subroutine mt(AT,A,NQ) c matrix transposition AT = A^T implicit none integer*4 NQ,i,j real*8 A(NQ,NQ),AT(NQ,NQ) do 1 i=1,NQ do 1 j=1,NQ 1 AT(i,j)=A(j,i) return end subroutine rw(o,N,a,b,i) implicit none integer*4 o,N,i,ns,ne,j real*8 a(*),b(*),cmtoau character*80 s cmtoau=219474.63d0 if(i.ge.2)return i=i+1 ns=1 1 read(o,9)s 9 format(a80) if(s(2:15).eq.'Frequencies --')then ne=min(N,ns+2) if(i.eq.1)read(s(16:len(s)),*)(a(j),j=ns,ne) if(i.eq.2)read(s(16:len(s)),*)(b(j),j=ns,ne) c convert to Hartree: do 2 j=ns,ne if(i.eq.1)a(j)=a(j)/cmtoau 2 if(i.eq.2)b(j)=b(j)/cmtoau ns=min(ns+3,N) if(ne.eq.N)return endif goto 1 end subroutine rdm(io,NQ,N,M,ic,s) IMPLICIT none integer*4 NQ,N,N1,N3,io,LN,J,ic real*8 M(N,N) character*(*) s write(6,*)s(1:len(s)/2) ic=ic+1 read(io,*) N1=1 1 N3=min(N1+4,NQ) read(io,*) DO 130 LN=1,NQ 130 READ(io,*)M(LN,N1),(M(LN,J),J=N1,N3) N1=N1+5 IF(N3.LT.NQ)GOTO 1 return end subroutine rds(io,NQ,N,M,ic) IMPLICIT none integer*4 NQ,N,N1,N3,io,LN,J,ic real*8 M(N,N) ic=ic+1 read(io,*) N1=1 1 N3=min(N1+4,NQ) read(io,*) DO 130 LN=1,N 130 READ(io,*)M(LN,N1),(M(LN,J),J=N1,N3) N1=N1+5 IF(N3.LT.NQ)GOTO 1 return end subroutine rdw(io,N,e,iw) IMPLICIT none integer*4 i,io,iw,N real*8 e(*),CM read(io,*) read(io,100)(e(i),i=1,N) 100 format(6f11.2) CM=219474.63d0 do 1 i=1,N 1 e(i)=e(i)/CM iw=iw+1 return end subroutine rduschs(N,NQ,s,f,ff) IMPLICIT none character*(*) f,ff integer*4 NQ,N,ic,I,J real*8 s(N,N),SFAC character*80 s80 SFAC=0.0234280d0 open(20,file=f,status='old') ic=0 read(20,*)NQ 2 read(20,900,end=88,err=88)s80 900 format(a80) if(s80(2:16).eq.ff)then call rds(20,NQ,N,s,ic) DO 5 I=1,N DO 5 J=1,NQ 5 s(I,J)=s(I,J)*SFAC close(20) write(6,*)f write(6,*)'S read, ',NQ,' modes' return endif goto 2 88 close(20) write(6,*)f if(ic.eq.0)call report('S not found') end subroutine rdusch(NQ,N,JT,K,A,B,C,D,E,W,WP,iw,ip,f) IMPLICIT none character*(*) f integer*4 NQ,N,ip(*),iw real*8 A(N,N),B(*),C(N,N),D(*),E(N,N),JT(NQ,NQ),K(*),WP(*),W(*) character*80 s80 open(20,file=f,status='old') read(20,*)NQ write(6,*)' number of modes :',NQ write(6,*)' matrix dimension:', N 2 read(20,900,end=88,err=88)s80 900 format(a80) if(s80(2:18).eq.'Duschinsky Matrix') 1 call rdm(20,NQ,NQ,JT,ip(1),s80) if(s80(2:13).eq.'Shift Vector') call rdv(20,NQ,K ,ip(2)) if(s80(2: 9).eq.'A Matrix' ) call rdm(20,NQ,N ,A ,ip(3),s80) if(s80(2: 9).eq.'B Vector' ) call rdv(20,NQ,B , ip(4)) if(s80(2: 9).eq.'C Matrix' ) call rdm(20,NQ,N ,C ,ip(5),s80) if(s80(2: 9).eq.'D Vector' ) call rdv(20,NQ,D , ip(6)) if(s80(2: 9).eq.'E Matrix' ) call rdm(20,NQ,N ,E ,ip(7),s80) if(s80(2: 9).eq.'Ground w' ) call rdw(20,NQ,W ,iw) if(s80(2:10).eq.'Excited w') call rdw(20,NQ,WP,iw) goto 2 88 close(20) write(6,*)'DUSCH.OUT read' return end subroutine rdv(io,N,V,ic) IMPLICIT none integer*4 N,io,LN,ic real*8 V(*) ic=ic+1 read(io,*) read(io,*) DO 130 LN=1,N 130 READ(io,*)V(LN),V(LN) return end function jeje(np,nx,it,NN,ee,np0,LEXCL) implicit none integer*4 np,nx,it(*),NN(*),np0,LEXCL,ee(np0,LEXCL),je,jeje,jj,ie je=0 do 104 jj=1,np if(nx.ne.NN(jj))goto 104 do 1041 ie=1,NN(jj) 1041 if(it(ie).ne.ee(jj,ie))goto 104 je=jj goto 1042 104 continue 1042 jeje=je return end subroutine digest(np,ie,np0,LEXCL,p,NN,it,iexc,T) implicit none integer*4 je,np,np0,LEXCL,NN(*),it(*),ie(np0,LEXCL),jj,iexc, 1jeje real*8 T,p(*) c does it exist already within 1 ... np?: je=jeje(np,iexc,it,NN,ie,np0,LEXCL) if(je.ne.0)then c the term already exist in the expansion as je^th - just add it p(je)=p(je)+T else c term not found - add as new term np=np+1 if(np.gt.np0)then write(6,*)np,np0 call report('digest - too many terms') endif p(np)=T NN(np)=iexc do 1 jj=1,iexc 1 ie(np,jj)=it(jj) endif return end function FC(fac,si,Nexc,np0,iwr,C,D,N) c FC = Franc Condon factor for <0|si> c fac = <0|0*> c np0 ... dimension of working buffer implicit none integer*4 si(*),Nexc,np,iex,ii,nu,jj,ip,N,ic,jold, 1nuj,jc,kk,iwr,np0,iq,jq real*8 FC,fac,D(*),C(N,N),pini real*8,allocatable::p(:) integer*4,allocatable::NN(:),ie(:,:),it(:) np=1 allocate(p(np0),NN(np0),ie(np0,Nexc),it(np0)) p(np)=1.0d0 NN(np)=Nexc if(iwr.gt.1)write(6,604)(si(iex),iex=1,NExc) 604 format(/,'<0|e>, e = ',10i3,' requested:') do 102 iex=1,NN(np) 102 ie(np,iex)=si(iex) c expand reccurent formula into a sum and shrink back to <0|0> 777 do 101 ii=1,np c term ii - reduce excitation one by one: pini=p(ii) if(iwr.gt.1)then write(6,6071)ii,p(ii) 6071 format(' term ',i2,':',f10.6) write(6,6072)(ie(ii,iex),iex=1,NN(ii)) 6072 format(20i3) endif do 101 iex=1,NN(ii) iq=ie(ii,iex) if(iq.gt.0)then c <0| si_nu> reduce to <0| i-1>, <0|i-2>, <0|i-1,j-1>(j<>i) nu=0 do 1032 jj=1,NN(ii) 1032 if(ie(ii,jj).eq.iq)nu=nu+1 c write term <0|v'-1_iex> into string it: ip=0 ic=0 do 1031 jj=1,NN(ii) if(iq.eq.ie(ii,jj).and.ic.lt.1)then ic=ic+1 else ip=ip+1 it(ip)=ie(ii,jj) endif 1031 continue c call digest(np,ie,np0,Nexc,p,NN,it,NN(ii)-1, 1 pini*D(iq)/dsqrt(dble(2*nu))) if(iwr.gt.1)write(6,606)(it(jj),jj=1,NN(ii)-1) 606 format('digest ',10i3) if(nu.gt.1)then c write term <0|v'-2_iex> into string it: ic=0 ip=0 do 1033 jj=1,NN(ii) if(ie(ii,jj).eq.iq.and.ic.lt.2)then ic=ic+1 else ip=ip+1 it(ip)=ie(ii,jj) endif 1033 continue call digest(np,ie,np0,Nexc,p,NN,it,NN(ii)-2, 1 pini*dsqrt(dble(nu-1)/dble(nu))*C(iq,iq)) if(iwr.gt.1)write(6,606)(it(jj),jj=1,NN(ii)-2) endif jold=0 do 106 jj=1,NN(ii) jq=ie(ii,jj) if(jq.ne.iq.and.jq.ne.jold)then nuj=0 do 1034 kk=1,NN(ii) 1034 if(jq.eq.ie(ii,kk))nuj=nuj+1 c write term <0|v'-1_iex-1_j, j<>iex> into it: ic=0 jc=0 ip=0 do 1035 kk=1,NN(ii) if(ie(ii,kk).eq.iq.and.ic.lt.1)then ic=ic+1 else if(ie(ii,kk).eq.jq.and.jc.lt.1)then jc=jc+1 else ip=ip+1 it(ip)=ie(ii,kk) endif endif 1035 continue call digest(np,ie,np0,Nexc,p,NN,it,NN(ii)-2, 1 pini*dsqrt(dble(nuj)/dble(nu))*C(iq,jq)) if(iwr.gt.1)write(6,606)(it(kk),kk=1,NN(ii)-2) endif 106 jold=jq if(iwr.gt.1)then write(6,*)'np now ',np do 108 jj=1,np 108 write(6,605)jj,NN(jj),p(jj),(ie(jj,kk),kk=1,NN(jj)) endif c eliminate the old term and start over do 105 jj=ii,np-1 p(jj)=p(jj+1) NN(jj)=NN(jj+1) do 105 kk=1,NN(jj) 105 ie(jj,kk)=ie(jj+1,kk) np=np-1 if(iwr.gt.1)then write(6,*)'np after elimination ',np do 107 jj=1,np 107 write(6,605)jj,NN(jj),p(jj),(ie(jj,kk),kk=1,NN(jj)) 605 format(i3,i2,' ',g9.3,10i3) endif goto 777 endif 101 continue if(np.ne.1)call report('np <> 1') FC=p(1)*fac return end function jeje1(np,nxi,nxj,it,jt,NNi,NNj,ei,ej,np0,LI,LJ) implicit none integer*4 np,nxi,nxj,it(*),jt(*),NNi(*),NNj(*),same,LI,LJ, 1np0,ei(np0,LI),ej(np0,LJ),je,jeje1,jj,ie same=0 do 104 jj=1,np if(nxi.ne.NNi(jj))goto 104 if(nxj.ne.NNj(jj))goto 104 do 1041 ie=1,NNi(jj) 1041 if(it(ie).ne.ei(jj,ie))goto 104 do 1043 je=1,NNj(jj) 1043 if(jt(je).ne.ej(jj,je))goto 104 same=jj goto 1042 104 continue 1042 jeje1=same return end subroutine digest1(np,ie,je,np0,LI,LJ, 1p,NNi,NNj,it,jt,iexc,jexc,T) implicit none integer*4 np,LI,ie(np0,LI),LJ,je(np0,LJ),jj, 1np0,NNi(*),NNj(*),it(*),jt(*),iexc,jexc,jeje1, 1id real*8 T,p(*) c does it exist already within 1 ... np?: id=jeje1(np,iexc,jexc,it,jt,NNi,NNj,ie,je,np0,LI,LJ) if(id.ne.0)then c the term already exist in the expansion as id^th - just add it p(id)=p(id)+T else c term not found - add as new term np=np+1 if(np.gt.np0)then write(6,*)np,np0 call report('digest1-too many terms') endif p(np)=T NNi(np)=iexc NNj(np)=jexc do 1 jj=1,iexc 1 ie(np,jj)=it(jj) do 2 jj=1,jexc 2 je(np,jj)=jt(jj) endif return end subroutine wrim(iq,NN,ie,ii,it,np0,LI) implicit none integer*4 iq,np0,LI,NN(*),ie(np0,LI),ip,ic,ii,jj,it(*) ip=0 ic=0 do 1031 jj=1,NN(ii) if(iq.eq.ie(ii,jj).and.ic.lt.1)then ic=ic+1 else ip=ip+1 it(ip)=ie(ii,jj) endif 1031 continue return end function FC1(fac,si,sj,Ni,Nj,np0,iwr,A,B,C,D,E,N) c FC = Franc Condon factor for reduce to sum(k) <0|vk> c fac = <0|0*> c np0 ... dimension of working buffer implicit none integer*4 si(*),sj(*),Ni,Nj,np,iex,ii,nui,jj,ip,N,ic,jold, 1nuj,jc,kk,iwr,np0,iq,jq,jex,iexc,jexc real*8 FC1,FC,fac,A(N,N),B(*),C(N,N),D(*),E(N,N),pini,su real*8,allocatable::p(:) integer*4,allocatable::NNi(:),NNj(:),ie(:,:),it(:),jt(:),je(:,:), 1sk(:) c initialize temporary variables: allocate(p(np0),NNi(np0),NNj(np0),ie(np0,Ni),je(np0,Nj), 1it(np0),jt(np0)) if(iwr.gt.1)write(6,604)(si(iex),iex=1,Ni),(sj(jex),jex=1,Nj) 604 format(/,' requested:',/, 1' j = ',10i3,' i = ',10i3,' requested:') c first term = input : np=1 p(np)=1.0d0 NNi(np)=Ni NNj(np)=Nj do 102 iex=1,NNi(np) 102 ie(np,iex)=si(iex) do 103 jex=1,NNj(np) 103 je(np,jex)=sj(jex) c expand using reccurent formula into a sum of <0|k> 777 do 101 ii=1,np c term ii - reduce excitation one by one: pini=p(ii) if(iwr.gt.1)write(6,617)ii,p(ii),(ie(ii,iex),iex=1,NNi(ii)) if(iwr.gt.1)write(6,618) (je(ii,jex),jex=1,NNj(ii)) 617 format(' term ',i2,':',f10.6,10i3) 618 format(' ',2x,' ',10x, 10i3) do 101 iex=1,NNi(ii) iq=ie(ii,iex) if(iq.gt.0)then c <0| si_nui> reduce to , , (j<>i), nui=0 do 1032 jj=1,NNi(ii) 1032 if(ie(ii,jj).eq.iq)nui=nui+1 c write term into string jt: do 1036 jj=1,NNj(ii) 1036 jt(jj)=je(ii,jj) iexc=NNi(ii)-1 jexc=NNj(ii) c add *Bi/sqrt(2nui): call digest1(np,ie,je,np0,Ni,Nj,p,NNi,NNj,it,jt,iexc,jexc, 1 pini*B(iq)/dsqrt(dble(2*nui))) if(iwr.gt.1)write(6,606)(it(jj),jj=1,NNi(ii)-1) if(iwr.gt.1)write(6,607)(jt(jj),jj=1,NNj(ii)) 606 format('digest ',10i3) 607 format(' ',10i3) c write term into string it: if(nui.gt.1)then ic=0 ip=0 do 1033 jj=1,NNi(ii) if(ie(ii,jj).eq.iq.and.ic.lt.2)then ic=ic+1 else ip=ip+1 it(ip)=ie(ii,jj) endif 1033 continue iexc=NNi(ii)-2 c add *sqrt((nui-1)/niu)*Aii: call digest1(np,ie,je,np0,Ni,Nj,p,NNi,NNj,it,jt,iexc,jexc, 1 pini*dsqrt(dble(nui-1)/dble(nui))*A(iq,iq)) if(iwr.gt.1)write(6,606)(it(jj),jj=1,NNi(ii)-2) if(iwr.gt.1)write(6,607)(jt(jj),jj=1,NNj(ii)) endif c write terms jp<>iex> into it: jold=0 do 106 jj=1,NNi(ii) jq=ie(ii,jj) if(jq.ne.iq.and.jq.ne.jold)then nuj=0 do 1034 kk=1,NNi(ii) 1034 if(jq.eq.ie(ii,kk))nuj=nuj+1 ic=0 jc=0 ip=0 do 1035 kk=1,NNi(ii) if(ie(ii,kk).eq.iq.and.ic.lt.1)then ic=ic+1 else if(ie(ii,kk).eq.jq.and.jc.lt.1)then jc=jc+1 else ip=ip+1 it(ip)=ie(ii,kk) endif endif 1035 continue iexc=NNi(ii)-2 c add *sqrt((nuj/nui)*Aij: call digest1(np,ie,je,np0,Ni,Nj, 1 p,NNi,NNj,it,jt,iexc,jexc, 1 pini*dsqrt(dble(nuj)/dble(nui))*A(iq,jq)) if(iwr.gt.1)write(6,606)(it(kk),kk=1,NNi(ii)-2) if(iwr.gt.1)write(6,607)(jt(kk),kk=1,NNj(ii)) endif 106 jold=jq c terms : c write term into jt: call wrim(jq,NNj,je,ii,jt,np0,Nj) iexc=NNi(ii)-1 jexc=NNj(ii)-1 c add *sqrt((nuj/4nui)*Eij: call digest1(np,ie,je,np0,Ni,Nj,p,NNi,NNj,it,jt,iexc,jexc, 1 pini*dsqrt(dble(nuj)/dble(4*nui))*E(jq,iq)) if(iwr.gt.1)write(6,606)(it(kk),kk=1,iexc) if(iwr.gt.1)write(6,607)(jt(kk),kk=1,jexc) endif 109 jold=jq if(iwr.gt.1)then write(6,*)'np now ',np do 108 jj=1,np write(6,605)jj,p(jj),(ie(jj,kk),kk=1,NNi(jj)) 108 write(6,655) (je(jj,kk),kk=1,NNj(jj)) endif c eliminate the old term ii and start over do 105 jj=ii,np-1 p(jj)=p(jj+1) NNi(jj)=NNi(jj+1) NNj(jj)=NNj(jj+1) do 1051 kk=1,NNi(jj) 1051 ie(jj,kk)=ie(jj+1,kk) do 105 kk=1,NNj(jj) 105 je(jj,kk)=je(jj+1,kk) np=np-1 if(iwr.gt.1)then write(6,*)'np after elimination ',np do 107 jj=1,np write(6,605)jj,p(jj),(ie(jj,kk),kk=1,NNi(jj)) 107 write(6,655) (je(jj,kk),kk=1,NNj(jj)) 605 format(i3,' ',g9.3,10i3) 655 format(12x, 10i3) endif goto 777 endif 101 continue c sum all terms of type <0|j>: allocate(sk(Nj+1)) su=0.0d0 do 111 ii=1,np do 112 jj=1,NNj(ii) 112 sk(jj)=je(ii,jj) 111 su=su+p(ii)*FC(fac,sk,NNj(ii),np0,iwr,C,D,N) FC1=su return end subroutine r00(f,nroot,u0,m0,v0,q0) c read transition dipoles from excited state freq calc implicit none integer*4 ln,i,nroot,ic,ix,nd,i1,i2,i3,i4,i5 real*8 u0(*),m0(3),v0(3),q0(6),ev,eau character*(*) f character*80 s80 real*8,allocatable::v16(:,:) c write(6,*) write(6,*)' R00: reading '//f write(6,*) open(9,file=f,status='old') ln=0 i1=0 i2=0 i3=0 i4=0 i5=0 c where it starts: 1 read(9,900,end=88,err=88)s80 900 format(a80) ln=ln+1 if(s80(1:2).eq.' #')then ic=0 do 3 i=1,len(s80)-4 if(s80(i:i+4).eq.' freq'.or.s80(i:i+4).eq.' freq')ic=ic+1 3 if(s80(i:i+2).eq.' td' .or.s80(i:i+2).eq.' TD' )ic=ic+1 if(ic.eq.2)then write(6,*)'TD starts at line ',ln goto 4 endif endif goto 1 88 close(9) call report('TD freq not found') 4 read(9,900,end=78,err=78)s80 if(s80(2:65).eq.'Ground to excited state transition electric dipol 1e moments (Au):'.and.i1.eq.0)then write(6,900)s80 do 5 i=1,nroot 5 read(9,*) read(9,*)u0(1),(u0(ix),ix=1,3) i1=i1+1 endif if(s80(2:65).eq.'Ground to excited state transition velocity dipol 1e moments (Au):'.and.i2.eq.0)then write(6,900)s80 do 11 i=1,nroot 11 read(9,*) read(9,*)v0(1),(v0(ix),ix=1,3) i2=i2+1 endif if(s80(2:65).eq.'Ground to excited state transition magnetic dipol 1e moments (Au):'.and.i3.eq.0)then write(6,900)s80 do 14 i=1,nroot 14 read(9,*) read(9,*)m0(1),(m0(ix),ix=1,3) i3=i3+1 endif if(s80(2:69).eq.'Ground to excited state transition velocity quadr 1upole moments (Au):'.and.i4.eq.0)then write(6,900)s80 do 17 i=1,nroot 17 read(9,*) read(9,*)q0(1),q0(1),q0(4),q0(6),q0(2),q0(3),q0(5) i4=i4+1 endif if(s80(2:15).eq.'Excited State '.and.s80(16:16).ne.'s'. 1and.i5.eq.0)then do 20 i=1,79 if(s80(i:i) .eq.':') read(s80(15:i-1),*)nd 20 if(s80(i:i+1).eq.'eV')read(s80(i-10:i-2),*)ev if(nd.eq.nroot)then write(6,900)s80 eau=ev/27.211384205943d0 i5=i5+1 endif endif c analytical frequency output: c AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA if(s80(2:31).eq.'Electronic transition elements')then c read nroot moments write(6,900)s80 allocate(v16(16,nroot)) call ru(9,v16,16,nroot) do 21 ix=1,3 u0(ix )=v16(ix+ 1,nroot) v0(ix )=v16(ix+ 4,nroot) 21 m0(ix )=v16(ix+ 7,nroot) q0(1)=v16(11,nroot) q0(2)=v16(14,nroot) q0(3)=v16(15,nroot) q0(4)=v16(12,nroot) q0(5)=v16(16,nroot) q0(6)=v16(13,nroot) c our order 1 2 3 4 5 6 c our order xx xy xz yy yz zz c 1 2 3 4 5 6 c 11 12 13 14 15 16 c gaussian # xx yy zz xy xz yz deallocate(v16) write(6,*)'Analytical transitions read' endif c AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA goto 4 78 close(9) if(nd.eq.0)call report('Energy not found') v0 = -v0 / eau q0 = -q0 / eau m0 = m0 / 2.0d0 c looks like that we have this situation: c Gaussian gives <0|r|e>, , <0|-r x grad|e> c and c To transform it to what we want we can use c hbar^2 c <0|r|e> = ------- <0|grad|e> c m Ee0 c and c hbar^2 c <0|rr|e> = ------- <0|r grad + grad r|e> c m E0 c Eeo=Ee-E0 c so that (in atomic units hbar=m=1) c <0|r|e>(in velocity) = - / Ee0 c Im <0|m|e>= Im <0|-r x grad/2|e> = <0|-r x grad|e> / 2 c <0|rr|e> = - / Ee0 c return end c ============================================================== subroutine rdd(f,d,nat,nroot,u0,iwr,m0,a,v,v0,q,q0) c read transition dipole derivatives from excited state freq calc implicit none integer*4 nat,ln,ia,xa,i,nroot,xar,iar,ibr,ib,ic,ii,ix,iwr,nd, 1ntr,j,ir real*8 d(9*nat),u(6),u0(*),step,sign,stepau,m0(3),a(9*nat), 1v(9*nat),v0(3),q(18*nat),q0(6),ev,eau logical lnumerical character*(*) f character*80 s80 real*8,allocatable::v16(:,:) c write(6,*) write(6,*)' Rdd: reading '//f write(6,*) c total number of roots (exc. states) calculated: ntr=0 lnumerical=.true. open(9,file=f,status='old') ln=0 iar=0 xar=0 ibr=0 c where it starts: 1 read(9,900,end=88,err=88)s80 900 format(a80) ln=ln+1 if(s80(1:2).eq.' #')then ic=0 do 3 i=1,len(s80)-4 if(s80(i:i+4).eq.' freq'.or.s80(i:i+4).eq.' freq')ic=ic+1 if(s80(i:i+7).eq.'nstates='.or.s80(i:i+7).eq.'NStates='.or. 1 s80(i:i+7).eq.'Nstates='.or.s80(i:i+7).eq.'NSTATES=')then do 31 j=i+8,len(s80) 31 if(s80(j:j).eq.','.or.s80(j:j).eq.')')goto 32 32 read(s80(i+8:j-1),*)ntr write(6,*)ntr,' excited states calculated' endif 3 if(s80(i:i+2).eq.' td' .or.s80(i:i+2).eq.' TD' )ic=ic+1 if(ic.eq.2)then write(6,*)'TD starts at line ',ln goto 2 endif endif goto 1 88 close(98) call report('TD freq not found') 2 ia=1 xa=1 ib=0 ii=0 step=0.001d0 write(6,*)'iwr:',iwr a=0.0d0 v=0.0d0 q=0.0d0 d=0.0d0 nd=0 4 read(9,900,end=78,err=78)s80 if(s80(2:14).eq.'Nuclear step=')then write(6,*)s80(1:23) read(s80(15:23),*)step endif if(s80(2:24).eq.'Re-enter D2Numr: IAtom=')then read(s80(25:27),*)iar read(s80(34:34),*)xar read(s80(42:43),*)ibr if(ia.ne.iar)call report('ia <> iar') if(xa.ne.xar)call report('xa <> xar') if(ib.ne.ibr)call report('ib <> ibr') endif if(s80(2:65).eq.'Ground to excited state transition electric dipol 1e moments (Au):')then if(ii.eq.0)then write(6,*)'Zero point electric' do 5 i=1,nroot 5 read(9,*) read(9,*)u0(1),(u0(ix),ix=1,3) else ib=ib+1 if(ib.gt.2)then ib=1 xa=xa+1 if(xa.gt.3)then xa=1 ia=ia+1 endif endif if(iwr.gt.1)write(6,*)' d ',ia,xa,ib,iar,xar,ibr do 6 i=1,nroot 6 read(9,*) read(9,*)u(1),(u(ix),ix=1,3) if(ib.eq.1)then sign=1.0d0 else sign=-1.0d0 endif do 8 ix=1,3 8 d(ix+3*(xa-1)+9*(ia-1))=d(ix+3*(xa-1)+9*(ia-1))+sign*u(ix) endif endif if(s80(2:65).eq.'Ground to excited state transition velocity dipol 1e moments (Au):')then if(ii.eq.0)then write(6,*)'Zero point velocity' do 11 i=1,nroot 11 read(9,*) read(9,*)v0(1),(v0(ix),ix=1,3) else if(iwr.gt.1)write(6,*)' v ',ia,xa,ib,iar,xar,ibr do 12 i=1,nroot 12 read(9,*) read(9,*)u(1),(u(ix),ix=1,3) do 13 ix=1,3 13 v(ix+3*(xa-1)+9*(ia-1))=v(ix+3*(xa-1)+9*(ia-1))+sign*u(ix) endif endif if(s80(2:65).eq.'Ground to excited state transition magnetic dipol 1e moments (Au):')then if(ii.eq.0)then write(6,*)'Zero point magnetic' do 14 i=1,nroot 14 read(9,*) read(9,*)m0(1),(m0(ix),ix=1,3) else if(iwr.gt.1)write(6,*)' m ',ia,xa,ib,iar,xar,ibr do 15 i=1,nroot 15 read(9,*) read(9,*)u(1),(u(ix),ix=1,3) do 16 ix=1,3 16 a(ix+3*(xa-1)+9*(ia-1))=a(ix+3*(xa-1)+9*(ia-1))+sign*u(ix) endif endif if(s80(2:69).eq.'Ground to excited state transition velocity quadr 1upole moments (Au):')then if(ii.eq.0)then write(6,*)'Zero point quadrupole' do 17 i=1,nroot 17 read(9,*) c our order 1 2 3 4 5 6 c our order xx xy xz yy yz zz c gaussian # xx yy zz xy xz yz read(9,*)q0(1),q0(1),q0(4),q0(6),q0(2),q0(3),q0(5) else if(iwr.gt.1)write(6,*)' m ',ia,xa,ib,iar,xar,ibr do 18 i=1,nroot 18 read(9,*) read(9,*)u(1),u(1),u(4),u(6),u(2),u(3),u(5) do 19 ix=1,3 19 q(ix+6*(xa-1)+18*(ia-1))=q(ix+6*(xa-1)+18*(ia-1))+sign*q(ix) endif endif if(s80(2:15).eq.'Excited State '.and.s80(16:16).ne.'s')then if(ii.eq.0)then do 20 i=1,79 if(s80(i:i) .eq.':') read(s80(15:i-1),*)nd 20 if(s80(i:i+1).eq.'eV')read(s80(i-10:i-2),*)ev if(nd.eq.nroot)then eau=ev/27.211384205943d0 if(ia.eq.nat.and.ix.eq.3.and.ib.eq.2)goto 78 ii=ii+1 write(6,*)'energy read, go to the next point' endif endif endif c analytical frequency output: c AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA if(s80(2:31).eq.'Electronic transition elements')then c read nroot moments allocate(v16(16,nroot)) call ru(9,v16,16,nroot) do 21 ix=1,3 u0(ix)=v16(ix+ 1,nroot) v0(ix)=v16(ix+ 4,nroot) 21 m0(ix)=v16(ix+ 7,nroot) q0(1 )=v16(11,nroot) q0(2 )=v16(14,nroot) q0(3 )=v16(15,nroot) q0(4 )=v16(12,nroot) q0(5 )=v16(16,nroot) q0(6 )=v16(13,nroot) deallocate(v16) write(6,*)'Analytical transitions read' endif if(s80(2:34).eq.'Electronic Transition Derivatives')then allocate(v16(16,3 + 3*nat)) call ru(9,v16,16,3 + 3*nat) do 22 ia=1,nat do 22 xa=1,3 ii=xa+3*(ia-1) do 221 ix=1,3 d(ix +3*(ii-1))=v16(ix+ 1,3+ii) v(ix +3*(ii-1))=v16(ix+ 4,3+ii) 221 a(ix +3*(ii-1))=v16(ix+ 7,3+ii) q(1+6*(ii-1))=v16(11,3+ii) q(2+6*(ii-1))=v16(14,3+ii) q(3+6*(ii-1))=v16(15,3+ii) q(4+6*(ii-1))=v16(12,3+ii) q(5+6*(ii-1))=v16(16,3+ii) 22 q(6+6*(ii-1))=v16(13,3+ii) deallocate(v16) write(6,*)'Analytical transition derivatives read' lnumerical=.false. endif c AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA c checkpoint style c CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC if(s80(1:18).eq.'ETran state values')then if(ntr.eq.0)call report('nstates not found') allocate(v16(1,16*ntr+48+16*3*nat)) read(9,*)v16 ii=0 do 237 ir=1,ntr ii=ii+1 do 231 ix=1,3 ii=ii+1 231 if(ir.eq.nroot)u0(ix)=v16(1,ii) do 232 ix=1,3 ii=ii+1 232 if(ir.eq.nroot)v0(ix)=v16(1,ii) do 233 ix=1,3 ii=ii+1 233 if(ir.eq.nroot)m0(ix)=v16(1,ii) ii=ii+1 if(ir.eq.nroot)q0(1 )=v16(1,ii) ii=ii+1 if(ir.eq.nroot)q0(4 )=v16(1,ii) ii=ii+1 if(ir.eq.nroot)q0(6 )=v16(1,ii) ii=ii+1 if(ir.eq.nroot)q0(2 )=v16(1,ii) ii=ii+1 if(ir.eq.nroot)q0(3 )=v16(1,ii) ii=ii+1 237 if(ir.eq.nroot)q0(5 )=v16(1,ii) ii=ii+48 do 238 j=1,3*nat ii=ii+1 do 234 ix=1,3 ii=ii+1 234 d(ix+3*(j-1))=v16(1,ii) do 235 ix=1,3 ii=ii+1 235 v(ix+3*(j-1))=v16(1,ii) do 236 ix=1,3 ii=ii+1 236 a(ix+3*(j-1))=v16(1,ii) ii=ii+1 q(1+6*(j-1))=v16(1,ii) ii=ii+1 q(4+6*(j-1))=v16(1,ii) ii=ii+1 q(6+6*(j-1))=v16(1,ii) ii=ii+1 q(2+6*(j-1))=v16(1,ii) ii=ii+1 q(3+6*(j-1))=v16(1,ii) ii=ii+1 238 q(5+6*(j-1))=v16(1,ii) deallocate(v16) write(6,*)'Analytical transition derivatives read from chk' lnumerical=.false. endif c CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC goto 4 78 close(9) if(nd.eq.0)call report('Energy not found') if(lnumerical)then stepau=2.0d0*step/0.529177d0 do 9 ix=1,9*nat d(ix )=d(ix )/stepau v(ix )=v(ix )/stepau a(ix )=a(ix )/stepau q( ix)=q( ix)/stepau 9 q(9*nat+ix)=q(9*nat+ix)/stepau endif v = -v/eau q = -q/eau a = a/2.0d0 v0 = -v0/eau q0 = -q0/eau m0 = m0/2.0d0 c dipole derivatives from gaussian: open(40,file='DEG.TEN') write(40,*)'atom coord dipx dipy dipz' do 10 ia=1,nat do 10 xa=1,3 10 write(40,400)ia,xa,(d(ix+3*(xa-1)+9*(ia-1)),ix=1,3) write(40,*)'equilibrium transition electric dipole:' write(40,400)0,0,(u0(ix),ix=1,3) write(40,*)'atom coordmdipx mdipy mdipz' do 101 ia=1,nat do 101 xa=1,3 101 write(40,400)ia,xa,(a(ix+3*(xa-1)+9*(ia-1)),ix=1,3) write(40,*)'equilibrium transition magnetic dipole:' write(40,400)0,0,(m0(ix),ix=1,3) write(40,*)'atom coord Qv xx xy xz yy yz zz:' do 102 ia=1,nat do 102 xa=1,3 102 write(40,400)ia,xa,(q(ix+6*(xa-1)+18*(ia-1)),ix=1,6) write(40,*)'equilibrium transition quadrupole velocity:' write(40,400)0,0,(q0(ix),ix=1,6) write(40,*)'atom coord grad x y z:' do 103 ia=1,nat do 103 xa=1,3 103 write(40,400)ia,xa,(v(ix+3*(xa-1)+9*(ia-1)),ix=1,3) write(40,*)'equilibrium transition velocity:' write(40,400)0,0,(v0(ix),ix=1,3) 400 format(i5,i2,6g12.4) close(40) write(6,*)'DEG.TEN written' return end c ============================================================== subroutine rd(n,v,m,u) implicit none integer*4 n,ia,xa,ix,m,ii real*8 v(*),u(*) read(40,*) do 1 ia=1,n do 1 xa=1,3 ii=m*(xa-1)+3*m*(ia-1) 1 read(40,*)(v(ix+ii),ix=1,2),(v(ix+ii),ix=1,m) read(40,*) read(40,*)(u(ix),ix=1,2),(u(ix),ix=1,m) return end c ============================================================== subroutine rde(nat,d,u0,a,m0,v,v0,q,q0) c read transition dipole derivatives from file implicit none real*8 d(*),u0(*),a(*),m0(*),v(*),v0(*),q(*),q0(*) integer*4 nat open(40,file='DE.TEN') call rd(nat,d,3,u0) call rd(nat,v,3,v0) call rd(nat,a,3,m0) call rd(nat,q,6,q0) close(40) return end c ============================================================== subroutine READS(N3,S,E,NQ,lwzero,wzero) IMPLICIT none integer*4 N3,NQ,N,nat3,nat,i,J,ix,iz,ii,JR real*8 S(N3,N3),E(*),CM,SFAC,wzero logical lwzero CM=219474.63d0 SFAC=0.0234280d0 C 1 a.u.= 2.1947E5 cm^-1 open(4,file='F.INP',status='old') read(4,*)NQ,nat3,nat N=NAT3 do 1 i=1,NAT 1 read(4,*) read(4,*) DO 2 I=1,NAT ii=3*(I-1) DO 2 J=1,NQ JR=NQ-J+1 2 read(4,*)(s(ii+ix,JR),ix=1,2),(s(ii+ix,JR),ix=1,3) read(4,*) READ(4,4000)(E(NQ-I+1),I=1,NQ) 4000 FORMAT(6F11.6) close(4) c write(6,*)NQ,' modes found' iz=0 if(lwzero)then c make zero modes (translation and rotation) true modes c with wzero frequency: do 9 i=1,NQ iz=iz+1 9 if(E(i).lt.0.1d0)E(i)=wzero if(iz.gt.0)write(6,*)iz,' zero modes: replaced with wzero' else c delete zero if exist: 66 do 6 i=1,NQ if(dabs(E(i)).lt.0.1d0)then do 7 j=i,NQ-1 E(j)=E(j+1) do 7 ix=1,nat3 7 s(ix,j)=s(ix,j+1) do 8 ix=1,nat3 8 s(ix,NQ)=0.0d0 E(NQ)=0.0d0 iz=iz+1 NQ=NQ-1 goto 66 endif 6 continue if(iz.gt.0)write(6,*)iz,' zero modes: deleted' endif write(6,*)NQ,' vibrational modes considered' c transform to atomic units: DO 3 I=1,NQ 3 E(I)=E(I)/CM DO 5 I=1,N DO 5 J=1,N 5 S(I,J)=S(I,J)*SFAC c now SMS=1 if masses are in au write(6,*)NQ,' modes considered now' RETURN end c ============================================================== subroutine trafN(N,dd,ddi,nat,NQ,s) implicit none integer*4 N,nat,NQ,ix,iq,ia,xa,iqi,ii real*8 dd(*),ddi(*),s(3*nat,3*nat) do 1 ix=1,N do 1 iq=1,NQ iqi=ix+N*(iq-1) ddi(iqi)=0.0d0 do 2 ia=1,nat do 2 xa=1,3 ii=xa+3*(ia-1) c s-opposite order of normal modes: 2 ddi(iqi)=ddi(iqi)+dd(ix+N*(ii-1))*s(ii,iq) 1 continue return end c ============================================================== subroutine zm(M,N) implicit none integer*4 N,i,j real*8 M(N,N) do 1 i=1,N do 1 j=1,N 1 M(i,j)=0.0d0 return end c ============================================================== subroutine zv(J,N) implicit none real*8 J(*) integer*4 N,i do 1 i=1,N 1 J(i)=0.0d0 return end c ============================================================== subroutine wrgnj(i,g,d) implicit none integer*4 i,ix,iy real*8 g(*),d(*) open(43,file='GNJ.TEN') write(43,431)i 431 format(i5,' transition, Gnj tensor:') do 1 ix=1,3 1 write(43,4343)(g(ix+3*(iy-1)),iy=1,3) c ix index - electric 4343 format(6G14.6) write(43,*) write(43,432)i 432 format(i5,' transition electric dipole via length:') write(43,4343)(d(ix),ix=1,3) write(43,435)i 435 format(i5,' transition electric dipole via gradient:') write(43,4343)(d(ix),ix=4,6) write(43,433)i 433 format(i5,' transition magnetic dipole:') write(43,4343)(d(ix),ix=7,9) write(43,434)i 434 format(i5,' transition electric quadrupole xx xy xz yy yz zz:') write(43,4343)(d(ix),ix=13,18) close(43) return end c ============================================================== subroutine rdgnj(g,d,m,q,v) implicit none integer*4 ix,iy real*8 g(*),d(*),m(*),q(*),v(*) logical lex inquire(file='GNJR.TEN',exist=lex) if(lex)then open(43,file='GNJR.TEN') read(43,*) do 1 ix=1,3 1 read(43,*)(g(ix+3*(iy-1)),iy=1,3) read(43,*) read(43,*)(d(ix),ix=1,3) read(43,*) read(43,*)(m(ix),ix=1,3) read(43,*) read(43,*)(q(ix),ix=1,6) read(43,*) read(43,*)(v(ix),ix=1,3) close(43) write(6,*)' Gnj0 d0 m0 read from GNJR.TEN' else call report(' GNJR.TEN not foud') endif return end c ============================================================== subroutine wrgn(gnji,NQ,nroot) implicit none integer*4 NQ,i,ix,iy,nroot real*8 gnji(*) open(9,file='GNJDI.TEN') write(9,900)nroot 900 format(i3,' transition, derivatives of MCD tensor') do 1 i=1,NQ write(9,901)i 901 format(i5,' mode') do 1 ix=1,3 1 write(9,902)(gnji(ix+3*(iy-1)+9*(i-1)),iy=1,3) 902 format(3F12.6) close(9) end c ============================================================== subroutine wrda(ddi,aai,qqi,vvi,NQ,nroot) implicit none integer*4 NQ,i,ix,nroot real*8 ddi(*),aai(*),qqi(*),vvi(*) open(9,file='DEI.TEN') write(9,900)nroot 900 format(i3,' transition, derivatives of electric dipole',/, 1' mode ux uy uz') do 1 i=1,NQ 1 write(9,901)i,(ddi(ix+3*(i-1)),ix=1,3) 901 format(i5,6e12.4) write(9,902)nroot 902 format(i3,' transition, derivatives of magnetic dipole',/, 1' mode mx my mz') do 2 i=1,NQ 2 write(9,901)i,(aai(ix+3*(i-1)),ix=1,3) write(9,903)nroot 903 format(i3,' transition, derivatives of quadrupole',/, 1' mode xx xy xz yy yz zz') do 3 i=1,NQ 3 write(9,901)i,(qqi(ix+6*(i-1)),ix=1,6) write(9,904)nroot 904 format(i3,' transition, derivatives of velocity dipole',/, 1' mode vx vy vz') do 4 i=1,NQ 4 write(9,901)i,(vvi(ix+3*(i-1)),ix=1,3) close(9) end c ============================================================== subroutine wrram2(ei,ef,THRC,nt,si,ni,nf,sf,EXCNM, 1wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1lr,li,vr,vi,gr,gi,ar,ai) c EXCNM ... excitation frequency in nm implicit none integer*4 i,sf(*),ni,nf,si(*),j,nt,npx real*8 ef,ei,fwhh,reram(*),reroa(*),THRC,CM,AMU,BOHR,ECM,EXCNM, 1wrax,wrin,SAL0,SAL0v,SAL1,SAL1v,SAG0,SAG0v,SAG1,SAG1v,SA1, 1S180,D180,S90X,S90Z,D90Z,YDY,YDX,P1,down,doc, 1ro,SpA32,gpisvejc,betaa,betag,betagv,D,DX,DZ,D90X,beta2, 1EXCA,roa3,roa2,ram2,CID2,roa1,roa1v,ram1,CID1, 1lr(3,3),li(3,3),gr(3,3),ar(3,3,3), 1vr(3,3),vi(3,3),gi(3,3),ai(3,3,3) logical ltab,lglg CM=219474.63d0 AMU=1822.0d0 BOHR=0.529177d0 EXCA=EXCNM*10.0d0 ECM=(ef-ei)*CM gpisvejc=(AMU*BOHR**5)*1.0d4*2.0d0*4.0d0*atan(1.0d0)/EXCA SAL0 =0.0d0 SAL0v=0.0d0 SAL1 =0.0d0 SAL1v=0.0d0 SAG0 =0.0d0 SAG0v=0.0d0 SAG1 =0.0d0 SAG1v=0.0d0 SA1=0.0d0 c work with G/W: DO 6 I=1,3 DO 6 J=1,3 c <0|u|e> c Re(aG*)=Re(a)Re(G)+Im(a)Im(G), etc SAL0 =SAL0 +lr(I,I)*lr(J,J)+li(I,I)*li(J,J) SAL0v=SAL0v+vr(I,I)*vr(J,J)+vi(I,I)*vi(J,J) SAL1 =SAL1 +lr(I,J)*lr(I,J)+li(I,J)*li(I,J) SAL1v=SAL1v+vr(I,J)*vr(I,J)+vi(I,J)*vi(I,J) SAG0 =SAG0 +lr(I,I)*gr(J,J)+li(I,I)*gi(J,J) SAG0v=SAG0v+vr(I,I)*gr(J,J)+vi(I,I)*gi(J,J) SAG1 =SAG1 +lr(I,J)*gr(I,J)+li(I,J)*gi(I,J) 6 SAG1v=SAG1v+vr(I,J)*gr(I,J)+vi(I,J)*gi(I,J) DO 7 J=1,3 7 SA1=(lr(1,J)*(ar(2,3,J)-ar(3,2,J)) 1 +lr(2,J)*(ar(3,1,J)-ar(1,3,J)) 1 +lr(3,J)*(ar(1,2,J)-ar(2,1,J)) 1 +li(1,J)*(ai(2,3,J)-ai(3,2,J)) 1 +li(2,J)*(ai(3,1,J)-ai(1,3,J)) 1 +li(3,J)*(ai(1,2,J)-ai(2,1,J)))/3.0d0 c IL+/-IR, backscattering S180=7.0d0*SAL1+SAL0 D180=8.0d0*(3.0d0*SAG1-SAG0+SA1) D=D180 IF(S180.gt.1.0d-9)D=D/S180 c IL+/-IR, 90o, x S90X=7.0d0*SAL1+SAL0 D90X=2.0d0*(7.0d0*SAG1+SAG0+SA1) DX=D90X IF(S90X.gt.1.0d-9)DX=DX/S90X c c IL+/-IR, 90o, z S90Z=2.0d0*(3.0d0*SAL1-SAL0) D90Z=4.0d0*(3.0d0*SAG1-SAG0-SA1) DZ=D90Z IF(S90Z.gt.1.0d-9)DZ=DZ/S90Z c c polarized backscattering components (YDY+YDX=S180): YDY=3.0d0*SAL1-SAL0 YDX=4.0d0*SAL1+2.0d0*SAL0 if(YDX.gt.1.0d-9)then P1=YDY/YDX else P1=0.0d0 endif c calculate degree of circularity down= 1.0d0*SAL0+ 7.0d0*SAL1 doc=5.0d0*( 1.0d0*SAL0- 1.0d0*SAL1) if(down.ne.0.0d0)doc=doc/down c calculate depolarization down= 6.0d0*SAL0-12.0d0*SAL1 ro =-3.0d0*SAL0+ 9.0d0*SAL1 if(down.ne.0.0d0)ro=ro/down c SpA32 =SAL0 /9.0d0*(AMU*BOHR**4) beta2=0.5d0*(3*SAL1-SAL0)*(AMU*BOHR**4) YDY=6.0d0*YDY*(AMU*BOHR**4) YDX=6.0d0*YDX*(AMU*BOHR**4) c c alphag=SAG0/9.0d0*gpisvejc c c beta(A)^2=Delta2 in Gaussian: betaa=SA1*3.0d0/2.0d0*gpisvejc betag =(3.0d0*SAG1 -SAG0 )/2.0d0*gpisvejc betagv=(3.0d0*SAG1v-SAG0v)/2.0d0*gpisvejc c c DCP 180 c ram3=24.0d0*beta2 roa3=8.0d0*(12.0d0*betag+4.0d0*betaa) c c unknown: S90X=S90X*(AMU*BOHR**4) D90X=D90x*gpisvejc DX=D90X IF(S90X.gt.1.0d-9)DX=DX/S90X c c ICP(90)=90Z roa2=8.0d0*(3.0d0*betag-betaa) ram2=12.0d0*beta2 CID2=0.0d0 if(ram2.gt.1.0d-9)CID2=roa2/ram2 c c ICP(180): c 8/c*(12*beta(G')^2 + 4*beta(A)^2): YDX=YDX YDY=YDY ram1 = 4.0d0*(45.0d0*SpA32+7.0d0*beta2) if(ram1.gt.THRC)then roa1 =96.0d0*(betag +betaa/3.0d0) roa1v=96.0d0*(betagv +betaa/3.0d0) roa3=roa3 CID1=0.0d0 doc=(3*P1-1)/(P1+1) CID1=roa1/ram1 nt=nt+1 call app(ECM,ram1,roa1,reram,reroa,wrin,wrax,npx,fwhh,lglg,1) if(ltab)then WRITE(44,3000)nt,ECM,YDX,YDY,ram1,CID2,DX,CID1,P1,roa1,doc, 1 roa3,roa1v 3000 FORMAT(I7,f9.2,3g12.4,3g11.3,f6.3,g12.4,f7.3,2g12.4,$) call wrs(44,si,ni) call wrs(44,sf,nf) write(44,*) endif endif return end subroutine wrs(p,s,n) implicit none integer*4 p,s(*),n,i if(n.eq.0)then write(p,1) 1 format(' |0>',$) else write(p,2) 2 format(' |',$) do 3 i=1,n if(i.gt.1)write(p,444) 444 format(1h ,$) if(s(i).lt.10)then write(p,411)s(i) 411 format(i1,$) else if(s(i).lt.100)then write(p,412)s(i) 412 format(i2,$) else if(s(i).lt.1000)then write(p,413)s(i) 413 format(i3,$) else write(p,414)s(i) 414 format(i4,$) endif endif endif 3 continue write(p,5) 5 format('>',$) endif return end c ============================================================ subroutine downexcf(si,ni,seb,neb,lf,utb,IQBUF,u0,m0,q0,v0, 1fac,np0,iwr,A,B,C,D,E,N,LQ1,NQ,G,GP,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1qt,ldis,vrroa,troa,ltens,gtens,atens,enr,anroa, 1NQBUF,NEXC0,eb,frroa,sr,lwten,nproc,lvel,ldo) c compute all down transitions from se(ne,e) c transition moments 0 -> ev: ut,mt,qt,mt c faster version with a buffer of transitions c IQBUF ... number of buffer elements c NQBUF ... dimension implicit none integer*4 ne,lf,ix,NExf,np0,iwr,N,NQ,kk,neb(*),ib,jx, 1ic,NQ1,si(*),ni,nt,I,icen,iex,II,npx,jj,NF, 1IQBUF,NQBUF,NEXC0,seb(NQBUF,NEXC0),ns0,nproc parameter (ns0=19) real*8 uf(3),mf(3),qf(6),vf(3),EXCNM,ei,ef,u(3,3), 1FC1,fac,A(N,N),B(*),C(N,N),D(*),E(N,N),pp,qk,GP(N,N), 1G(N,N),gammaau,THRC,u0(*),m0(*),q0(*),v0(*),qke, 1ddi(*),aai(*),vvi(*),qqi(*),CM,wrax,wrin,fwhh, 1reram(*),reroa(*),qt(*),ed(3),vd(3),md(3),qd(6), 1troa,ltens(*),gtens(*),atens(*),enr(*),w,utb(NQBUF,15),eb(*), 1lra(9),gra(9),ara(18),ejs,sr(npx,2,ns0), 1ee,wei,r,uie,uif logical LQ1,ltab,lglg,ldis,anroa,vrroa,frroa,lwten,lvel,ldo(ns0) integer,allocatable::sf(:),st(:),sfb(:,:),se(:),Nexfb(:) real*8,allocatable::efb(:) allocate(sfb(NQBUF,NEXC0),efb(NQBUF),Nexfb(NQBUF)) write(6,6700)IQBUF,anroa,LDIS,vrroa,lf,frroa,lwten 6700 format(/,' Downexcf',/, 1 ' IQBUF = ',i7,' anroa = ',l7,/, 1 ' LDIS = ',l7,' vrroa = ',l7,/, 1 ' lf = ',i7,' frroa = ',l7,/, 1 ' lwten = ',l7) CM=219474.63d0 c excitation frequency in atomic units: w=(1.0d7/EXCNM)/CM c initial state ei=0.0d0 do 21 i=1,ni 21 ei=ei+G(si(i),si(i)) c immediate states: allocate(se(NEXC0),st(NEXC0+2)) call viz(st,NEXC0+2) c sf ... final state allocate(sf(lf+1)) do 122 ix=1,3 ed(ix )=u0(ix ) vd(ix )=v0(ix ) md(ix )=m0(ix ) qd(ix )=q0(ix ) 122 qd(ix+3)=q0(ix+3) if(ldis)then c if expansion around qt precalculated ed etc, c u(q')=u(qt)+du/dq' (q'-qt) c pre-calculate u - du/dQ Qt do 121 kk=1,NQ do 121 ix=1,3 ed(ix )=ed(ix )-ddi(ix +3*(kk-1))*qt(kk) vd(ix )=vd(ix )-aai(ix +3*(kk-1))*qt(kk) md(ix )=md(ix )-vvi(ix +3*(kk-1))*qt(kk) qd(ix )=qd(ix )-qqi(ix +6*(kk-1))*qt(kk) 121 qd(ix+3)=qd(ix+3)-qqi(ix+3+6*(kk-1))*qt(kk) endif c record <0 ... 1> polarizabilities into FILE.Q.res.TTT open(22,file='FILE.Q.res.TTT') write(22,2001)NQ 2001 FORMAT(' ROA tensors, normal modes derivatives',/,I4,' modes',/, 1' The electric-dipolar electric-dipolar polarizability:',/, 2 ' mode e(cm-1) jx jy jz') if(NQ1.eq.0)NQ1=lf NF=0 c make NF |f> states, collect in buffer: c sf <> |0>: do 30000 Nexf=1,lf c distribute excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexf 41 sf(iex)=1 50000 do 11000 I=1,Nexf icen=1 do 11000 II=I+1,Nexf if(sf(II).eq.sf(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c state energy: ef=ejs(sf,Nexf,G,N) write(6,*)'final state',(sf(II),II=1,Nexf) c skip if outside required range: if((ef-ei)*CM.gt.wrax)goto 12000 NF=NF+1 efb(NF)=ef Nexfb(NF)=Nexf do 123 ii=1,Nexf 123 sfb(NF,ii)=sf(ii) c zero-out transition polarizabilities : c 1 c al_ab = - sum ----------------- + ---------------- c h wmi-w+iG wmi+w+iG c c 1 c G_ab = - sum ----------------- + ---------------- c h wmi-w+iG wmi+w+iG c c 1 c Gc_ab = - sum ----------------- + ---------------- c h wmi-w+iG wmi+w+iG c c 1 c A_ab = - sum ----------------- + ----------------- c h wmi-w+iG wmi+w+iG c c 1 c Ac_ab = - sum ----------------- + ---------------- c h wmi-w+iG wmi+w+iG c l,v,g,a ... simplified tensors if(NF.eq.NQBUF) 1call empty(N,NQ,np0,iwr,NF,NQBUF,NEXC0,Nexfb,efb,sfb, 1ib,IQBUF,eb,neb,utb,fac,A,B,C,D,E,ed,vd,md,qd,LQ1,ddi,vvi,aai, 1qqi,frroa,anroa,vrroa,w,gammaau,ltens,gtens,atens,enr,troa,ei, 1THRC,EXCNM,nt,si,ni,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab,sr, 1lwten,GP,lf,nproc,seb,lvel,ldo) c find index to be changed 12000 do 80000 ic=Nexf,1,-1 80000 if(sf(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexf 10000 sf(i)=sf(ic)+1 sf(ic)=sf(ic)+1 c goto 50000 30000 continue close(22) if(NF.gt.0) 1call empty(N,NQ,np0,iwr,NF,NQBUF,NEXC0,NExfb,efb,sfb, 1ib,IQBUF,eb,neb,utb,fac,A,B,C,D,E,ed,vd,md,qd,LQ1,ddi,vvi,aai, 1qqi,frroa,anroa,vrroa,w,gammaau,ltens,gtens,atens,enr,troa,ei, 1THRC,EXCNM,nt,si,ni,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab,sr, 1lwten,GP,lf,nproc,seb,lvel,ldo) c zero-out Rayleigh polarizabilities call vz(lra,9) call vz(gra,9) call vz(ara,18) c calculate polarizabilities from a buffer of excited states |e>: do 343 ib=1,IQBUF ee=eb(ib) ne=neb(ib) do 351 i=1,ne 351 se(i)=seb(ib,i) wei=ee-ei r =(wei**2-w**2) / ((wei**2-w**2)**2 + (w*gammaau)**2) c =: pp=FC1(fac,sf,se,0,ne,np0,iwr,A,B,C,D,E,N) c =u0+du/dQk c (if ldis =(u0-du/dQ Qt)+du/dQk do 141 ix=1,3 uf(ix )=ed(ix)*pp vf(ix )=vd(ix)*pp mf(ix )=md(ix)*pp qf(ix )=qd(ix)*pp 141 qf(ix+3)=qd(ix+3)*pp c : if(LQ1)then do 151 kk=1,NQ qk=qke(sf,se,0,ne,kk,fac,st,iwr,A,B,C,D,E,N,np0,GP) do 151 ix=1,3 uf(ix )=uf(ix )+ddi(ix+ 3*(kk-1))*qk vf(ix )=vf(ix )+vvi(ix+ 3*(kk-1))*qk mf(ix )=mf(ix )+aai(ix+ 3*(kk-1))*qk qf(ix )=qf(ix )+qqi(ix+ 6*(kk-1))*qk 151 qf(ix+3)=qf(ix+3)+qqi(ix+3+6*(kk-1))*qk endif c transcript quadrupole to traceless one: call tqq(qf,u) c get back non-redundant components in order XX XY YY XZ YZ ZZ: call qbq(qf,u) do 343 ix=1,3 uie=2.0d0*wei*utb(ib,ix) uif=2.0d0* utb(ib,ix) do 343 jx=1,3 jj=ix+3*(jx-1) lra(jj) =lra(jj) + r*uie*uf(jx) gra(jj) =gra(jj) + r*uif*mf(jx) ara(jj) =ara(jj) + r*uie*qf(jx) 343 ara(jj+9)=ara(jj+9)+ r*uie*qf(jx+3) call writepol(lra,'POL.res',EXCNM,gammaau) call writepol(gra,'GP.res',EXCNM,gammaau) call writepol(ara,'A.res',EXCNM,gammaau) return end c ============================================================ subroutine imcdv(fn,iwr,LDD,nroot,nat,A,B,C,D,E,G,GP, 1N,fac,e00,gnji,lgnj,LDE,g0,NQ,ddi,aai,vvi,qqi, 1u0,m0,q0,v0,lwzero,wzero,lvert,ldusch,lqi) implicit none character*(*) fn character*80 s80 integer*4 iwr,nroot,ip(10),ix,iy,iz,ia,iw,N,nat,IERR,NQ,i0 logical LDD,lgnj,LDE,lqi c Full dimension (3 * nat): real*8 A(N,N),B(N),C(N,N),D(N),E(N,N),G(N,N),GP(N,N) real*8,allocatable::s(:,:),ene(:) real*8 u0(*),e00,ddi(*),fac,proc,gnji(*),g0(*),m0(*), 1aai(*),q0(6),vvi(*),qqi(*),v0(*),wzero,z1,z2 real*8,allocatable::J(:,:),JT(:,:),K(:), 1F(:,:),FI(:,:),W(:),WP(:),dd(:),T(:,:),TP(:,:), 1EE(:,:),gnjx(:),GT(:,:),GPT(:,:),aa(:), 1vv(:),qq(:) logical lwzero,lvert,ldusch write(6,6009)N,nat,ldusch,LDD,lDE 6009 format(/, 1 ' Imcdv',/, 1 ' ^^^^^',/,/, 1 ' Initialization of FC integrals',/,/, 1 ' N :',i4,' Nat :',i4,/, 1 ' ldusch :',l4,' LDD :',l4,' LDE : ',l4,/ ) NQ=0 c c N-dimensions: allocate(s(N,N),ene(N)) c read excited state s-matrix: if(ldusch)then if(lqi)then call rduschs(N,NQ,s,'DUSCH.OUT','Ground S-Matrix') else call rduschs(N,NQ,s,'DUSCH.OUT','Excited S-Matri') endif else call READS(N,s,ene,NQ,lwzero,wzero) endif allocate(W(N),WP(N)) call zv(W,N) call zv(WP,N) call zm(A,N) call zv(B,N) call zm(C,N) call zv(D,N) call zm(E,N) c normal mode dimensions: allocate(JT(NQ,NQ),K(NQ),J(NQ,NQ), 1FI(NQ,NQ),F(NQ,NQ),EE(NQ,2*NQ),GT(NQ,NQ),GPT(NQ,NQ), 1T(NQ,NQ),TP(NQ,NQ)) call zm(J ,NQ) call zm(JT,NQ) call zv(K ,NQ) if(dabs(e00).lt.1.0d-3)then i0=0 else i0=2 endif z1=0.0d0 z2=0.0d0 do 3 ix=1,10 3 ip(ix)=0 iw=0 open(9,file=fn,status='old') 2 read(9,900,end=88,err=88)s80 900 format(a80) c explore alternatives of the Gaussian output: if(s80(4:20).eq.'Duschinsky Matrix')call rdm(9,NQ,NQ,JT,ip(1),s80) if(s80(2:18).eq.'Duschinsky matrix')then read(9,*) read(9,900,end=88,err=88)s80 if(s80(2:5).ne.'Note')read(9,*) call rdm(9,NQ,NQ,JT,ip(1),s80) endif if(s80(2:24).eq.'Final Duschinsky matrix')then read(9,*) read(9,*) read(9,*) call rdm(9,NQ,NQ,JT,ip(1),s80) endif if(s80(4:15).eq.'Shift Vector')call rdv(9,NQ, K,ip(2)) if(s80(2:13).eq.'Shift Vector')call rdv(9,NQ, K,ip(2)) if(s80(4:11).eq.'A Matrix') call rdm(9,NQ,N, A,ip(3),s80) if(s80(2:9).eq.'A Matrix' ) call rdm(9,NQ,N, A,ip(3),s80) if(s80(4:11).eq.'B Vector') call rdv(9,NQ, B,ip(4)) if(s80(2:9).eq.'B Vector' ) call rdv(9,NQ, B,ip(4)) if(s80(4:11).eq.'C Matrix') call rdm(9,NQ,N, C,ip(5),s80) if(s80(2:9).eq.'C Matrix' ) call rdm(9,NQ,N, C,ip(5),s80) if(s80(4:11).eq.'D Vector') call rdv(9,NQ , D,ip(6)) if(s80(2:9).eq.'D Vector' ) call rdv(9,NQ , D,ip(6)) if(s80(4:11).eq.'E Matrix') call rdm(9,NQ,N ,E,ip(7),s80) if(s80(2:9).eq.'E Matrix' ) call rdm(9,NQ,N ,E,ip(7),s80) c if 0-0 energy not prescribed in GUVCDE.OPT, try to find it here: if(dabs(e00).lt.1.0d-3)then if(s80(2:30).eq.'Energy of the 0-0 transition:')then read(s80(31:42),*)e00 i0=i0+1 write(6,60091)e00 60091 format('E 0-0 explicit ',f12.2,' cm-1') endif if(s80(2:43).eq.'Sum of electronic and zero-point Energies=')then i0=i0+1 if(i0.eq.1)then read(s80(45:65),*)z1 else read(s80(45:65),*)z2 if(dabs(z2-z1).gt.0.00001d0)then e00=(z2-z1)*219474.0d0 write(6,6309)e00 6309 format('E 0-0 from ZPEs ',f12.2,' cm-1') endif endif endif endif if(s80(2:22).eq.'Harmonic frequencies ')call rw(9,N-6,W,WP,iw) goto 2 88 close(9) if(ldusch)call rdusch(NQ,N,JT,K,A,B,C,D,E,W,WP,iw,ip,'DUSCH.OUT') if(ip(1).eq.0)call report('Duschinsky Matrix not found') if(ip(2).eq.0)call report('Shift Vector not found') if(ip(3).eq.0)call report('A Matrix not found') if(ip(4).eq.0)call report('B Vector not found') if(ip(5).eq.0)call report('C Matrix not found') if(ip(6).eq.0)call report('D Vector not found') if(ip(7).eq.0)call report('E Matrix not found') if(iw.lt.2)call report('Frequencies not found') if(i0.lt.2)call report('0-0 energy not found') write(6,*)N,NQ if(lvert)then write(6,*)' Vertical approximation made, K=B=D=0)' do 8 ix=1,NQ K(ix)=0.0d0 B(ix)=0.0d0 8 D(ix)=0.0d0 endif call mz(G,N) call mz(GP,N) call mz(GT,NQ) call mz(GPT,NQ) do 4 ix=1,NQ G( ix,ix)=W( ix) GT( ix,ix)=W( ix) GP( ix,ix)=WP(ix) 4 GPT(ix,ix)=WP(ix) call mt(J,JT,NQ) call mm(T,GT,J,NQ) call mm(TP,JT,T,NQ) call ms(F,TP,GPT,NQ) call INV(F,FI,NQ,EE,IERR) if(IERR.ne.0)call report('Inversion error') call dofac(NQ,fac,J,JT,F,FI,GT,GPT,K) call wrdeb(NQ,N,A,B,C,D,E,F,FI,G,GP,J,JT,K) proc=fac*fac*100.0d0 write(6,300)fac,proc 300 format('<0|0*> = ',f20.13,' (',f6.2,'%)') c read moments: call r00(fn,nroot,u0,m0,v0,q0) c read moments and derivatives: if(LDD)then allocate(dd(9*nat),aa(9*nat),vv(9*nat),qq(18*nat)) if(LDE)then c read transition moments from a file: call rde(nat,dd,u0,aa,m0,vv,v0,qq,q0) else c read transition moments from Gaussian output: call rdd(fn,dd,nat,nroot,u0,iwr,m0,aa,vv,v0,qq,q0) endif call trafN(3,dd,ddi,nat,NQ,s) call trafN(3,aa,aai,nat,NQ,s) call trafN(6,qq,qqi,nat,NQ,s) call trafN(3,vv,vvi,nat,NQ,s) deallocate(dd,aa,vv,qq) call wrda(ddi,aai,qqi,vvi,NQ,nroot) endif if(lgnj)then allocate(gnjx(27*nat)) open(88,file='GNJD.TEN') do 1 ia=1,nat do 1 iz=1,3 read(88,*) do 1 ix=1,3 1 read(88,*)(gnjx(ix+3*(iy-1)+9*(iz-1)+27*(ia-1)),iy=1,3) c ix-electric,iy-magnetic,iz-atomic read(88,*) do 5 ix=1,3 5 read(88,*)(g0(ix+3*(iy-1)),iy=1,3) close(88) call trafN(9,gnjx,gnji,nat,NQ,s) deallocate(gnjx) call wrgn(gnji,NQ,nroot) endif return end c ======================================== subroutine initen(we) implicit none integer*4 is real*8 we character*11 s11 write(s11,300)we 300 format(f11.0) do 4 is=1,len(s11) 4 if(s11(is:is).ne.' ')goto 5 5 open(110,file=s11(is:11)//'TTT.OUT') return end subroutine c33w(wrin,wrax,npx,s,we,ldo) implicit none integer*4 npx,i,ns0,ii,ie,is,k parameter (ns0=19) logical ldo(ns0) real*8 wrin,wrax,s(npx,2,ns0),w,dw,we character*11 st(ns0),s11 data st/'ICP_0 ','ICPx_90 ','ICPz_90 ','ICPs_90 ', 1 'ICPu_90 ','ICP_180 ','SCP_0 ','SCPx_90 ', 1 'SCPz_90 ','SCPs_90 ','SCPu_90 ','SCP_180 ', 1 'DCPI_0 ','DCPI_90 ','DCPI_180 ','DCPII_0 ', 1 'DCPII_90 ','DCPII_180 ','FCTAB '/ character*3 s3(2) data s3/'ram','roa'/ dw=(wrax-wrin)/(npx-1) write(s11,300)we 300 format(f11.0) do 4 is=1,len(s11) 4 if(s11(is:is).ne.' ')goto 5 5 do 1 ii=1,ns0-1 if(ldo(ii))then do 101 ie=len(st(ii)),1,-1 101 if(st(ii)(ie:ie).ne.' ')goto 102 102 do 103 k=1,2 open(45,file=s11(is:11)//st(ii)(1:ie)//'.'//s3(k)//'.prn') w=wrin-dw do 2 i=1,npx w=w+dw 2 write(45,4545)w,s(i,k,ii) 4545 format(f12.3,' ',g12.4) 103 close(45) endif 1 continue return end c ======================================== subroutine c33(wrin,wrax,npx,s,T,ldo) implicit none integer*4 npx,i,ns0,ii,ie parameter (ns0=19) real*8 wrin,wrax,s(npx,2,ns0),w,dw,tempcm,T logical ldo(ns0) character*11 st(ns0) data st/'ICP_0 ','ICPx_90 ','ICPz_90 ','ICPs_90 ', 1 'ICPu_90 ','ICP_180 ','SCP_0 ','SCPx_90 ', 1 'SCPz_90 ','SCPs_90 ','SCPu_90 ','SCP_180 ', 1 'DCPI_0 ','DCPI_90 ','DCPI_180 ','DCPII_0 ', 1 'DCPII_90 ','DCPII_180 ','FCTAB '/ tempcm=0.6950d0*T do 100 ii=1,ns0-1 if(ldo(ii))then do 101 ie=len(st(ii)),1,-1 101 if(st(ii)(ie:ie).ne.' ')goto 102 102 open(45,file=st(ii)(1:ie)//'.ram.prn') dw=(wrax-wrin)/(npx-1) w=wrin-dw do 1 i=1,npx w=w+dw 1 write(45,4545)w,s(i,1,ii)/(1.0d0-exp(-w/tempcm)) 4545 format(f12.3,' ',g12.4) close(45) open(45,file=st(ii)(1:ie)//'.roa.prn') dw=(wrax-wrin)/(npx-1) w=wrin-dw do 2 i=1,npx w=w+dw 2 write(45,4545)w,s(i,2,ii)/(1.0d0-exp(-w/tempcm)) close(45) endif 100 continue return end c ======================================== subroutine c4546(wrin,wrax,npx,s,T,f,ic) implicit none real*8 wrin,wrax,s(*),w,dw,tempcm,c,T integer*4 npx,i,ic character*(*) f tempcm=0.6950d0*T open(45,file=f//'.prn') dw=(wrax-wrin)/(npx-1) w=wrin-dw do 1 i=1,npx w=w+dw c=1.0d0 c ABS if(ic.eq.1)c=108.7d0*w c CD: if(ic.eq.2)c=435.0d0*w c Raman, ROA: if(ic.eq.3)c=1.0d0/(1.0d0-exp(-w/tempcm)) if(ic.eq.8)c=1.0d0/(1.0d0-exp(-w/tempcm)) 1 write(45,4545)w,s(i)*c 4545 format(f12.3,' ',g12.4) close(45) return end c ======================================== subroutine ap3(is,ns0,ECM,a,s,wrin,wrax,npx,fwhh,lglg) implicit none integer*4 ns0,npx,i,is real*8 ECM,wrin,wrax,fwhh,w,dw,sf,a(2),s(npx,2,ns0),t logical lglg dw=(wrax-wrin)/(npx-1) w=wrin-dw do 1 i=1,npx w=w+dw t=sf(fwhh,lglg,w,ECM) s(i,1,is)=s(i,1,is)+t*a(1) 1 s(i,2,is)=s(i,2,is)+t*a(2) return end c ================================================================== subroutine app(ECM,ram1,roa1,reram,reroa,wrin,wrax,npx,fwhh,lglg, 1ic) implicit none real*8 ECM,wrin,wrax,reram(*),reroa(*),fwhh,w,dw,ram1,roa1,t,sf, 1r,a integer*4 npx,i,ic logical lglg c Make the scale similar to usual new6/tabprnf way c c ic=1: Raman, ROA: if(ic.eq.1)then r=ram1*2.0d0/219470.0d0 a=roa1*2.0d0/219470.0d0 endif c ic=2: abs,cd: if(ic.eq.2)then r=ram1 a=roa1 endif dw=(wrax-wrin)/(npx-1) w=wrin-dw do 1 i=1,npx w=w+dw t=sf(fwhh,lglg,w,ECM) reram(i)=reram(i)+t*r 1 reroa(i)=reroa(i)+t*a return end c ================================================================== function sf(d,g,x,x0) implicit none logical g real*8 pi,spi,sf,d,x,x0,dd pi =3.14159265358979d0 spi=1.77245385090552d0 dd=((x-x0)/d)**2 if(g)then if(dd.lt.20.0d0)then sf=exp(-dd)/d/spi else sf=0.0d0 endif else if(dd.lt.1.0d10)then sf=1.0d0/d/(dd+1.0d0)/pi else sf=0.0d0 endif endif return end c ============================================================== FUNCTION LOGDET(A,N,NQ) c logarithm of a determinant of a matrix,absolute value IMPLICIT none integer*4 N,I,J,K,NQ logical DETEXISTS real*8 A(N,N),M,TEMP,LOGDET real*8, allocatable::ELEM(:,:) allocate(ELEM(NQ,NQ)) DO 1 I=1,NQ DO 1 J=1,NQ 1 ELEM(I,J)=A(I,J) DETEXISTS=.TRUE. c L=1.0d0 DO 2 K=1,NQ-1 IF(ABS(ELEM(K,K)).LE.1.0d-20)THEN DETEXISTS=.FALSE. DO 3 I=K+1,NQ IF(ELEM(I,K).NE.0.0d0)THEN DO 4 J=1,NQ TEMP=ELEM(I,J) ELEM(I,J)=ELEM(K,J) 4 ELEM(K,J)=TEMP DETEXISTS=.TRUE. c L=-L EXIT ENDIF 3 CONTINUE IF (DETEXISTS.EQV..FALSE.)THEN LOGDET = 0.0d0 RETURN ENDIF ENDIF DO 2 J=K+1,NQ M=ELEM(J,K)/ELEM(K,K) DO 2 I=K+1,NQ 2 ELEM(J,I)=ELEM(J,I)-M*ELEM(K,I) LOGDET =0.0d0 DO 5 I=1,NQ if(ELEM(I,I).lt.0.0d0)then c L=-L LOGDET=LOGDET+log(-ELEM(I,I)) else LOGDET=LOGDET+log( ELEM(I,I)) endif 5 continue RETURN END c ============================================================== subroutine viz(v,n) integer*4 v(*),i,n do 1 i=1,n 1 v(i)=0 return end c ============================================================== subroutine puts(NQ,sd,sj) c rewrite vib state from long to compact notation: integer*4 NQ,sd(*),sj(*),kk,i,ii kk=0 do 21 i=1,NQ do 21 ii=1,sd(i) kk=kk+1 21 sj(kk)=i return end c ============================================================== function les(N,s) integer*4 les,N,s(*),u,i u=0 do 1 i=1,N 1 u=u+s(i) les=u return end c ============================================================== subroutine trl(si,Nexc,sl,NQ) integer*4 si(*),Nexc,sl(*),NQ,i do 1 i=1,NQ 1 sl(i)=0 do 2 i=1,Nexc 2 sl(si(i))=sl(si(i))+1 return end c ============================================================== subroutine rrrd(e00,fac,np0,iwr,N,A,B,C,D,E,G,GP, 1u0,m0,v0,q0,ddi,aai,qqi,vvi,LQ1,THRC,HW,NQ, 2LEXCL,LEXCF,EXCNM,gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 3reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1vrroa,troa,ltens,gtens,atens,enr,anroa,frroa,sr,lwten,nproc,lvel, 1ldo) c resonance Raman and ROA spectra - optimized routine c |0> -> |P> -> |f>, P ... states of biggest overlap with grounds c e00 ... energy of the 0-0 transition in cm-1 c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ,LEXCF,npx,nroot,NQBUF,IQBUF,TQ,LEXP,Nj,NEXC0, 1ias,les,Ni,NB,ns0,nproc parameter (NEXC0=100,ns0=19) real*8 pp,FC,e00,fac,ut(3),u0(*),ddi(*),A(N,N),B(*),C(N,N),D(N), 1E(N,N),G(N,N),GP(N,N),proc,EJ,CM,THRC,pm,qk,m0(*),aai(*), 1gammaau,q0(*),v0(*),qqi(*),vvi(*),EXCNM,wrax,wrin,tb,procold, 1fwhh,reram(*),reroa(*),wzero,kelvin,t0,FC1,ed(3),t,qkf, 1troa,ltens(*),gtens(*),atens(*),enr(*),e00au,sr(npx,2,ns0) logical LQ1,HW,lglg,ltab,lvert,lwzero,anroa,vrroa,frroa,lwten, 1lvel,ldo(ns0) integer*4,allocatable::si(:),sit(:),s0(:),sd(:),sdn(:),sl(:), 1st(:),sib(:,:),Nexcb(:),sj(:) real*8,allocatable::utb(:,:),tbb(:),qt(:),eb(:),EK(:) CM=219474.63d0 procold=0.0d0 e00au=e00/CM nt=0 c <0|0*>: nt=nt+1 proc=100.0d0*fac**2 allocate(si(LEXCL+1),s0(1),st(NQ),sl(NQ)) s0(1)=0 Ni=0 call viz(si,LEXCL+1) write(6,600)nroot,0,LEXCL,LEXCF,lwzero,wzero,lvert, 1wrin,wrax,npx,lglg,fwhh,ltab,kelvin,gammaau,N,NQ,EXCNM, 11.0d7/e00,NQBUF,THRC,frroa,lwten 600 format(/,' rrrd',/, 1 ' Resonance ROA calculation - fast, ldis = .true.',/, 1 ' --------------------------------------',/, 1 ' Root : ',i3,/, 1 ' Maximal exc. start : ',i3,/, 1 ' Maximal exc. intermediate: ',i3,/, 1 ' Maximal exc. final : ',i3,/, 1 ' lwzero : ',l3,/, 1 ' wzero : ',f12.3,/, 1 ' lvert : ',l3,/, 1 ' wmin / cm-1 : ',f12.3,/, 1 ' wmax / cm-1 : ',f12.3,/, 1 ' Number of points : ',i5,/, 1 ' Gaussian profile : ',l3,/, 1 ' FWHH / cm-1 : ',f12.3,/, 1 ' write RROA.TAB : ',l3,/, 1 ' Temperature / K : ',f12.3,/, 1 ' gamma / hartree : ',f12.3,/, 1 ' N : ',i3,/, 1 ' NQ : ',i3,/, 1 ' w_exc nm : ',f12.3,/, 1 ' w0 nm : ',f12.3,/, 1 ' NQBUF : ',i12,/, 1 ' threshold : ',g12.2,/, 1 ' frroa : ',l3,/, 1 ' lwten : ',l3,/, 1 '---------------------------') c read guess of the principal excited state: allocate(sd(NQ),sdn(NQ),qt(NQ),EK(NQ)) call rdgs(NQ,sd,qt,EK,NB) LEXP=les(NQ,sd) write(6,*)LEXP,' - times excited' write(6,609)(sd(kk),kk=1,NQ) 609 format(20i3) allocate(sj(LEXP+1)) call viz(sj,LEXP+1) call puts(NQ,sd,sj) Nj=LEXP t0=FC1(fac,si,sj,Ni,Nj,np0,iwr,A,B,C,D,E,N)**2 write(6,607)'0',proc write(6,607)'P',100.0d0*t0 607 format(' <0|',A1,'>: ',g12.4,' %') deallocate(sj) c rewrite initial guess to sdn: do 25 kk=1,NQ 25 sdn(kk)=sd(kk) c find maximum overlap state: call fmaxo(NQ,t0,sdn,LEXP,fac,si,Ni,Nj,np0,iwr,N, 1A,B,C,D,E) c : allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) t=FC1(fac,si,sj,Ni,Nj+1,np0,iwr,A,B,C,D,E,N) deallocate(sj) c pre-calculate u - du/dQ Qt do 121 ix=1,3 ed(ix)=u0(ix) do 121 kk=1,NQ 121 ed(ix)=ed(ix)-ddi(ix+3*(kk-1))*qt(kk) c ut ... electric dipole, length c <0|u|*>=(u0-du/dQk Qtk)<0|*>+du/dQk <0|Qk|*>,etc ut(1)=ed(1)*t ut(2)=ed(2)*t ut(3)=ed(3)*t if(LQ1)then do 10 kk=1,NQ c <0|Q*k|*>=sqrt(h/(2*wk)) [ sqrt(vk) <0|k-1> + sqrt(vk+1) <0|k+1> ]: sdn(kk)=sdn(kk)+1 LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) pp=sqrt(dble(sdn(kk)+1))*FC(fac,sj,LEXP,np0,iwr,C,D,N) sdn(kk)=sdn(kk)-1 deallocate(sj) if(sdn(kk).gt.0)then sdn(kk)=sdn(kk)-1 LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) pm=sqrt(dble(sdn(kk)+1))*FC(fac,sj,LEXP,np0,iwr,C,D,N) sdn(kk)=sdn(kk)+1 deallocate(sj) else pm=0.0d0 endif pp=(pp+pm)/dsqrt(2.0d0*GP(kk,kk)) ut(1)=ut(1)+ddi(1+3*(kk-1))*pp ut(2)=ut(2)+ddi(2+3*(kk-1))*pp ut(3)=ut(3)+ddi(3+3*(kk-1))*pp 10 if(iwr.gt.1)write(6,1600)kk,pp 1600 format('<0|Q_',i3,'|P> = ',g13.4) si(1)=0 endif c sum final states for 0 -> P -> f: LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call puts(NQ,sdn,sj) c initialize the buffer with states providing the c largest <0|u|*> dipole: allocate(sib(NQBUF,NEXC0),utb(NQBUF,15),tbb(NQBUF),Nexcb(NQBUF), 1eb(NQBUF)) do 4 kk=1,NQBUF Nexcb(kk)=0 eb (kk)=0.0d0 tbb(kk)=0.0d0 utb(kk,1)=0.0d0 utb(kk,2)=0.0d0 utb(kk,3)=0.0d0 do 4 ix=1,NEXC0 4 sib(kk,ix)=0 IQBUF=0 TQ=0 IQBUF=1 TQ=1 eb(1)=e00au tbb(1)=ut(1)**2+ut(2)**2+ut(3)**2 utb(1,1)=ut(1) utb(1,2)=ut(2) utb(1,3)=ut(3) Nexcb(1)=LEXP do 42 ix=1,LEXP 42 sib(1,ix)=sj(ix) deallocate(sj) c ================= Other states than |sdn>=|P> c Generate states Nexc excited: do 99999 ias=1,-1,-2 if(ias.eq.1)then write(6,*)'Adding excitations' else write(6,*)'Subtracting excitations' endif c ias= 1 ... add excitations c ias=-1 ... subtract excitations c states les(sdn)+/Nexc excited do 30000 Nexc=1,LEXCL write(6,*)Nexc c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(NQ1.ne.0.and.icen.gt.NQ1)goto 12000 c c transcript si (short notation) to sl (long) call trl(si,Nexc,sl,NQ) if(ias.eq.1)then c add this arbitrary state to sdn do 26 ii=1,NQ 26 st(ii)=sdn(ii)+sl(ii) else c subtract this state if possible do 27 ii=1,NQ st(ii)=sdn(ii)-sl(ii) 27 if(st(ii).lt.0)goto 12000 endif c rewrite final state st into short form in sj: LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sit,LEXP+2) call puts(NQ,st,sj) EJ=0.0d0 DO 1002 II=1,LEXP 1002 EJ=EJ+GP(sj(II),sj(II)) if(iwr.gt.1)write(6,604)ii,(si(iex),iex=1,NExc) 604 format(' state ',i2,':',10i3) c <0|*> pp=FC(fac,sj,LEXP,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0 if(proc.gt.procold+1.0d0)then write(6,602)pp,proc,EJ*CM procold=proc endif if(HW)then write(6,599) 599 format('<0|',$) do 107 I=1,LEXP 107 write(6,601)sj(I) 601 format(i3,$) write(6,598) 598 format('>: ',$) write(6,602)pp,proc,EJ*CM 602 format(g12.4,' (',f10.3,'%), E= ',F10.2) endif c <0|u|*>=u0<0|*>+du/dQk<0|Qk|*> ut(1)=ed(1)*pp ut(2)=ed(2)*pp ut(3)=ed(3)*pp if(LQ1)then c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) do 15 kk=1,NQ qk=qkf(sj,LEXP,kk,fac,sit,iwr,C,D,N,np0,GP) ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk 15 ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif tb=ut(1)**2+ut(2)**2+ut(3)**2 TQ=TQ+1 if(tb.gt.THRC)then if(IQBUF.lt.NQBUF)IQBUF=IQBUF+1 do 7 kk=1,NQBUF if(tb.gt.tbb(kk))then do 5 ic=NQBUF,kk+1,-1 eb (ic)=eb (ic-1) tbb (ic)=tbb (ic-1) utb (ic,1)=utb (ic-1,1) utb (ic,2)=utb (ic-1,2) utb (ic,3)=utb (ic-1,3) Nexcb(ic)=Nexcb (ic-1) do 5 ix=1,Nexcb (ic-1) 5 sib (ic,ix)=sib(ic-1,ix) eb (kk)=e00au+EJ tbb (kk)=tb utb (kk,1)=ut(1) utb (kk,2)=ut(2) utb (kk,3)=ut(3) Nexcb(kk)=LEXP if(LEXP.gt.NEXC0)call report('LEXP > NEXC0') do 3 ix=1,LEXP 3 sib (kk,ix)=sj(ix) goto 12001 endif 7 continue endif 12001 deallocate(sj,sit) c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue 99999 continue deallocate(si) write(6,*)IQBUF,' dipoles of ',TQ c add magnetic dipoles and quadrupoles: call addmq(NQBUF,N,NQ,np0,IQBUF,iwr,NExcb,LEXCL,sib,LQ1, 1sit,C,D,fac,GP,utb,v0,m0,q0,vvi,aai,qqi,NEXC0) c sum final states for 0 -> * -> f call downexcf(s0,0,sib,Nexcb,LEXCF,utb,IQBUF,u0,m0,q0, 1v0,fac,np0,iwr,A,B,C,D,E,N,LQ1,NQ,G,GP,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1qt,.true.,vrroa,troa,ltens,gtens,atens,enr,anroa, 1NQBUF,NEXC0,eb,frroa,sr,lwten,nproc,lvel,ldo) return end subroutine inpder(nvib,nq,l,g,a,e) c load normal mode derivatives of alpha, Gp and A tensors) implicit none integer*4 nq,nm,im,II,i1,i,j,k,i9,nvib real*8 l(*),g(*),a(*),ecm,e(*) logical lex inquire(file='FILE.Q.TTT',exist=lex) if(lex)then open(22,file='FILE.Q.TTT') read(22,*) read(22,*)nm write(6,*)nm,' modes in FILE.Q.TTT' read(22,*) read(22,*) im=0 DO 1 II=1,nm read(22,*)ecm,ecm if(dabs(ecm).gt.1.0d-1)then im=im+1 if(im.gt.nq)call report('Too many modes') i1=nq-im+1 e(i1)=ecm DO 11 i=1,3 11 read(22,*)l(i+9*(i1-1)),(l(i+3*(j-1)+9*(i1-1)),j=1,3) endif 1 continue if(im.ne.nvib)call report('number of modes does not match') read(22,*) read(22,*) im=0 DO 2 II=1,nm read(22,*)ecm,ecm if(dabs(ecm).gt.1.0d-1)then im=im+1 i1=nq-im+1 DO 21 i=1,3 21 read(22,*)g(i+9*(i1-1)),(g(i+3*(j-1)+9*(i1-1)),j=1,3) c j index magnetic endif 2 continue read(22,*) read(22,*) im=0 DO 3 II=1,nm read(22,*)ecm,ecm if(dabs(ecm).gt.1.0d-1)then im=im+1 i1=nq-im+1 i9=27*(i1-1) DO 31 I=1,3 DO 31 J=1,3 31 read(22,*)A(I+3*(J-1)+i9),A(I+3*(J-1)+i9), 1 (A(I+3*(J-1)+9*(K-1)+i9),K=1,3) endif 3 continue close(22) else call report('FILE.Q.TTT not found') endif return end c ============================================================ subroutine tqq(qf,u) implicit none real*8 qf(*),u(3,3),xx,xy,xz,yy,yz,zz xx=qf(1) xy=qf(2) xz=qf(3) yy=qf(4) yz=qf(5) zz=qf(6) c traceless quadrupole: u(1,1)=0.5d0*(xx+xx-yy-zz) u(2,2)=0.5d0*(yy+yy-zz-xx) u(3,3)=0.5d0*(zz+zz-xx-yy) u(1,2)=1.5d0*xy u(1,3)=1.5d0*xz u(2,1)=1.5d0*xy u(2,3)=1.5d0*yz u(3,1)=1.5d0*xz u(3,2)=1.5d0*yz return end c ============================================================ subroutine sospol(nd0,nmo,n,lopen,na,nb,ni,nid,aij,bij, 1cij,daij,dbij,dij,bp,bpd,nmo2,n22,djg,ifix,nib, 1cijb,aijb,bijb,djk,gammaau,EXCNM,eau,nat,xau,qq,dkg) c calculate polarizability derivatives by SOS implicit none integer*4 nd0,nmo,n,na,nb,ni(*),nid(*),aij(*),bij(*), 1daij(*),dbij(*),nmo2,n22,ifix,nib(*),aijb(*),bijb(*), 1j,k,i,ix,jx,nat,qq(*),ia,jj,ii,j1,j2,nn real*8 cij(*),dij(*),bp(*),bpd(*),djg(*),ekj, 1djk(*),EXCNM,wcm,w,CM,ejg,r,fjg,fjg1w,fjg2w,fkg1w,fkg2w, 1sum,ekg,fkg,fkj,eau(*),gammaau,cijb(*),un(3),xau(3,nat), 1dkg(*),qf(6),tq(3,3),c logical lopen real*8,allocatable::pre(:),pred(:),ujj(:),u0(:),u0d(:), 1al(:),gp(:),A(:),bo(:),t(:,:),g0(:),g0d(:),ojg(:),okg(:), 1ojk(:),bod(:),pro(:),prod(:),ojj(:),al1(:),al2(:),al3(:) c write(6,600) 600 format(/,' SOSPOL') c nuclear dipole moment: call uun(un,nat,xau,qq) nn=3*nat allocate(al(9*nn),gp(9*nn),A(18*nn),al1(9*nn),al2(9*nn),al3(9*nn)) call vz(al , 9*nn) call vz(al1, 9*nn) call vz(al2, 9*nn) call vz(al3, 9*nn) call vz(gp , 9*nn) call vz(A ,18*nn) c CM=219474.63d0 wcm=1.0d7/EXCNM w=wcm/CM allocate(ujj(nd0),pre(nd0*nmo2),pred(nd0*nmo2),u0(nd0),u0d(nd0), 1ojj(nn)) c electronic moments uj = sum(i) : call vz(u0,nd0) call vz(u0d,nd0) do 4 j=1,nd0 if(lopen)then do 5 i=1,na 5 u0( j)=u0( j)+bp( i+nmo*(i-1)+nmo2*(j-1)) do 6 i=1,nb 6 u0d(j)=u0d(j)+bpd(i+nmo*(i-1)+nmo2*(j-1)) else do 7 i=1,na 7 u0( j)=u0(j) +bp( i+nmo*(i-1)+nmo2*(j-1))*2.0d0 endif 4 continue write(6,700)(un(i)-u0(i),i=1,3) 700 format(' ground state dipole moment',3f11.4) c integrals allocate(bo(nmo2*nn),t(nmo,nmo),bod(nmo2*nn),okg(nn),ojk(nn)) call vz(bo,nmo2*nn) call vz(bod,nmo2*nn) open(38,file='OO.SCR.TXT',status='old') do 8 ia=1,nat do 8 ix=1,3 ii=ix+3*(ia-1) read(38,*) read(38,*) call rmtr38(t,nmo,nmo,1) do 8 i=1,nmo do 8 j=1,nmo 8 bo(i+nmo*(j-1)+nmo2*(ii-1))=t(i,j) close(38) if(lopen)call report('OPEN shell in O not implemented') allocate(pro(nn*nmo2),prod(nn*nmo2),g0(nn),g0d(nn),ojg(nn)) c gradient moments gj = sum(i) : call vz(g0 ,nn) call vz(g0d,nn) do 9 j=1,nn if(lopen)then do 10 i=1,na 10 g0( j)=g0( j)+bo( i+nmo*(i-1)+nmo2*(j-1)) do 11 i=1,nb 11 g0d(j)=g0d(j)+bod(i+nmo*(i-1)+nmo2*(j-1)) else do 12 i=1,na 12 g0( j)=g0(j) +bo( i+nmo*(i-1)+nmo2*(j-1))*2.0d0 endif 9 continue do 307 j=1,n ejg=eau(j) fjg=ejg/(ejg**2+gammaau**2) r=(ejg**2-w**2)/((ejg**2-w**2)**2+(gammaau*w)**2) fjg1w=ejg*r fjg2w= r c precalculate b>: call getieab(pre,pred,lopen,na,nb,nmo,ni,nid,j,aij,bij, 1cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,nd0,n22) c precalculate b>: call getieab(pro,prod,lopen,na,nb,nmo,ni,nid,j,aij,bij, 1cij,daij,dbij,dij,bo,bod,g0,g0d,nmo2,nn,n22) c calculate state dipole : call getdipole1(ujj,cij,nmo,ni,aij,bij, 1dij,nid,daij,dbij,lopen,pre,pred,j,nd0,n22) c calculate state gradient : call getdipole1(ojj,cij,nmo,ni,aij,bij, 1dij,nid,daij,dbij,lopen,pro,prod,j,nn,n22) sum=0.0d0 do 317 i=1,ni(j) 317 sum=sum+cij(n22*(j-1)+i)**2 do 326 i=1,nid(j) 326 sum=sum+dij(n22*(j-1)+i)**2 do 328 i=1,nib(j) 328 sum=sum-cijb(n22*(j-1)+i)**2 if(j.eq.3)write(6,*)' ... ' if(j.le.2.or.j.eq.n)write(6,3004)j,(un(ia)-ujj(ia),ia=1,3),sum 3004 format(i6,4f10.3) c djg=: " singlet (dsqrt(2)) call me(ni,nid,cij,dij,aij,daij,bij,dbij,j,lopen,djg,bp,bpd, 1nmo,nmo2,ifix,nib,cijb,aijb,bijb,nd0,n22) djg(4)=-djg(4)/ejg djg(5)=-djg(5)/ejg djg(6)=-djg(6)/ejg c ojg=: " singlet (dsqrt(2)) call me(ni,nid,cij,dij,aij,daij,bij,dbij,j,lopen,ojg,bo,bod, 1nmo,nmo2,ifix,nib,cijb,aijb,bijb,nn,n22) c parts dependent on the ground state dipole moment c - 2 un_x sum(j) onj ujn_y /(e_jn e_jnw) do 1 ii=1,nn do 1 ix=1,3 do 1 jx=1,3 jj=ix+3*(jx-1)+ 9*(ii-1) j1=ix+3*(jx-1)+18*(ii-1) j2=ix+3*(jx+2)+18*(ii-1) c=2.0d0*u0(ix)*ojg(ii)*fjg al1(jj)=al1(jj)-c*djg(jx )*fjg1w gp( jj)=gp( jj)-c*djg(jx+ 6)*fjg2w A( j1) =A( j1) -c*djg(jx+12)*fjg1w 1 A( j2)= A( j2) -c*djg(jx+15)*fjg1w c k=j: c 2 [ onj (ujj_x ujn_y + unj_x ujj_y) + unj_x o_jj ujn_y] / (e_jn * e_jnw) do 2 ii=1,nn do 2 ix=1,3 do 2 jx=1,3 jj=ix+3*(jx-1)+ 9*(ii-1) j1=ix+3*(jx-1)+18*(ii-1) j2=ix+3*(jx+2)+18*(ii-1) c=2.0d0*fjg al2(jj)=al2(jj) +(ojg(ii)*(ujj(ix)*djg(jx ) 1+djg(ix)*ujj(jx )) +djg(ix)*ojj(ii)*djg(jx )) *fjg1w*c gp (jj)=gp (jj) +(ojg(ii)*(ujj(ix)*djg(jx+ 6) 1+djg(ix)*ujj(jx+ 6)) +djg(ix)*ojj(ii)*djg(jx+ 6)) *fjg2w*c A (j1) =A (j1) +(ojg(ii)*(ujj(ix)*djg(jx+12) 1+djg(ix)*ujj(jx+12)) +djg(ix)*ojj(ii)*djg(jx+12)) *fjg1w*c 2 A (j2)= A (j2) +(ojg(ii)*(ujj(ix)*djg(jx+15) 1+djg(ix)*ujj(jx+15)) +djg(ix)*ojj(ii)*djg(jx+15)) *fjg1w*c c k<>j: c ukj_x ujn_y + unj_x ujk_y unj_x ojk u_kny c 2 (onk ------------------------- + ---------------) c e_jnw w_kn e_jn e_knw do 3071 k=1,n if(k.ne.j)then ekg=eau(k) ekj=ekg-ejg fkj=ekj/(ekj**2+gammaau**2) fkg=ekg/(ekg**2+gammaau**2) r=(ekg**2-w**2)/((ekg**2-w**2)**2+(gammaau*w)**2) fkg1w= ekg*r fkg2w= r c dkg=: "" singlet (dsqrt(2)) call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,k,lopen,dkg,bp,bpd,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb,nd0,n22) c okg=: "" singlet (dsqrt(2)) call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,k,lopen,okg,bo,bod,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb, nn,n22) c djk===> call dodjk(djk,nd0,ni,k,aij,bij,n22,cij,pre,lopen,daij,dbij, 1 pred,nmo,dij,nid) c ojk===> call dodjk(ojk, nn,ni,k,aij,bij,n22,cij,pro,lopen,daij,dbij, 1 prod,nmo,dij,nid) c transform gradient to dipole: djk(4)=-djk(4)*(-fkj) djk(5)=-djk(5)*(-fkj) djk(6)=-djk(6)*(-fkj) dkg(4)=-dkg(4)*fkg dkg(5)=-dkg(5)*fkg dkg(6)=-dkg(6)*fkg do 3 ii=1,nn do 3 ix=1,3 do 3 jx=1,3 jj=ix+3*(jx-1)+ 9*(ii-1) j1=ix+3*(jx-1)+18*(ii-1) j2=ix+3*(jx+2)+18*(ii-1) c=2.0d0*okg(ii)*fkg al3(jj)=al3(jj)+c*(djk(ix)*djg(jx )+djg(ix)*djk(jx ))*fjg1w gp (jj)=gp (jj)+c*(djk(ix)*djg(jx+ 6)+djg(ix)*djk(jx+ 6))*fjg2w A (j1)=A (j1)+c*(djk(ix)*dkg(jx+12)+djg(ix)*djk(jx+12))*fjg1w A (j2)=A (j2)+c*(djk(ix)*dkg(jx+15)+djg(ix)*djk(jx+15))*fjg1w c=2.0d0*djg(ix)*ojk(ii)*fjg al3(jj)=al3(jj)+dkg(jx )*fkg1w*c gp (jj)=gp (jj)+dkg(jx+ 6)*fkg2w*c A (j1) =A (j1) +dkg(jx+12)*fkg1w*c 3 A (j2)= A (j2) +dkg(jx+15)*fkg1w*c endif 3071 continue c k 307 continue c j do 13 ii=1,nn do 13 ix=1,3 c Quadrupole order: 'XX','XY','XZ','YY','YZ','ZZ': do 81 jx=1,6 81 qf(jx)=A(ix+3*(jx-1)+18*(ii-1)) c get traceless quadrupole, multiply by 3/2: call tqq(qf,tq) c get back non-redundant components in POl.TTT order XX XY YY XZ YZ ZZ: call qbq(qf,tq) do 13 jx=1,6 13 A(ix+3*(jx-1)+18*(ii-1))=qf(jx) call writettt(nat,w,gammaau,al1,gp,a,'FILE.1.TTT') call writettt(nat,w,gammaau,al2,gp,a,'FILE.2.TTT') call writettt(nat,w,gammaau,al3,gp,a,'FILE.3.TTT') do 14 ii=1,9*nn 14 al(ii)=al1(ii)+al2(ii)+al3(ii) call writettt(nat,w,gammaau,al,gp,a,'FILE.SOS.TTT') return end c ============================================================ subroutine writettt(nat,w,g,al,gp,a,s) IMPLICIT none character*(*) s integer*4 nat,L,ix,i,j,k,ii real*8 w,g,al(*),gp(*),a(*) real*8,allocatable::aa(:,:,:,:) OPEN(2,FILE=s) WRITE(2,2000)NAT,w,g 2000 FORMAT(' ROA tensors, cartesian derivatives',/, 1I4,' atoms, w g: ',2g11.4/, 1' The electric-dipolar electric-dipolar polarizability:',/, 2' Atom/x jx jy jz') DO 1 I=1,3 WRITE(2,2002)I 2002 FORMAT(' Alpha(',I1,',J):') DO 1 L=1,NAT DO 1 IX=1,3 II=3*(L-1)+IX 1 WRITE(2,2001)L,IX,(AL(I+3*(J-1)+9*(II-1)),J=1,3) 2001 FORMAT(I5,1H ,I1,3g15.7) WRITE(2,2004) 2004 FORMAT(' The electric dipole magnetic dipole polarizability:',/, 1 ' Atom/x jx(Bx) jy(By) jz(Bz)') DO 2 I=1,3 WRITE(2,2003)I 2003 FORMAT(' G(',I1,',J):') DO 2 L=1,NAT DO 2 ix=1,3 II=3*(L-1)+IX 2 WRITE(2,2001)L,ix,(GP(I+3*(J-1)+9*(II-1)),J=1,3) WRITE(2,2005) 2005 FORMAT(' The electric dipole electric quadrupole polarizability:', 2/, ' Atom/x kx ky kz') allocate(AA(3,3,3,3*NAT)) DO 5 L=1,NAT DO 5 ix=1,3 II=3*(L-1)+IX DO 5 K=1,3 c order XX XY YY XZ YZ ZZ: AA(K,1,1,ii)=A(K+ 18*(ii-1)) AA(K,1,2,ii)=A(K+ 3+18*(ii-1)) AA(K,2,2,ii)=A(K+ 6+18*(ii-1)) AA(K,1,3,ii)=A(K+ 9+18*(ii-1)) AA(K,2,3,ii)=A(K+12+18*(ii-1)) AA(K,3,3,ii)=A(K+15+18*(ii-1)) AA(K,2,1,ii)=AA(K,1,2,ii) AA(K,3,1,ii)=AA(K,1,3,ii) 5 AA(K,3,2,ii)=AA(K,2,3,ii) DO 3 I=1,3 DO 3 J=1,3 WRITE(2,2006)I,J 2006 FORMAT(' A(',I1,',',I1,',K):') DO 3 L=1,NAT DO 3 ix=1,3 II=3*(L-1)+IX 3 WRITE(2,2007)L,ix, 1(AA(K,J,I,ii)*3.d0/2.d0,K=1,3),L,ix,I,J 2007 FORMAT(I5,1H ,I1,3g15.7,' ',4i3) write(2,*) write(2,*)'dummy alpha v:' DO 4 I=1,3 WRITE(2,2002)I DO 4 L=1,NAT DO 4 IX=1,3 II=3*(L-1)+IX 4 WRITE(2,2001)L,IX,(AL(I+3*(J-1)+9*(II-1)),J=1,3) CLOSE(2) write(6,*)s//' written' RETURN END c ============================================================ subroutine gmroa(ntr,n,gammaau,EXCNM,eau,dl,r,qv) c calculate alpha G A from Gaussian transition moments c tensors implicit none integer*4 ntr,n,j,ix,jx,jj real*8 al(9),EXCNM,wcm,w,CM,dd,gp(9),a(18),ejg, 1f1,f2,eau(*),gammaau,qf(6),tq(3,3),dl(ntr,3),r(ntr,3),qv(ntr,3,3) c write(6,600) 600 format(' GMROA') c polarizability: call vz(al, 9) c Gp polarizability: call vz(gp, 9) c A polarizability: call vz(A ,18) c CM=219474.63d0 wcm=1.0d7/EXCNM w=wcm/CM open(55,file='JN.SCR.TXT') write(55,552)n,gammaau,w 552 format(i10,2g16.7) do 307 j=1,n ejg=eau(j) dd=ejg**2-w**2 f1= 2.0d0*ejg*dd/(dd**2+gammaau**2*w**2) f2= 2.0d0 *dd/(dd**2+gammaau**2*w**2) write(55,551)f1,f2,(dl(j,ix),ix=1,3),(r(j,ix),ix=1,3), 1((qv(j,ix,jx),ix=1,3),jx=1,3),ejg 551 format(18g16.7) do 1 ix=1,3 do 2 jx=1,3 jj=ix+3*(jx-1) al(jj)=al(jj) +f1*dl(j,ix)*dl(j,jx) 2 gp(jj)=gp(jj) +f2*dl(j,ix)*r( j,jx) A(ix+3*(1-1))=A(ix+3*(1-1))+f1*dl(j,ix)*qv(j,1,1) A(ix+3*(2-1))=A(ix+3*(2-1))+f1*dl(j,ix)*qv(j,1,2) A(ix+3*(3-1))=A(ix+3*(3-1))+f1*dl(j,ix)*qv(j,1,3) A(ix+3*(4-1))=A(ix+3*(4-1))+f1*dl(j,ix)*qv(j,2,2) A(ix+3*(5-1))=A(ix+3*(5-1))+f1*dl(j,ix)*qv(j,2,3) 1 A(ix+3*(6-1))=A(ix+3*(6-1))+f1*dl(j,ix)*qv(j,3,3) 307 continue close(55) c Quadrupole order: 'XX','XY','XZ','YY','YZ','ZZ' do 8 ix=1,3 do 81 jx=1,6 81 qf(jx)=A(ix+3*(jx-1)) c get traceless quadrupole, multiply by 3/2: call tqq(qf,tq) c get back non-redundant components in POl.TTT order XX XY YY XZ YZ ZZ: call qbq(qf,tq) do 8 jx=1,6 8 A(ix+3*(jx-1))=qf(jx) call smooth(al,9) call smooth(gp,9) call smooth(a,18) call writepol(al,'POL',EXCNM,gammaau) call writepol(gp,'GP',EXCNM,gammaau) call writepol(a,'A',EXCNM,gammaau) return end c ============================================================ subroutine cmroa(nd0,nmo,n,lopen,na,nb,ni,nid,aij,bij, 1cij,daij,dbij,dij,bp,bpd,nmo2,n22,djg,ifix,nib, 1cijb,aijb,bijb,djk,lgamma,gammaau,EXCNM,eau,nat,xau,qq,dkg) c calculate magnetically perturbed polarizability and some other c tensors implicit none integer*4 nd0,nmo,n,na,nb,ni(*),nid(*),aij(*),bij(*), 1daij(*),dbij(*),nmo2,n22,ifix,nib(*),aijb(*),bijb(*), 1j,k,i,ix,jx,kx,nat,qq(*),ia,jj real*8 ab(27),cij(*),dij(*),bp(*),bpd(*),djg(*), 1djk(*),al(9),EXCNM,wcm,w,CM,dd,gp(9),a(18),ejg,fjg,r,d, 1f1,f2,sum,ekg,ekj,fkg,fkj,eau(*),gammaau,cijb(*),un(3),xau(3,nat), 1dkg(*),y,qf(6),tq(3,3) real*8,allocatable::pre(:),pred(:),ut(:,:),u0(:),u0d(:) logical lopen,lgamma c write(6,600) 600 format(' MROA') c nuclear dipole moment: call uun(un,nat,xau,qq) c polarizability: call vz(al, 9) c Gp polarizability: call vz(gp, 9) c A polarizability: call vz(A ,18) c magnetic-perturbed polarizability: call vz(ab,27) c CM=219474.63d0 wcm=1.0d7/EXCNM w=wcm/CM allocate(ut(3,n),pre(nd0*nmo2),pred(nd0*nmo2),u0(nd0),u0d(nd0)) c electronic moments: call vz(u0,nd0) call vz(u0d,nd0) do 4 j=1,nd0 if(lopen)then do 5 i=1,na 5 u0( j)=u0( j)+bp( i+nmo*(i-1)+nmo2*(j-1)) do 6 i=1,nb 6 u0d(j)=u0d(j)+bpd(i+nmo*(i-1)+nmo2*(j-1)) else do 7 i=1,na 7 u0( j)=u0(j) +bp( i+nmo*(i-1)+nmo2*(j-1))*2.0d0 endif 4 continue do 307 j=1,n ejg=eau(j) if(lgamma)then fjg=ejg/(ejg**2+gammaau**2) else fjg=1.0d0/ejg endif dd=ejg**2-w**2 r=dd/(dd**2+gammaau**2*w**2) f1= 2.0d0*ejg*r f2= 2.0d0 *r c precalculate b>: call getieab(pre,pred,lopen,na,nb,nmo,ni,nid,j,aij,bij, 1cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,nd0,n22) c calculate state dipole: call getdipole(ut,n,cij,nmo,ni,aij,bij, 1dij,nid,daij,dbij,lopen,pre,pred,j,nd0,3,n22) sum=0.0d0 do 317 i=1,ni(j) 317 sum=sum+cij(n22*(j-1)+i)**2 do 326 i=1,nid(j) 326 sum=sum+dij(n22*(j-1)+i)**2 do 328 i=1,nib(j) 328 sum=sum-cijb(n22*(j-1)+i)**2 if(j.eq.2)write(6,*)' ... ' if(j.eq.1.or.j.eq.n)write(6,3004)j,(un(ia)-ut(ia,j),ia=1,3),sum 3004 format(i6,4f10.3) c djg=: " singlet (dsqrt(2)) call me(ni,nid,cij,dij,aij,daij,bij,dbij,j,lopen,djg,bp,bpd, 1nmo,nmo2,ifix,nib,cijb,aijb,bijb,nd0,n22) djg(4)=-djg(4)/ejg djg(5)=-djg(5)/ejg djg(6)=-djg(6)/ejg do 1 ix=1,3 do 1 jx=1,3 jj=ix+3*(jx-1) al(jj )=al(jj) +f1*djg(ix)*djg(jx ) gp(jj )=gp(jj) +f2*djg(ix)*djg(jx+ 6) A(jj )= A(jj) +f1*djg(ix)*djg(jx+12) 1 A(jj+9)= A(jj+9)+f1*djg(ix)*djg(jx+15) do 2 ix=1,3 do 2 jx=1,3 d=(djg(ix)*(ut(jx,j)-u0(jx))-(ut(ix,j)-u0(ix))*djg(jx))*f1 do 2 kx=1,3 jj=ix+3*(jx-1)+9*(kx-1) 2 ab(jj)=ab(jj)+d*djg(6+kx)*fjg c -2.0d0*ejg/(ejg**2+gammaau**2)**2*(m0j(kx)-m0n(kx))*djg(ix)*djg(jx) do 307 k=1,n if(k.ne.j)then ekg=eau(k) ekj=ekg-ejg fkj=ekj/(ekj**2+gammaau**2) fkg=ekg/(ekg**2+gammaau**2) c dkg=: "" singlet (dsqrt(2)) call me( 1 ni,nid,cij,dij,aij,daij,bij,dbij,k,lopen,dkg,bp,bpd,nmo,nmo2, 1 ifix,nib,cijb,aijb,bijb,nd0,n22) c djk===> call dodjk(djk,nd0,ni,k,aij,bij,n22,cij,pre,lopen,daij,dbij, 1 pred,nmo,dij,nid) c transform gradient to dipole: djk(4)=-djk(4)*(-fkj) djk(5)=-djk(5)*(-fkj) djk(6)=-djk(6)*(-fkj) dkg(4)=-dkg(4)*fkg dkg(5)=-dkg(5)*fkg dkg(6)=-dkg(6)*fkg do 3 ix=1,3 do 3 jx=1,3 d=(djg(ix)*djk(jx)-djk(ix)*djg(jx))*f1 y=(dkg(ix)*djg(jx)-djg(ix)*dkg(jx))*f1 do 3 kx=1,3 jj=ix+3*(jx-1)+9*(kx-1) 3 ab(jj)=ab(jj)+d*djg(6+kx)*fkg+y*djk(6+kx)*fkj endif 307 continue c Quadrupole order: 'XX','XY','XZ','YY','YZ','ZZ' do 8 ix=1,3 do 81 jx=1,6 81 qf(jx)=A(ix+3*(jx-1)) c get traceless quadrupole, multiply by 3/2: call tqq(qf,tq) c get back non-redundant components in POl.TTT order XX XY YY XZ YZ ZZ: call qbq(qf,tq) do 8 jx=1,6 8 A(ix+3*(jx-1))=qf(jx) call smooth(al,9) call smooth(gp,9) call smooth(a,18) call writepol(al,'POL',EXCNM,gammaau) call writepol(gp,'GP',EXCNM,gammaau) call writepol(a,'A',EXCNM,gammaau) call writepol(ab,'AB',EXCNM,gammaau) return end c ============================================================ subroutine smooth(a,n) implicit none real*8 a(*) integer*4 i,n do 1 i=1,n 1 if(dabs(a(i)).lt.1.0d-6)a(i)=0.0d0 return end c ============================================================ subroutine prep69(n,n6,pre6,pred6,lopen,na,nb,nmo,ni,nid,aij,bij, 1cij,daij,dbij,dij,bp,bpd,u0,u0d,nmo2,n22,djg,ifix,nib, 2cijb,aijb,bijb,djk,dlg,hd) c pre-calculating , x=r,grad, etc. implicit none integer*4 i,j,k,n,n6,na,nb,nmo,ni(*),nid(*),aij(*),bij(*), 1daij(*),dbij(*),nmo2,n22,ifix,nib(*),aijb(*),bijb(*) real*8 pre6(*),pred6(*),cij(*),dij(*),bp(*),bpd(*), 1u0(*),u0d(*),djg(*),cijb(*),djk(*),dlg(*),hd(*) real*8,allocatable::ut6(:,:) logical lopen allocate(ut6(n6,n)) do 305 j=1,n c precalculate b>: call getieab(pre6,pred6,lopen,na,nb,nmo,ni,nid,j,aij,bij,cij, 1daij,dbij,dij,bp,bpd,u0,u0d,nmo2,n6,n22) c diagonal dipole and gradient: call getdipole(ut6,n,cij,nmo,ni,aij,bij,dij,nid,daij,dbij,lopen, 1pre6,pred6,j,n6,n6,n22) c dlg=: " singlet (dsqrt(2)) call me(ni,nid,cij,dij,aij,daij,bij,dbij,j,lopen,djg,bp, 1bpd,nmo,nmo2,ifix,nib,cijb,aijb,bijb,n6,n22) do 3051 i=1,n6 c : dlg(i+n6*(j-1))=djg(i) c : 3051 hd(i+(j-1+n*(j-1))*6)=ut6(i,j) do 305 k=1,n if(k.ne.j)then c djk===> call dodjk(djk,n6,ni,k,aij,bij,n22,cij,pre6,lopen,daij, 1 dbij,pred6,nmo,dij,nid) do 3052 i=1,n6 3052 hd(i+(j-1+n*(k-1))*6)=djk(i) endif 305 continue write(6,*)' ... done' return end c ============================================================ subroutine writepol(a,s,EXCNM,gammaau) implicit none real*8 a(*),EXCNM,gammaau character*(*) s integer*4 IX,IY,IZ OPEN(90,FILE=s//'.TTT') if(s(1:1).eq.'A')then write(90,800)' A ',EXCNM,gammaau 800 format(a7,' w_exc = ',f12.4,' nm, Gamma_au = ',g12.4) write(90,902) 902 format( 1 ' XX XY YY XZ', 2 ' YZ ZZ') do 1 IX=1,3 1 write(90,900)(a(IX+3*(IY-1)),IY=1,6) 900 format(9g14.6) else if(s(1:3).eq.'POL')then write(90,800)' Alpha',EXCNM,gammaau write(90,902) write(90,900)((a(IY+(IX-1)*3),IY=1,IX),IX=1,3) else if(s(1:2).eq.'GP')then write(90,800)'G ten/w',EXCNM,gammaau write(90,901) 901 format( 1 ' XX XY XZ YX', 2 ' YY YZ ZX ZY', 3 ' ZZ') write(90,900)((a(IX+(IY-1)*3),IY=1,3),IX=1,3) else if(s(1:2).eq.'AB')then write(90,*)'Polarizability - magnetic field' write(90,901) do 2 IZ=1,3 write(90,903)IZ 903 format(' Field ',i2,':') 2 write(90,900)((a(IY+(IX-1)*3+9*(IZ-1)),IY=1,3),IX=1,3) else call report('Unknown polarizability requested') endif endif endif endif write(6,*)s//'.TTT written' return end c ============================================================ subroutine qbq(q,t) implicit none real*8 q(*),t(3,3) c POL.TTT order XX XY YY XZ YZ ZZ: q(1)=t(1,1) q(2)=t(1,2) q(3)=t(2,2) q(4)=t(1,3) q(5)=t(2,3) q(6)=t(3,3) return end c ============================================================ subroutine mcdis(e00,fac,np0,N,C,D,GP,LEXCL,u0,m0,g0,Gnj, 1LDD,THRC,lgnj,gnji,NQ,ddi,aai,rgnj,LUE,LUM) c mdci, but not 0->0', but 0->P c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c Gnj ... "MCD tensor" for this transition c gnji ... MCD tensor derivatives c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 N,LEXCL,ix,kk,np0,I,II, 1NQ,LEXP,les,NB real*8 FCsimple,e00,fac,ut(3),u0(*),ddi(*),Gnj(*), 1GP(N,N),proc,ds,enm,EJ,CM,THRC,qk,rs,gnji(*),gt(9),g0(*), 1m0(*),aai(*),mt(3),mcd,vt(3),q0(6),v0(3), 1C(N,N),D(N),estart,qkf, 1t,ed(3),md(3),gd(9),procold logical LDD,lgnj,rgnj,LUE,LUM integer*8 nt8,i8 integer*4,allocatable::si(:),sit(:),sd(:),sj(:), 1st(:),nn(:,:),nbi(:),is(:) real*8,allocatable::qt(:),EK(:) CM=219474.63d0 proc=0.0d0 procold=0.0d0 allocate(si(LEXCL+1),st(NQ),EK(NQ),is(NQ)) call viz(is,NQ) call viz(si,LEXCL+1) c read guess of the principal excited state: allocate(sd(NQ),qt(NQ)) call rdgs(NQ,sd,qt,EK,NB) allocate(nn(NQ,NB),nbi(NQ)) c read the span of the quantum numbers: call rdts(nbi,nn,NQ,NB) estart=e00 do 100 ii=1,NQ 100 estart=estart+EK(ii)*CM nt8=1 do 1 ii=1,NQ 1 nt8=int(nt8,8)*int(nbi(ii),8) write(6,*)nt8,' terms' if(rgnj)call rdgnj(Gnj,u0,m0,q0,v0) c pre-calculate u - du/dQ Qt do 1211 ix=1,3 ed(ix)=u0(ix) 1211 md(ix)=m0(ix) c do 121 ix=1,3 c do 121 kk=1,NQ c ed(ix)=ed(ix)-ddi(ix+3*(kk-1))*qt(kk) c21 md(ix)=md(ix)-aai(ix+3*(kk-1))*qt(kk) c MCD tensor: do 124 ix=1,9 if(lgnj)then gd(ix)=g0(ix) else gd(ix)=Gnj(ix) endif do 124 kk=1,NQ 124 gd(ix)=gd(ix)-gnji(ix+9*(kk-1))*qt(kk) write(6,9009)ed,md,gd,e00,estart,lgnj,LDD,THRC 9009 format(/,' mcdis:',/, 1' u0 : ',3g12.4,/, 1' m0 : ',3g12.4,/, 1' G0 : ',9g12.4,/, 1' e00: ',g12.4,' estart: ',g12.4,' cm-1',/, 1' lgnj LDD: ',2l3,/, 1' THRC: ',g12.4) call inispec(42,'MCDI.TAB','MCD vibrational') call inispec(43,'ECDI.TAB','ECD vibrational') do 2 i8=1,nt8 if(proc.gt.procold+0.1d0)then write(6,6000)i8,proc 6000 format(i20,f9.4,'%') procold=proc endif c decipher the state for term i8: call getis(i8,is,st,NQ,nn,NB,nbi) c rewrite st into short form in sj: LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sit,LEXP+2) call puts(NQ,st,sj) c calculate its energy: EJ=estart DO 1002 II=1,LEXP 1002 EJ=EJ+GP(sj(II),sj(II))*CM c <0|*>: t=FCsimple(fac,sj,LEXP,np0,C,D,N) if(dabs(t).gt.1.0d-13)then c ------------------------------------------------------------ proc=proc+100.0d0*t**2 c transition el and magn dipole c <0|u|*>=u0<0|*>+du/dQk<0|Qk-Qt|*> c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) do 14 ix=1,3 ut(ix)=ed(ix)*t 14 mt(ix)=md(ix)*t if(lgnj)then do 3 ix=1,9 3 Gt(ix)=gd(ix)*t endif if(LDD)then do 15 kk=1,NQ qk=qkf(sj,LEXP,kk,fac,sit,0,C,D,N,np0,GP) if(LUE)then ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif if(LUM)then mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk endif if(lgnj)then Gt(1)=Gt(1)+gnji(1+9*(kk-1))*qk Gt(2)=Gt(2)+gnji(2+9*(kk-1))*qk Gt(3)=Gt(3)+gnji(3+9*(kk-1))*qk Gt(4)=Gt(4)+gnji(4+9*(kk-1))*qk Gt(5)=Gt(5)+gnji(5+9*(kk-1))*qk Gt(6)=Gt(6)+gnji(6+9*(kk-1))*qk Gt(7)=Gt(7)+gnji(7+9*(kk-1))*qk Gt(8)=Gt(8)+gnji(8+9*(kk-1))*qk Gt(9)=Gt(9)+gnji(9+9*(kk-1))*qk endif 15 continue endif c LDD vt(1)=0.0d0 vt(2)=0.0d0 vt(3)=0.0d0 c vt(1)=Gt(2+3*(3-1))-Gt(3+3*(2-1)) c vt(2)=Gt(3+3*(1-1))-Gt(1+3*(3-1)) c vt(3)=Gt(1+3*(2-1))-Gt(2+3*(1-1)) ds =ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3) rs =ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3) mcd=ut(1)*vt(1)+ut(2)*vt(2)+ut(3)*vt(3) if(dabs(ds).gt.THRC)then nt8=nt8+1 enm=1.0d7/EJ write(42,5501)nt8,enm,ds,mcd,proc 5501 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',$) do 42 i=1,LEXP 42 write(42,5502)sj(i) 5502 format(i3,$) write(42,*) write(43,5501)nt8,enm,ds,rs ,proc do 43 i=1,LEXP 43 write(43,5502)sj(i) write(43,*) endif c ------------------------------------------------------------ endif 2 deallocate(sj,sit) write(42,3002) write(43,3002) 3002 format(80(1h-)) close(42) close(43) c return end c ============================================================== subroutine rdts(nbi,nn,NQ,NB) implicit none integer*4 NQ,NB,nbi(*),nn(NQ,NB),i,k open(9,file='PSTATE.TAB',status='old') do 1 i=1,NQ 1 read(9,*)nbi(i),nbi(i),nbi(i),(nn(i,k),k=1,nbi(i)) close(9) return end c ============================================================== subroutine getis(i8,is,st,NQ,nn,NB,nbi) implicit none integer*4 is(*),st(*),NQ,NB,nn(NQ,NB),nbi(*),ii,k,kk integer*8 i8,isum,ifa,ifa2 do 21 ii=NQ,1,-1 isum=i8-int(1,8) do 221 k=1,NQ-ii ifa=int(nbi(1),8) do 223 kk=2,NQ-k 223 ifa=ifa*int(nbi(kk),8) 221 isum=isum-ifa*int(is(NQ-k+1)-1,8) ifa2=1 do 222 k=1,ii-1 222 ifa2=ifa2*int(nbi(k),8) 21 is(ii)=int(isum/ifa2+int(1,8),4) do 224 k=1,NQ 224 st(k)=nn(k,is(k)) return end c ============================================================== function FCsimple(fac,si,Nexc,np0,C,D,N) c FC = Franc Condon factor for <0|si> c fac = <0|0*> c np0 ... dimension of working buffer implicit none integer*4 si(*),Nexc,np,iex,ii,nu,jj,ip,N,ic,jold, 1nuj,jc,kk,np0,iq,jq real*8 FCsimple,fac,D(*),C(N,N),pini real*8,allocatable::p(:) integer*4,allocatable::NN(:),ie(:,:),it(:) np=1 allocate(p(np0),NN(np0),ie(np0,Nexc),it(np0)) p(np)=1.0d0 NN(np)=Nexc do 102 iex=1,NN(np) 102 ie(np,iex)=si(iex) c expand reccurent formula into a sum and shrink back to <0|0> 777 do 101 ii=1,np c term ii - reduce excitation one by one: pini=p(ii) do 101 iex=1,NN(ii) iq=ie(ii,iex) if(iq.gt.0)then c <0| si_nu> reduce to <0| i-1>, <0|i-2>, <0|i-1,j-1>(j<>i) nu=0 do 1032 jj=1,NN(ii) 1032 if(ie(ii,jj).eq.iq)nu=nu+1 c write term <0|v'-1_iex> into string it: ip=0 ic=0 do 1031 jj=1,NN(ii) if(iq.eq.ie(ii,jj).and.ic.lt.1)then ic=ic+1 else ip=ip+1 it(ip)=ie(ii,jj) endif 1031 continue c call digestsi(np,ie,np0,Nexc,p,NN,it,NN(ii)-1, 1 pini*D(iq)/dsqrt(dble(2*nu))) if(nu.gt.1)then c write term <0|v'-2_iex> into string it: ic=0 ip=0 do 1033 jj=1,NN(ii) if(ie(ii,jj).eq.iq.and.ic.lt.2)then ic=ic+1 else ip=ip+1 it(ip)=ie(ii,jj) endif 1033 continue call digestsi(np,ie,np0,Nexc,p,NN,it,NN(ii)-2, 1 pini*dsqrt(dble(nu-1)/dble(nu))*C(iq,iq)) endif jold=0 do 106 jj=1,NN(ii) jq=ie(ii,jj) if(jq.ne.iq.and.jq.ne.jold)then nuj=0 do 1034 kk=1,NN(ii) 1034 if(jq.eq.ie(ii,kk))nuj=nuj+1 c write term <0|v'-1_iex-1_j, j<>iex> into it: ic=0 jc=0 ip=0 do 1035 kk=1,NN(ii) if(ie(ii,kk).eq.iq.and.ic.lt.1)then ic=ic+1 else if(ie(ii,kk).eq.jq.and.jc.lt.1)then jc=jc+1 else ip=ip+1 it(ip)=ie(ii,kk) endif endif 1035 continue call digestsi(np,ie,np0,Nexc,p,NN,it,NN(ii)-2, 1 pini*dsqrt(dble(nuj)/dble(nu))*C(iq,jq)) endif 106 jold=jq c eliminate the old term and start over do 105 jj=ii,np-1 p(jj)=p(jj+1) NN(jj)=NN(jj+1) do 105 kk=1,NN(jj) 105 ie(jj,kk)=ie(jj+1,kk) np=np-1 goto 777 endif 101 continue if(np.ne.1)call report('np <> 1') FCsimple=p(1)*fac return end c ============================================================== subroutine digestsi(np,ie,np0,LEXCL,p,NN,it,iexc,T) implicit none integer*4 je,np,np0,LEXCL,NN(*),it(*),ie(np0,LEXCL),jj,iexc, 1jejesi real*8 T,p(*) c does it exist already within 1 ... np?: je=jejesi(np,iexc,it,NN,ie,np0,LEXCL) if(je.ne.0)then c the term already exist in the expansion as je^th - just add it p(je)=p(je)+T else c term not found - add as new term np=np+1 if(np.gt.np0)then write(6,*)np,np0 call report('digestsi-too many terms') endif p(np)=T NN(np)=iexc do 1 jj=1,iexc 1 ie(np,jj)=it(jj) endif return end c ============================================================== function jejesi(np,nx,it,NN,ee,np0,LEXCL) implicit none integer*4 np,nx,it(*),NN(*),np0,LEXCL,ee(np0,LEXCL),je,jejesi 1,jj,ie je=0 do 104 jj=1,np if(nx.ne.NN(jj))goto 104 do 1041 ie=1,NN(jj) 1041 if(it(ie).ne.ee(jj,ie))goto 104 je=jj goto 1042 104 continue 1042 jejesi=je return end c ============================================================== subroutine dofac(NQ,fac,J,JT,F,FI,G,GP,K) integer*4 NQ real*8 fac,G(NQ,NQ),GP(NQ,NQ),K(*),lT,lF,LOGDET,lQ,sp1,sp2, 1F(NQ,NQ),J(NQ,NQ),JT(NQ,NQ),FI(NQ,NQ),lJ,f1,sp real*8,allocatable:: T(:,:),TV(:),TU(:) allocate(T(NQ,NQ),TV(NQ),TU(NQ)) call mm(T,G,GP,NQ) lT=LOGDET(T,NQ,NQ) lF=LOGDET(F,NQ,NQ) lJ=LOGDET(J,NQ,NQ) lQ=dble(NQ)*log(2.0d0) f1=exp((lQ+lt/2.0d0+lJ-lF)/2.0d0) call mv(TV,G ,K ,NQ,NQ) sp1=sp(K,TV,NQ) call mv(TU,G ,K ,NQ,NQ) call mv(TV,JT,TU,NQ,NQ) call mv(TU,FI,TV,NQ,NQ) call mv(TV,J ,TU,NQ,NQ) call mv(TU,G ,TV,NQ,NQ) sp2=sp(K,TU,NQ) fac=f1*exp(-0.50d0*(sp1-sp2)) return end c ============================================================== subroutine ecdic(e00,fac,N,C,D,GP,nproc,u0,m0,LQ1, 1THRC,HW,NQ,ddi,aai,NQ1,winm,wanm,fwnm,kelvin,npx,ltab, 1lspec,lglg,mmax,th1,th2,icw) c ecdi with classes formalism c e00 ... energy of the 0-0 transition implicit none integer*4 nt,N,kk,NQ1,i,nproc,k1,NQ,m,mmax,mfc,ilm,ii, 1j,ns,LNQ,icw real*8 pp,e00,fac,u0(*),ddi(*),C(N,N),D(N), 1GP(N,N),prc,CM,THRC,qk,prc_,d2,d2l,ux,uy,uz,mx,my,mz, 1m0(*),aai(*),debye,clight,th1,th2,enq,vqkv0 logical LQ1,HW integer,allocatable::sm(:),wmax(:),NQs(:),wkl(:,:) c spectral variables: real*8 winm,wanm,fwnm,kelvin,FCOvI0 integer*4 npx logical ltab,lspec,lglg,InCl logical,allocatable::doe(:) real*8,allocatable::abso(:),cd(:),FCI1(:),cred(:,:),dred(:), 1enm(:),ds(:),rs(:),abso_(:),cd_(:) if(nproc.ne.0)call omp_set_num_threads(nproc) write(6,7878)ltab,LQ1,mmax,nproc,THRC,NQ1,NQ 7878 format(/,' Ecdic',/, 1 ' ^^^^~',/, 1 ' LTAB : ',l3,/, 1 ' LQ1 : ',l3,/, 1 ' MMAX : ',i3,/, 1 ' NPROC: ',i3,/, 1 ' THRC : ',g12.4,/, 1 ' NQ1 : ',i3,/, 1 ' NQ : ',i3,/) if(ltab)call inispec(43,'ECDI.TAB','ECD vibrational') if(lspec)then allocate(abso(npx),cd(npx),abso_(npx),cd_(npx)) call vz(abso,npx) call vz(cd ,npx) endif debye=2.541765d0 clight=137.035999139d0 CM=219474.63d0 nt=0 d2=debye**2 d2l=debye**2/clight prc=0.0d0 c threshold estimation allocate(wkl(NQ,NQ)) call estw(th1,th2,NQ,N,C,D,fac,wkl,prc,HW,icw) prc=0.0d0 do 77777 m=0,mmax ilm=max(1,m) allocate(sm(ilm),wmax(ilm),NQs(ilm),cred(ilm,ilm),dred(ilm)) C$OMP Parallel Do Schedule(Dynamic) Default(Shared) C$OMP+ Private(ii,prc_,sm,i,j,dred,cred,wmax,ns,FCI1,InCl,LNQ,NQs, C$OMP+ pp,ux,uy,uz,mx,my,mz,kk,qk,k1,ds,rs,enm,doe,abso_,cd_) do 22222 ii=1,mfc(NQ,m) abso_=0.0d0 cd_ =0.0d0 prc_=0.0d0 call getdis(ii,sm,NQ,m,ilm) do 65 i=1,m dred(i)=D(sm(i)) do 65 j=1,m 65 cred(i,j)=C(sm(i),sm(j)) do 60 i=1,m c maximal excitation for oscillator i in this class: wmax(i)=wkl(sm(i),sm(i)) do 61 j=1,m 61 if(j.ne.i.and. 1wkl(sm(i),sm(j)).lt.wmax(i))wmax(i)=wkl(sm(i),sm(j)) c 0-excited correspnds to wmax=1 60 wmax(i)=wmax(i)+1 ns=1 do 68 j=1,m 68 ns=ns*wmax(j) allocate(FCI1(ns),ds(ns),rs(ns),enm(ns),doe(ns)) c <0|e>: FCI1(i)=fac do 62 i=1,ns call FCA2NQ(m,i,wmax,InCl,LNQ,NQs) if(i.eq.1)then pp=fac else pp=FCOvI0(m,LNQ,i,NQs,wmax,DRed,CRed,FCI1) endif FCI1(i)=pp doe(i)=InCl if(InCl)then prc_=prc_+FCI1(i)**2 enm(i)=1.0d7/(e00+enq(LNQ,N,sm,GP,NQs)*CM) ux=u0(1)*pp uy=u0(2)*pp uz=u0(3)*pp mx=m0(1)*pp my=m0(2)*pp mz=m0(3)*pp if(LQ1)then do 15 kk=1,NQ qk=vqkv0(kk,N,m,GP,C,D,FCI1,ns,wmax,i,sm,LNQ,NQs) k1=kk+kk+kk-2 ux=ux+ddi( k1)*qk uy=uy+ddi(1+k1)*qk uz=uz+ddi(2+k1)*qk mx=mx+aai( k1)*qk my=my+aai(1+k1)*qk 15 mz=mz+aai(2+k1)*qk endif ds(i) =(ux*ux+uy*uy+uz*uz)*d2 if(dabs(ds(i)).gt.THRC)then rs(i) =(ux*mx+uy*my+uz*mz)*d2l if(lspec)call app(enm(i),ds(i),rs(i),abso_,cd_,winm,wanm,npx, 1 fwnm,lglg,2) else doe(i)=.false. endif endif 62 continue C$OMP Critical prc=prc+prc_ abso=abso+abso_ cd=cd+cd_ if(ltab)then do 3 i=1,ns if(doe(i).and.dabs(ds(i)).gt.THRC)then nt=nt+1 write(43,5501)nt,enm(i),ds(i),rs(i) 5501 format(i8,f10.2,2(' ',g13.4)) endif 3 continue endif C$OMP End Critical 22222 deallocate(FCI1,enm,ds,rs,doe) write(6,601)m,mfc(NQ,m),100.0d0*prc 601 format(' Class',i2,',',i12,' combinations,', 1' sum(e)<0|e> = ',g12.3,' %') 77777 deallocate(sm,wmax,NQs,cred,dred) c eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee if(ltab)then write(43,3002) close(43) 3002 format(80(1h-)) endif if(lspec)call c4546(winm,wanm,npx,abso,kelvin,'d',1) if(lspec)call c4546(winm,wanm,npx,cd ,kelvin,'r',2) return end c ============================================================== subroutine ecdi(e00,fac,np0,iwr,N,C,D,GP,LEXCL,u0,m0,LQ1,LDD, 1THRC,HW,NQ,ddi,aai,NQ1,LUE,LUM,winm,wanm,fwnm,kelvin,npx,ltab, 1lspec,lglg) c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ real*8 pp,FC,e00,fac,ut(3),u0(*),ddi(*),C(N,N),D(N),qkf, 1GP(N,N),proc,ds,enm,EJ,CM,THRC,qk,rs, 1m0(*),aai(*),mt(3),debye,clight logical LQ1,LDD,HW,LUE,LUM integer,allocatable::si(:),sit(:) c spectral variables: real*8 winm,wanm,fwnm,kelvin integer*4 npx logical ltab,lspec,lglg real*8,allocatable::abso(:),cd(:) write(6,7878)LEXCL,THRC,NQ1,NQ 7878 format(/,' Ecdi',/, 1 ' ^^^^',/,/, 1 ' LEXCL: ',i3,/, 1 ' THRC : ',g12.4,/, 1 ' NQ1 : ',i3,/, 1 ' NQ : ',i3,/) if(ltab)call inispec(43,'ECDI.TAB','ECD vibrational') if(lspec)then allocate(abso(npx),cd(npx)) call vz(abso,npx) call vz(cd ,npx) endif debye=2.541765d0 clight=137.035999139d0 CM=219474.63d0 proc=0.0d0 nt=0 c <0|0*>: nt=nt+1 proc=proc+100.0d0*fac**2 allocate(si(LEXCL+1),sit(LEXCL+2)) call viz(si,LEXCL+1) call viz(sit,LEXCL+2) c transition el and magn dipole <0|u|*>=u0<0|*>+du/dQk <0|Qk|*>,etc do 12 ix=1,3 mt(ix)=m0(ix)*fac 12 ut(ix)=u0(ix)*fac if(LQ1)then do 10 kk=1,NQ si(1)=kk c <0|Q*k|0*>=sqrt(h/(2*wk)) <0|1*k> pp=FC(fac,si,1,np0,iwr,C,D,N)/dsqrt(2.0d0*GP(kk,kk)) if(LDD)then if(LUE)then do 131 ix=1,3 131 ut(ix)=ut(ix)+ ddi(ix+3*(kk-1))*pp endif if(LUM)then do 132 ix=1,3 132 mt(ix)=mt(ix)+ aai(ix+3*(kk-1))*pp endif endif 10 if(HW)write(6,1600)kk,pp 1600 format('<0|Q_',i3,'|0*> = ',g13.4) endif ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight c cm-1 to nm: enm=1.0d7/e00 if(ltab)write(43,550)nt,enm,ds,rs ,proc if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) 550 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',10i3) c states Nexc excited if(NQ1.eq.0)NQ1=LEXCL do 30000 Nexc=1,LEXCL write(6,6001)Nexc,proc 6001 format(i5,f10.4,' %') c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c EJ=0.0d0 DO 1002 II=1,Nexc 1002 EJ=EJ+GP(si(II),si(II)) if(iwr.gt.1)write(6,604)ii,(si(iex),iex=1,NExc) 604 format(' state ',i2,':',10i3) c <0|*> pp=FC(fac,si,Nexc,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0 if(HW)then write(6,599) 599 format('<0|',$) do 107 I=1,Nexc 107 write(6,601)si(I) 601 format(i3,$) write(6,598) 598 format('>: ',$) write(6,602)pp,proc,EJ*CM 602 format(g12.4,' (',f10.3,'%), E= ',F10.2) endif c <0|u|*>=u0<0|*>+du/dQk<0|Qk|*> do 14 ix=1,3 ut(ix)=u0(ix)*pp 14 mt(ix)=m0(ix)*pp if(LQ1)then if(LDD)then do 15 kk=1,NQ c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) qk=qkf(si,Nexc,kk,fac,sit,iwr,C,D,N,np0,GP) if(LUE)then ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif if(LUM)then mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk endif 15 continue endif c LDD endif c LQ1 ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight if(dabs(ds).gt.THRC)then nt=nt+1 enm=1.0d7/(e00+EJ*CM) if(ltab)then write(43,5501)nt,enm,ds,rs ,proc 5501 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',$) do 43 i=1,Nexc 43 write(43,5502)si(i) 5502 format(i3,$) write(43,*) endif if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) endif c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue write(6,6002)proc 6002 format(' Total ',f10.4,' %') if(ltab)then write(43,3002) close(43) 3002 format(80(1h-)) endif if(lspec)call c4546(winm,wanm,npx,abso,kelvin,'d',1) if(lspec)call c4546(winm,wanm,npx,cd ,kelvin,'r',2) return end c ============================================================ subroutine ecdis(e00,fac,np0,N,C,D,GP,LEXCL,u0,m0, 1LDD,THRC,NQ,ddi,aai, 1winm,wanm,fwnm,kelvin,npx,ltab,lspec,lglg) c mdci, but not 0->0', but 0->P c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 N,LEXCL,ix,kk,np0,I,II, 1NQ,LEXP,les,NB real*8 FCsimple,e00,fac,ut(3),u0(*),ddi(*),GP(N,N),proc,ds,enm, 1EJ,CM,THRC,qk,rs,debye,clight,m0(*),aai(*),mt(3),qkf, 1C(N,N),D(N),estart,t,ed(3),md(3),procold,ejs logical LDD integer*8 nt8,i8 integer*4,allocatable::si(:),sit(:),sd(:),sj(:), 1st(:),nn(:,:),nbi(:),is(:) real*8,allocatable::qt(:),EK(:) c spectral variables: real*8 winm,wanm,fwnm,kelvin integer*4 npx logical ltab,lspec,lglg real*8,allocatable::abso(:),cd(:) if(ltab)call inispec(43,'ECDI.TAB','ECD vibrational') if(lspec)then allocate(abso(npx),cd(npx)) call vz(abso,npx) call vz(cd ,npx) endif debye=2.541765d0 clight=137.035999139d0 CM=219474.63d0 proc=0.0d0 procold=0.0d0 allocate(si(LEXCL+1),st(NQ),is(NQ)) call viz(is,NQ) call viz(si,LEXCL+1) c read guess of the principal excited state from PSTATE: allocate(sd(NQ),qt(NQ),EK(NQ)) call rdgs(NQ,sd,qt,EK,NB) c read the span of the quantum numbers from PSTATE.TAB: allocate(nn(NQ,NB),nbi(NQ)) call rdts(nbi,nn,NQ,NB) estart=e00 do 100 ii=1,NQ 100 estart=estart+EK(ii)*CM nt8=1 do 1 ii=1,NQ 1 nt8=int(nt8,8)*int(nbi(ii),8) write(6,*)nt8,' terms' c pre-calculate u - du/dQ Qt do 1211 ix=1,3 ed(ix)=u0(ix) 1211 md(ix)=m0(ix) write(6,9009)ed,md,e00,estart,LDD,THRC 9009 format(/,' ecdis:',/, 1' u0 : ',3g12.4,/, 1' m0 : ',3g12.4,/, 1' e00: ',g12.4,' estart: ',g12.4,' cm-1',/, 1' LDD: ',l3,/, 1' THRC: ',g12.4) do 2 i8=1,nt8 if(proc.gt.procold+0.1d0)then write(6,6000)i8,proc 6000 format(i20,f9.4,'%') procold=proc endif c decipher the state for term i8: call getis(i8,is,st,NQ,nn,NB,nbi) c rewrite st into short form in sj: LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sit,LEXP+2) call puts(NQ,st,sj) c calculate its energy: EJ=estart+ejs(sj,LEXP,GP,N)*CM c <0|*>: t=FCsimple(fac,sj,LEXP,np0,C,D,N) if(dabs(t).gt.1.0d-13)then c ------------------------------------------------------------ proc=proc+100.0d0*t**2 c transition el and magn dipole c <0|u|*>=u0<0|*>+du/dQk<0|Qk-Qt|*> c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) ut(1)=ed(1)*t ut(2)=ed(2)*t ut(3)=ed(3)*t mt(1)=md(1)*t mt(2)=md(2)*t mt(3)=md(3)*t if(LDD)then do 15 kk=1,NQ qk=qkf(sj,LEXP,kk,fac,sit,0,C,D,N,np0,GP) ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk 15 continue endif c LDD ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight if(dabs(ds).gt.THRC)then nt8=nt8+1 enm=1.0d7/EJ if(ltab)then write(43,5501)nt8,enm,ds,rs ,proc 5501 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',$) do 43 i=1,LEXP 43 write(43,5502)sj(i) 5502 format(i3,$) write(43,*) endif if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) endif c ------------------------------------------------------------ endif 2 deallocate(sj,sit) if(ltab)then write(43,3002) close(43) 3002 format(80(1h-)) endif if(lspec)call c4546(winm,wanm,npx,abso,kelvin,'d',1) if(lspec)call c4546(winm,wanm,npx,cd ,kelvin,'r',2) return end c ============================================================== subroutine rrri(e00,fac,np0,iwr,N,A,B,C,D,E,G,GP, 1u0,m0,v0,q0,ddi,aai,qqi,vvi,LDD,THRC,NQ, 2LEXCF,EXCNM,gammaau,NQ1,wrax,wrin,npx,lglg,fwhh,ltab, 3reram,reroa,nroot,lvert,lwzero,wzero,kelvin,NQBUF, 1vrroa,anroa,frroa,sr,lwten,lvel,ldo) c resonance Raman and ROA spectra - optimized routine c |0> -> |P> -> |f>, P ... states of biggest overlap with grouns c e00 ... energy of the 0-0 transition in cm-1 c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug implicit none integer*4 nt,N,ix,kk,np0,NQ1,II,ic, 1iwr,NQ,LEXCF,npx,nroot,NQBUF,IQBUF,LEXP,NEXC0, 1les,NB,ns0 integer*8 nt8,i8 parameter (NEXC0=100,ns0=19) real*8 e00,fac,ut(3),u0(*),ddi(*),A(N,N),B(*),C(N,N),D(N), 1E(N,N),G(N,N),GP(N,N),proc,EJ,CM,THRC,qk,m0(*),aai(*),estart, 1gammaau,q0(*),v0(*),qqi(*),vvi(*),EXCNM,wrax,wrin,tb,procold, 1fwhh,reram(*),reroa(*),wzero,kelvin,ed(3),t,FCSimple,e00au,qkf, 1sr(npx,2,ns0) logical LDD,lglg,ltab,lvert,lwzero,anroa,vrroa,frroa,lwten,lvel, 1ldo(ns0) integer*4,allocatable::sit(:),s0(:),sd(:), 1st(:),sib(:,:),Nexcb(:),sj(:),nn(:,:),nbi(:),is(:) real*8,allocatable::utb(:,:),tbb(:),qt(:),eb(:),EK(:) CM=219474.63d0 proc=0.0d0 procold=0.0d0 e00au=e00/CM allocate(s0(1),st(NQ),is(NQ)) call viz(is,NQ) s0(1)=0 c initialize the buffer with states providing the c largest <0|u|*> dipole: allocate(sib(NQBUF,NEXC0),utb(NQBUF,15),tbb(NQBUF),Nexcb(NQBUF), 1eb(NQBUF)) Nexcb=0 eb =0.0d0 tbb=0.0d0 utb=0.0d0 sib=0 IQBUF=0 write(6,600)nroot,0,LEXCF,lwzero,wzero,lvert, 1wrin,wrax,npx,lglg,fwhh,ltab,kelvin,gammaau,N,NQ,EXCNM, 11.0d7/e00,NQBUF,THRC,frroa,lwten 600 format(/,' Rrri',/, 1 ' ^^^^',/,/, 1 ' Resonance ROA calculation - fast, ldis = .true.',/, 1 ' --------------------------------------',/, 1 ' Root : ',i3,/, 1 ' Maximal exc. start : ',i3,/, 1 ' Maximal exc. final : ',i3,/, 1 ' lwzero : ',l3,/, 1 ' wzero : ',f12.3,/, 1 ' lvert : ',l3,/, 1 ' wmin / cm-1 : ',f12.3,/, 1 ' wmax / cm-1 : ',f12.3,/, 1 ' Number of points : ',i5,/, 1 ' Gaussian profile : ',l3,/, 1 ' FWHH / cm-1 : ',f12.3,/, 1 ' write RROA.TAB : ',l3,/, 1 ' Temperature / K : ',f12.3,/, 1 ' gamma / hartree : ',f12.3,/, 1 ' N : ',i3,/, 1 ' NQ : ',i3,/, 1 ' w_exc nm : ',f12.3,/, 1 ' w0 nm : ',f12.3,/, 1 ' NQBUF : ',i12,/, 1 ' threshold : ',g12.2,/, 1 ' frroa : ',l3,/, 1 ' lwten : ',l3,/, 1 '---------------------------') c read guess of the principal excited state from PSTATE: allocate(sd(NQ),qt(NQ),EK(NQ)) call rdgs(NQ,sd,qt,EK,NB) LEXP=les(NQ,sd) write(6,*)LEXP,' - times excited' write(6,609)(sd(kk),kk=1,NQ) 609 format(20i3) c read the span of the quantum numbers from PSTATE.TAB: allocate(nn(NQ,NB),nbi(NQ)) call rdts(nbi,nn,NQ,NB) estart=e00au do 100 ii=1,NQ 100 estart=estart+EK(ii) nt8=1 do 1 ii=1,NQ 1 nt8=int(nt8,8)*int(nbi(ii),8) write(6,6100)estart*CM,nt8 6100 format(' Estart ',f10.2,' cm-1',i20,' terms') do 121 ix=1,3 121 ed(ix)=u0(ix) c do 121 kk=1,NQ c21 ed(ix)=ed(ix)-ddi(ix+3*(kk-1))*qt(kk) c c loop over all selected excited vib states do 2 i8=1,nt8 if(proc.gt.procold+0.1d0)then write(6,6000)i8,proc 6000 format(i20,f9.4,'%') procold=proc endif c decipher the state for term i8: call getis(i8,is,st,NQ,nn,NB,nbi) c rewrite st into short form in sj: LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sit,LEXP+2) call puts(NQ,st,sj) c calculate its energy: EJ=estart DO 1002 II=1,LEXP 1002 EJ=EJ+GP(sj(II),sj(II)) c <0|*>: t=FCsimple(fac,sj,LEXP,np0,C,D,N) if(dabs(t).gt.1.0d-13)then c ------------------------------------------------------------ proc=proc+t**2*100.0d0 c <0|u|*>=u0<0|*>+du/dQk<0|Qk|*> ut(1)=ed(1)*t ut(2)=ed(2)*t ut(3)=ed(3)*t if(LDD)then c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) do 15 kk=1,NQ qk=qkf(sj,LEXP,kk,fac,sit,iwr,C,D,N,np0,GP) ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk 15 ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif c if significant, store it in the buffer: tb=ut(1)**2+ut(2)**2+ut(3)**2 if(tb.gt.THRC)then if(IQBUF.lt.NQBUF)IQBUF=IQBUF+1 do 7 kk=1,NQBUF if(tb.gt.tbb(kk))then do 5 ic=NQBUF,kk+1,-1 eb (ic)=eb (ic-1) tbb (ic)=tbb (ic-1) utb (ic,1)=utb (ic-1,1) utb (ic,2)=utb (ic-1,2) utb (ic,3)=utb (ic-1,3) Nexcb(ic)=Nexcb (ic-1) do 5 ix=1,Nexcb (ic-1) 5 sib (ic,ix)=sib(ic-1,ix) eb (kk)=EJ tbb (kk)=tb utb (kk,1)=ut(1) utb (kk,2)=ut(2) utb (kk,3)=ut(3) Nexcb(kk)=LEXP if(LEXP.gt.NEXC0)call report('LEXP > NEXC0') do 3 ix=1,LEXP 3 sib (kk,ix)=sj(ix) goto 12001 endif 7 continue endif c ------------------------------------------------------------ endif 12001 deallocate(sj,sit) 2 continue write(6,*)IQBUF,' |0> -> |ve> dipoles stored' c do ic=1,IQBUF c write(6,900)eb(ic)*CM,(utb(ic,kk),kk=1,3) c00 format(f12.2,3g12.4) c enddo c stop c add magnetic dipoles and quadrupoles: call addmq(NQBUF,N,NQ,np0,IQBUF,iwr,NExcb,NEXC0-1,sib,LDD, 1sit,C,D,fac,GP,utb,v0,m0,q0,vvi,aai,qqi,NEXC0) c sum final states for 0 -> * -> f call downi(s0,0,sib,Nexcb,LEXCF,utb,IQBUF,u0,m0,q0, 1v0,fac,np0,iwr,A,B,C,D,E,N,LDD,NQ,G,GP,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1qt,.true.,vrroa,anroa,NQBUF,NEXC0,eb,frroa,sr,lwten,lvel,ldo) return end c ============================================================ subroutine downi(si,ni,seb,neb,lf,utb,IQBUF,u0,m0,q0,v0, 1fac,np0,iwr,A,B,C,D,E,N,LDD,NQ,G,GP,EXCNM,gammaau,NQ1,THRC,nt, 1ddi,aai,vvi,qqi,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1qt,ldis,vrroa,anroa, 1NQBUF,NEXC0,eb,frroa,sr,lwten,lvel,ldo) c simplified downexcf, just transition polarizabilities c compute all down transitions from se(ne,e) c transition moments 0 -> ev: ut,mt,qt,mt c faster version with a buffer of transitions c IQBUF ... number of buffer elements c NQBUF ... dimension implicit none integer*4 ne,lf,ix,NExf,np0,iwr,N,NQ,kk,neb(*),ib, 1ic,NQ1,si(*),ni,nt,I,icen,iex,II,npx,ns0, 1IQBUF,NQBUF,NEXC0,seb(NQBUF,NEXC0),ni0 parameter (ns0=19,ni0=13) integer,allocatable::sf(:),st(:) real*8 uf(3),mf(3),qf(6),vf(3),EXCNM,ei,ef,u(3,3),inv(ni0), 1FC1,fac,A(N,N),B(*),C(N,N),D(*),E(N,N),pp,qk,GP(N,N),wef, 1G(N,N),gammaau,THRC,u0(*),m0(*),q0(*),v0(*),qke, 1ddi(*),aai(*),vvi(*),qqi(*),CM,wrax,wrin,fwhh, 1reram(*),reroa(*),qt(*),ed(3),vd(3),md(3),qd(6), 1w,utb(NQBUF,15),eb(*),sr(npx,2,ns0), 1lr(3,3),li(3,3),gr(3,3),gi(3,3),ar(3,3,3),ai(3,3,3), 1vr(3,3),vi(3,3),ee,wei,avr(3,3),avi(3,3), 1alr(3,3),ali(3,3),gtr(3,3),gti(3,3),gcr(3,3),gci(3,3), 1atr(3,3,3),ati(3,3,3),acr(3,3,3),aci(3,3,3), 1ui(3),uvi(3),mi(3),uqi(6),uu(3,3),alur(3,3),alui(3,3) logical LDD,ltab,lglg,ldis,anroa,vrroa,frroa,lwten,lvel,ldo(ns0) integer,allocatable::se(:) write(6,6700)IQBUF,anroa,LDIS,vrroa,lf,frroa,lwten 6700 format(/,' Downexcf',/, 1 ' IQBUF = ',i7,' anroa = ',l7,/, 1 ' LDIS = ',l7,' vrroa = ',l7,/, 1 ' lf = ',i7,' frroa = ',l7,/, 1 ' lwten = ',l7) CM=219474.63d0 c excitation frequency in atomic units: w=(1.0d7/EXCNM)/CM c initial state ei=0.0d0 do 21 i=1,ni 21 ei=ei+G(si(i),si(i)) c immediate states: allocate(se(NEXC0),st(NEXC0+2)) call viz(st,NEXC0+2) c sf ... final state allocate(sf(lf+1)) do 122 ix=1,3 ed(ix )=u0(ix ) vd(ix )=v0(ix ) md(ix )=m0(ix ) qd(ix )=q0(ix ) 122 qd(ix+3)=q0(ix+3) if(ldis)then c if expansion around qt precalculated ed etc, c u(q')=u(qt)+du/dq' (q'-qt) c pre-calculate u - du/dQ Qt do 121 kk=1,NQ do 121 ix=1,3 ed(ix )=ed(ix )-ddi(ix +3*(kk-1))*qt(kk) vd(ix )=vd(ix )-aai(ix +3*(kk-1))*qt(kk) md(ix )=md(ix )-vvi(ix +3*(kk-1))*qt(kk) qd(ix )=qd(ix )-qqi(ix +6*(kk-1))*qt(kk) 121 qd(ix+3)=qd(ix+3)-qqi(ix+3+6*(kk-1))*qt(kk) endif c record <0 ... 1> polarizabilities into FILE.Q.res.TTT open(22,file='FILE.Q.res.TTT') write(22,2001)NQ 2001 FORMAT(' ROA tensors, normal modes derivatives',/,I4,' modes',/, 1' The electric-dipolar electric-dipolar polarizability:',/, 2 ' mode e(cm-1) jx jy jz') c make |f> states: if(NQ1.eq.0)NQ1=lf c sf <> |0>: do 30000 Nexf=1,lf c distribute excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexf 41 sf(iex)=1 50000 do 11000 I=1,Nexf icen=1 do 11000 II=I+1,Nexf if(sf(II).eq.sf(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c state energy: ef=0.0d0 DO 1002 II=1,Nexf 1002 ef=ef+G(sf(II),sf(II)) write(6,*)(sf(II),II=1,Nexf) c skip if outside required range: if((ef-ei)*CM.gt.wrax)goto 12000 c zero-out transition polarizabilities : call bzz(lr,li,vr,vi,gr,gi,ar,ai,alr,ali,gtr,gti,gcr,gci, 1atr,ati,acr,aci,avr,avi) c calculate polarizabilities from a buffer of excited states |e>: do 34 ib=1,IQBUF ee=eb(ib) ne=neb(ib) do 342 i=1,3 c <0|u|e>, etc.: ui( i)=utb(ib, i) uvi( i)=utb(ib, 3+i) mi( i)=utb(ib, 6+i) uqi( i)=utb(ib, 9+i) 342 uqi(3+i)=utb(ib,12+i) call tqq(uqi,uu) do 35 i=1,ne 35 se(i)=seb(ib,i) wei=ee-ei wef=ee-ef c =: pp=FC1(fac,sf,se,Nexf,ne,np0,iwr,A,B,C,D,E,N) c =u0+du/dQk c (if ldis =(u0-du/dQ Qt)+du/dQk do 14 ix=1,3 uf(ix )=ed(ix)*pp vf(ix )=vd(ix)*pp mf(ix )=md(ix)*pp qf(ix )=qd(ix)*pp 14 qf(ix+3)=qd(ix+3)*pp c : if(LDD)then do 15 kk=1,NQ qk=qke(sf,se,Nexf,ne,kk,fac,st,iwr,A,B,C,D,E,N,np0,GP) do 15 ix=1,3 uf(ix )=uf(ix )+ddi(ix+ 3*(kk-1))*qk vf(ix )=vf(ix )+vvi(ix+ 3*(kk-1))*qk mf(ix )=mf(ix )+aai(ix+ 3*(kk-1))*qk qf(ix )=qf(ix )+qqi(ix+ 6*(kk-1))*qk 15 qf(ix+3)=qf(ix+3)+qqi(ix+3+6*(kk-1))*qk endif c transcript quadrupole to traceless one: call tqq(qf,u) if(frroa)call dzz(ui,uvi,mi,uu,uf,vf,mf,u,alr,ali,avr,avi, 1gtr,gti,gcr,gci,atr,ati,acr,aci,wei,wef,w,gammaau,lvel) 34 call d1zz(w,wei,ui,uf,vf,mf,u,lr,li,vr,vi,gr,gi,ar,ai,gammaau) c use this for Raman intensities: call wrram2(ei,ef,THRC,nt,si,ni,Nexf, 1sf,EXCNM,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1lr,li,vr,vi,gr,gi,ar,ai) if(lvel)then alur=avr alui=avi else alur=alr alui=ali endif if(frroa)call wrram3(w,ei,ef,THRC,nt,si,ni,Nexf,sf,EXCNM,wrin, 1wrax,npx,lglg,fwhh,ltab,inv,alur,alui,gtr,gti,gcr,gci,atr,ati, 1acr,aci,sr,1.0d0,.true.,.true.,ldo,0.0d0,0.0d0) if(lwten)call wzz(w,ei,ef,alr,ali,gtr,gti,gcr,gci,atr,ati, 1acr,aci,avr,avi,inv) c find index to be changed 12000 do 80000 ic=Nexf,1,-1 80000 if(sf(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexf 10000 sf(i)=sf(ic)+1 sf(ic)=sf(ic)+1 c goto 50000 30000 continue close(22) return end c ============================================================ function ejs(sj,Nj,GP,N) implicit none integer*4 sj(*),Nj,N,i real*8 ejs,a,GP(N,N) a=0.0d0 DO 1 i=1,Nj 1 a=a+GP(sj(i),sj(i)) ejs=a return end c ============================================================ function qkf(sj,Nj,kk,fac,sit,iwr,C,D,N,np0,GP) c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) implicit none integer*4 sj(*),sit(*),Nj,nuk,kk,iwr,ic,ip,ik,N,np0 real*8 qkf,pm,FC,fac,C(N,N),D(*),pp,GP(N,N) nuk=0 do 16 ic=1,Nj 16 if(sj(ic).eq.kk)nuk=nuk+1 if(nuk.gt.0)then ip=0 ik=0 do 17 ic=1,Nj if(sj(ic).eq.kk.and.ik.eq.0)then ik=ik+1 else ip=ip+1 sit(ip)=sj(ic) endif 17 continue pm=dsqrt(dble(nuk))*FC(fac,sit,Nj-1,np0,iwr,C,D,N) else pm=0.0d0 endif do 18 ic=1,Nj 18 sit(ic)=sj(ic) sit(Nj+1)=kk pp=dsqrt(dble(nuk+1))*FC(fac,sit,Nj+1,np0,iwr,C,D,N) qkf=(pm+pp)/dsqrt(2.0d0*GP(kk,kk)) return end c ============================================================ function qke(sf,se,Nexf,ne,kk,fac,st,iwr,A,B,C,D,E,N,np0,GP) c =sqrt(h/(2wk))(sqrt(vk)+sqrt(vk+1)) implicit none integer*4 sf(*),se(*),ne,kk,st(*),iwr,N,np0,nuk,ic,ip,ik,Nexf real*8 qke,fac,C(N,N),D(*),GP(N,N),A(N,N),B(*),E(N,N), 1pm,pp,FC1 nuk=0 do 16 ic=1,ne 16 if(se(ic).eq.kk)nuk=nuk+1 if(nuk.gt.0)then ip=0 ik=0 do 17 ic=1,ne if(se(ic).eq.kk.and.ik.eq.0)then ik=ik+1 else ip=ip+1 st(ip)=se(ic) endif 17 continue pm=dsqrt(dble(nuk))* 1 FC1(fac,sf,st,Nexf,ne-1,np0,iwr,A,B,C,D,E,N) else pm=0.0d0 endif do 18 ic=1,ne 18 st(ic)=se(ic) st(ne+1)=kk pp=dsqrt(dble(nuk+1))* 1FC1(fac,sf,st,Nexf,ne+1,np0,iwr,A,B,C,D,E,N) qke=(pm+pp)/dsqrt(2.0d0*GP(kk,kk)) return end c ============================================================ subroutine ecdid(e00,fac,np0,iwr,N,A,B,C,D,E,GP,LEXCL, 1u0,m0,LQ1,LDD,THRC,HW,NQ,ddi,aai,NQ1,LUE,LUM, 1winm,wanm,fwnm,kelvin,npx,ltab,lspec,lglg,loit) c excited states around PSTATE, c mdci, but not 0->0', but 0->P c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ,LEXP,Ni,Nj,les,NB,nem,emin,emax integer*8 nt8,i8 real*8 pp,FC,e00,fac,ut(3),u0(*),ddi(*),ejs,qkf, 1proc,ds,enm,EJ,CM,THRC,qk,rs,debye,clight, 1m0(*),aai(*),mt(3),FC1, 1A(N,N),B(*),C(N,N),D(*),E(N,N),GP(N,N), 1t0,t,ed(3),md(3),procold logical LQ1,LDD,HW,LUE,LUM,loit integer*4,allocatable::si(:),sit(:),sd(:),sj(:),sdn(:),sl(:), 1st(:),nn(:,:),nbi(:),ml(:),is(:),ste(:) real*8,allocatable::qt(:) c spectral variables: real*8 winm,wanm,fwnm,kelvin integer*4 npx logical ltab,lspec,lglg real*8,allocatable::abso(:),cd(:),EK(:) write(6,7878) 7878 format(/,' Ecdid',/, 1 ' ^^^^^',/) if(ltab)call inispec(43,'ECDI.TAB','ECD vibrational') if(lspec)then allocate(abso(npx),cd(npx)) call vz(abso,npx) call vz(cd ,npx) endif debye=2.541765d0 clight=137.035999139d0 CM=219474.63d0 proc=0.0d0 procold=0.0d0 nt=0 c <0|0*>: nt=nt+1 Ni=0 allocate(si(LEXCL+1),sl(NQ)) call viz(si,LEXCL+1) c read guess of the principal excited state: allocate(sd(NQ),sdn(NQ),qt(NQ),EK(NQ)) call rdgs(NQ,sd,qt,EK,NB) LEXP=les(NQ,sd) write(6,*)LEXP,' - times excited' do 6091 kk=1,NQ 6091 if(sd(kk).ne.0)write(6,609)kk,sd(kk) 609 format(i4,':',i3,$) write(6,*) allocate(sj(LEXP+1)) call viz(sj,LEXP+1) call puts(NQ,sd,sj) Nj=LEXP t0=FC1(fac,si,sj,Ni,Nj,np0,iwr,A,B,C,D,E,N)**2 write(6,607)'0',100.0d0*fac**2 write(6,607)'P',100.0d0*t0 607 format(' <0|',A1,'>: ',g12.4,' %') deallocate(sj) c rewrite initial guess to sdn: do 25 kk=1,NQ 25 sdn(kk)=sd(kk) c find maximum overlap state: if(loit)call fmaxo(NQ,t0,sdn,LEXP,fac,si,Ni,Nj,np0,iwr,N, 1A,B,C,D,E) c : LEXP=les(NQ,sdn) allocate(sj(LEXP+1)) call viz(sj,LEXP+1) call puts(NQ,sdn,sj) Nj=LEXP EJ=ejs(sj,Nj,GP,N) t=FC1(fac,si,sj,Ni,Nj,np0,iwr,A,B,C,D,E,N) write(6,607)'T',100.0d0*t**2 c number of excited modes: nem=0 do 102 kk=1,NQ 102 if(sdn(kk).ne.0)nem=nem+1 allocate(nn(nem,LEXCL+2),nbi(nem),ml(nem)) nem=0 c number of states: nt8=1 do 101 kk=1,NQ if(sdn(kk).ne.0)then nem=nem+1 ml(nem)=kk emin=max(0,sdn(kk)-LEXCL/2) emax=emin+LEXCL do 1011 ii=emin,emax 1011 nn(nem,ii-emin+1)=ii nbi(nem)=emax-emin+1 c make sure zero excitation is always included: if(emin.ne.0)then nbi(nem)=nbi(nem)+1 nn(nem,nbi(nem))=0 endif nt8=nt8*int(nbi(nem),8) endif 101 continue write(6,6071)nem,LEXCL,nt8 6071 format(' Number of excited modes explored:',i5,/, 1 ' LEXCL: ',i5,/, 1 ' Number of states: ',i20,/) do 121 ix=1,3 ed(ix)=u0(ix) 121 md(ix)=m0(ix) deallocate(sj) c >>>>>>>>>>>> <0|T'> <<<<<<<<<<<<<<<<<<<<<<<<<<<<< c transition el and magn dipole c <0|u|*>= (u0 - du/dQk Qtk) <0|*>+du/dQk <0|Qk|*>,etc c additional loop over the excited modes allocate(is(nem),ste(nem),st(NQ)) is=0 do 28 ii=1,NQ 28 st(ii)=sdn(ii) c systematic loop over excited states do 99998 i8=1,nt8 call getis(i8,is,ste,nem,nn,LEXCL+2,nbi) do 26 ii=1,nem 26 st(ml(ii))=ste(ii) do 6092 kk=1,NQ 6092 if(st(kk).ne.0)write(6,609)kk,st(kk) write(6,*) LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sj,LEXP+1) call viz(sit,LEXP+2) call puts(NQ,st,sj) Nj=LEXP EJ=ejs(sj,Nj,GP,N) t=FC1(fac,si,sj,Ni,Nj,np0,iwr,A,B,C,D,E,N) proc=proc+100.0d0*t**2 do 12 ix=1,3 ut( ix)=ed( ix)*t 12 mt( ix)=md( ix)*t if(LQ1)then do 10 kk=1,NQ c <0|Q*k|*>=sqrt(h/(2*wk)) [ sqrt(vk) <0|k-1> + sqrt(vk+1) <0|k+1> ]: pp=qkf(sj,Nj,kk,fac,sit,iwr,C,D,N,np0,GP) if(LDD)then if(LUE)then do 131 ix=1,3 131 ut(ix)=ut(ix)+ ddi(ix+3*(kk-1))*pp endif if(LUM)then do 132 ix=1,3 132 mt(ix)=mt(ix)+ aai(ix+3*(kk-1))*pp endif endif if(HW)write(6,1600)kk,pp 1600 format('<0|Q_',i3,'|*> = ',g13.4) 10 continue endif ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight c cm-1 to nm: enm=1.0d7/(e00+EJ*CM) if(ltab)then write(43,5501)nt,enm,ds,rs ,proc do 43 i=1,Nj 43 write(43,5502)sj(i) write(43,*) endif if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) deallocate(sj,sit) 99998 continue c >>>>>>>>>>>> <0|T'> (end) c >>>>>>>>>>>> Other transitions:' c states les(sdn)+/Nexc excited do 30000 Nexc=1,LEXCL write(6,6001)Nexc,proc 6001 format(i5,f10.4,' %') c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 continue c skip states when too many centers excited: if(NQ1.ne.0)then do 11000 I=1,Nexc icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 endif c skip states where the excited modes additionally excited: do 11001 I=1,Nexc do 11001 II=1,nem 11001 if(si(I).eq.ml(II))goto 12000 c transcript si (short notation) to sl (long) call trl(si,Nexc,sl,NQ) c additional loop over the excited modes do 99999 i8=1,nt8 do 29 ii=1,NQ 29 st(ii)=sl(ii) call getis(i8,is,ste,nem,nn,LEXCL+2,nbi) do 27 ii=1,nem 27 st(ml(ii))=st(ml(ii))+ste(ii) c rewrite final state st into short form in sj: LEXP=les(NQ,st) allocate(sj(LEXP+1),sit(LEXP+2)) call viz(sj,LEXP+1) call viz(sit,LEXP+2) call puts(NQ,st,sj) Nj=LEXP EJ=ejs(sj,Nj,GP,N) if(iwr.gt.1)write(6,604)ii,(sj(iex),iex=1,LEXP) 604 format(' state ',i2,':',10i3) c <0|*> pp=FC(fac,sj,Nj,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0 if(proc.gt.procold+1.0d0)then write(6,602)pp,proc,EJ*CM procold=proc endif if(HW.and.iwr.gt.1)then write(6,599) 599 format('<0|',$) do 107 I=1,LEXP 107 write(6,601)sj(I) 601 format(i3,$) write(6,598) 598 format('>: ',$) write(6,602)pp,proc,EJ*CM 602 format(g12.4,' (',f10.3,'%), E= ',F10.2) endif c <0|u|*>=u0<0|*>+du/dQk<0|Qk-Qt|*> c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) do 14 ix=1,3 ut(ix)=ed(ix)*pp 14 mt(ix)=md(ix)*pp if(LQ1)then if(LDD)then do 15 kk=1,NQ c <0|Qk|*>=sqrt(h/(2wk))(sqrt(vk)<0|*-1k>+sqrt(vk+1)<0|*+1k>) qk=qkf(sj,Nj,kk,fac,sit,iwr,C,D,N,np0,GP) if(LUE)then ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk endif if(LUM)then mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk endif 15 continue endif c LDD endif c LQ1 ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight if(dabs(ds).gt.THRC)then nt=nt+1 enm=1.0d7/(e00+EJ*CM) if(ltab)then write(43,5501)nt,enm,ds,rs ,proc 5501 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',$) do 44 i=1,Nj 44 write(43,5502)sj(i) 5502 format(i3,$) write(43,*) endif if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) endif deallocate(sj,sit) 99999 continue c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue write(6,602)pp,proc,EJ*CM c >>>>>>>>>>>> Other transitions:' if(ltab)then write(43,3002) close(43) 3002 format(80(1h-)) endif if(lspec)call c4546(winm,wanm,npx,abso,kelvin,'d',1) if(lspec)call c4546(winm,wanm,npx,cd ,kelvin,'r',2) return end c ============================================================ subroutine ecdb(e00,fac,np0,iwr,N,A,B,C,D,E,G,GP,LEXCL, 1u0,m0,LQ1,THRC,NQ,ddi,aai,NQ1, 1winm,wanm,fwnm,kelvin,npx,ltab,lspec,lglg) c e00 ... energy of the 0-0 transition c fac = <0|0*> c dimension of the expansion space c iwr .. extra writing for debug c lids ... a "dissociated" exci el state - read vibr guess from PSTATE implicit none integer*4 nt,N,LEXCL,ix,kk,np0,NQ1,NExc,iex,I,icen,II,ic, 1iwr,NQ,iexg,Ig,Nexcg,NL real*8 pp,FC,e00,fac,ut(3),u0(*),ddi(*),A(N,N),B(N),C(N,N),D(N), 1E(N,N),qkf,G(N,N),GP(N,N),proc,ds,enm,EJ,CM,THRC,qk,rs,kelvin,af, 1p,EJg,m0(*),aai(*),mt(3),debye,clight,tempau,qke,Q,ejs,FC1,ejsm logical LQ1 integer,allocatable::si(:),sit(:),st(:),sig(:),ml(:) c spectral variables: real*8 winm,wanm,fwnm integer*4 npx logical ltab,lspec,lglg real*8,allocatable::abso(:),cd(:) write(6,7878)LEXCL,THRC,NQ1,NQ,kelvin 7878 format(/,' Ecdb',/, 1 ' ^^^^',/,/, 1 ' LEXCL : ',i3,/, 1 ' THRC : ',g12.4,/, 1 ' NQ1 : ',i3,/, 1 ' NQ : ',i3,/, 1 ' Temp/K : ',f10.2,/) if(ltab)call inispec(43,'ECDI.TAB','ECD vibrational') if(lspec)then allocate(abso(npx),cd(npx)) call vz(abso,npx) call vz(cd ,npx) endif debye=2.541765d0 clight=137.035999139d0 CM=219474.63d0 proc=0.0d0 nt=0 tempau=kelvin/315777.0d0 allocate(si(LEXCL+1),sit(LEXCL+2),sig(LEXCL+1)) call viz(si,LEXCL+1) call viz(sit,LEXCL+2) call viz(sig,LEXCL+2) if(NQ1.eq.0)NQ1=LEXCL c immediate states: allocate(st(LEXCL+2)) call viz(st,LEXCL+2) c select low modes NL=0 allocate(ml(NQ)) do 1 i=1,NQ if(G(N,N).lt.tempau*4.0d0)then NL=NL+1 ml(NL)=i endif 1 continue write(6,500)NL 500 format(i4,' low modes') c CALCULATE PARTITION FUNCTION Q=0.0d0 c ground state Q=Q+1 c states Nexc excited do 30001 Nexc=1,LEXCL do 40001 iex=1,Nexc 40001 si(iex)=1 50001 do 11001 I=1,Nexc icen=1 do 11001 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11001 if(icen.gt.NQ1)goto 12001 EJ=ejsm(ml,si,Nexc,G,N) af=EJ/tempau if(af.lt.4.0d0)Q=Q+dexp(-af) 12001 do 80001 ic=Nexc,1,-1 80001 if(si(ic).lt.NL)goto 90001 goto 30001 90001 do 10001 i=ic+1,Nexc 10001 si(i)=si(ic)+1 si(ic)=si(ic)+1 goto 50001 30001 continue c GROUND STATE c GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG c GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG c c <0|0*>: p=1.0d0/Q write(6,609)Q,p 609 format(' Partition function: ',g12.4,/, 1 ' Ground state probability ',g12.4) nt=nt+1 c u0<0|0*>: do 12 ix=1,3 mt(ix)=m0(ix)*fac 12 ut(ix)=u0(ix)*fac c du/dQk <0|Qk|*>: if(LQ1)then do 10 kk=1,NQ si(1)=kk c <0|Q*k|0*>=sqrt(h/(2*wk)) <0|1*k> pp=FC(fac,si,1,np0,iwr,C,D,N)/dsqrt(2.0d0*GP(kk,kk)) do 10 ix=1,3 ut(ix)=ut(ix)+ ddi(ix+3*(kk-1))*pp 10 mt(ix)=mt(ix)+ aai(ix+3*(kk-1))*pp endif ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 *p rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight*p proc=proc+100.0d0*fac**2*p c cm-1 to nm: enm=1.0d7/e00 if(ltab)write(43,550)nt,enm,ds,rs ,proc if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) 550 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',10i3) c c <0|J*>: c states Nexc excited if(NQ1.eq.0)NQ1=LEXCL do 30000 Nexc=1,LEXCL write(6,6001)Nexc,proc 6001 format(i5,f10.4,' %') c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexc 41 si(iex)=1 50000 do 11000 I=1,Nexc icen=1 do 11000 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c EJ=ejs(si,Nexc,GP,N) c <0|J*>: pp=FC(fac,si,Nexc,np0,iwr,C,D,N) proc=proc+pp*pp*100.0d0*p c u0<0|*>: do 14 ix=1,3 ut(ix)=u0(ix)*pp 14 mt(ix)=m0(ix)*pp if(LQ1)then do 15 kk=1,NQ qk=qkf(si,Nexc,kk,fac,sit,iwr,C,D,N,np0,GP) ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk 15 mt(3)=mt(3)+aai(3+3*(kk-1))*qk endif c LQ1 ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 *p rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight*p if(dabs(ds).gt.THRC)then nt=nt+1 enm=1.0d7/(e00+EJ*CM) if(ltab)then write(43,5501)nt,enm,ds,rs ,proc 5501 format(i8,f10.2,2(' ',g13.4),' ',f10.2,'%',$) do 43 i=1,Nexc 43 write(43,5502)si(i) 5502 format(i3,$) write(43,*) endif if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) endif c c find index to be changed 12000 do 80000 ic=Nexc,1,-1 80000 if(si(ic).lt.NQ)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexc 10000 si(i)=si(ic)+1 si(ic)=si(ic)+1 c goto 50000 30000 continue write(6,6002)proc 6002 format(' Total ',f10.4,' %') c EXCITED STATES c EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE c EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE c c initial state loop: do 30002 Nexcg=1,LEXCL do 40002 iexg=1,Nexcg 40002 sig(iexg)=1 50002 do 11002 Ig=1,Nexcg icen=1 do 11002 II=Ig+1,Nexcg if(sig(II).eq.sig(I))icen=icen+1 11002 if(icen.gt.NQ1)goto 12002 EJg=ejsm(ml,sig,Nexcg,G,N) af=EJg/tempau if(af.lt.4.0d0)then p=dexp(-af)/Q c c u0 si(1)=0 c transition el and magn dipole <0|u|*>=u0<0|*>+du/dQk <0|Qk|*>,etc pp=FC1(fac,sig,si,Nexcg,0,np0,iwr,A,B,C,D,E,N) do 121 ix=1,3 mt(ix)=m0(ix)*pp 121 ut(ix)=u0(ix)*pp if(LQ1)then do 131 kk=1,NQ c du/dQk pp=qke(sig,si,Nexcg,0,kk,fac,st,iwr,A,B,C,D,E,N,np0,GP) do 131 ix=1,3 ut(ix)=ut(ix)+ ddi(ix+3*(kk-1))*pp 131 mt(ix)=mt(ix)+ aai(ix+3*(kk-1))*pp endif ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 *p rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight*p c cm-1 to nm: enm=1.0d7/e00 if(ltab)write(43,550)nt,enm,ds,rs ,proc if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) c final state loop: do 30003 Nexc=1,LEXCL write(6,6001)Nexc,proc c distribute Nexc excitations upon centers 1..NQ: c initial indices - all to the first center: do 411 iex=1,Nexc 411 si(iex)=1 50003 do 11003 I=1,Nexc icen=1 do 11003 II=I+1,Nexc if(si(II).eq.si(I))icen=icen+1 11003 if(icen.gt.NQ1)goto 12003 c EJ=ejs(si,Nexc,GP,N) c pp=FC1(fac,sig,si,Nexcg,Nexc,np0,iwr,A,B,C,D,E,N) proc=proc+pp*pp*100.0d0*p c u0 do 142 ix=1,3 ut(ix)=u0(ix)*pp 142 mt(ix)=m0(ix)*pp if(LQ1)then do 151 kk=1,NQ c qk=qke(sig,si,Nexcg,Nexc,kk,fac,st,iwr,A,B,C,D,E,N,np0,GP) ut(1)=ut(1)+ddi(1+3*(kk-1))*qk ut(2)=ut(2)+ddi(2+3*(kk-1))*qk ut(3)=ut(3)+ddi(3+3*(kk-1))*qk mt(1)=mt(1)+aai(1+3*(kk-1))*qk mt(2)=mt(2)+aai(2+3*(kk-1))*qk mt(3)=mt(3)+aai(3+3*(kk-1))*qk 151 continue endif c LQ1 ds =(ut(1)*ut(1)+ut(2)*ut(2)+ut(3)*ut(3))*debye**2 *p rs =(ut(1)*mt(1)+ut(2)*mt(2)+ut(3)*mt(3))*debye**2/clight*p if(dabs(ds).gt.THRC)then nt=nt+1 enm=1.0d7/(e00+EJ*CM) if(ltab)then write(43,5501)nt,enm,ds,rs ,proc do 431 i=1,Nexc 431 write(43,5502)si(i) write(43,*) endif if(lspec)call app(enm,ds,rs,abso,cd,winm,wanm,npx,fwnm,lglg,2) endif c c final state loop: 12003 do 80003 ic=Nexc,1,-1 80003 if(si(ic).lt.NQ)goto 90003 goto 30003 90003 do 10003 i=ic+1,Nexc 10003 si(i)=si(ic)+1 si(ic)=si(ic)+1 goto 50003 30003 continue endif c initial state loop: 12002 do 80002 ic=Nexcg,1,-1 80002 if(sig(ic).lt.NL)goto 90002 goto 30002 90002 do 10002 i=ic+1,Nexcg 10002 sig(i)=sig(ic)+1 sig(ic)=sig(ic)+1 goto 50002 30002 continue write(6,6002)proc if(ltab)then write(43,3002) close(43) 3002 format(80(1h-)) endif if(lspec)call c4546(winm,wanm,npx,abso,kelvin,'d',1) if(lspec)call c4546(winm,wanm,npx,cd ,kelvin,'r',2) return end c ============================================================ subroutine rdu(fdu,N,NQ,A,B,C,D,E,G,GP,fac,lvert) c read Duschinsky parameters from fdu c N - supplied dimenstion, 3x nat c NQ - read number of modes implicit none character*(*) fdu integer*4 ip(10),iw,N,NQ,IERR,ix c Full dimension (3 * nat): real*8 A(N,N),B(N),C(N,N),D(N),E(N,N),G(N,N),GP(N,N),fac real*8,allocatable::sg(:,:),se(:,:),J(:,:),JT(:,:),K(:), 1F(:,:),FI(:,:),W(:),WP(:),T(:,:),TP(:,:), 1EE(:,:),GT(:,:),GPT(:,:) logical lvert write(6,6019) 6019 format(/,' Rdu',/,' ^^^',/) c N-dimensions: allocate(sg(N,N),se(N,N),W(N),WP(N)) call zv(W,N) call zv(WP,N) call zm(A,N) call zv(B,N) call zm(C,N) call zv(D,N) call zm(E,N) c read ground and excited state s-matrix: call rduschs(N,NQ,sg,fdu,'Ground S-Matrix') call rduschs(N,NQ,se,fdu,'Excited S-Matri') deallocate(sg,se) write(6,6009)N,NQ 6009 format(' N :',i4,' NQ:',i4,/) c c normal mode dimensions: allocate(JT(NQ,NQ),K(NQ),J(NQ,NQ),FI(NQ,NQ),F(NQ,NQ),EE(NQ,2*NQ), 1GT(NQ,NQ),GPT(NQ,NQ),T(NQ,NQ),TP(NQ,NQ)) call zm(J ,NQ) call zm(JT,NQ) call zv(K ,NQ) call viz(ip,10) iw=0 call rdusch(NQ,N,JT,K,A,B,C,D,E,W,WP,iw,ip,fdu) if(ip(1).eq.0)call report('Duschinsky Matrix not found') if(ip(2).eq.0)call report('Shift Vector not found') if(ip(3).eq.0)call report('A Matrix not found') if(ip(4).eq.0)call report('B Vector not found') if(ip(5).eq.0)call report('C Matrix not found') if(ip(6).eq.0)call report('D Vector not found') if(ip(7).eq.0)call report('E Matrix not found') if(iw.lt.2)call report('Frequencies not found') if(lvert)then write(6,*)' Vertical approximation made, K=B=D=0)' do 8 ix=1,NQ K(ix)=0.0d0 B(ix)=0.0d0 8 D(ix)=0.0d0 endif call mz(G,N) call mz(GP,N) call mz(GT,NQ) call mz(GPT,NQ) do 4 ix=1,NQ G( ix,ix)=W( ix) GT( ix,ix)=W( ix) GP( ix,ix)=WP(ix) 4 GPT(ix,ix)=WP(ix) call mt(J,JT,NQ) call mm(T,GT,J,NQ) call mm(TP,JT,T,NQ) call ms(F,TP,GPT,NQ) call INV(F,FI,NQ,EE,IERR) if(IERR.ne.0)call report('Inversion error') call dofac(NQ,fac,J,JT,F,FI,GT,GPT,K) call wrdeb(NQ,N,A,B,C,D,E,F,FI,G,GP,J,JT,K) write(6,300)fac,fac*fac*100.0d0 300 format('<0|0*> = ',f20.13,' (',f6.2,'%)') return end c ======================================== subroutine wrdeb(NQ,N,A,B,C,D,E,F,FI,G,GP,J,JT,K) c list just for quick control implicit none integer*4 N,NQ real*8 A(N,N),B(*),C(N,N),D(*),E(N,N),F(N,N),FI(N,N),G(N,N), 1GP(N,N),J(NQ,NQ),JT(NQ,NQ),K(*) write(6,6555)'A ',1,1,NQ,NQ,A(1,1),A(NQ,NQ) write(6,6555)'B ',1,1,NQ,NQ,B(1),B(NQ) write(6,6555)'C ',1,1,NQ,NQ,C(1,1),C(NQ,NQ) write(6,6555)'D ',1,1,NQ,NQ,D(1),D(NQ) write(6,6555)'E ',1,1,NQ,NQ,E(1,1),E(NQ,NQ) write(6,6555)'F ',1,1,NQ,NQ,F(1,1),F(NQ,NQ) write(6,6555)'Fi',1,1,NQ,NQ,FI(1,1),FI(NQ,NQ) write(6,6555)'G ',1,1,NQ,NQ,G(1,1),G(NQ,NQ) write(6,6555)'GP',1,1,NQ,NQ,GP(1,1),GP(NQ,NQ) write(6,6555)'J ',1,1,NQ,NQ,J(1,1),J(NQ,NQ) write(6,6555)'JT',1,1,NQ,NQ,JT(1,1),JT(NQ,NQ) write(6,6555)'K ',1,1,NQ,NQ,K(1),K(NQ) 6555 format(1x,a2,2i3,1x,2i3,2f12.6) return end c ============================================================ subroutine downexcfh(si,ni,seb,neb,lf,utb,IQBUF,u0,m0,q0,v0, 1np0,iwr,N,LQ1,NQ,G,EXCNM,gammaau,NQ1,THRC,nt,ddi,aai,vvi,qqi, 1wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab,vrroa,anroa, 1NQBUF,NEXC0,eb,nmap,mmap,lvert,frroa,sr,lwten,lvel,ldo) c compute all down transitions from se(ne,e) c faster version with a buffer of transitions and phantom modes c IQBUF ... number of buffer elements c NQBUF ... dimension implicit none integer*4 ne,lf,ix,NExf,np0,iwr,N,NQ,kk,neb(*),ib, 1ic,NQ1,si(*),ni,nt,I,icen,iex,II,npx,NQ2,pmode,ns0, 1IQBUF,NQBUF,NEXC0,seb(NQBUF,NEXC0),nmap,mmap(*),ni0 parameter (ns0=19,ni0=13) integer,allocatable::sf(:),st(:) real*8 uf(3),mf(3),qf(6),vf(3),EXCNM,ei,ef,u(3,3),FC1,pp,qk, 1G(N,N),gammaau,THRC,u0(*),m0(*),q0(*),v0(*),qke,ddi(*),aai(*), 1vvi(*),qqi(*),CM,wrax,wrin,fwhh,reram(*),reroa(*),ed(3),vd(3), 1md(3),qd(6),w,utb(NQBUF,15),eb(*),lr(3,3),li(3,3),gr(3,3),gi(3,3), 1ar(3,3,3),ai(3,3,3),ejs,fac2,sr(npx,2,ns0),vr(3,3),vi(3,3),ee,wei, 1alr(3,3),ali(3,3),gtr(3,3),gti(3,3),gcr(3,3),gci(3,3),atr(3,3,3), 1ati(3,3,3),acr(3,3,3),aci(3,3,3),ui(3),uvi(3),mi(3),uqi(6), 1uu(3,3),avr(3,3),avi(3,3),inv(ni0),wef,alur(3,3),alui(3,3) logical LQ1,ltab,lglg,anroa,vrroa,lvert,frroa,lwten,lvel,ldo(ns0) integer,allocatable::se(:) real*8,allocatable::A2(:,:),B2(:),C2(:,:),D2(:),E2(:,:),G2(:,:), 1GP2(:,:) write(6,6700)IQBUF,anroa,vrroa,lf,frroa,lwten 6700 format(/,' Downexcfh',/, 1 ' IQBUF = ',i7,' anroa = ',l7,/, 1 ' vrroa = ',l7,/, 1 ' lf = ',i7,/, 1 ' frroa = ',i7,/, 1 ' lwten = ',l7,/) CM=219474.63d0 c excitation frequency in atomic units: w=(1.0d7/EXCNM)/CM c initial state ei=0.0d0 do 21 i=1,ni 21 ei=ei+G(si(i),si(i)) c immediate states: allocate(se(NEXC0),st(NEXC0+2)) call viz(st,NEXC0+2) c sf ... final state allocate(sf(lf+1)) do 122 ix=1,3 ed(ix )=u0(ix ) vd(ix )=v0(ix ) md(ix )=m0(ix ) qd(ix )=q0(ix ) 122 qd(ix+3)=q0(ix+3) c make |f> states using DUSCH2: allocate(A2(N,N),B2(N),C2(N,N),D2(N),E2(N,N),G2(N,N), 1GP2(N,N)) call rdu('DUSCH2.OUT',N,NQ2,A2,B2,C2,D2,E2,G2,GP2,fac2,lvert) write(6,6000)nmap 6000 format(i5,' phantom modes:') do 1 i=1,nmap 1 write(6,6001)i,mmap(i),GP2(mmap(i),mmap(i))*CM 6001 format(2i5,f10.2,' cm-1') if(NQ1.eq.0)NQ1=lf c sf <> |0>: do 30000 Nexf=1,lf c distribute excitations upon centers 1..NQ: c initial indices - all to the first center: do 41 iex=1,Nexf 41 sf(iex)=1 50000 do 11000 I=1,Nexf icen=1 do 11000 II=I+1,Nexf if(sf(II).eq.sf(I))icen=icen+1 11000 if(icen.gt.NQ1)goto 12000 c state energy: ef=ejs(sf,Nexf,G2,N) c skip if outside required range: if((ef-ei)*CM.gt.wrax)goto 12000 c zero-out transition polarizabilities : call bzz(lr,li,vr,vi,gr,gi,ar,ai,alr,ali,gtr,gti,gcr,gci, 1atr,ati,acr,aci,avr,avi) c calculate polarizabilities from a buffer of excited states |e>: do 34 ib=1,IQBUF ee=eb(ib) ne=neb(ib) do 35 i=1,ne c phantom mode: pmode=seb(ib,i) if(pmode.gt.nmap)call report('pmode > nmap') 35 se(i)=mmap(pmode) do 342 i=1,3 c <0|u|e>, etc.: ui( i)=utb(ib, i) uvi( i)=utb(ib, 3+i) mi( i)=utb(ib, 6+i) uqi( i)=utb(ib, 9+i) 342 uqi(3+i)=utb(ib,12+i) call tqq(uqi,uu) wei=ee-ei wef=ee-ef c pp=FC1(fac2,se,sf,ne,Nexf,np0,iwr,A2,B2,C2,D2,E2,N) c u do 14 ix=1,3 uf(ix )=ed(ix)*pp vf(ix )=vd(ix)*pp mf(ix )=md(ix)*pp qf(ix )=qd(ix)*pp 14 qf(ix+3)=qd(ix+3)*pp if(LQ1)then do 15 kk=1,NQ c : qk=qke(se,sf,ne,Nexf,kk,fac2,st,iwr,A2,B2,C2,D2,E2,N,np0,GP2) do 15 ix=1,3 c du/dQk: uf(ix )=uf(ix )+ddi(ix+ 3*(kk-1))*qk vf(ix )=vf(ix )+vvi(ix+ 3*(kk-1))*qk mf(ix )=mf(ix )+aai(ix+ 3*(kk-1))*qk qf(ix )=qf(ix )+qqi(ix+ 6*(kk-1))*qk 15 qf(ix+3)=qf(ix+3)+qqi(ix+3+6*(kk-1))*qk endif c transcript quadrupole to traceless one: call tqq(qf,u) c add the transition dipoles and quadrupole to the c ROA tensors: if(frroa)call dzz(ui,uvi,mi,uu,uf,vf,mf,u,alr,ali,avr,avi, 1gtr,gti,gcr,gci,atr,ati,acr,aci,wei,wef,w,gammaau,lvel) 34 call d1zz(w,wei,ui,uf,vf,mf,u,lr,li,vr,vi,gr,gi,ar,ai,gammaau) c use this for Raman intensities: ne=0 call wrram2(ei,ef,THRC,nt,si,ni,Nexf, 1sf,EXCNM,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1lr,li,vr,vi,gr,gi,ar,ai) if(lvel)then alur=avr alui=avi else alur=alr alui=ali endif if(frroa)call wrram3(w,ei,ef,THRC,nt,si,ni,Nexf,sf,EXCNM,wrin, 1wrax,npx,lglg,fwhh,ltab,inv,alur,alui,gtr,gti,gcr,gci,atr,ati, 1acr,aci,sr,1.0d0,.true.,.true.,ldo,0.0d0,0.0d0) if(lwten)call wzz(w,ei,ef,alr,ali,gtr,gti,gcr,gci,atr,ati, 1acr,aci,avr,avi,inv) c find index to be changed 12000 do 80000 ic=Nexf,1,-1 80000 if(sf(ic).lt.NQ2)goto 90000 goto 30000 90000 do 10000 i=ic+1,Nexf 10000 sf(i)=sf(ic)+1 sf(ic)=sf(ic)+1 c goto 50000 30000 continue return end c ============================================================ function ejsm(ml,si,Nexc,G,N) implicit none integer*4 ml(*),Nexc,si(*),N,II,mode real*8 ejsm,G(N,N),EJ EJ=0.0d0 DO 1 II=1,Nexc mode=ml(si(II)) 1 EJ=EJ+G(mode,mode) ejsm=EJ return end c ============================================================ subroutine bzz(lr,li,vr,vi,gr,gi,ar,ai,alr,ali,gtr,gti,gtcr,gtci, 1atr,ati,atcr,atci,avr,avi) implicit none real*8 alr(3,3),ali(3,3),gtr(3,3),gti(3,3),gtcr(3,3),gtci(3,3), 1atr(3,3,3),ati(3,3,3),atcr(3,3,3),atci(3,3,3), 1lr(3,3),li(3,3),vr(3,3),vi(3,3),gr(3,3),gi(3,3), 1ar(3,3,3),ai(3,3,3),avr(3,3),avi(3,3) lr=0.0d0 li=0.0d0 vr=0.0d0 vi=0.0d0 gr=0.0d0 gi=0.0d0 ar=0.0d0 ai=0.0d0 alr=0.0d0 ali=0.0d0 gtr=0.0d0 gti=0.0d0 gtcr=0.0d0 gtci=0.0d0 atr=0.0d0 ati=0.0d0 atcr=0.0d0 atci=0.0d0 avr=0.0d0 avi=0.0d0 return end c ============================================================== subroutine wz1(w,ei,ef,alr,ali,gr,gi,gcr,gci,ar,ai, 1acr,aci,avr,avi,inv,io,bf) c write ROA tensors into io implicit none integer*4 a,b,c,io,ni0 parameter (ni0=13) real*8 w,ef,ei,CM,ECM,wcm,alr(3,3),ali(3,3),gr(3,3),gi(3,3), 1gcr(3,3),gci(3,3),ar(3,3,3),ai(3,3,3),acr(3,3,3),aci(3,3,3), 1avr(3,3),avi(3,3),inv(ni0),bf character*1 xyz(3) data xyz/'X','Y','Z'/ character*9 si(ni0) data si/'a2 ','bs(a)2 ','ba(a)2 ','aG ', 1 'bs(G)2 ','ba(G)2 ','bs(A)2 ','ba(A)2 ', 1 'aGc ','bs(Gc)2 ','ba(Gc)2 ','bs(Ac)2 ', 1 'ba(Ac)2 '/ CM=219474.63d0 ECM=(ef-ei)*CM WCM=w*CM write(io,701)ECM 701 format(/,' Energy =',f12.4,' cm^-1') write(io,702)WCM,bf 702 format(' -> Omega =',f9.1,' cm^-1',' Boltzmann:',g12.4) write(io,706)' ELECTRIC DIPOLE-ELECTRIC DIPOLE ' 706 format(1x,40(1h-),/,A40,/,1x,40(1h-),/, 115x,'Real < v -v > Imag',11x,'Real < r - r> Imag') do 1 a=1,3 do 1 b=1,3 1 write(io,707)xyz(b),'-',xyz(a),' ',avr(b,a),avi(b,a), 1alr(b,a),ali(b,a) 707 format(2x,4a1,2E17.7,E15.7,E17.7) write(io,704)' ELECTRIC DIPOLE-MAGNETIC DIPOLE ' 704 format(1x,40(1h-),/,A40,/,1x,40(1h-),/,15x,'Real',13x,'Imag') do 2 a=1,3 do 2 b=1,3 2 write(io,705)xyz(b),'-',xyz(a),' ',gr(b,a),gi(b,a) 705 format(2x,4a1,2E17.7) write(io,704)' MAGNETIC DIPOLE-ELECTRIC DIPOLE ' do 3 a=1,3 do 3 b=1,3 3 write(io,705)xyz(b),'-',xyz(a),' ',gcr(b,a),gci(b,a) write(io,704)' ELECTRIC DIPOLE-ELECTRIC QUADRUPOLE ' do 4 a=1,3 do 4 b=1,3 do 4 c=1,b 4 write(io,705)xyz(a),'-',xyz(c),xyz(b), ar(a,c,b), ai(a,c,b) write(io,704)' ELECTRIC QUADRUPOLE-ELECTRIC DIPOLE ' do 5 a=1,3 do 5 b=1,a do 5 c=1,3 5 write(io,705)xyz(b),xyz(a),'-',xyz(b),acr(c,b,a),aci(c,b,a) do 7 a=1,ni0 7 write(io,708)si(a),inv(a) 708 format(3x,a9,' =',e14.6) return end c ============================================================== subroutine wzz(w,ei,ef,alr,ali,gr,gi,gcr,gci,ar,ai, 1acr,aci,avr,avi,inv) c write ROA tensors into TTT.OUT implicit none integer*4 a,b,c,io,ni0 parameter (ni0=13) real*8 w,ef,ei,CM,ECM,wcm,alr(3,3),ali(3,3),gr(3,3),gi(3,3), 1gcr(3,3),gci(3,3),ar(3,3,3),ai(3,3,3),acr(3,3,3),aci(3,3,3), 1avr(3,3),avi(3,3),inv(ni0) character*1 xyz(3) data xyz/'X','Y','Z'/ character*9 si(ni0) data si/'a2 ','bs(a)2 ','ba(a)2 ','aG ', 1 'bs(G)2 ','ba(G)2 ','bs(A)2 ','ba(A)2 ', 1 'aGc ','bs(Gc)2 ','ba(Gc)2 ','bs(Ac)2 ', 1 'ba(Ac)2 '/ CM=219474.63d0 ECM=(ef-ei)*CM WCM=w*CM do 6 io=77,78 write(io,701)ECM 701 format(/,' Energy =',f12.4,' cm^-1') 6 write(io,702)WCM 702 format(' -> Omega =',f9.1,' cm^-1') write(77,706)' ELECTRIC DIPOLE-ELECTRIC DIPOLE ' 706 format(1x,40(1h-),/,A40,/,1x,40(1h-),/, 115x,'Real < v -v > Imag',11x,'Real < r - r> Imag') do 1 a=1,3 do 1 b=1,3 1 write(77,707)xyz(b),'-',xyz(a),' ',avr(b,a),avi(b,a), 1alr(b,a),ali(b,a) 707 format(2x,4a1,2E17.7,E15.7,E17.7) write(77,704)' ELECTRIC DIPOLE-MAGNETIC DIPOLE ' 704 format(1x,40(1h-),/,A40,/,1x,40(1h-),/,15x,'Real',13x,'Imag') do 2 a=1,3 do 2 b=1,3 2 write(77,705)xyz(b),'-',xyz(a),' ',gr(b,a),gi(b,a) 705 format(2x,4a1,2E17.7) write(77,704)' MAGNETIC DIPOLE-ELECTRIC DIPOLE ' do 3 a=1,3 do 3 b=1,3 3 write(77,705)xyz(b),'-',xyz(a),' ',gcr(b,a),gci(b,a) write(77,704)' ELECTRIC DIPOLE-ELECTRIC QUADRUPOLE ' do 4 a=1,3 do 4 b=1,3 do 4 c=1,b 4 write(77,705)xyz(a),'-',xyz(c),xyz(b), ar(a,c,b), ai(a,c,b) write(77,704)' ELECTRIC QUADRUPOLE-ELECTRIC DIPOLE ' do 5 a=1,3 do 5 b=1,a do 5 c=1,3 5 write(77,705)xyz(b),xyz(a),'-',xyz(b),acr(c,b,a),aci(c,b,a) do 7 io=1,ni0 7 write(78,708)si(io),inv(io) 708 format(3x,a9,' =',e14.6) return end c ============================================================== subroutine wrram3(w,ei,ef,THRC,nt,si,ni,nf,sf,EXCNM,wrin,wrax, 1npx,lglg,fwhh,ltab,inv,alr,ali,gtr,gti,gtcr,gtci,atr,ati,atcr, 1atci,sr,bf,lusea,luseg,ldo,sr_,si_) c EXCNM ... excitation frequency in nm c bf .. Boltzmann factor implicit none integer*4 sf(*),ni,nf,si(*),nt,npx,ns0,ni0, 1ia,b,id,e,ii,is parameter (ns0=19,ni0=13) c ns0 : number of experimental setups c ni0 : number of invariants real*8 ef,ei,fwhh,THRC,CM,AMU,BOHR,ECM,EXCNM,wrax,wrin,w,clight, 1YDY,YDX,sr(npx,2,ns0),gpisvejc,EXCA,roa1,ram1,tr,ti,a(2),bf, 1inv(ni0),co(ni0+2,ns0),aaar,aaai,gtaar,gtaai,gtcaar,gtcaai, 1alr(3,3),ali(3,3),gtr(3,3),gti(3,3),gtcr(3,3),gtci(3,3), 1atr(3,3,3),ati(3,3,3),atcr(3,3,3),atci(3,3,3), 1alsr(3,3),alsi(3,3),gtsr(3,3),gtsi(3,3),gtcsr(3,3),gtcsi(3,3), 1alar(3,3),alai(3,3),gtar(3,3),gtai(3,3),gtcar(3,3),gtcai(3,3), 1ear(3,3),eapr(3,3),easr(3,3),eapsr(3,3),eaar(3,3),eapar(3,3), 1eai(3,3),eapi(3,3),easi(3,3),eapsi(3,3),eaai(3,3),eapai(3,3), 1eacr(3,3),eapcr(3,3),eacsr(3,3),eapcsr(3,3),eacar(3,3), 1eapcar(3,3),sr_,si_, 1eaci(3,3),eapci(3,3),eacsi(3,3),eapcsi(3,3),eacai(3,3),eapcai(3,3) logical ltab,lglg,lusea,luseg,ldo(ns0) c prefix RAM, prefix ROA c a2 bs(a)2 ba(a)2 aG bs(G)2 ba(G)2 bs(A)2 c ba(A)2 aG bs(G)2 ba(G)2 bs(A)2 ba(A)2 c script: ^ ^ ^ ^ ^ c c co: Raman prefactor, ROA prefactor,3 Raman invariants, c 10 ROA invariants, all for ns0=18 spectral kinds c 1 1 2 ICP(0o): Nafie data co/ 4.0d0, 8.0d0, 1 45.0d0, 7.0d0, 5.0d0, 45.0d0, 7.0d0, 5.0d0, 1.0d0, 1 -1.0d0,-45.0d0, 5.0d0, -5.0d0, -3.0d0, 1.0d0, c 2 3 4 ICPx(90o): Nafie 1 4.0d0, 2.0d0, 1 45.0d0, 7.0d0, 5.0d0, 45.0d0, 7.0d0, 5.0d0, 1.0d0, 1 -1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, c 3 5 6 ICPz(90o): Nafie 1 8.0d0, 4.0d0, 1 0.0d0, 3.0d0, 5.0d0, 0.0d0, 3.0d0, 5.0d0, -1.0d0, 1 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, c 4 7 8 ICP*(90o): (magic) Nafie 1 13.3333d0,6.666d0, 1 9.0d0, 2.0d0, 2.0d0, 9.0d0, 2.0d0, 2.0d0, 0.0d0, 1 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, c 5 9 10 ICPu(90o): Nafie 1 4.0d0, 4.0d0, 1 45.0d0, 13.0d0, 15.0d0, 45.0d0, 13.0d0, 15.0d0, -1.0d0, 1 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, c 6 11 12 ICP(180o): Nafie 1 4.0d0, 8.0d0, 1 45.0d0, 7.0d0, 5.0d0, 45.0d0, 7.0d0, 5.0d0, 1.0d0, 1 -1.0d0, 45.0d0, -5.0d0, 5.0d0, 3.0d0, -1.0d0, c 7 13 14 SCP(0o): nafie 1 4.0d0, 8.0d0, 1 45.0d0, 7.0d0, 5.0d0, 45.0d0, -5.0d0, 5.0d0, -3.0d0, 1 -1.0d0,-45.0d0, -7.0d0, -5.0d0, 1.0d0, 1.0d0, c 8 15 16 SCPx(90o): nafie 1 2.0d0, 4.0d0, 1 45.0d0, 7.0d0, 5.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1 0.0d0,-45.0d0, -7.0d0, -5.0d0, 1.0d0, 1.0d0, c 9 17 18 SCPz(90o): Nafie 1 4.0d0, 8.0d0, 1 0.0d0, 3.0d0, 5.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1 0.0d0, 0.0d0, -3.0d0, -5.0d0, -1.0d0, -1.0d0, c 10 19 20 SCP*(90o): Nafie 1 13.3333d0,6.666d0, 1 9.0d0, 2.0d0, 2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1 0.0d0, -9.0d0, -2.0d0, -2.0d0, 0.0d0, 0.0d0, c 11 21 22 SCPu(90o): Nafie 1 4.0d0, 4.0d0, 1 45.0d0, 13.0d0, 15.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1 0.0d0,-45.0d0,-13.0d0,-15.0d0, -1.0d0, -1.0d0, c 12 23 24 SCP(180o):Nafie 1 4.0d0, 8.0d0, 1 45.0d0, 7.0d0, 5.0d0,-45.0d0, 5.0d0, -5.0d0, 3.0d0, 1 1.0d0,-45.0d0, -7.0d0, -5.0d0, 1.0d0, 1.0d0, c 13 25 26 DCPI(0o): Nafie 1 4.0d0, 8.0d0, 1 45.0d0, 1.0d0, 5.0d0, 45.0d0, 1.0d0, 5.0d0, -1.0d0, 1 -1.0d0,-45.0d0, -1.0d0, -5.0d0, -1.0d0, +1.0d0, c 14 27 28 DCPI(90o): Nafie 1 2.0d0, 2.0d0, 1 45.0d0, 13.0d0, 15.0d0, 45.0d0, 13.0d0, 15.0d0, -1.0d0, 1 +1.0d0,-45.0d0,-13.0d0,-15.0d0, -1.0d0, -1.0d0, c 15 29 30 DCPI(180o): Nafie 1 24.0d0, 16.0d0, 1 0.0d0, 1.0d0, 0.0d0, 0.0d0, 3.0d0, 0.0d0, 1.0d0, 1 0.0d0, 0.0d0, -3.0d0, 0.0d0, 1.0d0, 0.0d0, c 16 31 32 DCPII(0o): Nafie 1 24.0d0, 16.0d0, 1 0.0d0, 1.0d0, 0.0d0, 0.0d0, 3.0d0, 0.0d0, 1.0d0, 1 0.0d0, 0.0d0, 3.0d0, 0.0d0, -1.0d0, 0.0d0, c 17 33 34 DCPII(90o): 1 2.0d0, 2.0d0, 1 45.0d0, 13.0d0, 15.0d0, 45.0d0, 13.0d0, 15.0d0, -1.0d0, 1 1.0d0, 45.0d0, 13.0d0, 15.0d0, 1.0d0, 1.0d0, c 18 35 36 DCPII(180o): 1 4.0d0, 8.0d0, 1 45.0d0, 1.0d0, 5.0d0, 45.0d0, 1.0d0, 5.0d0, -1.0d0, 1 -1.0d0, 45.0d0, 1.0d0, 5.0d0, 1.0d0, -1.0d0, c 19 special 1 1.0d0, 0.0d0, 1 1.0d0, .0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0/ c prefix a2 bs(a)2 ba(a)2 aG bs(G)2 ba(G)2 c bs(A)2 ba(A)2 aG bs(G)2 ba(G)2 bs(A)2 ba(A)2 c script: ^ ^ ^ ^ ^ ^ c invariants: c 1 a2 =(1/9)Re (as_aa as*_bb) c 2 bs(a)2 =(1/2)Re(3as_ab as*_ab-as_aa as*_bb) c 3 ba(a)2 =(1/2)Re(3as_ab as*_ab-as_aa as*_bb) c 4 aG =(1/9)Im(as_aa Gs*_bb) c 5 bs(G)2 =(1/2)Im(3as_ab Gs*_ab-as_aa Gs*_bb) c 6 ba(G)2 =(3/2)Im(3aa_ab Ga*_ab) c 7 bs(A)2 =(w/2)Im(i as_ab eas*_ab) c ea_ab=eps_adg A_d,gb c 8 ba(A)2 =(w/2)Im(i aa_ab eaa*_ab)+i aa_ab eap_ab c eap_ab=eps_abg A_d,gd c script tensors: c 9 aG =(1/9)Im(as_aa Gs*_bb) c 10 bs(G)2 =(1/2)Im(3as_ab Gs*_ab-as_aa Gs*_bb) c 11 ba(G)2 =(3/2)Im(3aa_ab Ga*_ab) c 12 bs(A)2 =(w/2)Im(i as_ab eas*_ab) c 13 ba(A)2 =(w/2)Im(i aa_ab eaa*_ab)+i aa_ab eap_ab CM=219474.63d0 AMU=1822.0d0 BOHR=0.529177d0 EXCA=EXCNM*10.0d0 ECM=(ef-ei)*CM gpisvejc=(AMU*BOHR**5)*1.0d4*2.0d0*4.0d0*atan(1.0d0)/EXCA clight=137.03599d0 c eap_ab = eps_abc A_d,cd call calcep(eapr ,atr ) call calcep(eapi ,ati ) call calcep(eapci,atci) call calcep(eapcr,atcr) c c ea_ab = eps_adc A_d,cb ear =0.0d0 eai =0.0d0 eacr=0.0d0 eaci=0.0d0 do 2 ia=1,3 id=ia+1 if(id.gt.3)id=1 e=id+1 if(e.gt.3)e=1 do 2 b=1,3 ear( ia,b)=atr (id,e,b)-atr (e,id,b) eai( ia,b)=ati (id,e,b)-ati (e,id,b) eacr(ia,b)=atcr(id,e,b)-atcr(e,id,b) 2 eaci(ia,b)=atci(id,e,b)-atci(e,id,b) c symmetric and antisymmetric tensor combinations call dsa(alr , ali, alsr, alsi, alar, alai) call dsa(gtr , gti, gtsr, gtsi, gtar, gtai) call dsa(gtcr,gtci,gtcsr,gtcsi,gtcar,gtcai) call dsa(ear ,eai ,easr ,easi ,eaar ,eaai ) call dsa(eapr ,eapi ,eapsr ,eapsi ,eapar ,eapai ) call dsa(eacr ,eaci ,eacsr ,eacsi ,eacar ,eacai ) call dsa(eapcr,eapci,eapcsr,eapcsi,eapcar,eapcai) inv=0.0d0 c a2: (1/9) Re (als_aa als*_bb) aaar=alsr(1,1)+alsr(2,2)+alsr(3,3) aaai=alsi(1,1)+alsi(2,2)+alsi(3,3) inv(1)=(aaar*aaar+aaai*aaai)/9.0d0 c beta_s(alpha)2:(1/2)Re(3als_ab als*_ab-als_aa als*_bb) call abab(tr,ti,alsr,alsi,alsr,alsi) inv(2)=1.5d0*tr-4.5d0*inv(1) c beta_a(alpha)2:(3/2)Re(als_ab als*_ab) call abab(tr,ti,alar,alai,alar,alai) inv(3)=1.5d0*tr if(luseg)then c aG: (1/9) Im(als_aa gs*_bb) gtaar=gtsr(1,1)+gtsr(2,2)+gtsr(3,3) gtaai=gtsi(1,1)+gtsi(2,2)+gtsi(3,3) inv(4)=(aaai*gtaar-aaar*gtaai)/9.0d0 c beta_s(G)2:(1/2)Im(3als_ab Gs*_ab-als_aa Gs*_bb) call abab(tr,ti,alsr,alsi,gtsr,gtsi) inv(5)=1.5d0*ti-4.5d0*inv(4) c beta_a(G)2: (3/2)Im(ala_ab Ga*_ab) call abab(tr,ti,alar,alai,gtar,gtai) inv(6)=1.5d0*ti c aGc: gtcaar=gtcsr(1,1)+gtcsr(2,2)+gtcsr(3,3) gtcaai=gtcsi(1,1)+gtcsi(2,2)+gtcsi(3,3) inv(9)=(aaai*gtcaar-aaar*gtcaai)/9.0d0 c beta_s(Gc)2: call abab(tr,ti,alsr,alsi,gtcsr,gtcsi) inv(10)=1.5d0*ti-4.5d0*inv(9) c beta_a(Gc)2: (3/2)Im(ala_ab Gca*_ab) call abab(tr,ti,alar,alai,gtcar,gtcai) inv(11)=1.5d0*ti endif if(lusea)then c betasA2: (w/2)Im(i als_ab e_agd As*g,db) call abab(tr,ti,alsr,alsi,easr,easi) inv(7)=0.5d0*w*tr/clight c betaaA2: (w/2)Im(i[ala_ab[e_agd Aa*g,db+ e_abg Aa*d,gd) call abab(tr,ti,alar,alai,eaar,eaai) inv(8)=tr call abab(tr,ti,alar,alai,eapar,eapai) inv(8)=0.5d0*w*(inv(8)+tr)/clight c betasAc2: (w/2)Im(i als_ab e_agd Acs*g,db) call abab(tr,ti,alsr,alsi,eacsr,eacsi) inv(12)=0.5d0*w*tr/clight c betaaAc2: call abab(tr,ti,alar,alai,eacar,eacai) inv(13)=tr call abab(tr,ti,alar,alai,eapcar,eapcai) inv(13)=0.5d0*w*(inv(13)+tr)/clight endif c spectral intensities: do 3 is=1,ns0 if(ldo(is))then c Raman: a(1)= 1 bf*co(1,is)*(co(3,is)*inv(1)+co(4,is)*inv(2)+co(5,is)*inv(3)) c ROA: a(2)=0.0d0 do 4 ii=4,ni0 4 a(2)=a(2)+inv(ii)*co(2+ii,is) a(2)=bf*co(2,is)*a(2) if(dabs(a(1)).gt.THRC)then if(is.le.18)call ap3(is,ns0,ECM,a,sr,wrin,wrax,npx,fwhh,lglg) if(ltab)then YDX=0.0d0 YDY=0.0d0 if(is.eq.19)then ram1=sr_*sr_+si_*si_ roa1=0.0d0 else ram1=a(1)*gpisvejc roa1=a(2)*gpisvejc endif WRITE(50+is,3001)nt,ECM,YDX,YDY,ram1,roa1,bf 3001 FORMAT(I7,f9.2,2f3.0,g12.4,' 0 0 0 0',2g12.4,$) c initial and final states: if(is.eq.12)then call wrs(50+is,si,ni) call wrs(50+is,sf,nf) endif write(50+is,*) endif endif endif 3 continue return end subroutine calcep(e,a) c eap_ab = eps_abc A_d,cd implicit none real*8 e(3,3),a(3,3,3) e(1,1)=0.0d0 e(2,2)=0.0d0 e(3,3)=0.0d0 e(1,2)= a(1,3,1)+a(2,3,2)+a(3,3,3) e(1,3)=-a(1,2,1)-a(2,2,2)-a(3,2,3) e(2,3)= a(1,1,1)+a(2,1,2)+a(3,1,3) e(2,1)=-e(1,2) e(3,1)=-e(1,3) e(3,2)=-e(2,3) return end subroutine abab(tr,ti,ar,ai,br,bi) c t = a_ab b*_ab implicit none integer*4 a real*8 tr,ti,ar(3,3),ai(3,3),br(3,3),bi(3,3) tr=0.0d0 ti=0.0d0 do 1 a=1,3 tr=tr+ar(a,1)*br(a,1)+ai(a,1)*bi(a,1) 1 +ar(a,2)*br(a,2)+ai(a,2)*bi(a,2) 1 +ar(a,3)*br(a,3)+ai(a,3)*bi(a,3) 1 ti=ti-ar(a,1)*bi(a,1)+ai(a,1)*br(a,1) 1 -ar(a,2)*bi(a,2)+ai(a,2)*br(a,2) 1 -ar(a,3)*bi(a,3)+ai(a,3)*br(a,3) return end subroutine dsa(tr,ti,tsr,tsi,tar,tai) implicit none real*8 tr(3,3),ti(3,3),tsr(3,3),tsi(3,3),tar(3,3),tai(3,3) integer*4 a,b do 1 a=1,3 do 1 b=1,3 tsr(a,b)=0.5d0*(tr(a,b)+tr(b,a)) tsi(a,b)=0.5d0*(ti(a,b)+ti(b,a)) tar(a,b)=0.5d0*(tr(a,b)-tr(b,a)) 1 tai(a,b)=0.5d0*(ti(a,b)-ti(b,a)) return end subroutine dzz(ui,vi,mi,qi,uf,vf,mf,qf,alr,ali,avr,avi, 1gtr,gti,gcr,gci,atr,ati,acr,aci,wei,wef,w,gammaau,lvel) c add the transition dipoles and quadrupoles to the c ROA tensors implicit none real*8 ui(3),vi(3),mi(3),uf(3),vf(3),sr_,si_, 1mf(3),alr(3,3),ali(3,3),avr(3,3),avi(3,3),wef, 1gtr(3,3),gti(3,3),gcr(3,3),gci(3,3),atr(3,3,3),ati(3,3,3), 1acr(3,3,3),aci(3,3,3),wei,w,gammaau,qi(3,3),qf(3,3), 1lr_(3,3),li_(3,3),vr_(3,3),vi_(3,3),gr_(3,3),gi_(3,3),gcr_(3,3), 1gci_(3,3),ar_(3,3,3),ai_(3,3,3),acr_(3,3,3),aci_(3,3,3) logical lvel c make this contribution: call dzc(ui,vi,mi,qi,uf,vf,mf,qf,lr_,li_,vr_,vi_, 1gr_,gi_,gcr_,gci_,ar_,ai_,acr_,aci_,wei,wef,w,gammaau,lvel,sr_, 1si_,0.0d0,0.0d0) c add: alr=alr+lr_ ali=ali+li_ avr=avr+vr_ avi=avi+vi_ gtr=gtr+gr_ gti=gti+gi_ gcr=gcr+gcr_ gci=gci+gci_ atr=atr+ar_ ati=ati+ai_ acr=acr+acr_ aci=aci+aci_ return end subroutine dzc(ui,vi,mi,qi,uf,vf,mf,qf,alr,ali,avr,avi, 1gtr,gti,gcr,gci,atr,ati,acr,aci,wei,wef,w,gammaau,lvel,sr,si, 1fi,ff) c combine the transition dipoles and quadrupole to the c ROA tensors implicit none integer*4 a,b,c real*8 rm,rp,im,ip,ui(3),vi(3),mi(3),uf(3),vf(3),sr,si, 1mf(3),alr(3,3),ali(3,3),avr(3,3),avi(3,3),wef,fi,ff, 1gtr(3,3),gti(3,3),gcr(3,3),gci(3,3),atr(3,3,3),ati(3,3,3), 1acr(3,3,3),aci(3,3,3),wei,w,gammaau,qi(3,3),qf(3,3), 1uia,via,ufa,vfa logical lvel rm= (wei-w)/((wei-w)**2+gammaau**2) im= gammaau/((wei-w)**2+gammaau**2) rp= (wef+w)/((wef+w)**2+gammaau**2) ip=-gammaau/((wef+w)**2+gammaau**2) c zero-out transition polarizabilities : c 1 c al_ab = - sum ----------------- + ---------------- c h wmi-w-iG wmf+w+iG c c 1 c G_ab = - sum ----------------- + ---------------- c h wmi-w-iG wmf+w+iG c c 1 c Gc_ab = - sum ----------------- + ---------------- c h wmi-w-iG wmf+w+iG c c 1 c A_abg = - sum ----------------- + ----------------- c h wmi-w-iG wmf+w+iG c c 1 c Ac_abg = - sum ----------------- + ---------------- c h wmi-w-iG wmf+w+iG c c 1 c sc = - sum ----------- + ---------------- c h wmi-w-iG wmf+w+iG c c Nnotes: for A,Ac the dipole index always the first c wmf+w=wmi+w' c in older works "iG" in the first expressions is positive if(lvel)then do 35 a=1,3 uia=ui(a) via=vi(a) ufa=uf(a) vfa=vf(a) do 35 b=1,3 c c Re al = Re(f) Re(uu) c Im al = Im(f) Re(uu) alr(a,b)=rm*ufa*ui(b)+rp*uf(b)*uia ali(a,b)=im*ufa*ui(b)+ip*uf(b)*uia avr(a,b)=rm*vfa*vi(b)+rp*vf(b)*via avi(a,b)=im*vfa*vi(b)+ip*vf(b)*via c note that m is purely imaginary and =- c + c uf(a) -mi mf ui x i^2 c Real G = - Im(f) Im(m) c Im G = Re(f) Im(m) gtr(a,b)= -im*vfa*(-mi(b))-ip*mf(b)*via gti(a,b)= rm*vfa*(-mi(b))+rp*mf(b)*via c + , suppose mf(a)= c mf(a) ui uf -mi x i^2 gcr(a,b)= -im*mf(a)*vi(b) -ip*vf(b)*(-mi(a)) gci(a,b)= rm*mf(a)*vi(b) +rp*vf(b)*(-mi(a)) do 35 c=1,3 c + atr(a,b,c)=rm*vfa*qi(b,c)+rp*qf(b,c)*via ati(a,b,c)=im*vfa*qi(b,c)+ip*qf(b,c)*via c + acr(a,b,c)=rm*qf(b,c)*via+rp*vfa*qi(b,c) 35 aci(a,b,c)=im*qf(b,c)*via+ip*vfa*qi(b,c) else do 36 a=1,3 uia=ui(a) via=vi(a) ufa=uf(a) vfa=vf(a) do 36 b=1,3 alr(a,b)=rm*ufa*ui(b)+rp*uf(b)*uia ali(a,b)=im*ufa*ui(b)+ip*uf(b)*uia avr(a,b)=rm*vfa*vi(b)+rp*vf(b)*via avi(a,b)=im*vfa*vi(b)+ip*vf(b)*via gtr(a,b)= -im*ufa*(-mi(b))-ip*mf(b)*uia gti(a,b)= rm*ufa*(-mi(b))+rp*mf(b)*uia gcr(a,b)= -im*mf(a)*ui(b) -ip*uf(b)*(-mi(a)) gci(a,b)= rm*mf(a)*ui(b) +rp*uf(b)*(-mi(a)) do 36 c=1,3 atr(a,b,c)=rm*ufa*qi(b,c)+rp*qf(b,c)*uia ati(a,b,c)=im*ufa*qi(b,c)+ip*qf(b,c)*uia acr(a,b,c)=rm*qf(b,c)*uia+rp*ufa*qi(b,c) 36 aci(a,b,c)=im*qf(b,c)*uia+ip*ufa*qi(b,c) endif sr=(rm+rp)*ff*fi si=(im+ip)*ff*fi return end subroutine d1zz(w,wei,ui,uf,vf,mf,u, 1lr,li,vr,vi,gr,gi,ar,ai,gammaau) implicit none integer*4 ix,jx,kx real*8 uie,uif,wei,ui(3),uf(3),mf(3),u(3,3),lr(3,3),li(3,3),w, 1vr(3,3),vi(3,3),gr(3,3),gi(3,3),ar(3,3,3),ai(3,3,3),d1,r,ig, 1gammaau,vf(3) d1=wei**2-w**2 r = d1/(d1**2+w**2*gammaau**2) ig=w*gammaau/(d1**2+w**2*gammaau**2) do 34 ix=1,3 uie=2.0d0*wei*ui(ix) uif=2.0d0* ui(ix) do 34 jx=1,3 lr(ix,jx)=lr(ix,jx)+ r*uie*uf(jx) li(ix,jx)=li(ix,jx)+ig*uie*uf(jx) vr(ix,jx)=vr(ix,jx)+ r*uie*vf(jx) vi(ix,jx)=vi(ix,jx)+ig*uie*vf(jx) c suppose that =-: gr(ix,jx)=gr(ix,jx)- r*uif*mf(jx) gi(ix,jx)=gi(ix,jx)-ig*uif*mf(jx) do 34 kx=1,3 ar(ix,jx,kx)=ar(ix,jx,kx)+ r*uie*u(jx,kx) 34 ai(ix,jx,kx)=ai(ix,jx,kx)+ig*uie*u(jx,kx) return end subroutine addmq(NQBUF,N,NQ,np0,IQBUF,iwr,NExcb,LEXCL,sib,LQ1, 1sit,C,D,fac,GP,utb,v0,m0,q0,vvi,aai,qqi,NEXC0) implicit none integer*4 NQBUF,IQBUF,ic,N,np0,iwr,NExc,NExcb(*),LEXCL,NEXC0, 1sib(NQBUF,NEXC0),ix,kk,NQ,sit(*) real*8 pp,FC,fac,C(N,N),D(N),ut(15),v0(*),m0(*),q0(*),qk,qkf, 1GP(N,N),utb(NQBUF,15),vvi(*),aai(*),qqi(*) logical LQ1 integer*4,allocatable::si(:) allocate(si(LEXCL+1)) write(6,*)'adding magnetic dipoles and quadrupoles' do 108 ic=1,IQBUF NExc=NExcb(ic) si=0 do 104 ix=1,Nexc 104 si(ix)=sib(ic,ix) c <0}si>: pp=FC(fac,si,Nexc,np0,iwr,C,D,N) c u0<0|si>: do 105 ix=1,3 ut( 3+ix)=v0(ix )*pp ut( 6+ix)=m0(ix )*pp ut( 9+ix)=q0(ix )*pp 105 ut(12+ix)=q0(ix+3)*pp if(LQ1)then do 106 kk=1,NQ qk=qkf(si,Nexc,kk,fac,sit,iwr,C,D,N,np0,GP) c du/dq <0|Q|si>: do 106 ix=1,3 ut( 3+ix)=ut( 3+ix)+vvi(ix +3*(kk-1))*qk ut( 6+ix)=ut( 6+ix)+aai(ix +3*(kk-1))*qk ut( 9+ix)=ut( 9+ix)+qqi(ix +6*(kk-1))*qk 106 ut(12+ix)=ut(12+ix)+qqi(ix+3+6*(kk-1))*qk endif do 108 ix=4,15 108 utb(ic,ix)=ut(ix) return end subroutine addumq(NQBUF,N,NQ,np0,IQBUF,iwr,NExcb,LEXCL,sib,LQ1, 1sit,C,D,fac,GP,utb,u0,v0,m0,q0,ddi,vvi,aai,qqi,NEXC0, 1eb,e00au) implicit none integer*4 NQBUF,IQBUF,ic,N,np0,iwr,NExc,NExcb(*),LEXCL,NEXC0, 1sib(NQBUF,NEXC0),ix,kk,NQ,sit(*) real*8 pp,FC,fac,C(N,N),D(N),ut(15),v0(*),m0(*),q0(*),qk,qkf, 1GP(N,N),utb(NQBUF,15),vvi(*),aai(*),qqi(*),u0(*),ddi(*), 1eb(NQBUF),e00au,ejs logical LQ1 integer*4,allocatable::si(:) allocate(si(LEXCL+1)) write(6,*)'adding electric and magnetic dipoles and quadrupoles' C$OMP Parallel Do Schedule(Dynamic) Default(Shared) C$OMP+ Private(ic,NExc,si,ix,eb,pp,ut,kk,qk) do 108 ic=1,IQBUF NExc=NExcb(ic) si=0 do 104 ix=1,Nexc 104 si(ix)=sib(ic,ix) eb(ic)=e00au+ejs(si,Nexc,GP,N) c <0}si>: pp=FC(fac,si,Nexc,np0,iwr,C,D,N) c u0<0|si>: do 105 ix=1,3 ut( ix)=u0(ix )*pp ut( 3+ix)=v0(ix )*pp ut( 6+ix)=m0(ix )*pp ut( 9+ix)=q0(ix )*pp 105 ut(12+ix)=q0(ix+3)*pp if(LQ1)then do 106 kk=1,NQ qk=qkf(si,Nexc,kk,fac,sit,iwr,C,D,N,np0,GP) c du/dq <0|Q|si>: do 106 ix=1,3 ut( ix)=ut( ix)+ddi(ix +3*(kk-1))*qk ut( 3+ix)=ut( 3+ix)+vvi(ix +3*(kk-1))*qk ut( 6+ix)=ut( 6+ix)+aai(ix +3*(kk-1))*qk ut( 9+ix)=ut( 9+ix)+qqi(ix +6*(kk-1))*qk 106 ut(12+ix)=ut(12+ix)+qqi(ix+3+6*(kk-1))*qk endif do 108 ix=1,15 108 utb(ic,ix)=ut(ix) return end subroutine empty(N,NQ,np0,iwr,NF,NQBUF,NEXC0,Nexfb,efb,sfb, 1ib,IQBUF,eb,neb,utb,fac,A,B,C,D,E,ed,vd,md,qd,LQ1,ddi,vvi,aai, 1qqi,frroa,anroa,vrroa,w,gammaau,ltens,gtens,atens,enr,troa,ei, 1THRC,EXCNM,nt,si,ni,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab,sr, 1lwten,GP,lf,nproc,seb,lvel,ldo) implicit none integer*4 N,NF,NQ,i1,ii,Nexf,NQBUF,Nexfb(NQBUF),sfb(NQBUF,NEXC0), 1ib,IQBUF,neb(*),seb(NQBUF,NEXC0),np0,iwr,ix,kk,i,k,jx,ir,nt, 1si(*),ni,npx,ns0,ne,NEXC0,lf,nproc,ni0 parameter (ni0=13,ns0=19) real*8 ef,efb(NQBUF),fac,A(N,N),B(*),C(N,N),D(*),E(N,N),FC1,qke, 1lr(3,3),li(3,3),vr(3,3),vi(3,3),gr(3,3),gi(3,3),enr(*),ei,wei, 1ar(3,3,3),ai(3,3,3),avr(3,3),avi(3,3),pp,GP(N,N),inv(ni0), 1alr(3,3),ali(3,3),gtr(3,3),gti(3,3),gcr(3,3),gci(3,3), 1atr(3,3,3),ati(3,3,3),acr(3,3,3),aci(3,3,3),wef, 1ui(3),uvi(3),mi(3),uqi(6),eb(*),uu(3,3),u(3,3), 1uf(3),vf(3),mf(3),qf(6),qk,ddi(*),aai(*),qqi(*),vvi(*), 1ed(3),vd(3),md(3),qd(6),w,gammaau,CM,f,lambda,troa,q12, 1ltens(*),gtens(*),atens(*),THRC,EXCNM,wrin,wrax,fwhh,reram(*), 1reroa(*),sr(npx,2,ns0),pi,spi,ee,utb(NQBUF,15), 1alur(3,3),alui(3,3) logical LQ1,frroa,anroa,vrroa,lglg,ltab,lwten,lvel,ldo(ns0) integer*4,allocatable::sf(:),st(:),se(:) allocate(sf(lf+1),st(NEXC0+2),se(NEXC0)) st=0 CM=219474.63d0 pi=4.0d0*atan(1.0d0) spi=dsqrt(2.0d0*pi) if(nproc.ne.0)call omp_set_num_threads(nproc) C$OMP Parallel Do Schedule(Dynamic) Default(Shared) C$OMP+ Private(lr,li,vr,vi,gr,gi,ar,ai,alr,ali,gtr,gti,gcr,gci, C$OMP+ atr,ati,acr,aci,avr,avi,i1,ef,Nexf,sf,ii,ib,ee,ne,i,wef, C$OMP+ ui,uvi,mi,uqi,se,wei,pp,ix,uu,uf,vf,mf,qf,kk,qk,u,f,jx,k, C$OMP+ ir,lambda,q12,alur,alui) do 1 i1=1,NF ef=efb(i1) Nexf=Nexfb(i1) do 124 ii=1,Nexf 124 sf(ii)=sfb(i1,ii) c zero-out polarizabilities: call bzz(lr,li,vr,vi,gr,gi,ar,ai,alr,ali,gtr,gti,gcr,gci, 1atr,ati,acr,aci,avr,avi) c add contributions from a buffer of excited states |e>: do 34 ib=1,IQBUF ee=eb(ib) ne=neb(ib) do 342 ii=1,3 c <0|u|e>, etc.: ui( ii)=utb(ib, ii) uvi( ii)=utb(ib, 3+ii) mi( ii)=utb(ib, 6+ii) uqi( ii)=utb(ib, 9+ii) 342 uqi(3+ii)=utb(ib,12+ii) call tqq(uqi,uu) do 341 ii=1,ne 341 se(ii)=seb(ib,ii) wei=ee-ei wef=ee-ef c , etc.: c =: pp=FC1(fac,sf,se,Nexf,ne,np0,iwr,A,B,C,D,E,N) c =u0+du/dQk c (if ldis =(u0-du/dQ Qt)+du/dQk do 14 ix=1,3 uf(ix )=ed(ix)*pp vf(ix )=vd(ix)*pp mf(ix )=md(ix)*pp qf(ix )=qd(ix)*pp 14 qf(ix+3)=qd(ix+3)*pp c : if(LQ1)then do 15 kk=1,NQ qk=qke(sf,se,Nexf,ne,kk,fac,st,iwr,A,B,C,D,E,N,np0,GP) do 15 ix=1,3 uf(ix )=uf(ix )+ddi(ix+ 3*(kk-1))*qk vf(ix )=vf(ix )+vvi(ix+ 3*(kk-1))*qk mf(ix )=mf(ix )+aai(ix+ 3*(kk-1))*qk qf(ix )=qf(ix )+qqi(ix+ 6*(kk-1))*qk 15 qf(ix+3)=qf(ix+3)+qqi(ix+3+6*(kk-1))*qk endif c transcript quadrupole to traceless one: call tqq(qf,u) c add the transition dipoles and quadrupole to the c ROA tensors: if(frroa)call dzz(ui,uvi,mi,uu,uf,vf,mf,u,alr,ali,avr,avi, 1gtr,gti,gcr,gci,atr,ati,acr,aci,wei,wef,w,gammaau,lvel) c add the transition dipoles and quadrupole to the c simplified ROA tensors: 34 call d1zz(w,wei,ui,uf,vf,mf,u,lr,li,vr,vi,gr,gi,ar,ai,gammaau) c add non-resonance harmonic polarizability for 0 -> 1 transition if(anroa)then if(Nexf.eq.1)then i=sf(1) c <0|Q|1>: f=dsqrt(CM/2.0d0/enr(i)) do 8 ix=1,3 do 8 jx=1,3 k=ix+3*(jx-1) lr(ix,jx) =lr(ix,jx) +ltens(k+9*(i-1)) *f gr(ix,jx) =gr(ix,jx) +gtens(k+9*(i-1)) *f ar(ix,jx,1)=ar(ix,jx,1)+atens(k+9*(1-1)+27*(i-1))*f ar(ix,jx,2)=ar(ix,jx,2)+atens(k+9*(2-1)+27*(i-1))*f 8 ar(ix,jx,3)=ar(ix,jx,3)+atens(k+9*(3-1)+27*(i-1))*f endif endif if(vrroa)then c add non-resonance harmonic polarizability) for close frequency ir=0 do 4 i=1,NQ lambda=ef*CM-enr(i) c find which energy might be close if(abs(lambda).lt.4.0d0*troa)then ir=ir+1 c <0|Q|1>: q12=dsqrt(CM/2.0d0/enr(i)) f=exp(-2.0d0*(lambda/troa)**2)/troa/spi*q12 do 5 ix=1,3 do 5 jx=1,3 k=ix+3*(jx-1) lr(ix,jx) =lr(ix,jx) +ltens(k+9*(i-1)) *f gr(ix,jx) =gr(ix,jx) +gtens(k+9*(i-1)) *f ar(ix,jx,1)=ar(ix,jx,1)+atens(k+9*(1-1)+27*(i-1))*f ar(ix,jx,2)=ar(ix,jx,2)+atens(k+9*(2-1)+27*(i-1))*f 5 ar(ix,jx,3)=ar(ix,jx,3)+atens(k+9*(3-1)+27*(i-1))*f endif 4 continue endif c write tensors into TTT.OUT in the Gaussian format: c use this for Raman intensities: call wrram2(ei,ef,THRC,nt,si,ni,Nexf, 1sf,EXCNM,wrin,wrax,npx,lglg,fwhh,reram,reroa,ltab, 1lr,li,vr,vi,gr,gi,ar,ai) if(lvel)then alur=avr alui=avi else alur=alr alui=ali endif if(frroa)call wrram3(w,ei,ef,THRC,nt,si,ni,Nexf, 1sf,EXCNM,wrin,wrax,npx,lglg,fwhh,ltab,inv, 1alur,alui,gtr,gti,gcr,gci,atr,ati,acr,aci,sr,1.0d0,.true., 1.true.,ldo,0.0d0,0.0d0) if(lwten)call wzz(w,ei,ef,alr,ali,gtr,gti,gcr,gci,atr,ati, 1acr,aci,avr,avi,inv) c if <0 .. 1> the record to FILE.Q.res.TTT if(Nexf.eq.1)then write(22,221)sf(1),ef*CM 221 format(i5,f12.2) DO 2002 ix=1,3 2002 WRITE(22,2003)ix,(lr(ix,jx),jx=1,3) 2003 FORMAT(I3,3g14.6) WRITE(22,2004) 2004 FORMAT(' The electric dipole magnetic dipole polarizability:',/, 1 ' mode e(cm-1) jx(Bx) jy(By) jz(Bz)') write(22,221)sf(1),ef*CM DO 2005 ix=1,3 2005 WRITE(22,2003)ix,(gr(jx,ix),jx=1,3) WRITE(22,2006) 2006 FORMAT(' The dipole quadrupole polarizability:', 2 /, ' mode e(cm-1) kx ky kz') write(22,221)sf(1),ef*CM DO 2007 ix=1,3 DO 2007 jx=1,3 2007 WRITE(22,2008)ix,jx,(ar(ix,jx,k),k=1,3) 2008 FORMAT(2I3,3g14.6) endif 1 continue NF=0 return end subroutine invm(maxo,maxd,nsi,o,d,sto,no,std,nd,si,ni) implicit none real*8 maxo,maxd,o,d integer*4 nsi,sto(nsi),std(nsi),si(nsi),no,nd,ni if(o.gt.maxo)then maxo=o no=ni sto=si endif if(d.gt.maxd)then maxd=d nd=ni std=si endif return end c subroutine rpe(s,e) c real*8 e c character*(*)s c character*12 s1,s2 c write(s1,10) e*219474.0d0 c write(s2,10)1.0d7/(e*219474.0d0) c10 format(f12.2) c write(6,'(a)')s//s1//' cm-1 '//s2//' nm' c return c end Subroutine SRC1(OvI,Ci1i1,Di1,OvI00,NQi1,EqnNA) Implicit Real*8(A-H,O-Z) C C Sharp and Rosenstock analytic formulae for Class 1 C Computes the Franck-Condon integrals analytically for overtones C C Input: C Ci1i1 : (i1,i1) element of the C Matrix C Di1 : (i1) element of the D Vector C OvI00 : Overlap integral <0_i|0_f> C NQi1 : Number of quanta for the mode i1 C C Output: C OvI : Calculated overlap integral. Null if not available C EqnNA : Indicates if an analytic formula was available or not C Nota: it is TRUE if _not_ found C C Input Integer NQi1 Real*8 Ci1i1, Di1, GFloat, OvI00 C Output Real*8 OvI Logical EqnNA C Local Integer i Real*8 One, Two, X C Save One, Two Data One/1.0D0/, Two/2.0D0/ C C Coefficient = OvI00/(SQRT(2^NQi1/NQi1!)*S_max!) with S_max = NQi1 C ==> X = OvI00/SQRT(2^NQi1*NQi1!) X = One EqnNA=.false. Do 100 i = NQi1, 1, -1 100 X = X * Two * GFloat(i) X = OvI00 / Sqrt(X) If(NQi1.eq.1) then C Case : < 0 | i^1 > OvI = X * Di1 else if(NQi1.eq.2) then C Case : < 0 | i^2 > OvI = X * (2.D0*Ci1i1 + Di1**2) else if(NQi1.eq.3) then C Case : < 0 | i^3 > OvI = X * (6.D0*Di1*Ci1i1 + Di1**3) else if(NQi1.eq.4) then C Case : < 0 | i^4 > OvI = X * (12.D0*Ci1i1**2 + 12.D0*Di1**2*Ci1i1 + Di1**4) else if(NQi1.eq.5) then C Case : < 0 | i^5 > OvI = X *(60.D0*Di1*Ci1i1**2 + 20.D0*Di1**3*Ci1i1 $ + Di1**5) else if(NQi1.eq.6) then C Case : < 0 | i^6 > OvI = X * (120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6) else if(NQi1.eq.7) then C Case : < 0 | i^7 > OvI = X * Di1*(840.D0*Ci1i1**3 + 420.D0*Ci1i1**2*Di1**2 $ + 42.D0*Ci1i1*Di1**4 + Di1**6) else if(NQi1.eq.8) then C Case : < 0 | i^8 > OvI = X * (1680.D0*Ci1i1**4 + 3360.D0*Ci1i1**3*Di1**2 $ + 840.D0*Ci1i1**2*Di1**4 + 56.D0*Ci1i1*Di1**6 + Di1**8) else if(NQi1.eq.9) then C Case : < 0 | i^9 > OvI = X * Di1*(15120.D0*Ci1i1**4 $ + 10080.D0*Ci1i1**3*Di1**2 + 1512.D0*Ci1i1**2*Di1**4 $ + 72.D0*Ci1i1*Di1**6 + Di1**8) else if(NQi1.eq.10) then C Case : < 0 | i^10 > OvI = X * (30240.D0*Ci1i1**5 + 75600.D0*Ci1i1**4*Di1**2 $ + 25200.D0*Ci1i1**3*Di1**4 + 2520.D0*Ci1i1**2*Di1**6 $ + 90.D0*Ci1i1*Di1**8 + Di1**10) else if(NQi1.eq.11) then C Case : < 0 | i^11 > OvI = X * Di1*(332640.D0*Ci1i1**5 $ + 277200.D0*Ci1i1**4*Di1**2 + 55440.D0*Ci1i1**3*Di1**4 $ + 3960.D0*Ci1i1**2*Di1**6 + 110.D0*Ci1i1*Di1**8 + Di1**10) else if(NQi1.eq.12) then C Case : < 0 | i^12 > OvI = X * (665280.D0*Ci1i1**6 $ + 1995840.D0*Ci1i1**5*Di1**2 + 831600.D0*Ci1i1**4*Di1**4 $ + 110880.D0*Ci1i1**3*Di1**6 + 5940.D0*Ci1i1**2*Di1**8 $ + 132.D0*Ci1i1*Di1**10 + Di1**12) else if(NQi1.eq.13) then C Case : < 0 | i^13 > OvI = X * Di1*(864864.D0*Ci1i1**6 $ + 8648640.D0*Ci1i1**5*Di1**2 + 2162160.D0*Ci1i1**4*Di1**4 $ + 205920.D0*Ci1i1**3*Di1**6 + 8580.D0*Ci1i1**2*Di1**8 $ + 156.D0*Ci1i1*Di1**10 + Di1**12) else if(NQi1.eq.14) then C Case : < 0 | i^14 > OvI = X * (17297280.D0*Ci1i1**7 $ + 60540480.D0*Ci1i1**6*Di1**2 + 30270240.D0*Ci1i1**5*Di1**4 $ + 5045040.D0*Ci1i1**4*Di1**6 + 360360.D0*Ci1i1**3*Di1**8 $ + 12012.D0*Ci1i1**2*Di1**10 + 182.D0*Ci1i1*Di1**12 + Di1**14) else if(NQi1.eq.15) then C Case : < 0 | i^15 > OvI = X * Di1*(259459200.D0*Ci1i1**7 $ + 302702400.D0*Ci1i1**6*Di1**2 + 90810720.D0*Ci1i1**5*Di1**4 $ + 10810800.D0*Ci1i1**4*Di1**6 + 600600.D0*Ci1i1**3*Di1**8 $ + 16380.D0*Ci1i1**2*Di1**10 + 210.D0*Ci1i1*Di1**12 + Di1**14) else if(NQi1.eq.16) then C Case : < 0 | i^16 > OvI = X * (518918400.D0*Ci1i1**8 $ + 2075673600.D0*Ci1i1**7*Di1**2 $ + 1210809600.D0*Ci1i1**6*Di1**4 + 242161920.D0*Ci1i1**5*Di1**6 $ + 21621600.D0*Ci1i1**4*Di1**8 + 960960.D0*Ci1i1**3*Di1**10 $ + 21840.D0*Ci1i1**2*Di1**12 + 240.D0*Ci1i1*Di1**14 + Di1**16) else if(NQi1.eq.17) then C Case : < 0 | i^17 > OvI = X * Di1*(8821612800.D0*Ci1i1**8 $ + 11762150400.D0*Ci1i1**7*Di1**2 $ + 4116752640.D0*Ci1i1**6*Di1**4 + 588107520.D0*Ci1i1**5*Di1**6 $ + 40840800.D0*Ci1i1**4*Di1**8 + 1485120.D0*Ci1i1**3*Di1**10 $ + 28560.D0*Ci1i1**2*Di1**12 + 272.D0*Ci1i1*Di1**14 + Di1**16) else if(NQi1.eq.18) then C Case : < 0 | i^18 > OvI = X * (17643225600.D0*Ci1i1**9 $ + 79394515200.D0*Ci1i1**8*Di1**2 $ + 52929676800.D0*Ci1i1**7*Di1**4 $ + 12350257920.D0*Ci1i1**6*Di1**6 $ + 1323241920.D0*Ci1i1**5*Di1**8 + 73513440.D0*Ci1i1**4*Di1**10 $ + 2227680.D0*Ci1i1**3*Di1**12 + 36720.D0*Ci1i1**2*Di1**14 $ + 306.D0*Ci1i1*Di1**16 + Di1**18) else if(NQi1.eq.19) then C Case : < 0 | i^19 > OvI = X * Di1*(335221286400.D0*Ci1i1**9 $ + 502831929600.D0*Ci1i1**8*Di1**2 $ + 201132771840.D0*Ci1i1**7*Di1**4 $ + 33522128640.D0*Ci1i1**6*Di1**6 $ + 2793510720.D0*Ci1i1**5*Di1**8 $ + 126977760.D0*Ci1i1**4*Di1**10 + 3255840.D0*Ci1i1**3*Di1**12 $ + 46512.D0*Ci1i1**2*Di1**14 + 342.D0*Ci1i1*Di1**16 + Di1**18) else if(NQi1.eq.20) then C Case : < 0 | i^20 > OvI = X * (67044257280.D0*Ci1i1**10 $ + 3352212864000.D0*Ci1i1**9*Di1**2 $ + 2514159648000.D0*Ci1i1**8*Di1**4 $ + 670442572800.D0*Ci1i1**7*Di1**6 $ + 83805321600.D0*Ci1i1**6*Di1**8 $ + 5587021440.D0*Ci1i1**5*Di1**10 $ + 211629600.D0*Ci1i1**4*Di1**12 + 4651200.D0*Ci1i1**3*Di1**14 $ + 58140.D0*Ci1i1**2*Di1**16 + 380.D0*Ci1i1*Di1**18 + Di1**20) else if(NQi1.eq.21) then C Case : < 0 | i^21 > OvI = X * Di1*(14079294028800.D0*Ci1i1**10 $ + 23465490048000.D0*Ci1i1**9*Di1**2 $ + 10559470521600.D0*Ci1i1**8*Di1**4 $ + 2011327718400.D0*Ci1i1**7*Di1**6 $ + 195545750400.D0*Ci1i1**6*Di1**8 $ + 10666131840.D0*Ci1i1**5*Di1**10 $ + 341863200.D0*Ci1i1**4*Di1**12 + 6511680.D0*Ci1i1**3*Di1**14 $ + 71820.D0*Ci1i1**2*Di1**16 + 420.D0*Ci1i1*Di1**18 + Di1**20) else if(NQi1.eq.22) then C Case : < 0 | i^22 > OvI = X * (28158588057600.D0*Ci1i1**11 $ + 154872234316800.D0*Ci1i1**10*Di1**2 $ + 129060195264000.D0*Ci1i1**9*Di1**4 $ + 38718058579200.D0*Ci1i1**8*Di1**6 $ + 5531151225600.D0*Ci1i1**7*Di1**8 $ + 430200650880.D0*Ci1i1**6*Di1**10 $ + 19554575040.D0*Ci1i1**5*Di1**12 $ + 537213600.D0*Ci1i1**4*Di1**14 + 8953560.D0*Ci1i1**3*Di1**16 $ + 87780.D0*Ci1i1**2*Di1**18 + 462.D0*Ci1i1*Di1**20 + Di1**22) else if(NQi1.eq.23) then C Case : < 0 | i^23 > OvI = X * Di1*(647647525324800.D0*Ci1i1**11 $ + 1187353796428800.D0*Ci1i1**10*Di1**2 $ + 593676898214400.D0*Ci1i1**9*Di1**4 $ + 127216478188800.D0*Ci1i1**8*Di1**6 $ + 14135164243200.D0*Ci1i1**7*Di1**8 $ + 899510451840.D0*Ci1i1**6*Di1**10 $ + 34596555840.D0*Ci1i1**5*Di1**12 $ + 823727520.D0*Ci1i1**4*Di1**14 + 12113640.D0*Ci1i1**3*Di1**16 $ + 106260.D0*Ci1i1**2*Di1**18 + 506.D0*Ci1i1*Di1**20 + Di1**22) else if(NQi1.eq.24) then C Case : < 0 | i^24 > OvI = X * (1295295050649600.D0*Ci1i1**12 $ + 7771770303897600.D0*Ci1i1**11*Di1**2 $ + 7124122778572800.D0*Ci1i1**10*Di1**4 $ + 2374707592857600.D0*Ci1i1**9*Di1**6 $ + 381649434566400.D0*Ci1i1**8*Di1**8 $ + 33924394183680.D0*Ci1i1**7*Di1**10 $ + 1799020903680.D0*Ci1i1**6*Di1**12 $ + 59308381440.D0*Ci1i1**5*Di1**14 $ + 1235591280.D0*Ci1i1**4*Di1**16 $ + 16151520.D0*Ci1i1**3*Di1**18 + 127512.D0*Ci1i1**2*Di1**20 $ + 552.D0*Ci1i1*Di1**22 + Di1**24) else if(NQi1.eq.25) then C Case : < 0 | i^25 > OvI = X * Di1*(32382376266240000.D0*Ci1i1**12 $ + 64764752532480000.D0*Ci1i1**11*Di1**2 $ + 35620613892864000.D0*Ci1i1**10*Di1**4 $ + 8481098545920000.D0*Ci1i1**9*Di1**6 $ + 1060137318240000.D0*Ci1i1**8*Di1**8 $ + 77100895872000.D0*Ci1i1**7*Di1**10 $ + 3459655584000.D0*Ci1i1**6*Di1**12 $ + 98847302400.D0*Ci1i1**5*Di1**14 $ + 1817046000.D0*Ci1i1**4*Di1**16 $ + 21252000.D0*Ci1i1**3*Di1**18 + 151800.D0*Ci1i1**2*Di1**20 $ + 600.D0*Ci1i1*Di1**22 + Di1**24) else if(NQi1.eq.26) then C Case : < 0 | i^26 > OvI = X * (64764752532480000.D0*Ci1i1**13 $ + 420970891461120000.D0*Ci1i1**12*Di1**2 $ + 420970891461120000.D0*Ci1i1**11*Di1**4 $ + 154355993535744000.D0*Ci1i1**10*Di1**6 $ + 27563570274240000.D0*Ci1i1**9*Di1**8 $ + 2756357027424000.D0*Ci1i1**8*Di1**10 $ + 167051941056000.D0*Ci1i1**7*Di1**12 $ + 6425074656000.D0*Ci1i1**6*Di1**14 $ + 160626866400.D0*Ci1i1**5*Di1**16 $ + 2624622000.D0*Ci1i1**4*Di1**18 $ + 27627600.D0*Ci1i1**3*Di1**20 + 179400.D0*Ci1i1**2*Di1**22 $ + 650.D0*Ci1i1*Di1**24 + Di1**26) else if(NQi1.eq.27) then C Case : < 0 | i^27 > OvI = X * Di1*(1748648318376960000.D0*Ci1i1**13 $ + 3788738023150080000.D0*Ci1i1**12*Di1**2 $ + 2273242813890048000.D0*Ci1i1**11*Di1**4 $ + 595373117923584000.D0*Ci1i1**10*Di1**6 $ + 82690710822720000.D0*Ci1i1**9*Di1**8 $ + 6765603612768000.D0*Ci1i1**8*Di1**10 $ + 346954031424000.D0*Ci1i1**7*Di1**12 $ + 11565134380800.D0*Ci1i1**6*Di1**14 $ + 255113258400.D0*Ci1i1**5*Di1**16 $ + 3729726000.D0*Ci1i1**4*Di1**18 $ + 35521200.D0*Ci1i1**3*Di1**20 + 210600.D0*Ci1i1**2*Di1**22 $ + 702.0D0*Ci1i1*Di1**24 + Di1**26) else if(NQi1.eq.28) then C Case : < 0 | i^28 > OvI = X * (3497296636753920000.D0*Ci1i1**14 $ + 24481076457277440000.D0*Ci1i1**13*Di1**2 $ + 26521166162050560000.D0*Ci1i1**12*Di1**4 $ + 10608466464820224000.D0*Ci1i1**11*Di1**6 $ + 2083805912732544000.D0*Ci1i1**10*Di1**8 $ + 231533990303616000.D0*Ci1i1**9*Di1**10 $ + 15786408429792000.D0*Ci1i1**8*Di1**12 $ + 693908062848000.D0*Ci1i1**7*Di1**14 $ + 20238985166400.D0*Ci1i1**6*Di1**16 $ + 396842846400.D0*Ci1i1**5*Di1**18 $ + 5221616400.D0*Ci1i1**4*Di1**20 $ + 45208800.D0*Ci1i1**3*Di1**22 + 245700.D0*Ci1i1**2*Di1**24 $ + 756.D0*Ci1i1*Di1**26 + Di1**28) else if(NQi1.eq.29) then C Case : < 0 | i^29 > OvI = X * Di1*(101421602465863680000.D0*Ci1i1**14 $ + 236650405753681920000.D0*Ci1i1**13*Di1**2 $ + 153822763739893248000.D0*Ci1i1**12*Di1**4 $ + 43949361068540928000.D0*Ci1i1**11*Di1**6 $ + 6714485718804864000.D0*Ci1i1**10*Di1**8 $ + 610407792618624000.D0*Ci1i1**9*Di1**10 $ + 35215834189536000.D0*Ci1i1**8*Di1**12 $ + 1341555588172800.D0*Ci1i1**7*Di1**14 $ + 34525327636800.D0*Ci1i1**6*Di1**16 $ + 605707502400.D0*Ci1i1**5*Di1**18 $ + 7210803600.D0*Ci1i1**4*Di1**20 $ + 57002400.D0*Ci1i1**3*Di1**22 + 285012.D0*Ci1i1**2*Di1**24 $ + 812.D0*Ci1i1*Di1**26 + Di1**28) else if(NQi1.eq.30) then C Case : < 0 | i^30 > OvI = X * (202843204931727360000.D0*Ci1i1**15 $ + 1521324036987955200000.D0*Ci1i1**14*Di1**2 $ + 1774878043152614400000.D0*Ci1i1**13*Di1**4 $ + 769113818699466240000.D0*Ci1i1**12*Di1**6 $ + 164810104007028480000.D0*Ci1i1**11*Di1**8 $ + 20143457156414592000.D0*Ci1i1**10*Di1**10 $ + 1526019481546560000.D0*Ci1i1**9*Di1**12 $ + 75462501834720000.D0*Ci1i1**8*Di1**14 $ + 2515416727824000.D0*Ci1i1**7*Di1**16 $ + 57542212728000.D0*Ci1i1**6*Di1**18 $ + 908561253600.D0*Ci1i1**5*Di1**20 $ + 9832914000.D0*Ci1i1**4*Di1**22 $ + 71253000.D0*Ci1i1**3*Di1**24 + 328860.D0*Ci1i1**2*Di1**26 $ + 870.D0*Ci1i1*Di1**28 + Di1**30) else C Case "not found" EqnNA = .True. endIf Return End Subroutine SRC2(OvI,Ci1i1,Ci2i2,Ci1i2,Di1,Di2,OvI00,NQi1, $ NQi2,EqnNA) Implicit Real*8(A-H,O-Z) C C Sharp and Rosenstock analytic formulae for Class 2 C Computes the Franck-Condon integral for combination between 2 excited C vibrational states C C Input: C Ci1i1 : (i1,i1) element of the C Matrix C Ci2i2 : (i2,i2) element of the C Matrix C Ci1i2 : (i1,i2) element of the C Matrix C Di1 : (i1) element of the D Vector C Di1 : (i2) element of the D Vector C OvI00 : Overlap integral <0_i|0_f> C NQi1 : Number of quanta for the mode i1 C NQi2 : Number of quanta for the mode i2 C C Output: C OvI : Calculated overlap integral. Null if not available C EqnNA : Indicates if an analytic formula was available or not C Nota: it is TRUE if _not_ found C C Input Integer NQi1, NQi2 Real*8 Ci1i1, Ci1i2, Ci2i2, Di1, Di2, GFloat, OvI00 C Output Real*8 OvI Logical EqnNA C Local Integer i Real*8 One, Two, X, X1 Save One, Two Data One/1.0D0/, Two/2.0D0/ C C Coefficient = OvI00 * (NQi1!*NQi2!)^1/2 / ((2^NQi1*2^NQi2)^1/2 C * S_max!) with S_max! = NQi1!*NQi2! C ==> X = OvI00/SQRT(2^(NQi1+NQi2)*NQi1!*NQi2!) EqnNA=.false. X = One Do 10 i = NQi2, 1, -1 X = X * Two * GFloat(i) If(i.le.NQi1) X = X * Two * GFloat(i) 10 Continue X = OvI00 / Sqrt(X) If(NQi1.eq.1) then C Case < 0 | i^1,j^n > If(NQi2.eq.1) then C Case < 0 | i^1,j^1 > OvI = X * (2.D0*Ci1i2 + Di2*Di1) else if(NQi2.eq.2) then C Case < 0 | i^1,j^2 > OvI = X * (4.D0*Di2*Ci1i2 + 2.D0*Di1*Ci2i2 $ + Di2**2*Di1) else if(NQi2.eq.3) then C Case < 0 | i^1,j^3 > OvI = X * (12.D0*Ci2i2*Ci1i2 + 6.D0*Di2**2*Ci1i2 $ + 6.D0*Di2*Di1*Ci2i2 + Di2**3*Di1) else if(NQi2.eq.4) then C Case < 0 | i^1,j^4 > OvI = X * (48.D0*Ci2i2*Ci1i2*Di2 + 8.D0*Ci1i2*Di2**3 $ + 12.D0*Ci2i2**2*Di1 + 12.D0*Ci2i2*Di2**2*Di1 + Di2**4*Di1) else if(NQi2.eq.5) then C Case < 0 | i^1,j^5 > OvI = X * (120.D0*Ci2i2**2*Ci1i2 $ + 120.D0*Ci2i2*Ci1i2*Di2**2 + 10.D0*Ci1i2*Di2**4 $ + 60.D0*Ci2i2**2*Di2*Di1 + 20.D0*Ci2i2*Di2**3*Di1 $ + Di2**5*Di1) else if(NQi2.eq.6) then C Case < 0 | i^1,j^6 > OvI = X * (720.D0*Ci2i2**2*Ci1i2*Di2 $ + 240.D0*Ci2i2*Ci1i2*Di2**3 + 12.D0*Ci1i2*Di2**5 $ + 120.D0*Ci2i2**3*Di1 + 180.D0*Ci2i2**2*Di2**2*Di1 $ + 30.D0*Ci2i2*Di2**4*Di1 + Di2**6*Di1) else if(NQi2.eq.7) then C Case < 0 | i^1,j^7 > OvI = X * (1680.D0*Ci2i2**3*Ci1i2 $ + 2520.D0*Ci2i2**2*Ci1i2*Di2**2 + 420.D0*Ci2i2*Ci1i2*Di2**4 $ + 14.D0*Ci1i2*Di2**6 + 840.D0*Ci2i2**3*Di2*Di1 $ + 420.D0*Ci2i2**2*Di2**3*Di1 + 42.D0*Ci2i2*Di2**5*Di1 $ + Di2**7*Di1) else if(NQi2.eq.8) then C Case < 0 | i^1,j^8 > OvI = X * (13440.D0*Ci2i2**3*Ci1i2*Di2 $ + 6720.D0*Ci2i2**2*Ci1i2*Di2**3 + 672.D0*Ci2i2*Ci1i2*Di2**5 $ + 16.D0*Ci1i2*Di2**7 + 1680.D0*Ci2i2**4*Di1 $ + 3360.D0*Ci2i2**3*Di2**2*Di1 + 840.D0*Ci2i2**2*Di2**4*Di1 $ + 56.D0*Ci2i2*Di2**6*Di1 + Di2**8*Di1) else if(NQi2.eq.9) then C Case < 0 | i^1,j^9 > OvI = X * (30240.D0*Ci2i2**4*Ci1i2 $ + 60480.D0*Ci2i2**3*Ci1i2*Di2**2 $ + 15120.D0*Ci2i2**2*Ci1i2*Di2**4 $ + 1008.D0*Ci2i2*Ci1i2*Di2**6 + 18.D0*Ci1i2*Di2**8 $ + 15120.D0*Ci2i2**4*Di2*Di1 + 10080.D0*Ci2i2**3*Di2**3*Di1 $ + 1512.D0*Ci2i2**2*Di2**5*Di1 + 72.D0*Ci2i2*Di2**7*Di1 $ + Di2**9*Di1) else if(NQi2.eq.10) then C Case < 0 | i^1,j^10 > OvI = X * (302400.D0*Ci2i2**4*Ci1i2*Di2 $ + 201600.D0*Ci2i2**3*Ci1i2*Di2**3 $ + 30240.D0*Ci2i2**2*Ci1i2*Di2**5 $ + 1440.D0*Ci2i2*Ci1i2*Di2**7 + 20.D0*Ci1i2*Di2**9 $ + 30240.D0*Ci2i2**5*Di1 + 75600.D0*Ci2i2**4*Di2**2*Di1 $ + 25200.D0*Ci2i2**3*Di2**4*Di1 + 2520.D0*Ci2i2**2*Di2**6*Di1 $ + 90.D0*Ci2i2*Di2**8*Di1 + Di2**10*Di1) else if(NQi2.eq.11) then C Case < 0 | i^1,j^11 > OvI = X * (665280.D0*Ci2i2**5*Ci1i2 $ + 1663200.D0*Ci2i2**4*Ci1i2*Di2**2 $ + 554400.D0*Ci2i2**3*Ci1i2*Di2**4 $ + 55440.D0*Ci2i2**2*Ci1i2*Di2**6 $ + 1980.D0*Ci2i2*Ci1i2*Di2**8 + 22.D0*Ci1i2*Di2**10 $ + 332640.D0*Ci2i2**5*Di2*Di1 + 277200.D0*Ci2i2**4*Di2**3*Di1 $ + 55440.D0*Ci2i2**3*Di2**5*Di1 + 3960.D0*Ci2i2**2*Di2**7*Di1 $ + 110.D0*Ci2i2*Di2**9*Di1 + Di2**11*Di1) else if(NQi2.eq.12) then C Case < 0 | i^1,j^12 > OvI = X * (665280.D0*Ci2i2**6*Di1 $ + 1995840.D0*Ci2i2**5*Di2*(4.D0*Ci1i2 + Di2*Di1) $ + 831600.D0*Ci2i2**4*Di2**3*(8.D0*Ci1i2 + Di2*Di1) $ + 110880.D0*Ci2i2**3*Di2**5*(12.D0*Ci1i2 + Di2*Di1) $ + 5940.D0*Ci2i2**2*Di2**7*(16.D0*Ci1i2 + Di2*Di1) $ + 132.D0*Ci2i2*Di2**9*(20.D0*Ci1i2 + Di2*Di1) $ + Di2**11*(24.D0*Ci1i2 + Di2*Di1)) C Case < 0 | i^1,j^13 > else if(NQi2.eq.13) then C Case < 0 | i^1,j^13 > OvI = X * (8648640.D0*Ci2i2**6*(2.D0*Ci1i2 + Di2*Di1) $ + 8648640.D0*Ci2i2**5*Di2**2*(6.D0*Ci1i2 + Di2*Di1) $ + 2162160.D0*Ci2i2**4*Di2**4*(10.D0*Ci1i2 + Di2*Di1) $ + 205920.D0*Ci2i2**3*Di2**6*(14.D0*Ci1i2 + Di2*Di1) $ + 8580.D0*Ci2i2**2*Di2**8*(18.D0*Ci1i2 + Di2*Di1) $ + 156.D0*Ci2i2*Di2**10*(22.D0*Ci1i2 + Di2*Di1) $ + Di2**12*(26.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.14) then C Case < 0 | i^1,j^14 > OvI = X * (17297280.D0*Ci2i2**7*Di1 $ + 60540480.D0*Ci2i2**6*Di2*(4.D0*Ci1i2 + Di2*Di1) $ + 30270240.D0*Ci2i2**5*Di2**3*(8.D0*Ci1i2 + Di2*Di1) $ + 5045040.D0*Ci2i2**4*Di2**5*(12.D0*Ci1i2 + Di2*Di1) $ + 360360.D0*Ci2i2**3*Di2**7*(16.D0*Ci1i2 + Di2*Di1) $ + 12012.D0*Ci2i2**2*Di2**9*(20.D0*Ci1i2 + Di2*Di1) $ + 182.D0*Ci2i2*Di2**11*(24.D0*Ci1i2 + Di2*Di1) $ + Di2**13*(28.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.15) then C Case < 0 | i^1,j^15 > OvI = X * (259459200.D0*Ci2i2**7*(2.D0*Ci1i2 + Di2*Di1) $ + 302702400.D0*Ci2i2**6*Di2**2*(6.D0*Ci1i2 + Di2*Di1) $ + 90810720.D0*Ci2i2**5*Di2**4*(10.D0*Ci1i2 + Di2*Di1) $ + 10810800.D0*Ci2i2**4*Di2**6*(14.D0*Ci1i2 + Di2*Di1) $ + 600600.D0*Ci2i2**3*Di2**8*(18.D0*Ci1i2 + Di2*Di1) $ + 16380.D0*Ci2i2**2*Di2**10*(22.D0*Ci1i2 + Di2*Di1) $ + 210.D0*Ci2i2*Di2**12*(26.D0*Ci1i2 + Di2*Di1) $ + Di2**14*(30.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.16) then C Case < 0 | i^1,j^16 > OvI = X * (518918400.D0*Ci2i2**8*Di1 $ + 2075673600.D0*Ci2i2**7*Di2*(4.D0*Ci1i2 + Di2*Di1) $ + 1210809600.D0*Ci2i2**6*Di2**3*(8.D0*Ci1i2 + Di2*Di1) $ + 242161920.D0*Ci2i2**5*Di2**5*(12.D0*Ci1i2 + Di2*Di1) $ + 21621600.D0*Ci2i2**4*Di2**7*(16.D0*Ci1i2 + Di2*Di1) $ + 960960.D0*Ci2i2**3*Di2**9*(20.D0*Ci1i2 + Di2*Di1) $ + 21840.D0*Ci2i2**2*Di2**11*(24.D0*Ci1i2 + Di2*Di1) $ + 240.D0*Ci2i2*Di2**13*(28.D0*Ci1i2 + Di2*Di1) $ + Di2**15*(32.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.17) then C Case < 0 | i^1,j^17 > OvI = X*(8821612800.D0*Ci2i2**8*(2.D0*Ci1i2 + Di2*Di1) $ + 11762150400.D0*Ci2i2**7*Di2**2*(6.D0*Ci1i2 + Di2*Di1) $ + 4116752640.D0*Ci2i2**6*Di2**4*(10.D0*Ci1i2 + Di2*Di1) $ + 588107520.D0*Ci2i2**5*Di2**6*(14.D0*Ci1i2 + Di2*Di1) $ + 40840800.D0*Ci2i2**4*Di2**8*(18.D0*Ci1i2 + Di2*Di1) $ + 1485120.D0*Ci2i2**3*Di2**10*(22.D0*Ci1i2 + Di2*Di1) $ + 28560.D0*Ci2i2**2*Di2**12*(26.D0*Ci1i2 + Di2*Di1) $ + 272.D0*Ci2i2*Di2**14*(30.D0*Ci1i2 + Di2*Di1) $ + Di2**16*(34.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.18) then C Case < 0 | i^1,j^18 > OvI = X * (17643225600.D0*Ci2i2**9*Di1 $ + 79394515200.D0*Ci2i2**8*Di2*(4.D0*Ci1i2 + Di2*Di1) $ + 52929676800.D0*Ci2i2**7*Di2**3*(8.D0*Ci1i2 + Di2*Di1) $ + 12350257920.D0*Ci2i2**6*Di2**5*(12.D0*Ci1i2 + Di2*Di1) $ + 1323241920.D0*Ci2i2**5*Di2**7*(16.D0*Ci1i2 + Di2*Di1) $ + 73513440.D0*Ci2i2**4*Di2**9*(20.D0*Ci1i2 + Di2*Di1) $ + 2227680.D0*Ci2i2**3*Di2**11*(24.D0*Ci1i2 + Di2*Di1) $ + 36720.D0*Ci2i2**2*Di2**13*(28.D0*Ci1i2 + Di2*Di1) $ + 306.D0*Ci2i2*Di2**15*(32.D0*Ci1i2 + Di2*Di1) $ + Di2**17*(36.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.19) then C Case < 0 | i^1,j^19 > OvI = X * (335221286400.D0*Ci2i2**9*(2.D0*Ci1i2 $ + Di2*Di1) + 502831929600.D0*Ci2i2**8*Di2**2*(6.D0*Ci1i2 $ + Di2*Di1) + 201132771840.D0*Ci2i2**7*Di2**4*(10.D0*Ci1i2 $ + Di2*Di1) + 33522128640.D0*Ci2i2**6*Di2**6*(14.D0*Ci1i2 $ + Di2*Di1) + 2793510720.D0*Ci2i2**5*Di2**8*(18.D0*Ci1i2 $ + Di2*Di1) + 126977760.D0*Ci2i2**4*Di2**10*(22.D0*Ci1i2 $ + Di2*Di1) + 3255840.D0*Ci2i2**3*Di2**12*(26.D0*Ci1i2 $ + Di2*Di1) + 46512.D0*Ci2i2**2*Di2**14*(30.D0*Ci1i2 $ + Di2*Di1) + 342.D0*Ci2i2*Di2**16*(34.D0*Ci1i2 + Di2*Di1) $ + Di2**18*(38.D0*Ci1i2 + Di2*Di1)) else if(NQi2.eq.20) then C Case < 0 | i^1,j^20 > OvI = X * (670442572800.D0*Ci2i2**10*Di1 $ + 3352212864000.D0*Ci2i2**9*Di2*(4.D0*Ci1i2 + Di2*Di1) $ + 2514159648000.D0*Ci2i2**8*Di2**3*(8.D0*Ci1i2 + Di2*Di1) $ + 670442572800.D0*Ci2i2**7*Di2**5*(12.D0*Ci1i2 + Di2*Di1) $ + 83805321600.D0*Ci2i2**6*Di2**7*(16.D0*Ci1i2 + Di2*Di1) $ + 5587021440.D0*Ci2i2**5*Di2**9*(20.D0*Ci1i2 + Di2*Di1) $ + 211629600.D0*Ci2i2**4*Di2**11*(24.D0*Ci1i2 + Di2*Di1) $ + 4651200.D0*Ci2i2**3*Di2**13*(28.D0*Ci1i2 + Di2*Di1) $ + 58140.D0*Ci2i2**2*Di2**15*(32.D0*Ci1i2 + Di2*Di1) $ + 380.D0*Ci2i2*Di2**17*(36.D0*Ci1i2 + Di2*Di1) $ + Di2**19*(40.D0*Ci1i2 + Di2*Di1)) else C Case "not found" EqnNA = .True. endIf else if(NQi1.eq.2) then C Case < 0 | i^2,j^n > If(NQi2.eq.2) then C Case < 0 | i^2,j^2 > OvI = X * (8.D0*Ci1i2**2 + 4.D0*Ci2i2*Ci1i1 $ + 2.D0*Ci1i1*Di2**2 + 8.D0*Ci1i2*Di2*Di1 + 2.D0*Ci2i2*Di1**2 $ + Di2**2*Di1**2) else if(NQi2.eq.3) then C Case < 0 | i^2,j^3 > OvI = X * (24.D0*Ci1i2**2*Di2 + 12.D0*Ci2i2*Ci1i1*Di2 $ + 2.D0*Ci1i1*Di2**3 + 24.D0*Ci2i2*Ci1i2*Di1 $ + 12.D0*Ci1i2*Di2**2*Di1 + 6.D0*Ci2i2*Di2*Di1**2 $ + Di2**3*Di1**2) else if(NQi2.eq.4) then C Case < 0 | i^2,j^4 > OvI = X * (96.D0*Ci2i2*Ci1i2**2 + 24.D0*Ci2i2**2*Ci1i1 $ + 48.D0*Ci1i2**2*Di2**2 + 24.D0*Ci2i2*Ci1i1*Di2**2 $ + 2.D0*Ci1i1*Di2**4 + 96.D0*Ci2i2*Ci1i2*Di2*Di1 $ + 16.D0*Ci1i2*Di2**3*Di1 + 12.D0*Ci2i2**2*Di1**2 $ + 12.D0*Ci2i2*Di2**2*Di1**2 + Di2**4*Di1**2) else if(NQi2.eq.5) then C Case < 0 | i^2,j^5 > OvI = X * (480.D0*Ci2i2*Ci1i2**2*Di2 $ + 120.D0*Ci2i2**2*Ci1i1*Di2 + 80.D0*Ci1i2**2*Di2**3 $ + 40.D0*Ci2i2*Ci1i1*Di2**3 + 2.D0*Ci1i1*Di2**5 $ + 240.D0*Ci2i2**2*Ci1i2*Di1 + 240.D0*Ci2i2*Ci1i2*Di2**2*Di1 $ + 20.D0*Ci1i2*Di2**4*Di1 + 60.D0*Ci2i2**2*Di2*Di1**2 $ + 20.D0*Ci2i2*Di2**3*Di1**2 + Di2**5*Di1**2) else if(NQi2.eq.6) then C Case < 0 | i^2,j^6 > OvI = X * (1440.D0*Ci2i2**2*Ci1i2**2 $ + 240.D0*Ci2i2**3*Ci1i1 + 1440.D0*Ci2i2*Ci1i2**2*Di2**2 $ + 360.D0*Ci2i2**2*Ci1i1*Di2**2 + 120.D0*Ci1i2**2*Di2**4 $ + 60.D0*Ci2i2*Ci1i1*Di2**4 + 2.D0*Ci1i1*Di2**6 $ + 1440.D0*Ci2i2**2*Ci1i2*Di2*Di1 $ + 480.D0*Ci2i2*Ci1i2*Di2**3*Di1 + 24.D0*Ci1i2*Di2**5*Di1 $ + 120.D0*Ci2i2**3*Di1**2 + 180.D0*Ci2i2**2*Di2**2*Di1**2 $ + 30.D0*Ci2i2*Di2**4*Di1**2 + Di2**6*Di1**2) else if(NQi2.eq.7) then C Case < 0 | i^2,j^7 > OvI = X * (10080.D0*Ci2i2**2*Ci1i2**2*Di2 $ + 1680.D0*Ci2i2**3*Ci1i1*Di2 + 3360.D0*Ci2i2*Ci1i2**2*Di2**3 $ + 840.D0*Ci2i2**2*Ci1i1*Di2**3 + 168.D0*Ci1i2**2*Di2**5 $ + 84.D0*Ci2i2*Ci1i1*Di2**5 + 2.D0*Ci1i1*Di2**7 $ + 3360.D0*Ci2i2**3*Ci1i2*Di1 $ + 5040.D0*Ci2i2**2*Ci1i2*Di2**2*Di1 $ + 840.D0*Ci2i2*Ci1i2*Di2**4*Di1 + 28.D0*Ci1i2*Di2**6*Di1 $ + 840.D0*Ci2i2**3*Di2*Di1**2 + 420.D0*Ci2i2**2*Di2**3*Di1**2 $ + 42.D0*Ci2i2*Di2**5*Di1**2 + Di2**7*Di1**2) else if(NQi2.eq.8) then C Case < 0 | i^2,j^8 > OvI = X * (1680.D0*Ci2i2**4*(2.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci2i2**3*(8.D0*Ci1i2**2 + 8.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 840.D0*Ci2i2**2*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 56.D0*Ci2i2*Di2**4*(120.D0*Ci1i2**2 + 24.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) + Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.9) then C Case < 0 | i^2,j^9 > OvI = X * (15120.D0*Ci2i2**4*(2.D0*Ci1i1*Di2 $ + Di1*(4.D0*Ci1i2 + Di2*Di1)) $ + 10080.D0*Ci2i2**3*Di2*(24.D0*Ci1i2**2 $ + 12.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 1512.D0*Ci2i2**2*Di2**3*(80.D0*Ci1i2**2 $ + 20.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 72.D0*Ci2i2*Di2**5*(168.D0*Ci1i2**2 $ + 28.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**7*(288.D0*Ci1i2**2 + 36.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.10) then C Case < 0 | i^2,j^10 > OvI = X * (30240.D0*Ci2i2**5*(2.D0*Ci1i1 + Di1**2) $ + 75600.D0*Ci2i2**4*(8.D0*Ci1i2**2 + 8.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 25200.D0*Ci2i2**3*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 2520.D0*Ci2i2**2*Di2**4*(120.D0*Ci1i2**2 $ + 24.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 90.D0*Ci2i2*Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**8*(360.D0*Ci1i2**2 + 40.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.11) then C Case < 0 | i^2,j^11 > OvI = X * (332640.D0*Ci2i2**5*(2.D0*Ci1i1*Di2 $ + Di1*(4.D0*Ci1i2 + Di2*Di1)) $ + 277200.D0*Ci2i2**4*Di2*(24.D0*Ci1i2**2 $ + 12.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 55440.D0*Ci2i2**3*Di2**3*(80.D0*Ci1i2**2 $ + 20.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 3960.D0*Ci2i2**2*Di2**5*(168.D0*Ci1i2**2 $ + 28.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 110.D0*Ci2i2*Di2**7*(288.D0*Ci1i2**2 + 36.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2*Ci1i1 + Di1**2)) + Di2**9*(440.D0*Ci1i2**2 $ + 44.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.12) then C Case < 0 | i^2,j^12 > OvI = X * (665280.D0*Ci2i2**6*(2.D0*Ci1i1 + Di1**2) $ + 1995840.D0*Ci2i2**5*(8*Ci1i2**2 + 8.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 831600.D0*Ci2i2**4*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 110880.D0*Ci2i2**3*Di2**4*(120.D0*Ci1i2**2 $ + 24.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 5940.D0*Ci2i2**2*Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 132.D0*Ci2i2*Di2**8*(360.D0*Ci1i2**2 + 40.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) + Di2**10*(528.D0*Ci1i2**2 $ + 48.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.13) then C Case < 0 | i^2,j^13 > OvI = X * (8648640.D0*Ci2i2**6*(2.D0*Ci1i1*Di2 $ + Di1*(4.D0*Ci1i2 + Di2*Di1)) $ + 8648640.D0*Ci2i2**5*Di2*(24*Ci1i2**2 $ + 12.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 2162160.D0*Ci2i2**4*Di2**3*(80.D0*Ci1i2**2 $ + 20.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 205920.D0*Ci2i2**3*Di2**5*(168.D0*Ci1i2**2 $ + 28.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 8580.D0*Ci2i2**2*Di2**7*(288.D0*Ci1i2**2 $ + 36.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 156.D0*Ci2i2*Di2**9*(440.D0*Ci1i2**2 + 44.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) + Di2**11*(624.D0*Ci1i2**2 $ + 52.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.14) then C Case < 0 | i^2,j^14 > OvI = X * (17297280.D0*Ci2i2**7*(2.D0*Ci1i1 + Di1**2) $ + 60540480.D0*Ci2i2**6*(8.D0*Ci1i2**2 + 8.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 30270240.D0*Ci2i2**5*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 5045040.D0*Ci2i2**4*Di2**4*(120.D0*Ci1i2**2 $ + 24.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 360360.D0*Ci2i2**3*Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 12012.D0*Ci2i2**2*Di2**8*(360.D0*Ci1i2**2 $ + 40.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 182.D0*Ci2i2*Di2**10*(528.D0*Ci1i2**2 $ + 48.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**12*(728.D0*Ci1i2**2 + 56.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.15) then C Case < 0 | i^2,j^15 > OvI = X * (259459200.D0*Ci2i2**7*(2.D0*Ci1i1*Di2 $ + Di1*(4.D0*Ci1i2 + Di2*Di1)) $ + 302702400.D0*Ci2i2**6*Di2*(24.D0*Ci1i2**2 $ + 12.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 90810720.D0*Ci2i2**5*Di2**3*(80.D0*Ci1i2**2 $ + 20.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 10810800.D0*Ci2i2**4*Di2**5*(168.D0*Ci1i2**2 $ + 28.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 600600.D0*Ci2i2**3*Di2**7*(288.D0*Ci1i2**2 $ + 36.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 16380.D0*Ci2i2**2*Di2**9*(440.D0*Ci1i2**2 $ + 44.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 210.D0*Ci2i2*Di2**11*(624.D0*Ci1i2**2 $ + 52.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**13*(840.D0*Ci1i2**2 + 60.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.16) then C Case < 0 | i^2,j^16 > OvI = X * (518918400.D0*Ci2i2**8*(2.D0*Ci1i1 + Di1**2) $ + 2075673600.D0*Ci2i2**7*(8.D0*Ci1i2**2 + 8.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 1210809600.D0*Ci2i2**6*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 242161920.D0*Ci2i2**5*Di2**4*(120.D0*Ci1i2**2 $ + 24.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 21621600.D0*Ci2i2**4*Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 960960.D0*Ci2i2**3*Di2**8*(360.D0*Ci1i2**2 $ + 40.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 21840.D0*Ci2i2**2*Di2**10*(528.D0*Ci1i2**2 $ + 48.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 240.D0*Ci2i2*Di2**12*(728.D0*Ci1i2**2 $ + 56.D0*Ci1i2*Di2*Di1 + Di2**2*(2*Ci1i1 + Di1**2)) $ + Di2**14*(960*Ci1i2**2 + 64.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.17) then C Case < 0 | i^2,j^17 > OvI = X * (8821612800.D0*Ci2i2**8*(2.D0*Ci1i1*Di2 $ + Di1*(4.D0*Ci1i2 + Di2*Di1)) $ + 11762150400.D0*Ci2i2**7*Di2*(24.D0*Ci1i2**2 $ + 12.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 4116752640.D0*Ci2i2**6*Di2**3*(80.D0*Ci1i2**2 $ + 20.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 588107520.D0*Ci2i2**5*Di2**5*(168.D0*Ci1i2**2 $ + 28.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 40840800.D0*Ci2i2**4*Di2**7*(288.D0*Ci1i2**2 $ + 36.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 1485120.D0*Ci2i2**3*Di2**9*(440.D0*Ci1i2**2 $ + 44.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 28560.D0*Ci2i2**2*Di2**11*(624.D0*Ci1i2**2 $ + 52.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 272.D0*Ci2i2*Di2**13*(840.D0*Ci1i2**2 $ + 60.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**15*(1088.D0*Ci1i2**2 + 68.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.18) then C Case < 0 | i^2,j^18 > OvI = X*(17643225600.D0*Ci2i2**9*(2.D0*Ci1i1 + Di1**2) $ + 79394515200.D0*Ci2i2**8*(8.D0*Ci1i2**2 $ + 8.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 52929676800.D0*Ci2i2**7*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 12350257920.D0*Ci2i2**6*Di2**4*(120.D0*Ci1i2**2 $ + 24.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 1323241920.D0*Ci2i2**5*Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 73513440.D0*Ci2i2**4*Di2**8*(360.D0*Ci1i2**2 $ + 40.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 2227680.D0*Ci2i2**3*Di2**10*(528.D0*Ci1i2**2 $ + 48.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 36720.D0*Ci2i2**2*Di2**12*(728.D0*Ci1i2**2 $ + 56.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 306.D0*Ci2i2*Di2**14*(960.D0*Ci1i2**2 $ + 64.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**16*(1224.D0*Ci1i2**2 + 72.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.19) then C Case < 0 | i^2,j^19 > OvI = X * (335221286400.D0*Ci2i2**9*(2.D0*Ci1i1*Di2 $ + Di1*(4.D0*Ci1i2 + Di2*Di1)) $ + 502831929600.D0*Ci2i2**8*Di2*(24.D0*Ci1i2**2 $ + 12.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 201132771840.D0*Ci2i2**7*Di2**3*(80.D0*Ci1i2**2 $ + 20.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 33522128640.D0*Ci2i2**6*Di2**5*(168.D0*Ci1i2**2 $ + 28.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 2793510720.D0*Ci2i2**5*Di2**7*(288.D0*Ci1i2**2 $ + 36.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 126977760.D0*Ci2i2**4*Di2**9*(440.D0*Ci1i2**2 $ + 44.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 3255840.D0*Ci2i2**3*Di2**11*(624.D0*Ci1i2**2 $ + 52.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 46512.D0*Ci2i2**2*Di2**13*(840.D0*Ci1i2**2 $ + 60.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 342.D0*Ci2i2*Di2**15*(1088.D0*Ci1i2**2 $ + 68.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**17*(1368.D0*Ci1i2**2 + 76.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.20) then C Case < 0 | i^2,j^20 > X1 = 670442572800.D0*Ci2i2**10*(2.D0*Ci1i1 + Di1**2) $ + 3352212864000.D0*Ci2i2**9*(8.D0*Ci1i2**2 $ + 8.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 2514159648000.D0*Ci2i2**8*Di2**2*(48.D0*Ci1i2**2 $ + 16.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 670442572800.D0*Ci2i2**7*Di2**4*(120.D0*Ci1i2**2 $ + 24.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 83805321600.D0*Ci2i2**6*Di2**6*(224.D0*Ci1i2**2 $ + 32.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 5587021440.D0*Ci2i2**5*Di2**8*(360.D0*Ci1i2**2 $ + 40.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) X1 = X1 + 211629600.D0*Ci2i2**4*Di2**10*(528.D0*Ci1i2**2 $ + 48.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 4651200.D0*Ci2i2**3*Di2**12*(728.D0*Ci1i2**2 $ + 56.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 58140.D0*Ci2i2**2*Di2**14*(960.D0*Ci1i2**2 $ + 64.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + 380.D0*Ci2i2*Di2**16*(1224.D0*Ci1i2**2 $ + 72.D0*Ci1i2*Di2*Di1 + Di2**2*(2.D0*Ci1i1 + Di1**2)) $ + Di2**18*(1520.D0*Ci1i2**2 + 80.D0*Ci1i2*Di2*Di1 $ + Di2**2*(2.D0*Ci1i1 + Di1**2)) OvI = X * X1 else C Case "not found" EqnNA = .True. endIf else if(NQi1.eq.3) then C Case < 0 | i^3,j^n > If(NQi2.eq.3) then C Case < 0 | i^3,j^3 > OvI = X * (48.D0*Ci1i2**3 + 72.D0*Ci1i2**2*Di2*Di1 $ + 18.D0*Ci1i2*(2.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 + Di1**2) $ + Di2*(6.D0*Ci2i2 + Di2**2)*Di1*(6.D0*Ci1i1 + Di1**2)) else if(NQi2.eq.4) then C Case < 0 | i^3,j^4 > OvI = X * (192.D0*Ci1i2**3*Di2 $ + 144.D0*Ci1i2**2*(2.D0*Ci2i2 + Di2**2)*Di1 $ + 24.D0*Ci1i2*Di2*(6.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2) + (12.D0*Ci2i2**2 + 12.D0*Ci2i2*Di2**2 $ + Di2**4)*Di1*(6.D0*Ci1i1 + Di1**2)) else if(NQi2.eq.5) then C Case < 0 | i^3,j^5 > OvI = X * (60.D0*Ci2i2**2*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 20.D0*Ci2i2*(48.D0*Ci1i2**3 + 72.D0*Ci1i2**2*Di2*Di1 $ + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**2*(480.D0*Ci1i2**3 + 240.D0*Ci1i2**2*Di2*Di1 $ + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.6) then C Case < 0 | i^3,j^6 > OvI = X * (120.D0*Ci2i2**3*(6.D0*Ci1i1*Di1 + Di1**3) $ + 180.D0*Ci2i2**2*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 30.D0*Ci2i2*Di2*(192.D0*Ci1i2**3 + 144.D0*Ci1i2**2*Di2*Di1 $ + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**3*(960.D0*Ci1i2**3 + 360.D0*Ci1i2**2*Di2*Di1 $ + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.7) then C Case < 0 | i^3,j^7 > OvI = X * (840.D0*Ci2i2**3*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 420.D0*Ci2i2**2*(48.D0*Ci1i2**3 + 72.D0*Ci1i2**2*Di2*Di1 $ + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 42.D0*Ci2i2*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**4*(1680.D0*Ci1i2**3 + 504.D0*Ci1i2**2*Di2*Di1 $ + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.8) then C Case < 0 | i^3,j^8 > OvI = X * (1680.D0*Ci2i2**4*(6.D0*Ci1i1*Di1 + Di1**3) $ + 3360.D0*Ci2i2**3*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 840.D0*Ci2i2**2*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 56.D0*Ci2i2*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**5*(2688.D0*Ci1i2**3 + 672.D0*Ci1i2**2*Di2*Di1 $ + 48.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.9) then C Case < 0 | i^3,j^9 > OvI = X * (15120.D0*Ci2i2**4*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 10080.D0*Ci2i2**3*(48.D0*Ci1i2**3 + 72.D0*Ci1i2**2*Di2*Di1 $ + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 1512.D0*Ci2i2**2*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 72.D0*Ci2i2*Di2**4*(1680.D0*Ci1i2**3 $ + 504.D0*Ci1i2**2*Di2*Di1 + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**6*(4032.D0*Ci1i2**3 + 864.D0*Ci1i2**2*Di2*Di1 $ + 54*Ci1i2*Di2**2*(2*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.10) then C Case < 0 | i^3,j^10 > OvI = X * (30240.D0*Ci2i2**5*(6.D0*Ci1i1*Di1 + Di1**3) $ + 75600.D0*Ci2i2**4*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 25200.D0*Ci2i2**3*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 2520.D0*Ci2i2**2*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 90.D0*Ci2i2*Di2**5*(2688.D0*Ci1i2**3 $ + 672.D0*Ci1i2**2*Di2*Di1 + 48.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**7*(5760.D0*Ci1i2**3 + 1080.D0*Ci1i2**2*Di2*Di1 $ + 60.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.11) then C Case < 0 | i^3,j^11 > OvI = X * (332640.D0*Ci2i2**5*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 277200.D0*Ci2i2**4*(48.D0*Ci1i2**3 $ + 72.D0*Ci1i2**2*Di2*Di1 + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 55440.D0*Ci2i2**3*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 3960.D0*Ci2i2**2*Di2**4*(1680.D0*Ci1i2**3 $ + 504.D0*Ci1i2**2*Di2*Di1 + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 110.D0*Ci2i2*Di2**6*(4032.D0*Ci1i2**3 $ + 864.D0*Ci1i2**2*Di2*Di1 + 54.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**8*(7920.D0*Ci1i2**3 + 1320.D0*Ci1i2**2*Di2*Di1 $ + 66.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.12) then C Case < 0 | i^3,j^12 > OvI = X * (665280.D0*Ci2i2**6*(6.D0*Ci1i1*Di1 + Di1**3) $ + 1995840.D0*Ci2i2**5*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 831600.D0*Ci2i2**4*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 110880.D0*Ci2i2**3*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 5940.D0*Ci2i2**2*Di2**5*(2688.D0*Ci1i2**3 $ + 672.D0*Ci1i2**2*Di2*Di1 + 48.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 132.D0*Ci2i2*Di2**7*(5760.D0*Ci1i2**3 $ + 1080.D0*Ci1i2**2*Di2*Di1 + 60.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**9*(10560.D0*Ci1i2**3 + 1584.D0*Ci1i2**2*Di2*Di1 $ + 72.D0*Ci1i2*Di2**2*(2*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.13) then C Case < 0 | i^3,j^13 > OvI = X * (8648640.D0*Ci2i2**6*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 8648640.D0*Ci2i2**5*(48.D0*Ci1i2**3 $ + 72.D0*Ci1i2**2*Di2*Di1 + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 2162160.D0*Ci2i2**4*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 205920.D0*Ci2i2**3*Di2**4*(1680.D0*Ci1i2**3 $ + 504.D0*Ci1i2**2*Di2*Di1 + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 8580.D0*Ci2i2**2*Di2**6*(4032.D0*Ci1i2**3 $ + 864.D0*Ci1i2**2*Di2*Di1 + 54.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 156.D0*Ci2i2*Di2**8*(7920.D0*Ci1i2**3 $ + 1320.D0*Ci1i2**2*Di2*Di1 + 66.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**10*(13728.D0*Ci1i2**3 + 1872.D0*Ci1i2**2*Di2*Di1 $ + 78.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2))) else if(NQi2.eq.14) then C Case < 0 | i^3,j^14 > X1 = 17297280.D0*Ci2i2**7*(6.D0*Ci1i1*Di1 + Di1**3) $ + 60540480.D0*Ci2i2**6*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 30270240.D0*Ci2i2**5*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6*Ci1i1 + Di1**2)) $ + 5045040.D0*Ci2i2**4*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 360360.D0*Ci2i2**3*Di2**5*(2688.D0*Ci1i2**3 $ + 672.D0*Ci1i2**2*Di2*Di1 + 48.D0*Ci1i2*Di2**2*(2*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6*Ci1i1 + Di1**2)) $ + 12012.D0*Ci2i2**2*Di2**7*(5760.D0*Ci1i2**3 $ + 1080.D0*Ci1i2**2*Di2*Di1 + 60.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 182.D0*Ci2i2*Di2**9*(10560.D0*Ci1i2**3 $ + 1584.D0*Ci1i2**2*Di2*Di1 + 72.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**11*(17472.D0*Ci1i2**3 + 2184.D0*Ci1i2**2*Di2*Di1 $ + 84.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else if(NQi2.eq.15) then C Case < 0 | i^3,j^15 > X1 = 259459200.D0*Ci2i2**7*(6.D0*Ci1i2*(2.D0*Ci1i1 + Di1**2) $ + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 302702400.D0*Ci2i2**6*(48.D0*Ci1i2**3 $ + 72.D0*Ci1i2**2*Di2*Di1 + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 90810720.D0*Ci2i2**5*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 10810800.D0*Ci2i2**4*Di2**4*(1680.D0*Ci1i2**3 $ + 504.D0*Ci1i2**2*Di2*Di1 + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 600600.D0*Ci2i2**3*Di2**6*(4032.D0*Ci1i2**3 $ + 864.D0*Ci1i2**2*Di2*Di1 + 54.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 16380.D0*Ci2i2**2*Di2**8*(7920.D0*Ci1i2**3 $ + 1320.D0*Ci1i2**2*Di2*Di1 + 66.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 210.D0*Ci2i2*Di2**10*(13728.D0*Ci1i2**3 $ + 1872.D0*Ci1i2**2*Di2*Di1 + 78.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**12*(21840.D0*Ci1i2**3 + 2520.D0*Ci1i2**2*Di2*Di1 $ + 90.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else if(NQi2.eq.16) then C Case < 0 | i^3,j^16 > X1 = 518918400.D0*Ci2i2**8*(6.D0*Ci1i1*Di1 + Di1**3) $ + 2075673600.D0*Ci2i2**7*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 1210809600.D0*Ci2i2**6*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 242161920.D0*Ci2i2**5*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 21621600.D0*Ci2i2**4*Di2**5*(2688.D0*Ci1i2**3 $ + 672.D0*Ci1i2**2*Di2*Di1 + 48.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 960960.D0*Ci2i2**3*Di2**7*(5760.D0*Ci1i2**3 $ + 1080.D0*Ci1i2**2*Di2*Di1 + 60.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 21840.D0*Ci2i2**2*Di2**9*(10560.D0*Ci1i2**3 $ + 1584.D0*Ci1i2**2*Di2*Di1 + 72.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 240.D0*Ci2i2*Di2**11*(17472.D0*Ci1i2**3 $ + 2184.D0*Ci1i2**2*Di2*Di1 + 84.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**13*(26880.D0*Ci1i2**3 + 2880.D0*Ci1i2**2*Di2*Di1 $ + 96.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else if(NQi2.eq.17) then C Case < 0 | i^3,j^17 > X1 = 8821612800.D0*Ci2i2**8*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 11762150400.D0*Ci2i2**7*(48.D0*Ci1i2**3 $ + 72.D0*Ci1i2**2*Di2*Di1 + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 4116752640.D0*Ci2i2**6*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 588107520.D0*Ci2i2**5*Di2**4*(1680.D0*Ci1i2**3 $ + 504.D0*Ci1i2**2*Di2*Di1 + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 40840800.D0*Ci2i2**4*Di2**6*(4032.D0*Ci1i2**3 $ + 864.D0*Ci1i2**2*Di2*Di1 + 54.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 1485120.D0*Ci2i2**3*Di2**8*(7920.D0*Ci1i2**3 $ + 1320.D0*Ci1i2**2*Di2*Di1 + 66.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 28560.D0*Ci2i2**2*Di2**10*(13728.D0*Ci1i2**3 $ + 1872.D0*Ci1i2**2*Di2*Di1 + 78.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 272*Ci2i2*Di2**12*(21840.D0*Ci1i2**3 $ + 2520.D0*Ci1i2**2.D0*Di2*Di1 $ + 90.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**14*(32640.D0*Ci1i2**3 + 3264.D0*Ci1i2**2*Di2*Di1 $ + 102.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else if(NQi2.eq.18) then C Case < 0 | i^3,j^18 > X1 = 17643225600.D0*Ci2i2**9*(6.D0*Ci1i1*Di1 + Di1**3) $ + 79394515200.D0*Ci2i2**8*(24.D0*Ci1i2**2*Di1 $ + 12*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 52929676800.D0*Ci2i2**7*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 12350257920.D0*Ci2i2**6*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 1323241920.D0*Ci2i2**5*Di2**5*(2688.D0*Ci1i2**3 $ + 672.D0*Ci1i2**2*Di2*Di1 + 48.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 73513440.D0*Ci2i2**4*Di2**7*(5760.D0*Ci1i2**3 $ + 1080.D0*Ci1i2**2*Di2*Di1 + 60.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 2227680.D0*Ci2i2**3*Di2**9*(10560.D0*Ci1i2**3 $ + 1584.D0*Ci1i2**2*Di2*Di1 + 72.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 36720.D0*Ci2i2**2*Di2**11*(17472.D0*Ci1i2**3 $ + 2184.D0*Ci1i2**2*Di2*Di1 + 84.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 306.D0*Ci2i2*Di2**13*(26880.D0*Ci1i2**3 $ + 2880.D0*Ci1i2**2*Di2*Di1 + 96.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**15*(39168.D0*Ci1i2**3 + 3672.D0*Ci1i2**2*Di2*Di1 $ + 108.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else if(NQi2.eq.19) then C Case < 0 | i^3,j^19 > X1 = 335221286400.D0*Ci2i2**9*(6.D0*Ci1i2*(2.D0*Ci1i1 $ + Di1**2) + Di2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 502831929600.D0*Ci2i2**8*(48.D0*Ci1i2**3 $ + 72.D0*Ci1i2**2*Di2*Di1 + 18.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 201132771840.D0*Ci2i2**7*Di2**2*(480.D0*Ci1i2**3 $ + 240.D0*Ci1i2**2*Di2*Di1 + 30.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 33522128640.D0*Ci2i2**6*Di2**4*(1680.D0*Ci1i2**3 $ + 504.D0*Ci1i2**2*Di2*Di1 + 42.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 2793510720.D0*Ci2i2**5*Di2**6*(4032.D0*Ci1i2**3 $ + 864.D0*Ci1i2**2*Di2*Di1 + 54.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 126977760.D0*Ci2i2**4*Di2**8*(7920.D0*Ci1i2**3 $ + 1320.D0*Ci1i2**2*Di2*Di1 + 66.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 3255840.D0*Ci2i2**3*Di2**10*(13728.D0*Ci1i2**3 $ + 1872.D0*Ci1i2**2*Di2*Di1 + 78.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 46512.D0*Ci2i2**2*Di2**12*(21840.D0*Ci1i2**3 $ + 2520.D0*Ci1i2**2*Di2*Di1 + 90.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 342.D0*Ci2i2*Di2**14*(32640.D0*Ci1i2**3 $ + 3264.D0*Ci1i2**2*Di2*Di1 + 102.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**16*(46512.D0*Ci1i2**3 + 4104.D0*Ci1i2**2*Di2*Di1 $ + 114*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else if(NQi2.eq.20) then C Case < 0 | i^3,j^20 > X1 = 670442572800.D0*Ci2i2**10*(6.D0*Ci1i1*Di1 + Di1**3) $ + 3352212864000.D0*Ci2i2**9*(24.D0*Ci1i2**2*Di1 $ + 12.D0*Ci1i2*Di2*(2.D0*Ci1i1 + Di1**2) $ + Di2**2*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 2514159648000.D0*Ci2i2**8*Di2*(192.D0*Ci1i2**3 $ + 144.D0*Ci1i2**2*Di2*Di1 + 24.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 670442572800.D0*Ci2i2**7*Di2**3*(960.D0*Ci1i2**3 $ + 360.D0*Ci1i2**2*Di2*Di1 + 36.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 83805321600.D0*Ci2i2**6*Di2**5*(2688.D0*Ci1i2**3 $ + 672.D0*Ci1i2**2*Di2*Di1 + 48.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 5587021440.D0*Ci2i2**5*Di2**7*(5760.D0*Ci1i2**3 $ + 1080.D0*Ci1i2**2*Di2*Di1 + 60.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 211629600.D0*Ci2i2**4*Di2**9*(10560.D0*Ci1i2**3 $ + 1584.D0*Ci1i2**2*Di2*Di1 + 72.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 4651200.D0*Ci2i2**3*Di2**11*(17472.D0*Ci1i2**3 $ + 2184*Ci1i2**2*Di2*Di1 + 84.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + 58140.D0*Ci2i2**2*Di2**13*(26880.D0*Ci1i2**3 $ + 2880.D0*Ci1i2**2*Di2*Di1 + 96.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) X1 = X1 + 380.D0*Ci2i2*Di2**15*(39168.D0*Ci1i2**3 $ + 3672.D0*Ci1i2**2*Di2*Di1 + 108.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) $ + Di2**17*(54720.D0*Ci1i2**3 + 4560.D0*Ci1i2**2*Di2*Di1 $ + 120.D0*Ci1i2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + Di2**3*Di1*(6.D0*Ci1i1 + Di1**2)) OvI = X * X1 else C Case "not found" EqnNA = .True. endIf else if(NQi1.eq.4) then C Case < 0 | i^4,j^n > If(NQi2.eq.4) then C Case < 0 | i^4,j^4 > OvI = X * (384.D0*Ci1i2**4 + 768.D0*Ci1i2**3*Di2*Di1 $ + (3.D0*Ci1i2**2*(2.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2))*96.D0 + (Ci1i2*Di2*(6.D0*Ci2i2 $ + Di2**2)*Di1*(6.D0*Ci1i1 + Di1**2))*32.D0 $ + ((12.D0*Ci2i2**2 + 12.D0*Ci2i2*Di2**2 $ + Di2**4)*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4))) else if(NQi2.eq.5) then C Case < 0 | i^4,j^5 > OvI = X * (1920.D0*Ci1i2**4*Di2 $ + 1920.D0*Ci1i2**3*(2.D0*Ci2i2 + Di2**2)*Di1 $ + 480.D0*Ci1i2**2*Di2*(6.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2) + 40.D0*Ci1i2*(12.D0*Ci2i2**2 + 12.D0*Ci2i2*Di2**2 $ + Di2**4)*Di1*(6.D0*Ci1i1 + Di1**2) + Di2*(60.D0*Ci2i2**2 $ + 20.D0*Ci2i2*Di2**2 + Di2**4)*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4)) else if(NQi2.eq.6) then C Case < 0 | i^4,j^6 > OvI = X * (120.D0*Ci2i2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 180.D0*Ci2i2**2*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 30.D0*Ci2i2*(384.D0*Ci1i2**4 + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**2*(5760.D0*Ci1i2**4 + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4))) else if(NQi2.eq.7) then C Case < 0 | i^4,j^7 > OvI = X * (840.D0*Ci2i2**3*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 420.D0*Ci2i2**2*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 42.D0*Ci2i2*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**3*(13440.D0*Ci1i2**4 + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4))) else if(NQi2.eq.8) then C Case < 0 | i^4,j^8 > OvI = X * (1680.D0*Ci2i2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 3360.D0*Ci2i2**3*(48.D0*Ci1i2**2*(2.D0*Ci1i1 + Di1**2) $ + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 840.D0*Ci2i2**2*(384.D0*Ci1i2**4 + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 56.D0*Ci2i2*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**4*(26880.D0*Ci1i2**4 + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4))) else if(NQi2.eq.9) then C Case < 0 | i^4,j^9 > X1 = 15120.D0*Ci2i2**4*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 10080.D0*Ci2i2**3*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 1512.D0*Ci2i2**2*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 72.D0*Ci2i2*Di2**3*(13440.D0*Ci1i2**4 $ + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**5*(48384.D0*Ci1i2**4 + 16128.D0*Ci1i2**3*Di2*Di1 $ + 1728.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 72.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.10) then C Case < 0 | i^4,j^10 > X1 = 30240.D0*Ci2i2**5*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + 75600.D0*Ci2i2**4*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 25200.D0*Ci2i2**3*(384.D0*Ci1i2**4 $ + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 2520.D0*Ci2i2**2*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 $ + Di1**2) + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 90.D0*Ci2i2*Di2**4*(26880.D0*Ci1i2**4 $ + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**6*(80640.D0*Ci1i2**4 + 23040.D0*Ci1i2**3*Di2*Di1 $ + 2160.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.11) then C Case < 0 | i^4,j^11 > X1 = 332640.D0*Ci2i2**5*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 277200.D0*Ci2i2**4*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 55440.D0*Ci2i2**3*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 3960.D0*Ci2i2**2*Di2**3*(13440.D0*Ci1i2**4 $ + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 110.D0*Ci2i2*Di2**5*(48384.D0*Ci1i2**4 $ + 16128.D0*Ci1i2**3*Di2*Di1 $ + 1728.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 72.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**7*(126720.D0*Ci1i2**4 + 31680.D0*Ci1i2**3*Di2*Di1 $ + 2640.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 88.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.12) then C Case < 0 | i^4,j^12 > X1 = 665280.D0*Ci2i2**6*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + 1995840.D0*Ci2i2**5*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 831600.D0*Ci2i2**4*(384.D0*Ci1i2**4 $ + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 110880.D0*Ci2i2**3*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 5940.D0*Ci2i2**2*Di2**4*(26880.D0*Ci1i2**4 $ + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 132.D0*Ci2i2*Di2**6*(80640.D0*Ci1i2**4 $ + 23040.D0*Ci1i2**3*Di2*Di1 $ + 2160.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**8*(190080.D0*Ci1i2**4 + 42240.D0*Ci1i2**3*Di2*Di1 $ + 3168.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 96.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.13) then C Case < 0 | i^4,j^13 > X1 = 8648640.D0*Ci2i2**6*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 8648640.D0*Ci2i2**5*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 2162160.D0*Ci2i2**4*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 205920.D0*Ci2i2**3*Di2**3*(13440.D0*Ci1i2**4 $ + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 8580.D0*Ci2i2**2*Di2**5*(48384.D0*Ci1i2**4 $ + 16128.D0*Ci1i2**3*Di2*Di1 $ + 1728.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 72.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 156.D0*Ci2i2*Di2**7*(126720.D0*Ci1i2**4 $ + 31680.D0*Ci1i2**3*Di2*Di1 $ + 2640.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 88.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**9*(274560.D0*Ci1i2**4 + 54912.D0*Ci1i2**3*Di2*Di1 $ + 3744.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 104.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.14) then C Case < 0 | i^4,j^14 > X1 = 17297280.D0*Ci2i2**7*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + 60540480.D0*Ci2i2**6*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 30270240.D0*Ci2i2**5*(384.D0*Ci1i2**4 $ + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 5045040.D0*Ci2i2**4*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 360360.D0*Ci2i2**3*Di2**4*(26880.D0*Ci1i2**4 $ + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 12012.D0*Ci2i2**2*Di2**6*(80640.D0*Ci1i2**4 $ + 23040.D0*Ci1i2**3*Di2*Di1 $ + 2160.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 182.D0*Ci2i2*Di2**8*(190080.D0*Ci1i2**4 $ + 42240.D0*Ci1i2**3*Di2*Di1 $ + 3168.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 96.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**10*(384384.D0*Ci1i2**4 + 69888.D0*Ci1i2**3*Di2*Di1 $ + 4368.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 112.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12*Ci1i1**2 + 12*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.15) then C Case < 0 | i^4,j^15 > X1 = 259459200.D0*Ci2i2**7*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 302702400.D0*Ci2i2**6*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 90810720.D0*Ci2i2**5*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 10810800.D0*Ci2i2**4*Di2**3*(13440.D0*Ci1i2**4 $ + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 600600.D0*Ci2i2**3*Di2**5*(48384.D0*Ci1i2**4 $ + 16128.D0*Ci1i2**3*Di2*Di1 $ + 1728.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 72.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 16380.D0*Ci2i2**2*Di2**7*(126720.D0*Ci1i2**4 $ + 31680.D0*Ci1i2**3*Di2*Di1 $ + 2640.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 88.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 210.D0*Ci2i2*Di2**9*(274560.D0*Ci1i2**4 $ + 54912.D0*Ci1i2**3*Di2*Di1 $ + 3744.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 104.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**11*(524160.D0*Ci1i2**4 + 87360.D0*Ci1i2**3*Di2*Di1 $ + 5040.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.16) then C Case < 0 | i^4,j^16 > X1 =518918400.D0*Ci2i2**8*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4)+2075673600.D0*Ci2i2**7*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 1210809600.D0*Ci2i2**6*(384.D0*Ci1i2**4 $ + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 242161920.D0*Ci2i2**5*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 21621600.D0*Ci2i2**4*Di2**4*(26880.D0*Ci1i2**4 $ + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 960960.D0*Ci2i2**3*Di2**6*(80640.D0*Ci1i2**4 $ + 23040.D0*Ci1i2**3*Di2*Di1 $ + 2160.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 21840.D0*Ci2i2**2*Di2**8*(190080.D0*Ci1i2**4 $ + 42240.D0*Ci1i2**3*Di2*Di1 $ + 3168.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 96.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 240*Ci2i2*Di2**10*(384384.D0*Ci1i2**4 $ + 69888.D0*Ci1i2**3*Di2*Di1 $ + 4368.D0*Ci1i2**2*Di2**2*(2*Ci1i1 + Di1**2) $ + 112.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**12*(698880.D0*Ci1i2**4 + 107520.D0*Ci1i2**3*Di2*Di1 $ + 5760.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 128.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.17) then C Case < 0 | i^4,j^17 > X1 = 8821612800.D0*Ci2i2**8*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 11762150400.D0*Ci2i2**7*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 4116752640.D0*Ci2i2**6*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 588107520.D0*Ci2i2**5*Di2**3*(13440.D0*Ci1i2**4 $ + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 40840800.D0*Ci2i2**4*Di2**5*(48384.D0*Ci1i2**4 $ + 16128.D0*Ci1i2**3*Di2*Di1 $ + 1728.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 72.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 1485120.D0*Ci2i2**3*Di2**7*(126720.D0*Ci1i2**4 $ + 31680.D0*Ci1i2**3*Di2*Di1 $ + 2640.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 88.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 28560.D0*Ci2i2**2*Di2**9*(274560.D0*Ci1i2**4 $ + 54912.D0*Ci1i2**3*Di2*Di1 $ + 3744.D0*Ci1i2**2*Di2**2*(2*Ci1i1 + Di1**2) $ + 104.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 272.D0*Ci2i2*Di2**11*(524160.D0*Ci1i2**4 $ + 87360.D0*Ci1i2**3*Di2*Di1 $ + 5040.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**13*(913920.D0*Ci1i2**4 + 130560.D0*Ci1i2**3*Di2*Di1 $ + 6528.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 136.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.18) then C Case < 0 | i^4,j^18 > X1 = 17643225600.D0*Ci2i2**9*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 79394515200.D0*Ci2i2**8*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 52929676800.D0*Ci2i2**7*(384.D0*Ci1i2**4 $ + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 12350257920.D0*Ci2i2**6*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 1323241920.D0*Ci2i2**5*Di2**4*(26880.D0*Ci1i2**4 $ + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 73513440.D0*Ci2i2**4*Di2**6*(80640.D0*Ci1i2**4 $ + 23040.D0*Ci1i2**3*Di2*Di1 $ + 2160.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 2227680.D0*Ci2i2**3*Di2**8*(190080.D0*Ci1i2**4 $ + 42240.D0*Ci1i2**3*Di2*Di1 $ + 3168.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 96.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 36720.D0*Ci2i2**2*Di2**10*(384384.D0*Ci1i2**4 $ + 69888.D0*Ci1i2**3*Di2*Di1 $ + 4368.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 112.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 306.D0*Ci2i2*Di2**12*(698880.D0*Ci1i2**4 $ + 107520.D0*Ci1i2**3*Di2*Di1 $ + 5760.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 28.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**14*(1175040.D0*Ci1i2**4 + 156672.D0*Ci1i2**3*Di2*Di1 $ + 7344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 144.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.19) then C Case < 0 | i^4,j^19 > X1 = 335221286400.D0*Ci2i2**9*(12.D0*Ci1i1**2*Di2 $ + 12.D0*Ci1i1*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + Di1**3*(8.D0*Ci1i2 + Di2*Di1)) $ + 502831929600.D0*Ci2i2**8*(192.D0*Ci1i2**3*Di1 $ + 144.D0*Ci1i2**2*Di2*(2.D0*Ci1i1 + Di1**2) $ + 24.D0*Ci1i2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 201132771840.D0*Ci2i2**7*Di2*(1920.D0*Ci1i2**4 $ + 1920.D0*Ci1i2**3*Di2*Di1 $ + 480.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 33522128640.D0*Ci2i2**6*Di2**3*(13440.D0*Ci1i2**4 $ + 6720.D0*Ci1i2**3*Di2*Di1 $ + 1008.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 56.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 2793510720.D0*Ci2i2**5*Di2**5*(48384.D0*Ci1i2**4 $ + 16128.D0*Ci1i2**3*Di2*Di1 $ + 1728.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 72.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 126977760.D0*Ci2i2**4*Di2**7*(126720.D0*Ci1i2**4 $ + 31680.D0*Ci1i2**3*Di2*Di1 $ + 2640.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 88.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 3255840.D0*Ci2i2**3*Di2**9*(274560.D0*Ci1i2**4 $ + 54912.D0*Ci1i2**3*Di2*Di1 $ + 3744.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 104.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 46512.D0*Ci2i2**2*Di2**11*(524160.D0*Ci1i2**4 $ + 87360.D0*Ci1i2**3*Di2*Di1 $ + 5040.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 342.D0*Ci2i2*Di2**13*(913920.D0*Ci1i2**4 $ + 130560.D0*Ci1i2**3*Di2*Di1 $ + 6528.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 136.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + Di2**15*(1488384.D0*Ci1i2**4 + 186048.D0*Ci1i2**3*Di2*Di1 $ + 8208.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 152.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else if(NQi2.eq.20) then C Case < 0 | i^4,j^20 > X1 = 670442572800.D0*Ci2i2**10*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 3352212864000.D0*Ci2i2**9*(48.D0*Ci1i2**2*(2.D0*Ci1i1 $ + Di1**2) + 16.D0*Ci1i2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 2514159648000.D0*Ci2i2**8*(384.D0*Ci1i2**4 $ + 768.D0*Ci1i2**3*Di2*Di1 $ + 288.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 32.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 670442572800.D0*Ci2i2**7*Di2**2*(5760.D0*Ci1i2**4 $ + 3840.D0*Ci1i2**3*Di2*Di1 $ + 720.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 48.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 83805321600.D0*Ci2i2**6*Di2**4*(26880.D0*Ci1i2**4 $ + 10752.D0*Ci1i2**3*Di2*Di1 $ + 1344.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 64.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 5587021440.D0*Ci2i2**5*Di2**6*(80640.D0*Ci1i2**4 $ + 23040.D0*Ci1i2**3*Di2*Di1 $ + 2160.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 211629600.D0*Ci2i2**4*Di2**8*(190080.D0*Ci1i2**4 $ + 42240.D0*Ci1i2**3*Di2*Di1 $ + 3168.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 96.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + 4651200.D0*Ci2i2**3*Di2**10*(384384.D0*Ci1i2**4 $ + 69888.D0*Ci1i2**3*Di2*Di1 $ + 4368.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 112.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 58140.D0*Ci2i2**2*Di2**12*(698880.D0*Ci1i2**4 $ + 107520.D0*Ci1i2**3*Di2*Di1 $ + 5760.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 128.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) $ + 380.D0*Ci2i2*Di2**14*(1175040.D0*Ci1i2**4 $ + 156672.D0*Ci1i2**3*Di2*Di1 $ + 7344.D0*Ci1i2**2*Di2**2*(2*Ci1i1 + Di1**2) $ + 144.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) X1 = X1 + Di2**16*(1860480.D0*Ci1i2**4 $ + 218880.D0*Ci1i2**3*Di2*Di1 $ + 9120.D0*Ci1i2**2*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 160.D0*Ci1i2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4)) OvI = X * X1 else C Case "not found" EqnNA = .True. endIf else if(NQi1.eq.5) then C Case < 0 | i^5,j^n > If(NQi2.eq.5) then C Case < 0 | i^5,j^5 > OvI = X * (3840.D0*Ci1i2**5 + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*(2.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2) + 800.D0*Ci1i2**2*Di2*(6.D0*Ci2i2 $ + Di2**2)*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*(12.D0*Ci2i2**2 + 12.D0*Ci2i2*Di2**2 $ + Di2**4)*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + Di2*(60.D0*Ci2i2**2 + 20.D0*Ci2i2*Di2**2 $ + Di2**4)*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) else if(NQi2.eq.6) then C Case < 0 | i^5,j^6 > OvI = X * (23040.D0*Ci1i2**5*Di2 $ + 28800.D0*Ci1i2**4*(2.D0*Ci2i2 + Di2**2)*Di1 $ + 9600.D0*Ci1i2**3*Di2*(6.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2) + 1200.D0*Ci1i2**2*(12.D0*Ci2i2**2 $ + 12.D0*Ci2i2*Di2**2 + Di2**4)*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2*(60.D0*Ci2i2**2 + 20.D0*Ci2i2*Di2**2 $ + Di2**4)*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + (120.D0*Ci2i2**3 + 180.D0*Ci2i2**2*Di2**2 $ + 30.D0*Ci2i2*Di2**4 + Di2**6)*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) else if(NQi2.eq.7) then C Case < 0 | i^5,j^7 > OvI = X * (840.D0*Ci2i2**3*(10.D0*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 420.D0*Ci2i2**2*(480.D0*Ci1i2**3*(2.D0*Ci1i1 + Di1**2) $ + 240.D0*Ci1i2**2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 42.D0*Ci2i2*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4))) else if(NQi2.eq.8) then C Case < 0 | i^5,j^8 > X1 = 1680.D0*Ci2i2**4*(60.D0*Ci1i1**2*Di1 + 20.D0*Ci1i1*Di1**3 $ + Di1**5) + 3360.D0*Ci2i2**3*(80.D0*Ci1i2**2*(6.D0*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 840.D0*Ci2i2**2*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2.D0*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 56.D0*Ci2i2*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.9) then C Case < 0 | i^5,j^9 > X1 = 15120.D0*Ci2i2**4*(10.D0*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 10080.D0*Ci2i2**3*(480.D0*Ci1i2**3*(2*Ci1i1 + Di1**2) $ + 240.D0*Ci1i2**2*Di2*Di1*(6*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 1512.D0*Ci2i2**2*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 72.D0*Ci2i2*Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**4*(483840.D0*Ci1i2**5 $ + 241920.D0*Ci1i2**4*Di2*Di1 $ + 40320.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 90.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.10) then C Case < 0 | i^5,j^10 > X1 =30240.D0*Ci2i2**5*(60.D0*Ci1i1**2*Di1 + 20.D0*Ci1i1*Di1**3 $ + Di1**5) $ + 75600.D0*Ci2i2**4*(80.D0*Ci1i2**2*(6.D0*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 25200.D0*Ci2i2**3*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2.D0*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 2520.D0*Ci2i2**2*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 90.D0*Ci2i2*Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**5*(967680.D0*Ci1i2**5 $ + 403200.D0*Ci1i2**4*Di2*Di1 $ + 57600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 3600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 100.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.11) then C Case < 0 | i^5,j^11 > X1 = 332640.D0*Ci2i2**5*(10*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 277200.D0*Ci2i2**4*(480.D0*Ci1i2**3*(2.D0*Ci1i1 + Di1**2) $ + 240.D0*Ci1i2**2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 55440.D0*Ci2i2**3*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 3960.D0*Ci2i2**2*Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60*Ci1i1**2 + 20*Ci1i1*Di1**2 $ + Di1**4)) + 110.D0*Ci2i2*Di2**4*(483840.D0*Ci1i2**5 $ + 241920.D0*Ci1i2**4*Di2*Di1 $ + 40320.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 90.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + Di2**6*(1774080.D0*Ci1i2**5 $ + 633600.D0*Ci1i2**4*Di2*Di1 $ + 79200.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 4400*Ci1i2**2*Di2**3*Di1*(6*Ci1i1 + Di1**2) $ + 110.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.12) then C Case < 0 | i^5,j^12 > X1 = 665280.D0*Ci2i2**6*(60.D0*Ci1i1**2*Di1 $ + 20.D0*Ci1i1*Di1**3 + Di1**5) $ + 1995840.D0*Ci2i2**5*(80.D0*Ci1i2**2*(6.D0*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 831600.D0*Ci2i2**4*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2.D0*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 110880.D0*Ci2i2**3*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 5940.D0*Ci2i2**2*Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 132.D0*Ci2i2*Di2**5*(967680.D0*Ci1i2**5 $ + 403200.D0*Ci1i2**4*Di2*Di1 $ + 57600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 3600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 100.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**7*(3041280.D0*Ci1i2**5 $ + 950400.D0*Ci1i2**4*Di2*Di1 $ + 105600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 5280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60*Ci1i1**2 + 20*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.13) then C Case < 0 | i^5,j^13 > X1 = 8648640.D0*Ci2i2**6*(10.D0*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 8648640.D0*Ci2i2**5*(480.D0*Ci1i2**3*(2.D0*Ci1i1 + Di1**2) $ + 240.D0*Ci1i2**2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 2162160.D0*Ci2i2**4*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 205920.D0*Ci2i2**3*Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 8580.D0*Ci2i2**2*Di2**4*(483840.D0*Ci1i2**5 $ + 241920.D0*Ci1i2**4*Di2*Di1 $ + 40320.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 90.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 156.D0*Ci2i2*Di2**6*(1774080.D0*Ci1i2**5 $ + 633600.D0*Ci1i2**4*Di2*Di1 $ + 79200.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 4400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 110.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**8*(4942080.D0*Ci1i2**5 $ + 1372800.D0*Ci1i2**4*Di2*Di1 $ + 137280.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 6240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 130.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.14) then C Case < 0 | i^5,j^14 > X1 = 17297280.D0*Ci2i2**7*(60.D0*Ci1i1**2*Di1 $ + 20.D0*Ci1i1*Di1**3 + Di1**5) $ + 60540480.D0*Ci2i2**6*(80.D0*Ci1i2**2*(6*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 30270240.D0*Ci2i2**5*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2.D0*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 5045040.D0*Ci2i2**4*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 360360.D0*Ci2i2**3*Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 12012.D0*Ci2i2**2*Di2**5*(967680.D0*Ci1i2**5 $ + 403200.D0*Ci1i2**4*Di2*Di1 $ + 57600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 3600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 100.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 182.D0*Ci2i2*Di2**7*(3041280.D0*Ci1i2**5 $ + 950400.D0*Ci1i2**4*Di2*Di1 $ + 105600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 5280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**9*(7687680.D0*Ci1i2**5 $ + 1921920.D0*Ci1i2**4*Di2*Di1 $ + 174720.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 7280*Ci1i2**2*Di2**3*Di1*(6*Ci1i1 + Di1**2) $ + 140.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.15) then C Case < 0 | i^5,j^15 > X1 = 259459200.D0*Ci2i2**7*(10.D0*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 302702400.D0*Ci2i2**6*(480.D0*Ci1i2**3*(2.D0*Ci1i1 $ + Di1**2) + 240.D0*Ci1i2**2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 90810720.D0*Ci2i2**5*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 10810800.D0*Ci2i2**4*Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 600600.D0*Ci2i2**3*Di2**4*(483840.D0*Ci1i2**5 $ + 241920.D0*Ci1i2**4*Di2*Di1 $ + 40320.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 90.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 16380.D0*Ci2i2**2*Di2**6*(1774080.D0*Ci1i2**5 $ + 633600.D0*Ci1i2**4*Di2*Di1 $ + 79200.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 4400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 110.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 210.D0*Ci2i2*Di2**8*(4942080.D0*Ci1i2**5 $ + 1372800.D0*Ci1i2**4*Di2*Di1 $ + 137280.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 6240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 130.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + Di2**10*(11531520.D0*Ci1i2**5 $ + 2620800.D0*Ci1i2**4*Di2*Di1 $ + 218400.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 8400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 150.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.16) then C Case < 0 | i^5,j^16 > X1 = 518918400.D0*Ci2i2**8*(60.D0*Ci1i1**2*Di1 $ + 20.D0*Ci1i1*Di1**3 + Di1**5) $ + 2075673600.D0*Ci2i2**7*(80.D0*Ci1i2**2*(6.D0*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 1210809600.D0*Ci2i2**6*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2.D0*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 242161920.D0*Ci2i2**5*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 21621600.D0*Ci2i2**4*Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 960960.D0*Ci2i2**3*Di2**5*(967680.D0*Ci1i2**5 $ + 403200.D0*Ci1i2**4*Di2*Di1 $ + 57600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 3600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 100.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 21840.D0*Ci2i2**2*Di2**7*(3041280.D0*Ci1i2**5 $ + 950400.D0*Ci1i2**4*Di2*Di1 $ + 105600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 5280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 240.D0*Ci2i2*Di2**9*(7687680.D0*Ci1i2**5 $ + 1921920.D0*Ci1i2**4*Di2*Di1 $ + 174720.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 7280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 140.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + Di2**11*(16773120.D0*Ci1i2**5 $ + 3494400.D0*Ci1i2**4*Di2*Di1 $ + 268800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 160.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.17) then C Case < 0 | i^5,j^17 > X1 = 8821612800.D0*Ci2i2**8*(10*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 11762150400.D0*Ci2i2**7*(480.D0*Ci1i2**3*(2.D0*Ci1i1 $ + Di1**2) + 240.D0*Ci1i2**2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 4116752640.D0*Ci2i2**6*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 588107520.D0*Ci2i2**5*Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 40840800.D0*Ci2i2**4*Di2**4*(483840.D0*Ci1i2**5 $ + 241920.D0*Ci1i2**4*Di2*Di1 $ + 40320.D0*Ci1i2**3*Di2**2*(2*Ci1i1 + Di1**2) $ + 2880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 90.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 1485120.D0*Ci2i2**3*Di2**6*(1774080.D0*Ci1i2**5 $ + 633600.D0*Ci1i2**4*Di2*Di1 $ + 79200.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 4400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 110*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 28560.D0*Ci2i2**2*Di2**8*(4942080.D0*Ci1i2**5 $ + 1372800.D0*Ci1i2**4*Di2*Di1 $ + 137280.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 6240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 130.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 272.D0*Ci2i2*Di2**10*(11531520.D0*Ci1i2**5 $ + 2620800.D0*Ci1i2**4*Di2*Di1 $ + 218400.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 8400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 150.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**12*(23761920.D0*Ci1i2**5 $ + 4569600.D0*Ci1i2**4*Di2*Di1 $ + 326400.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 10880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 170.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.18) then C Case < 0 | i^5,j^18 > X1 = 17643225600.D0*Ci2i2**9*(60.D0*Ci1i1**2*Di1 $ + 20.D0*Ci1i1*Di1**3 + Di1**5) $ + 79394515200.D0*Ci2i2**8*(80.D0*Ci1i2**2*(6.D0*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 52929676800.D0*Ci2i2**7*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 12350257920.D0*Ci2i2**6*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) $ + 1323241920.D0*Ci2i2**5*Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 73513440.D0*Ci2i2**4*Di2**5*(967680.D0*Ci1i2**5 $ + 403200.D0*Ci1i2**4*Di2*Di1 $ + 57600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 3600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 100.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 2227680.D0*Ci2i2**3*Di2**7*(3041280.D0*Ci1i2**5 $ + 950400.D0*Ci1i2**4*Di2*Di1 $ + 105600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 5280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 36720.D0*Ci2i2**2*Di2**9*(7687680.D0*Ci1i2**5 $ + 1921920.D0*Ci1i2**4*Di2*Di1 $ + 174720.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 7280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 140.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 306.D0*Ci2i2*Di2**11*(16773120.D0*Ci1i2**5 $ + 3494400.D0*Ci1i2**4*Di2*Di1 $ + 268800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 160.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + Di2**13*(32901120.D0*Ci1i2**5 $ + 5875200.D0*Ci1i2**4*Di2*Di1 $ + 391680.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 12240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 180.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.19) then C Case < 0 | i^5,j^19 > X1 = 335221286400.D0*Ci2i2**9*(10.D0*Ci1i2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 502831929600.D0*Ci2i2**8*(480.D0*Ci1i2**3*(2.D0*Ci1i1 $ + Di1**2) + 240.D0*Ci1i2**2*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 30.D0*Ci1i2*Di2**2*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**3*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 201132771840.D0*Ci2i2**7*(3840.D0*Ci1i2**5 $ + 9600.D0*Ci1i2**4*Di2*Di1 $ + 4800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 800.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 50.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 33522128640.D0*Ci2i2**6*Di2**2*(80640.D0*Ci1i2**5 $ + 67200.D0*Ci1i2**4*Di2*Di1 $ + 16800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 70.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) $ + 2793510720.D0*Ci2i2**5*Di2**4*(483840.D0*Ci1i2**5 $ + 241920.D0*Ci1i2**4*Di2*Di1 $ + 40320.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 90.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 126977760.D0*Ci2i2**4*Di2**6*(1774080.D0*Ci1i2**5 $ + 633600.D0*Ci1i2**4*Di2*Di1 $ + 79200.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 4400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 110.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 3255840.D0*Ci2i2**3*Di2**8*(4942080.D0*Ci1i2**5 $ + 1372800.D0*Ci1i2**4*Di2*Di1 $ + 137280.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 6240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 130.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 46512.D0*Ci2i2**2*Di2**10*(11531520.D0*Ci1i2**5 $ + 2620800.D0*Ci1i2**4*Di2*Di1 $ + 218400.D0*Ci1i2**3*Di2**2*(2*Ci1i1 + Di1**2) $ + 8400.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 150.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 342.D0*Ci2i2*Di2**12*(23761920.D0*Ci1i2**5 $ + 4569600.D0*Ci1i2**4*Di2*Di1 $ + 326400.D0*Ci1i2**3*Di2**2*(2*Ci1i1 + Di1**2) $ + 10880.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 170.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + Di2**14*(44651520.D0*Ci1i2**5 $ + 7441920.D0*Ci1i2**4*Di2*Di1 $ + 465120.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 13680.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 190.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else if(NQi2.eq.20) then C Case < 0 | i^5,j^20 > X1 = 670442572800.D0*Ci2i2**10*(60.D0*Ci1i1**2*Di1 $ + 20.D0*Ci1i1*Di1**3 + Di1**5) $ + 3352212864000.D0*Ci2i2**9*(80.D0*Ci1i2**2*(6.D0*Ci1i1*Di1 $ + Di1**3) + 20.D0*Ci1i2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 2514159648000.D0*Ci2i2**8*(1920.D0*Ci1i2**4*Di1 $ + 1920.D0*Ci1i2**3*Di2*(2.D0*Ci1i1 + Di1**2) $ + 480.D0*Ci1i2**2*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 40.D0*Ci1i2*Di2**3*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**4*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 670442572800.D0*Ci2i2**7*Di2*(23040.D0*Ci1i2**5 $ + 28800.D0*Ci1i2**4*Di2*Di1 $ + 9600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 60.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4)) $ + 83805321600.D0*Ci2i2**6*Di2**3*(215040.D0*Ci1i2**5 $ + 134400.D0*Ci1i2**4*Di2*Di1 $ + 26880.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 2240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 80.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 5587021440.D0*Ci2i2**5*Di2**5*(967680.D0*Ci1i2**5 $ + 403200.D0*Ci1i2**4*Di2*Di1 $ + 57600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 3600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 100.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) $ + 211629600.D0*Ci2i2**4*Di2**7*(3041280.D0*Ci1i2**5 $ + 950400.D0*Ci1i2**4*Di2*Di1 $ + 105600.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 5280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 120.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 4651200.D0*Ci2i2**3*Di2**9*(7687680.D0*Ci1i2**5 $ + 1921920.D0*Ci1i2**4*Di2*Di1 $ + 174720.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 7280.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 140.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + 58140.D0*Ci2i2**2*Di2**11*(16773120.D0*Ci1i2**5 $ + 3494400.D0*Ci1i2**4*Di2*Di1 $ + 268800.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 160.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) X1 = X1 + 380.D0*Ci2i2*Di2**13*(32901120.D0*Ci1i2**5 $ + 5875200.D0*Ci1i2**4*Di2*Di1 $ + 391680.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 12240.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 180.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) + Di2**15*(59535360.D0*Ci1i2**5 $ + 9302400.D0*Ci1i2**4*Di2*Di1 $ + 547200.D0*Ci1i2**3*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 15200.D0*Ci1i2**2*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 200.D0*Ci1i2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**5*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4)) OvI = X * X1 else C Case "not found" EqnNA = .True. endIf else if(NQi1.eq.6) then C Case < 0 | i^6,j^n > If(NQi2.eq.6) then C Case < 0 | i^6,j^6 > OvI = X * (46080.D0*Ci1i2**6 $ + 46080.D0*3.D0*Ci1i2**5*Di2*Di1 $ + (15.D0*Ci1i2**4*(2.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2))*5760 + (5.D0*Ci1i2**3*Di2*(6.D0*Ci2i2 $ + Di2**2)*Di1*(6.D0*Ci1i1 + Di1**2))*3840.D0 $ + (5.D0*Ci1i2**2*(12.D0*Ci2i2**2 + 12.D0*Ci2i2*Di2**2 $ + Di2**4)*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4))*360.D0 + (Ci1i2*Di2*(60.D0*Ci2i2**2 $ + 20.D0*Ci2i2*Di2**2 + Di2**4)*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4))*72.D0 + ((120.D0*Ci2i2**3 $ + 180.D0*Ci2i2**2*Di2**2 + 30.D0*Ci2i2*Di2**4 $ + Di2**6)*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6))) else if(NQi2.eq.7) then C Case < 0 | i^6,j^7 > OvI = X * (322560.D0*Ci1i2**6*Di2 $ + 483840.D0*Ci1i2**5*(2.D0*Ci2i2 + Di2**2)*Di1 $ + 201600.D0*Ci1i2**4*Di2*(6.D0*Ci2i2 + Di2**2)*(2.D0*Ci1i1 $ + Di1**2) + 33600.D0*Ci1i2**3*(12.D0*Ci2i2**2 $ + 12.D0*Ci2i2*Di2**2 + Di2**4)*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2*(60.D0*Ci2i2**2 + 20.D0*Ci2i2*Di2**2 $ + Di2**4)*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*(120.D0*Ci2i2**3 + 180.D0*Ci2i2**2*Di2**2 $ + 30.D0*Ci2i2*Di2**4 + Di2**6)*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2*(840.D0*Ci2i2**3 $ + 420.D0*Ci2i2**2*Di2**2 + 42.D0*Ci2i2*Di2**4 $ + Di2**6)*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) else if(NQi2.eq.8) then C Case < 0 | i^6,j^8 > X1 =1680.D0*Ci2i2**4*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 3360.D0*Ci2i2**3*(120.D0*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**2*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 840.D0*Ci2i2**2*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 + Di1**2) $ + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 56.D0*Ci2i2*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + Di2**2*(1290240.D0*Ci1i2**6 + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.9) then C Case < 0 | i^6,j^9 > X1 = 15120.D0*Ci2i2**4*(120.D0*Ci1i1**3*Di2 $ + 180.D0*Ci1i1**2*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + 30.D0*Ci1i1*Di1**3*(8.D0*Ci1i2 + Di2*Di1) $ + Di1**5*(12.D0*Ci1i2 + Di2*Di1)) $ + 10080.D0*Ci2i2**3*(960.D0*Ci1i2**3*(6.D0*Ci1i1*Di1 $ + Di1**3) + 360.D0*Ci1i2**2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 36.D0*Ci1i2*Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**3*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 1512.D0*Ci2i2**2*(23040.D0*Ci1i2**5*Di1 $ + 28800.D0*Ci1i2**4*Di2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**3*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 60.D0*Ci1i2*Di2**4*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 72.D0*Ci2i2*Di2*(322560.D0*Ci1i2**6 $ + 483840.D0*Ci1i2**5*Di2*Di1 $ + 201600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 33600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + Di2**3*(3870720.D0*Ci1i2**6 + 2903040.D0*Ci1i2**5*Di2*Di1 $ + 725760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80640.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 4320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 108.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.10) then C Case < 0 | i^6,j^10 > X1 = 30240.D0*Ci2i2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 75600.D0*Ci2i2**4*(120*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**2*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 25200.D0*Ci2i2**3*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 + Di1**2) $ + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 2520.D0*Ci2i2**2*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 90.D0*Ci2i2*Di2**2*(1290240.D0*Ci1i2**6 $ + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**4*(9676800.D0*Ci1i2**6 $ + 5806080.D0*Ci1i2**5*Di2*Di1 $ + 1209600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 115200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 5400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 120.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.11) then C Case < 0 | i^6,j^11 > X1 = 332640.D0*Ci2i2**5*(120.D0*Ci1i1**3*Di2 $ + 180.D0*Ci1i1**2*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + 30.D0*Ci1i1*Di1**3*(8.D0*Ci1i2 + Di2*Di1) $ + Di1**5*(12.D0*Ci1i2 + Di2*Di1)) $ + 277200.D0*Ci2i2**4*(960.D0*Ci1i2**3*(6.D0*Ci1i1*Di1 $ + Di1**3) + 360.D0*Ci1i2**2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 36.D0*Ci1i2*Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**3*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 55440.D0*Ci2i2**3*(23040.D0*Ci1i2**5*Di1 $ + 28800.D0*Ci1i2**4*Di2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**3*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 60.D0*Ci1i2*Di2**4*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 3.D00*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 3960.D0*Ci2i2**2*Di2*(322560.D0*Ci1i2**6 $ + 483840.D0*Ci1i2**5*Di2*Di1 $ + 201600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 33600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 110.D0*Ci2i2*Di2**3*(3870720.D0*Ci1i2**6 $ + 2903040.D0*Ci1i2**5*Di2*Di1 $ + 725760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80640.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 4320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 108.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**5*(21288960.D0*Ci1i2**6 $ + 10644480.D0*Ci1i2**5*Di2*Di1 $ + 1900800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 158400.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 6600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 132.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.12) then C Case < 0 | i^6,j^12 > X1 = 665280.D0*Ci2i2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 1995840.D0*Ci2i2**5*(120.D0*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**2*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 831600.D0*Ci2i2**4*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 + Di1**2) $ + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 110880.D0*Ci2i2**3*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 5940.D0*Ci2i2**2*Di2**2*(1290240.D0*Ci1i2**6 $ + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 132.D0*Ci2i2*Di2**4*(9676800.D0*Ci1i2**6 $ + 5806080.D0*Ci1i2**5*Di2*Di1 $ + 1209600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 115200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 5400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 120.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**6*(42577920.D0*Ci1i2**6 $ + 18247680.D0*Ci1i2**5*Di2*Di1 $ + 2851200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 211200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 7920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 144.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.13) then C Case < 0 | i^6,j^13 > X1 = 8648640.D0*Ci2i2**6*(120.D0*Ci1i1**3*Di2 $ + 180.D0*Ci1i1**2*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + 30.D0*Ci1i1*Di1**3*(8.D0*Ci1i2 + Di2*Di1) $ + Di1**5*(12.D0*Ci1i2 + Di2*Di1)) $ + 8648640.D0*Ci2i2**5*(960.D0*Ci1i2**3*(6.D0*Ci1i1*Di1 $ + Di1**3) + 360.D0*Ci1i2**2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 36.D0*Ci1i2*Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**3*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 2162160.D0*Ci2i2**4*(23040.D0*Ci1i2**5*Di1 $ + 28800.D0*Ci1i2**4*Di2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**3*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 60.D0*Ci1i2*Di2**4*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 205920.D0*Ci2i2**3*Di2*(322560.D0*Ci1i2**6 $ + 483840.D0*Ci1i2**5*Di2*Di1 $ + 201600.D0*Ci1i2**4*Di2**2*(2*Ci1i1 + Di1**2) $ + 33600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 8580.D0*Ci2i2**2*Di2**3*(3870720.D0*Ci1i2**6 $ + 2903040.D0*Ci1i2**5*Di2*Di1 $ + 725760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80640.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 4320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 108.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 156.D0*Ci2i2*Di2**5*(21288960.D0*Ci1i2**6 $ + 10644480.D0*Ci1i2**5*Di2*Di1 $ + 1900800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 158400.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 6600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 132.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + Di2**7*(79073280.D0*Ci1i2**6 $ + 29652480.D0*Ci1i2**5*Di2*Di1 $ + 4118400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 274560.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 9360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 156.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.14) then C Case < 0 | i^6,j^14 > X1 = 17297280.D0*Ci2i2**7*(120*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 60540480.D0*Ci2i2**6*(120.D0*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**2*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 30270240.D0*Ci2i2**5*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 $ + Di1**2) + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 5045040.D0*Ci2i2**4*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 360360.D0*Ci2i2**3*Di2**2*(1290240.D0*Ci1i2**6 $ + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 12012.D0*Ci2i2**2*Di2**4*(9676800.D0*Ci1i2**6 $ + 5806080.D0*Ci1i2**5*Di2*Di1 $ + 1209600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 115200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 5400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 120.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 182.D0*Ci2i2*Di2**6*(42577920.D0*Ci1i2**6 $ + 18247680.D0*Ci1i2**5*Di2*Di1 $ + 2851200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 211200*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 7920*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 + 12.D0*Ci1i1*Di1**2 $ + Di1**4) + 144.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**8*(138378240.D0*Ci1i2**6 $ + 46126080.D0*Ci1i2**5*Di2*Di1 $ + 5765760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 349440.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 10920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 168.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.15) then C Case < 0 | i^6,j^15 > X1 = 259459200.D0*Ci2i2**7*(120.D0*Ci1i1**3*Di2 $ + 180.D0*Ci1i1**2*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + 30.D0*Ci1i1*Di1**3*(8.D0*Ci1i2 + Di2*Di1) $ + Di1**5*(12.D0*Ci1i2 + Di2*Di1)) $ + 302702400.D0*Ci2i2**6*(960.D0*Ci1i2**3*(6.D0*Ci1i1*Di1 $ + Di1**3) + 360.D0*Ci1i2**2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 36.D0*Ci1i2*Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) $ + Di2**3*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 90810720.D0*Ci2i2**5*(23040.D0*Ci1i2**5*Di1 $ + 28800.D0*Ci1i2**4*Di2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**3*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 60.D0*Ci1i2*Di2**4*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 10810800.D0*Ci2i2**4*Di2*(322560.D0*Ci1i2**6 $ + 483840.D0*Ci1i2**5*Di2*Di1 $ + 201600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 33600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 600600.D0*Ci2i2**3*Di2**3*(3870720.D0*Ci1i2**6 $ + 2903040.D0*Ci1i2**5*Di2*Di1 $ + 725760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80640.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 4320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 108.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 16380.D0*Ci2i2**2*Di2**5*(21288960.D0*Ci1i2**6 $ + 10644480.D0*Ci1i2**5*Di2*Di1 $ + 1900800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 158400.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 6600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 132.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 210.D0*Ci2i2*Di2**7*(79073280.D0*Ci1i2**6 $ + 29652480.D0*Ci1i2**5*Di2*Di1 $ + 4118400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 274560.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 9360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 156.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + Di2**9*(230630400.D0*Ci1i2**6 $ + 69189120.D0*Ci1i2**5*Di2*Di1 $ + 7862400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 436800.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 12600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 + 12*Ci1i1*Di1**2 $ + Di1**4) + 180.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.16) then C Case < 0 | i^6,j^16 > X1 = 518918400.D0*Ci2i2**8*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 2075673600.D0*Ci2i2**7*(120.D0*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**2*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 1210809600.D0*Ci2i2**6*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 $ + Di1**2) + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 242161920.D0*Ci2i2**5*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 21621600.D0*Ci2i2**4*Di2**2*(1290240.D0*Ci1i2**6 $ + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 960960.D0*Ci2i2**3*Di2**4*(9676800.D0*Ci1i2**6 $ + 5806080.D0*Ci1i2**5*Di2*Di1 $ + 1209600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 115200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 5400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 120.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 21840.D0*Ci2i2**2*Di2**6*(42577920.D0*Ci1i2**6 $ + 18247680.D0*Ci1i2**5*Di2*Di1 $ + 2851200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 211200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 7920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 144.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 240.D0*Ci2i2*Di2**8*(138378240.D0*Ci1i2**6 $ + 46126080.D0*Ci1i2**5*Di2*Di1 $ + 5765760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 349440.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 10920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 168.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30*Ci1i1*Di1**4 + Di1**6)) $ + Di2**10*(369008640.D0*Ci1i2**6 $ + 100638720.D0*Ci1i2**5*Di2*Di1 $ + 10483200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 537600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 14400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 192.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.17) then C Case < 0 | i^6,j^17 > X1 = 8821612800.D0*Ci2i2**8*(120.D0*Ci1i1**3*Di2 $ + 180.D0*Ci1i1**2*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + 30.D0*Ci1i1*Di1**3*(8.D0*Ci1i2 + Di2*Di1) $ + Di1**5*(12.D0*Ci1i2 + Di2*Di1)) $ + 11762150400.D0*Ci2i2**7*(960.D0*Ci1i2**3*(6.D0*Ci1i1*Di1 $ + Di1**3) + 360.D0*Ci1i2**2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 36.D0*Ci1i2*Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**3*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 4116752640.D0*Ci2i2**6*(23040.D0*Ci1i2**5*Di1 $ + 28800.D0*Ci1i2**4*Di2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**3*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 60.D0*Ci1i2*Di2**4*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 588107520.D0*Ci2i2**5*Di2*(322560.D0*Ci1i2**6 $ + 483840.D0*Ci1i2**5*Di2*Di1 $ + 201600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 33600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 40840800.D0*Ci2i2**4*Di2**3*(3870720.D0*Ci1i2**6 $ + 2903040.D0*Ci1i2**5*Di2*Di1 $ + 725760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80640.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 4320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 108.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 1485120.D0*Ci2i2**3*Di2**5*(21288960.D0*Ci1i2**6 $ + 10644480.D0*Ci1i2**5*Di2*Di1 $ + 1900800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 158400.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 6600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 132.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 28560.D0*Ci2i2**2*Di2**7*(79073280*Ci1i2**6 $ + 29652480.D0*Ci1i2**5*Di2*Di1 $ + 4118400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 274560.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 9360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 156.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 272.D0*Ci2i2*Di2**9*(230630400.D0*Ci1i2**6 $ + 69189120.D0*Ci1i2**5*Di2*Di1 $ + 7862400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 436800.D0*Ci1i2**3*Di2**3*Di1*(6*Ci1i1 + Di1**2) $ + 12600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 180.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**11*(570286080.D0*Ci1i2**6 $ + 142571520.D0*Ci1i2**5*Di2*Di1 $ + 13708800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 652800.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 16320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 204.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.18) then C Case < 0 | i^6,j^18 > X1 = 17643225600.D0*Ci2i2**9*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 79394515200.D0*Ci2i2**8*(120.D0*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**2*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 52929676800.D0*Ci2i2**7*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 $ + Di1**2) + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 12350257920.D0*Ci2i2**6*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 1323241920.D0*Ci2i2**5*Di2**2*(1290240.D0*Ci1i2**6 $ + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 73513440.D0*Ci2i2**4*Di2**4*(9676800.D0*Ci1i2**6 $ + 5806080.D0*Ci1i2**5*Di2*Di1 $ + 1209600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 115200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 5400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 120.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 2227680.D0*Ci2i2**3*Di2**6*(42577920.D0*Ci1i2**6 $ + 18247680.D0*Ci1i2**5*Di2*Di1 $ + 2851200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 211200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 7920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 144.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 36720.D0*Ci2i2**2*Di2**8*(138378240.D0*Ci1i2**6 $ + 46126080.D0*Ci1i2**5*Di2*Di1 $ + 5765760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 349440.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 10920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 168.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 306.D0*Ci2i2*Di2**10*(369008640.D0*Ci1i2**6 $ + 100638720.D0*Ci1i2**5*Di2*Di1 $ + 10483200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 537600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 14400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 192.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**12*(855429120.D0*Ci1i2**6 $ + 197406720.D0*Ci1i2**5*Di2*Di1 $ + 17625600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 783360.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 18360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 216.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.19) then C Case < 0 | i^6,j^19 > X1 = 335221286400.D0*Ci2i2**9*(120.D0*Ci1i1**3*Di2 $ + 180.D0*Ci1i1**2*Di1*(4.D0*Ci1i2 + Di2*Di1) $ + 30.D0*Ci1i1*Di1**3*(8.D0*Ci1i2 + Di2*Di1) $ + Di1**5*(12.D0*Ci1i2 + Di2*Di1)) $ + 502831929600.D0*Ci2i2**8*(960.D0*Ci1i2**3*(6.D0*Ci1i1*Di1 $ + Di1**3) + 360.D0*Ci1i2**2*Di2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 36.D0*Ci1i2*Di2**2*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**3*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 201132771840.D0*Ci2i2**7*(23040.D0*Ci1i2**5*Di1 $ + 28800.D0*Ci1i2**4*Di2*(2.D0*Ci1i1 + Di1**2) $ + 9600.D0*Ci1i2**3*Di2**2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1200.D0*Ci1i2**2*Di2**3*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 60.D0*Ci1i2*Di2**4*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**5*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 33522128640.D0*Ci2i2**6*Di2*(322560.D0*Ci1i2**6 $ + 483840.D0*Ci1i2**5*Di2*Di1 $ + 201600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 33600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 2520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 84.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 2793510720.D0*Ci2i2**5*Di2**3*(3870720.D0*Ci1i2**6 $ + 2903040.D0*Ci1i2**5*Di2*Di1 $ + 725760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 80640.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 4320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 108.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 126977760.D0*Ci2i2**4*Di2**5*(21288960.D0*Ci1i2**6 $ + 10644480.D0*Ci1i2**5*Di2*Di1 $ + 1900800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 158400.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 6600*Ci1i2**2*Di2**4*(12*Ci1i1**2 + 12*Ci1i1*Di1**2 $ + Di1**4) + 132.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 3255840.D0*Ci2i2**3*Di2**7*(79073280.D0*Ci1i2**6 $ + 29652480.D0*Ci1i2**5*Di2*Di1 $ + 4118400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 274560.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 9360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 156.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 46512.D0*Ci2i2**2*Di2**9*(230630400.D0*Ci1i2**6 $ + 69189120.D0*Ci1i2**5*Di2*Di1 $ + 7862400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 436800.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 12600.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 180.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 342.D0*Ci2i2*Di2**11*(570286080.D0*Ci1i2**6 $ + 142571520.D0*Ci1i2**5*Di2*Di1 $ + 13708800.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 652800.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 16320.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 204.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**13*(1250242560.D0*Ci1i2**6 $ + 267909120.D0*Ci1i2**5*Di2*Di1 $ + 22325760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 930240.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 20520.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 228.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else if(NQi2.eq.20) then C Case < 0 | i^6,j^20 > X1 = 670442572800.D0*Ci2i2**10*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6) $ + 3352212864000.D0*Ci2i2**9*(120.D0*Ci1i2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 24.D0*Ci1i2*Di2*Di1*(60.D0*Ci1i1**2 + 20.D0*Ci1i1*Di1**2 $ + Di1**4) + Di2**2*(120.D0*Ci1i1**3 + 180.D0*Ci1i1**2*Di1**2 $ + 30.D0*Ci1i1*Di1**4 + Di1**6)) $ + 2514159648000.D0*Ci2i2**8*(5760.D0*Ci1i2**4*(2.D0*Ci1i1 $ + Di1**2) + 3840.D0*Ci1i2**3*Di2*Di1*(6.D0*Ci1i1 + Di1**2) $ + 720.D0*Ci1i2**2*Di2**2*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 48.D0*Ci1i2*Di2**3*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**4*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 670442572800.D0*Ci2i2**7*(46080.D0*Ci1i2**6 $ + 138240.D0*Ci1i2**5*Di2*Di1 $ + 86400.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 19200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 1800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 72.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 83805321600.D0*Ci2i2**6*Di2**2*(1290240.D0*Ci1i2**6 $ + 1290240.D0*Ci1i2**5*Di2*Di1 $ + 403200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 53760.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 3360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 96.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 5587021440.D0*Ci2i2**5*Di2**4*(9676800.D0*Ci1i2**6 $ + 5806080.D0*Ci1i2**5*Di2*Di1 $ + 1209600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 115200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 5400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 120.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 211629600.D0*Ci2i2**4*Di2**6*(42577920.D0*Ci1i2**6 $ + 18247680.D0*Ci1i2**5*Di2*Di1 $ + 2851200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 211200.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 7920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 144.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 4651200.D0*Ci2i2**3*Di2**8*(138378240.D0*Ci1i2**6 $ + 46126080.D0*Ci1i2**5*Di2*Di1 $ + 5765760.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 349440.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 10920.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 168.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 58140.D0*Ci2i2**2*Di2**10*(369008640.D0*Ci1i2**6 $ + 100638720.D0*Ci1i2**5*Di2*Di1 $ + 10483200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 537600.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 14400.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 192.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + 380.D0*Ci2i2*Di2**12*(855429120.D0*Ci1i2**6 $ + 197406720.D0*Ci1i2**5*Di2*Di1 $ + 17625600.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 783360.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 18360.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 216.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) X1 = X1 + Di2**14*(1786060800.D0*Ci1i2**6 $ + 357212160.D0*Ci1i2**5*Di2*Di1 $ + 27907200.D0*Ci1i2**4*Di2**2*(2.D0*Ci1i1 + Di1**2) $ + 1094400.D0*Ci1i2**3*Di2**3*Di1*(6.D0*Ci1i1 + Di1**2) $ + 22800.D0*Ci1i2**2*Di2**4*(12.D0*Ci1i1**2 $ + 12.D0*Ci1i1*Di1**2 + Di1**4) $ + 240.D0*Ci1i2*Di2**5*Di1*(60.D0*Ci1i1**2 $ + 20.D0*Ci1i1*Di1**2 + Di1**4) + Di2**6*(120.D0*Ci1i1**3 $ + 180.D0*Ci1i1**2*Di1**2 + 30.D0*Ci1i1*Di1**4 + Di1**6)) OvI = X * X1 else C Case "not found" EqnNA = .True. endIf else C Case "not found" EqnNA = .True. endIf Return End function gfloat(i) real*8 gfloat integer*4 i gfloat=dble(i) return end Subroutine FCA2NQ(NOsc,Idx,NQm,InCl,LNQ,NQ) Implicit Integer(A-H,O-Z) C C Franck-Condon storage Array to Number of Quanta C Get the vector of quantum numbers NQ from the index in the storage C array C C Input: C NOsc : Max. num. of excited oscillators (=class) C Idx : Index in the storage array C NQm : (*) Maximum number reachable by each quantum in NQ C C Output: C InCl : True if the state is in class NOsc C LNQF : Length of NQ actually used C NQ : (LNQ) Vector of the quantum numbers C C Dimensions Integer NOsc, LNQ C Input Integer NQm(*), Idx C Output Integer NQ(*) Logical InCl C Local Integer i, j, N, NQi, NVS C LNQ = 0 C C Case |0>: nothing to do If(Idx.le.1) then C -- FUNDAMENTAL STATE |0> -- else if(Idx.le.NQm(1)) then C -- ONLY THE 1ST MODE IS EXCITED -- NQ(1) = Idx - 1 LNQ = 1 else C -- GENERAL CASE -- NVS = NQm(1)*NQm(2) i = 2 100 If(NVS.lt.Idx) then i = i + 1 NVS = NVS * NQm(i) Goto 100 endIf N = Idx LNQ = i 200 NVS = NVS/NQm(i) NQi = Int(N/NVS) N = N - NQi*NVS If(N.eq.0) then C All prev modes (j C to vibrational ground state (|2> = |0>) C The formulae used are those on Ruhoff, based on the approach of C Sharp and Rosenstock C P.T. Ruhoff, Chem. Phys. 186, 355 (1994) C T.E. Sharp and H.M. Rosenstock, J. Chem. Phys., 41, 3453 (1963) C C Input: C NOsc1 : Max. num. of excited oscillators in state 1 (for dim.) C NQ1n : Last element in NQ1 with a non-zero value C Id1 : Unique index of state 1 in storage arrays C NQ1 : (NOsc1) List of quanta representing vib. state |1> C NQ1m : (NOsc1) Max. possible num. or quanta for each mode in NQ1 C BRed : (NOsc1) Reduced form of the B vector C ARed : (NOsc1,NOsc1) Reduced form of the A matrix C FCI : (*) Storage array for the overlap integrals C C Dimensions Integer*4 NOsc1, NQ1n C Input Integer*4 NQ1(*), NQ1m(*), Id1, IFCADN Real*8 ARed(NOsc1,*), BRed(*), FCI(*), GFloat C Local Integer*4 i, i1, i2 Real*8 OvI, Sqrt2, Two Save Two Data Two/2.0D0/ C C -- INITIALIZATION -- Sqrt2 = Sqrt(Two) C -- CALCULATION -- i1 = IFCADN(Id1,NQ1n,-1,NQ1m) OvI = FCI(i1)/Sqrt2*BRed(NQ1n) If(NQ1(NQ1n).gt.1) then i2 = IFCADN(i1,NQ1n,-1,NQ1m) OvI = OvI+FCI(i2)*Sqrt(GFloat(NQ1(NQ1n)-1))*ARed(NQ1n,NQ1n) endIf Do 100 i = 1, NQ1n-1 If(NQ1(i).gt.0) then i2 = IFCADN(i1,i,-1,NQ1m) OvI = OvI + FCI(i2)*Sqrt(GFloat(NQ1(i)))*ARed(NQ1n,i) endIf 100 Continue FCOvI0 = OvI/Sqrt(GFloat(NQ1(NQ1n))) Return End subroutine estw(th1,th2,NQ,N,C,D,fac,wkl,prct,lwrt,ic) implicit none integer*4 NQ,wkl(NQ,NQ),i,j,Nexc,nm30,N,ii,nt,ic parameter (nm30=30) real*8 th1,th2,pp,C(N,N),D(N),fac,prct logical EqnNA,lwrt real*8,allocatable::FCl1(:) allocate(FCl1(NQ)) c class 1 c th1 .. threshold to take state do 51 i=1,NQ c maximal excitation for this mode to give a sizable contribution wkl(i,i)=0 do 52 Nexc=ic,nm30 if(Nexc.eq.0)then pp=fac else c <0|se>=<0|i**Nexc>: call SRC1(pp,C(i,i),D(i),fac,Nexc,EqnNA) FCl1(i)=pp if(EqnNA)then write(6,*)' Nexc =',Nexc call report('Analytical formula in SRC1 not found') endif prct=prct+pp**2 endif 52 if(pp**2.lt.th1)goto 51 c51 wkl(i,i)=Nexc 51 wkl(i,i)=max(Nexc-1,ic) write(6,1603)100.0d0*prct 1603 format(' <0|0*><0*|0> + <0|1*><1*|0> = ',g13.4,' %') write(6,600)th1 600 format(' Threshold',e12.4,'; Maximal excitations for one mode:') write(6,601)(wkl(i,i),i=1,NQ) 601 format(20i3) c class 2 c th2 .. threshold to take state do 55 i=1,NQ do 55 j=i+1,NQ c maximal excitation for this mode to give a sizable contribution wkl(i,j)=0 do 56 Nexc=1,6 c <0|se>=<0|i**Nexc j**Nexc>: call SRC2(pp,C(i,i),C(j,j),C(i,j),D(i),D(j),fac,Nexc,Nexc,EqnNA) if(EqnNA)then write(6,*)' Nexc =',Nexc call report('Analytical formula in SRC2 not found') endif prct=prct+pp**2 56 if(pp**2-FCl1(i)*FCl1(j)/fac**2.lt.th2)goto 551 551 wkl(i,j)=Nexc 55 wkl(j,i)=Nexc write(6,1604)100.0d0*prct 1604 format(' <0|0*><0*|0> + <0|1*><1*|0> + <0|2*><2*|0> = ',g13.4, 1' %') if(lwrt)then write(6,602)th2 602 format(' Threshold',e12.4,'; Maximal excitations for pairs:') ii=0 do 57 i=1,NQ do 57 j=i+1,NQ ii=ii+1 write(6,603)i,j,wkl(i,j) 603 format(3i3,1x,$) 57 if(mod(ii,8).eq.0)write(6,*) write(6,*) else ii=0 nt=0 do 581 i=1,NQ do 581 j=i+1,NQ ii=ii+1 581 nt=nt+wkl(i,j) write(6,607)th2,dble(nt)/dble(ii) 607 format(' Threshold',e12.4, 1 '; Average excitations for pairs:',f10.2) endif return end function skrna(m,NQ,w) integer s,i,skrna,m,NQ(*),w(*) if(m.gt.1)then s=w(m-1)*NQ(m) do 1 i=m-1,2,-1 1 s=w(i-1)*(s+NQ(i)) skrna=s+NQ(1)+1 else skrna=NQ(1)+1 endif return end Real*8 Function FCOvI(NVS2,NOsc2,NQ1n,NQ2n,Id1,Id2,NQ1,NQ2,NQ1m, $ NQ2m,DRed,CRed,ERed,FCI) Implicit Real*8(A-H,O-Z) C C Franck-Condon OVerlap Integral C Computes recursively the Franck-Condon overlap integral <1|2> C The formulae used are those on Ruhoff, based on the approach of C Sharp and Rosenstock C P.T. Ruhoff, Chem. Phys. 186, 355 (1994) C T.E. Sharp and H.M. Rosenstock, J. Chem. Phys., 41, 3453 (1963) C C Input: C NVS2 : Number of states 2 (used to define FCI) C NOsc2 : Max. num. of excited oscillators in state 2 (for dim.) C NQ1n : Last element in NQ1 with a non-zero value C NQ2n : Last element in NQ2 with a non-zero value C Id1 : Unique index of state 1 in storage arrays C Id2 : Unique index of state 2 in storage arrays C NQ1 : (NQ1n) List of quanta representing vib. state |1> C NQ2 : (NQ2n) List of quanta representing vib. state |2> C NQ1m : (NQ1n) Max. possible num. or quanta for each mode in NQ1 C NQ2m : (NQ2n) Max. possible num. or quanta for each mode in NQ2 C DRed : (NOsc2) Reduced form of the D vector C CRed : (NOsc2,NOsc2) Reduced form of the C matrix C ERed : (NOsc2,*) Reduced form of the E matrix C FCI : (NVS2,*) Storage array for the overlap integrals C C Notes: C QN1 and QN2 may have larger dimensions than NQ1n and NQ2n. C However, only those subsets are used. Integer NOsc2, NQ1n, NQ2n, NVS2 C Input Integer NQ1(*), NQ2(*), NQ1m(*), NQ2m(*), Id1, Id2, IFCADN Real*8 CRed(NOsc2,*), ERed(NOsc2,*), FCI(NVS2,*), DRed(*), GFloat C Local Integer i, i1, i2, i2ref Real*8 OvI, Sqrt2, Two Save Two Data Two/2.0D0/ C C -- INITIALIZATION -- Sqrt2 = Sqrt(Two) C -- CALCULATION -- i2ref = IFCADN(Id2,NQ2n,-1,NQ2m) OvI = FCI(i2ref,Id1)/Sqrt2*DRed(NQ2n) If(NQ2(NQ2n).gt.1) then i2 = IFCADN(i2ref,NQ2n,-1,NQ2m) OvI = OvI+FCI(i2,Id1)*Sqrt(GFloat(NQ2(NQ2n)-1))*CRed(NQ2n,NQ2n) endIf Do 100 i = 1, NQ2n-1 If(NQ2(i).gt.0) then i2 = IFCADN(i2ref,i,-1,NQ2m) OvI = OvI + FCI(i2,Id1)*Sqrt(GFloat(NQ2(i)))*CRed(NQ2n,i) endIf 100 Continue Do 200 i = 1, NQ1n If(NQ1(i).gt.0) then i1 = IFCADN(Id1,i,-1,NQ1m) OvI = OvI + FCI(i2ref,i1)*Sqrt(GFloat(NQ1(i)))*ERed(NQ2n,i) endIf 200 Continue FCOvI = OvI/Sqrt(GFloat(NQ2(NQ2n))) Return End Integer Function IFCADN(Id,i,n,NQm) Implicit Integer (A-Z) C C Index in Franck-Condon Array after Delta N C Returns the index of a state deriving from a reference state by N C quanta in mode I C C Input: C Id : Unique index of the state of interest in storage arrays C i : Index of the mode whose number of quanta changes C n : Number of quanta to add/subtract C NQm : (*) Max. possible num. or quanta for each mode in NQ C C Note: C For the sake of performance, the function does not control the C validity of the shift. C C Input Integer NQm(*), i, Id, n C Local Integer j, num C num = 1 Do 100 j = 1, i-1 100 num = num*NQm(j) IFCADN = Id + n*num Return End subroutine nkti(ki,kf,ktlim,mx,w,NQ,N,G,CM,kt,ic,qpar, 1emax,mmaxi,mmaxf,LEXCI,LEXCF,qred, 1wmi,wmf,nif) c ki: number of initial states with exp(-E/kT)') endif 3011 continue endif if(b.gt.ktlim.and.mi.le.mmaxi)then do 302 j=1,LNQi 302 if(NQSi(j).gt.LEXCI)goto 3012 ki=ki+1 ini=.true. bf(ki)=b/qred prec=prec+100.0d0*b/qpar if(ic.eq.0)then write(6,601)ki,e*CM,b,b/qpar*100.0d0,b/qred*100.0d0 601 format(i6,f12.2,f11.4,f9.4,f8.3,' |',$) if(LNQi.eq.0)write(6,603)0 603 format(i4,' ',$) do 6 j=1,LNQi 6 write(6,600)smi(j),NQsi(j) write(6,605) endif 3012 continue endif if(ini.or.inf)nif=nif+1 endif 3 continue 22 continue 7 deallocate(smi,NQsi,wmaxi) if(ic.eq.0)write(6,400)ki,kg,prec 400 format(/,i6,' initial states of',i11,' tried,', 1f9.4,' % population',/) if(ic.eq.1)write(6,404)kf,kg,nif 404 format(/,i6,' final states of',i11,/, 1i6,' states initial or final',/) return end function vqkv0(k,N,mj,GP,C,D,FC,n2,wmaxj,j,smj,LNQj,NQj) c <0|Qk'|v'> implicit none integer*4 k,N,mj,wmaxj(mj),ik,n2,NQj(*), 1LNQj,jj,smj(mj),skrna,j,l real*8 vqkv0,GP(N,N),wk,D(N),FC(n2),ak,C(N,N),aj,qk c / h \ c = sqrt| ---- | [sqrt(v'k)+ sqrt(v'k+1) ] c \ 2w'k / c / h \ c = sqrt| --- | [ Dk + sqrt(2v'k) (1 + Ckk} c \ 4w'k / c c + sum(j<>k) sqrt(2v'j) Ckj + sum(j) sqrt(v'j/2) Ekj ] wk=GP(k,k) c contribution: qk=D(k)*FC(j) c contribution: ik=0 do 1 jj=1,LNQj 1 if(smj(jj).eq.k.and.NQj(jj).gt.0)ik=jj if(ik.ne.0)then do 11 l=LNQj+1,mj 11 NQj(l)=0 ak=dble(NQj(ik)) NQj(ik)=NQj(ik)-1 qk=qk+dsqrt(ak+ak)*(1.0d0+C(k,k))*FC(skrna(mj,NQj,wmaxj)) NQj(ik)=NQj(ik)+1 endif c j<>k contributions: do 2 jj=1,LNQj if(smj(jj).ne.k.and.NQj(jj).gt.0)then aj=dble(NQj(jj)) NQj(jj)=NQj(jj)-1 do 12 l=LNQj+1,mj 12 NQj(l)=0 qk=qk+dsqrt(aj+aj)*C(k,smj(jj))*FC(skrna(mj,NQj,wmaxj)) NQj(jj)=NQj(jj)+1 endif 2 continue vqkv0=qk*dsqrt(0.25d0/wk) return end function vqkvp(k,N,mi,mj,GP,C,D,E,FC,n1,n2, 1wmaxi,wmaxj,i,j,smi,smj) c implicit none integer*4 k,N,mi,mj,wmaxi(mi),wmaxj(mj),ik,LNQi,n1,n2, 1LNQj,jj,smi(mi),smj(mj),skrna,i,j,l integer*4,allocatable::NQi(:),NQj(:) real*8 vqkvp,GP(N,N),wk,D(N),FC(n1,n2),ak,C(N,N),aj,qk,E(N,N) logical lt c / h \ c = sqrt| ---- | [sqrt(v'k)+ sqrt(v'k+1) ] c \ 2w'k / c / h \ c = sqrt| --- | [ Dk + sqrt(2v'k) (1 + Ckk} c \ 4w'k / c c + sum(j<>k) sqrt(2v'j) Ckj + sum(j) sqrt(v'j/2) Ekj ] allocate(NQi(mi),NQj(mj)) Call FCA2NQ(mi,i,wmaxi,lt,LNQi,NQi) Call FCA2NQ(mj,j,wmaxj,lt,LNQj,NQj) wk=GP(k,k) c contribution: qk=D(k)*FC(i,j) c contribution: ik=0 do 1 jj=1,LNQj 1 if(smj(jj).eq.k.and.NQj(jj).gt.0)ik=jj if(ik.ne.0)then do 11 l=LNQj+1,mj 11 NQj(l)=0 ak=dble(NQj(ik)) NQj(ik)=NQj(ik)-1 qk=qk+dsqrt(ak+ak)*(1.0d0+C(k,k))*FC(i,skrna(mj,NQj,wmaxj)) NQj(ik)=NQj(ik)+1 endif c j<>k contributions: do 2 jj=1,LNQj if(smj(jj).ne.k.and.NQj(jj).gt.0)then aj=dble(NQj(jj)) NQj(jj)=NQj(jj)-1 do 12 l=LNQj+1,mj 12 NQj(l)=0 qk=qk+dsqrt(aj+aj)*C(k,smj(jj))*FC(i,skrna(mj,NQj,wmaxj)) NQj(jj)=NQj(jj)+1 endif 2 continue c contributions: do 3 jj=1,LNQi if(NQi(jj).gt.0)then aj=dble(NQi(jj)) NQi(jj)=NQi(jj)-1 do 13 l=LNQi+1,mi 13 NQi(l)=0 qk=qk+dsqrt(aj/2.0d0)*E(k,smi(jj))*FC(skrna(mi,NQi,wmaxi),j) NQi(jj)=NQi(jj)+1 endif 3 continue vqkvp=qk*dsqrt(0.25d0/wk) return end function vqivp(k,N,mi,mj,G,A,B,E,FC,n1,n2, 1wmaxi,wmaxj,i,j,smi,smj) c = implicit none integer*4 k,N,mi,mj,wmaxi(mi),wmaxj(mj),ik,LNQi,n1,n2, 1LNQj,jj,smi(mi),smj(mj),skrna,i,j,l integer*4,allocatable::NQi(:),NQj(:) real*8 vqivp,G(N,N),wk,B(N),FC(n1,n2),ak,A(N,N),aj,qk,E(N,N) logical lt c / h \ c = sqrt| ----| [sqrt(vk)+ sqrt(vk+1) ] c \ 2wk / c / h \ c = sqrt| --- | [ Bk + sqrt(2vk) (1 + Akk} c \ 4wk / c c + sum(j<>k) sqrt(2vj) Akj + sum(j) sqrt(vj/2) Ejk ] allocate(NQi(mi),NQj(mj)) Call FCA2NQ(mi,i,wmaxi,lt,LNQi,NQi) Call FCA2NQ(mj,j,wmaxj,lt,LNQj,NQj) wk=G(k,k) c contribution: qk=B(k)*FC(i,j) c contribution: ik=0 do 1 jj=1,LNQi 1 if(smi(jj).eq.k.and.NQi(jj).gt.0)ik=jj if(ik.ne.0)then do 11 l=LNQi+1,mi 11 NQi(l)=0 ak=dble(NQi(ik)) NQi(ik)=NQi(ik)-1 qk=qk+dsqrt(ak+ak)*(1.0d0+A(k,k))*FC(skrna(mi,NQi,wmaxi),j) NQi(ik)=NQi(ik)+1 endif c j<>k contributions: do 2 jj=1,LNQi if(smi(jj).ne.k.and.NQi(jj).gt.0)then aj=dble(NQi(jj)) NQi(jj)=NQi(jj)-1 do 12 l=LNQi+1,mi 12 NQi(l)=0 qk=qk+dsqrt(aj+aj)*A(k,smi(jj))*FC(skrna(mi,NQi,wmaxi),j) NQi(jj)=NQi(jj)+1 endif 2 continue c contributions: do 3 jj=1,LNQj if(NQj(jj).gt.0)then aj=dble(NQj(jj)) NQj(jj)=NQj(jj)-1 do 13 l=LNQj+1,mj 13 NQj(l)=0 qk=qk+dsqrt(aj/2.0d0)*E(smj(jj),k)*FC(i,skrna(mj,NQj,wmaxj)) NQj(jj)=NQj(jj)+1 endif 3 continue vqivp=qk*dsqrt(0.25d0/wk) return end function enq(LNQ,N,sm,G,NQs) implicit none integer*4 LNQ,N,k,sm(*),NQs(*) real*8 enq,G(N,N),e e=0.0d0 do 4 k = 1,LNQ 4 e=e+G(sm(k),sm(k))*NQs(k) enq=e return end subroutine wlr3(k,nexc,nb0,nkt,lr3,li3,vr3,vi3,ei,ef,w) implicit none integer*4 nb0,nkt,a,b,nexc,k real*8 lr3(nexc,nb0,nkt,3,3),li3(nexc,nb0,nkt,3,3), 1vr3(nexc,nb0,nkt,3,3), 1vi3(nexc,nb0,nkt,3,3),ei,ef,CM,ECM,WCM,w character*1 xyz(3) data xyz/'X','Y','Z'/ CM=219474.63d0 ECM=(ef-ei)*CM WCM=w*CM write(6,701)ECM 701 format(/,' Energy =',f12.4,' cm^-1') write(6,702)WCM 702 format(' -> Omega =',f9.1,' cm^-1') write(6,706)' ELECTRIC DIPOLE-ELECTRIC DIPOLE ' 706 format(1x,40(1h-),/,A40,/,1x,40(1h-),/, 115x,'Real < v -v > Imag',11x,'Real < r - r> Imag') do 1 a=1,3 do 1 b=1,3 1 write(6,707)xyz(b),'-',xyz(a),' ',vr3(k,1,1,b,a),vi3(k,1,1,b,a), 1lr3(k,1,1,b,a),li3(k,1,1,b,a) 707 format(2x,4a1,2E17.7,E15.7,E17.7) return end subroutine kbmb(b,s) integer*4 b,mm,i,n1,n2 character*3 um character*(*) s if(b/1000000000.gt.1)then mm=b/1000000000 um=' GB' else if(b/1000000.gt.1)then mm=b/1000000 um=' MB' else if(b/1000.gt.1)then mm=b/1000 um=' kB' else mm=b um=' B ' endif do 1 n1=1,len(s) 1 if(s(n1:n1).ne.' ')goto 2 2 do 3 n2=len(s),1,-1 3 if(s(n2:n2).ne.' ')goto 4 4 write(6,601) 601 format(' ',$) do 5 i=n1,n2 5 write(6,600)s(i:i) 600 format(a1,$) write(6,609)mm,um 609 format(i9,a3) return end c ============================================================ subroutine bzw(nexc,lr,li,vr,vi,gr,gi,ar,ai,gcr,gci,acr,aci, 1srw,siw) implicit none integer*4 nexc real*8 lr(nexc,3,3),li(nexc,3,3),vr(nexc,3,3),vi(nexc,3,3), 1gr(nexc,3,3),gi(nexc,3,3),ar(nexc,3,3,3),ai(nexc,3,3,3), 1gcr(nexc,3,3),gci(nexc,3,3),acr(nexc,3,3,3),aci(nexc,3,3,3), 1srw(nexc),siw(nexc) lr=0.0d0 li=0.0d0 vr=0.0d0 vi=0.0d0 gr=0.0d0 gi=0.0d0 ar=0.0d0 ai=0.0d0 gcr=0.0d0 gci=0.0d0 acr=0.0d0 aci=0.0d0 srw=0.0d0 siw=0.0d0 return end c debug: c ne=0 c do 1 k=1,LNQ c ne=ne+NQs(k) c allocate(se(ne+1),sf(1)) c sf=0 c ie=0 c do 2 k=1,LNQ c do 2 kk=1,NQs(k) c ie=ie+1 c se(ie)=sm(k) COMP Critical c pc=FC1(fac,sf,se,0,ne,10000,1,A,B,C,D,E,N) c if(dabs((pc-pp)/pc).gt.1.0d-3)then c write(6,*)'state',(se(k),k=1,ne) c write(6,*)pp c write(6,*)pc c endif CcOMP End Critical c deallocate(se,sf)