c c Program RAM36, version December 2012 c c The program RAM36 is intended for fitting rotation–torsion energy levels in molecules in which c the frame has C2v symmetry and the top has C3v symmetry (like toluene or nitromethane). It is c also capable to deal with the case of a C3v top attached to a Cs molecular frame. c c The program was written by Dr. V.Ilyushin in collaboration with Dr. J.T. Hougen. c The effectiveness of this collaboration was considerably enhanced by the NIST exchange visitor c program, and the help of this NIST program is therefore gratefully acknowledged. c c The computer program uses several routines from the LAPACK library that have to be c provided at compilation time. These routines are DSTEQR, DSYTRD, DORGTR, c DGETRF, DGETRI, and DGESVD. If you are not using the LAPACK library package you will be c requested to provide also the auxiliary routines used in the LAPACK routines mentioned above. c c To achieve the highest performance of the program it is recommended to use c specific-processor-optimized versions of the LAPACK library like Intel Math c Kernel Library (MKL) or AMD Core Math Library (ACML). c c The DSBRDT routine from the Successive Band Reduction (SBR) package [ C.H. Bischof, c B. Lang, X.-.B. Sun, ACM Trans. Math. Software 26 (2000) 602-616.] is used, which source c code is provided in the end of this file. c for V3 problem idelm=3 and isigma=1 c for V6 problem idelm=6 and isigma=3 module dimens integer, parameter:: Jmaxdim=100 integer Ndimto, nvt,nvts,isigma, nsigma, Ktronc,idelm integer Ndat, Ncatm integer Npar integer ndim c Stol minimum change of S for stopping criterium deltaS/S real*8 stol,ocmax end module dimens module predict real*8 fupper, flower, Strunc, Temp,Vinttrunc,Temppred integer Jup,Jlo, vtup, vtlo, ipred, iMHz_or_cm, iexpect end module predict module vint integer jv1,jv2,isigvup,isigvlow,Jnv,kdstrength, istweight(0:3) real*8 FJ2,FM2 end module vint module SVD CHARACTER JOBU, JOBVT INTEGER LDAsvd, LDUsvd, LDVTsvd, LWORKsvd, nsvd real*8, allocatable:: Asvd(:,:), Ssvd(:), Usvd(:,:), VTsvd(:,:), WORKsvd(:) end module SVD module band CHARACTER JOBZband, UPLOband INTEGER kdband real*8, allocatable:: Aband(:,:),Subdiagtri(:) real*8, allocatable:: WORK( : ), TAU(:) real*8 alpha,beta end module band module expdat use dimens real*8 Symcatmhz(0:3),Smcatmhz(-9:9),Symcatcm(0:3),Smcatcm(-9:9) integer Isymcmhz(0:3), Imcmhz(-9:9),Isymccm(0:3), Imccm(-9:9) real*8, allocatable:: freqm(:),unc(:),weight(:),Scat(:),frlastcal(:) integer Ncat,Nlev,Ndata,nmaxlev,included,iblines,incllines,jlines,ibldifj integer, allocatable:: mq(:,:),Jq(:,:),Ka(:,:),Kc(:,:),incl(:),Incat(:) integer, allocatable:: icat(:),Jlev(:),mlev(:),itlev(:),ip(:),ipfr(:),ipbl(:),icatbl(:) integer, allocatable:: mbound(:,:),Jbnd(:,:),levnum(:,:) character*12, allocatable:: comment(:) end module expdat module param use dimens integer, allocatable:: IBpar(:,:),Nfloat(:),Nstage(:),ispar(:),Jdep(:,:),Kdep(:,:),Iprep(:,:) character*10, allocatable:: Bname(:) real*8, allocatable:: Bval(:),deltap(:),Bcomp(:),Bcompd(:) real*8 Fval,RHO,Sprev,Bslope,plmiRHO integer Numpar,Niter,Jmax,kdmax,Nrobust,iklF,iklRHO,norder,ispecFRHO end module param module paramtest use dimens integer, allocatable:: IBpartest(:,:),Nfloattest(:),Nstagetest(:) character*10, allocatable:: Bnametest(:) real*8, allocatable:: Bvaltest(:) integer Numpartest end module paramtest module calc use dimens c the array nv012() is considered only for the first three torsional states 0,1,2 integer, allocatable:: nv012(:,:,:,:),Jbound(:,:) real*8 Elowest real*8, allocatable:: H(:,:),EGVL(:),EGVC(:,:),Elst(:) real*8, allocatable:: ETORM(:,:,:), EVCTOR(:,:,:,:) c after second diagonalization step we save only for J-1,J,J+1 at each iteration by J real*8, allocatable:: Erottor(:,:,:), EVCrottor(:,:,:,:), A(:,:),parAB(:,:,:) real*8, allocatable:: drv(:,:,:),drvacc(:,:),fracc(:),sintacc(:),weightbl(:),frblend(:) integer valacc(8),valacc1(8),valacc2(8),valacc3(8),values(8),valinit(8),valinit1(8),ilowest character*10 date, time, zone end module calc c This is a program for calculating spectra with V6 leading term in expansion of potential c It also has a V3 mode PROGRAM RAM36 use predict use vint use param use paramtest use calc use expdat integer ierr call DATE_AND_TIME(date,time,zone,values) write(6,1012)values(3),values(2),values(1) write(6,1013)values(5),values(6),values(7),values(8) 1012 format(I2,'.',I2,'.',I4) 1013 format(I2,':',I2,':',I2,'.',I3/) c initialization of vint to avoid occasional coincidence at first entrance to Vintensity jv1=-1 jv2=-1 isigvup=-1 isigvlow=-1 Jnv=-1 itn=0 c initialize Sprev Sprev=0.d0 valacc=0 valacc1=0 valacc2=0 call inputdata() write(6,*)'input finished' allocate (Elst(0:isigma),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif Elowest=1.d+38 Elst=1.d+38 10 itn=itn+1 call DATE_AND_TIME(date,time,zone,values) write(6,1012)values(3),values(2),values(1) write(6,1013)values(5),values(6),values(7),values(8) valinit1=values write(6,*)'accumulated time for second stage diagonalization' write(6,1013)valacc(5),valacc(6),valacc(7),valacc(8) valacc=0 write(6,*)'accumulated time to setup a matrix for the second stage' write(6,1013)valacc1(5),valacc1(6),valacc1(7),valacc1(8) valacc1=0 write(6,*)'accumulated time to calculate derivatives' write(6,1013)valacc2(5),valacc2(6),valacc2(7),valacc2(8) valacc2=0 write(6,*)'accumulated time to label levels' write(6,1013)valacc3(5),valacc3(6),valacc3(7),valacc3(8) valacc3=0 write(6,*) write(6,*)'___________________________________________________________________________' write(6,*) write(6,*)'iteration number',itn call torsion() write(6,*)'torsion finished' call DATE_AND_TIME(date,time,zone,values) write(6,1012)values(3),values(2),values(1) write(6,1013)values(5),values(6),values(7),values(8) if(Niter.gt.0)then call fitting(itn) write(6,*)'fitting finished' call DATE_AND_TIME(date,time,zone,values) write(6,1012)values(3),values(2),values(1) write(6,1013)values(5),values(6),values(7),values(8) endif values=values-valinit1 if(values(8).ge.1000)then values(7)=values(7)+1 values(8)=values(8)-1000 endif if(values(8).lt.0)then values(7)=values(7)-1 values(8)=values(8)+1000 endif if(values(7).ge.60)then values(6)=values(6)+1 values(7)=values(7)-60 endif if(values(7).lt.0)then values(6)=values(6)-1 values(7)=values(7)+60 endif if(values(6).ge.60)then values(5)=values(5)+1 values(6)=values(6)-60 endif if(values(6).lt.0)then values(5)=values(5)-1 values(6)=values(6)+60 endif write(6,*)'time of iteration' write(6,1013)values(5),values(6),values(7),values(8) if(itn.lt.Niter)goto 10 if(norder.ne.0)then open(unit=10,file='testpar.txt',access='sequential',status='unknown') call allowedparam() endif c for calculation we need also not included in the fit levels deallocate(drv,levnum) i=-1 call levsort(i) allocate (drv(numpar,nmaxlev,0:2),levnum(2,nmaxlev),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif call torsion() c initialization of vint to avoid occasional coincidence at first entrance to Vintensity jv1=-1 jv2=-1 isigvup=-1 isigvlow=-1 Jnv=-1 call calculation(itn) call DATE_AND_TIME(date,time,zone,values) write(6,1012)values(3),values(2),values(1) write(6,1013)values(5),values(6),values(7),values(8) deallocate (Jlev,mlev,itlev) c deallocate (mbound) deallocate (mbound,Jbnd) deallocate (nv012,Jbound) deallocate (Etorm,Evctor) deallocate (Erottor,Evcrottor,parAB) deallocate (drv,levnum) if(ipred.ne.0)then ndim=(2*Jup+1)*nvt if(abs(ipred).eq.1)then nmaxlev=(2*Jup+1)*(vtup-vtlo+1)*(isigma+1) allocate (Jlev(nmaxlev*3),mlev(nmaxlev*3),itlev(nmaxlev*3),STAT=ierr) else allocate (Jlev(Ndata*2),mlev(Ndata*2),itlev(Ndata*2),STAT=ierr) endif if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (mbound(0:1,0:Jup),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (nv012(0:isigma,0:Jup,0:2,2*Jup+1),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif if(Jup.ge.Jmax)then allocate (Jbound(0:Jup,2),Jbnd(0:Jup,2),STAT=ierr) else allocate (Jbound(0:Jmax,2),Jbnd(0:Jmax,2),STAT=ierr) endif if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (Etorm(nvt,nsigma:isigma,-Jup:Jup),Evctor(Ndimto,nvt,nsigma:isigma,-Jup:Jup),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (Erottor(ndim,0:isigma,0:1),Evcrottor(ndim,ndim,0:isigma,0:1),parAB(ndim,0:isigma,0:1),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (drv(numpar,nmaxlev,0:1),levnum(2,nmaxlev),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif c saving Jmax for predictions Jmaxsave=Jmax Jmax=Jup call torsion() c initialization of vint to avoid occasional coincidence at first entrance to Vintensity jv1=-1 jv2=-1 isigvup=-1 isigvlow=-1 Jnv=-1 Jmax=Jmaxsave call jsort() ipfr=ip call prediction(itn) endif call DATE_AND_TIME(date,time,zone,values) write(6,1012)values(3),values(2),values(1) write(6,1013)values(5),values(6),values(7),values(8) END c in this subroutine the frequencies of all transitions are output subroutine prediction(itn) use predict use param use calc use expdat real*8 Aincer real*8 frc, Elow,Strength,Sint,Frexpect character*2 pr(0:7) integer ierr,ifile,ifile1,isul1,isul2 c the file to output predictions open(unit=7,file='predictdvt0.txt',access='sequential',status='unknown') write(7,2001)Temppred,Strunc,Vinttrunc write(7,2002)Flower,Fupper if(iMHz_or_cm.eq.0)then write(7,*)'Output in MHz' else write(7,*)'Output in cm-1' endif write(7,2003)Jlo,Jup,vtlo,vtup 2001 format('Temperature=',F6.1,5x,'Linestregth cutoff=',E10.3,5x,'Intensity cutoff=',E10.3) 2002 format('Lower frequency=',F12.3,3x,'Upper frequency=',F12.3) 2003 format('Jlow=',I4,2x,'Jup=',I4,2x,'vtlow=',I4,2x,'vtup=',I4) if(iexpect.eq.1)then c to output expectation values for different operators used in then fit open(unit=17,file='expectvt0.txt',access='sequential',status='unknown') c give the headings the names of the parameters write(17,4118) do in=1,numpar if(Nfloat(in).ne.1)cycle write(17,4117)Bname(in) enddo !END OF parameters cycle in write(17,3115) endif 4117 format(\3x,A10,$) 4118 format(/56x,' ',$) write(7,*)'Elowest=',Elowest,'cm-1' write(7,*)'Temperature=',Temppred if(ilowest.eq.1)then write(7,*)'Elowest for each symmerty=' do i=0,isigma write(7,*)'isigR=',i,'Elowest=',Elst(i) enddo endif write(7,*)'Elowest is used only in intensity calculation' write(7,*)'It is not subtracted from the values given in column Elow' write(7,1116) if(ipred.eq.-1)then open(unit=8,file='predictdvt1.txt',access='sequential',status='unknown') write(8,2001)Temppred,Strunc,Vinttrunc write(8,2002)Flower,Fupper if(iMHz_or_cm.eq.0)then write(8,*)'Output in MHz' else write(8,*)'Output in cm-1' endif write(8,2003)Jlo,Jup,vtlo,vtup write(8,*)'Elowest=',Elowest,'cm-1' write(8,*)'Temperature=',Temppred if(ilowest.eq.1)then write(8,*)'Elowest for each symmerty=' do i=0,isigma write(8,*)'isigR=',i,'Elowest=',Elst(i) enddo endif write(8,*)'Elowest is used only in intensity calculation' write(8,1116) if(iexpect.eq.1)then c to output expectation values for different operators used in then fit open(unit=18,file='expectvt1.txt',access='sequential',status='unknown') write(18,4118) do in=1,numpar if(Nfloat(in).ne.1)cycle write(18,4117)Bname(in) enddo !END OF parameters cycle in write(18,3115) endif endif !from ipred 1116 format(7x,'Upper level',8x,'Lower level',5x,'Intensity',6x,'Calculated(Unc.)',10x,'Elow',4x,'Strength',/) mbound=1 c symmtery labels for output if(isigma.eq.3)then pr(0)='A ' pr(1)='E1' pr(2)='E2' pr(3)='B ' pr(4)='A1' pr(5)='A2' pr(6)='B1' pr(7)='B2' elseif(isigma.eq.1)then pr(0)='A ' pr(1)='E ' pr(2)='A1' pr(3)='A2' pr(4)='* ' pr(5)='* ' pr(6)='*' pr(7)='*' endif c initial calculation for J=0 J=0 ikl=0 Jbound(J,1)=1 do isig=0,isigma do ivt=vtlo,vtup mval=isig+int4((ivt+1)/2)*idelm*(-1)**ivt do ikt=1,2*J+1 ikl=ikl+1 Jlev(ikl)=J mlev(ikl)=mval itlev(ikl)=ikt enddo enddo !end of ivt cycle enddo !end of isig cycle Jbound(J,2)=ikl NDIMR=(2*J+1)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif num=mod(J,2) call rotation(J,itn,num) c call parity(J,num) if(isigma.eq.1)then call labelingV3(J,itn,num) elseif(isigma.eq.3)then call labelingV6(J,itn,num) endif if(Niter.ne.0)then c calculate derivatives for fitted parameters and all levels for uncertainties only if there is not just a calculation where covariation matrix is not known call derivative(J,num) endif deallocate (H,EGVL,EGVC) do J=0,Jup c second stage calculation for particular J NDIMR=(2*J+3)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif if(J.ne.Jup)then Jbound(J+1,1)=Jbound(J,2)+1 if(Jbound(J+1,1)+(2*J+3)*(vtup-vtlo+1)*(isigma+1).gt.nmaxlev*3)Jbound(J+1,1)=1 ikl=Jbound(J+1,1)-1 do isig=0,isigma do ivt=vtlo,vtup mval=isig+int4((ivt+1)/2)*idelm*(-1)**ivt do ikt=1,2*J+3 ikl=ikl+1 Jlev(ikl)=J+1 mlev(ikl)=mval itlev(ikl)=ikt enddo enddo !end of ivt cycle enddo !end of isig cycle Jbound(J+1,2)=ikl num=mod(J+1,2) call rotation(J+1,itn,num) c call parity(J+1,num) if(isigma.eq.1)then call labelingV3(J+1,itn,num) elseif(isigma.eq.3)then call labelingV6(J+1,itn,num) endif if(Niter.ne.0)then c calculate derivatives for fitted parameters and all levels for uncertainties call derivative(J+1,num) endif endif c cycle over all energy levels of given J and calculate the frequency with current J and previous J c Q transitions do ij1=Jbound(J,1),Jbound(J,2)-1 do ij2=ij1+1,Jbound(J,2) if(mlev(ij1).ne.mlev(ij2))then if(ipred.eq.1)cycle endif c now find the levels in the list that correspond to this transitions itup=itlev(ij1) itlow=itlev(ij2) c here we determine what array section to take for particular J numup=mod(Jlev(ij1),2) numlo=mod(Jlev(ij2),2) c upper level isigup=abs(mod(idelm*nvt+mlev(ij1),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mlev(ij1).eq.isigup)ivt=0 if(mlev(ij1).eq.isigup-idelm)ivt=1 if(mlev(ij1).eq.isigup+idelm)ivt=2 itupn=nv012(isigup,Jlev(ij1),ivt,itup) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itupn.lt.0)then isigup=abs(isigup-3) itupn=abs(itupn) endif c lower level isiglow=abs(mod(idelm*nvt+mlev(ij2),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mlev(ij2).eq.isiglow)ivt=0 if(mlev(ij2).eq.isiglow-idelm)ivt=1 if(mlev(ij2).eq.isiglow+idelm)ivt=2 itlown=nv012(isiglow,Jlev(ij2),ivt,itlow) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itlown.lt.0)then isiglow=abs(isiglow-3) itlown=abs(itlown) endif c now we have ordinal numbers of the upper an lower levels of the transition we can build the matrix frc=Erottor(itupn,isigup,numup)-Erottor(itlown,isiglow,numlo) if(iMHz_or_cm.eq.0)then frc=frc*29979.2458D0 endif c check for frequency limits if(dabs(frc).lt.flower.or.dabs(frc).gt.fupper)cycle c check if we have measured transition ikstfin=0 if(frc.gt.0.d0)then Kaup=int4((itlev(ij1))/2) Kcup=Kaup-itlev(ij1)+Jlev(ij1)+1 Kalow=int4((itlev(ij2))/2) Kclow=Kalow-itlev(ij2)+Jlev(ij2)+1 c this is to mark already measured lines in prediction if(J.le.Jmax)then if(Jbnd(J,1).ne.0)then do ist=Jbnd(J,1),Jbnd(J,2) ikst=ipfr(ist) if(Jq(2,ikst).eq.J.and.Jq(1,ikst).eq.J.and.mq(2,ikst).eq.mlev(ij1).and.mq(1,ikst).eq.mlev(ij2))then if(Ka(1,ikst).eq.Kalow.and.Ka(2,ikst).eq.Kaup.and.Kc(1,ikst).eq.Kclow.and.Kc(2,ikst).eq.Kcup)then ikstfin=ikst exit endif endif enddo endif endif else Kaup=int4((itlev(ij2))/2) Kcup=Kaup-itlev(ij2)+Jlev(ij2)+1 Kalow=int4((itlev(ij1))/2) Kclow=Kalow-itlev(ij1)+Jlev(ij1)+1 c this is to mark already measured lines in prediction if(J.le.Jmax)then if(Jbnd(J,1).ne.0)then do ist=Jbnd(J,1),Jbnd(J,2) ikst=ipfr(ist) if(Jq(2,ikst).eq.J.and.Jq(1,ikst).eq.J.and.mq(2,ikst).eq.mlev(ij2).and.mq(1,ikst).eq.mlev(ij1))then if(Ka(1,ikst).eq.Kalow.and.Ka(2,ikst).eq.Kaup.and.Kc(1,ikst).eq.Kclow.and.Kc(2,ikst).eq.Kcup)then ikstfin=ikst exit endif endif enddo endif endif endif c calculation of intensities call Vintensity(Jlev(ij2),Jlev(ij1),numlo,numup,isigup,isiglow,itupn,itlown,Strength) c check for linestrength limit if(Strength.lt.Strunc.and.ikstfin.eq.0)cycle c check intensity cutoff if(frc.gt.0.d0)then c energy of the lower state Elow=Erottor(itlown,isiglow,numlo) if(ilowest.eq.1)then Elowest=Elst(isiglow) endif if(iMHz_or_cm.eq.0)then Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc/29979.2458d0)**2 else Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc)**2 endif if(Sint.lt.Vinttrunc.and.ikstfin.eq.0)cycle else Elow=Erottor(itupn,isigup,numup) if(ilowest.eq.1)then Elowest=Elst(isigup) endif if(iMHz_or_cm.eq.0)then Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc/29979.2458d0)**2 else Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc)**2 endif if(Sint.lt.Vinttrunc.and.ikstfin.eq.0)cycle endif c calculation of unceratinties for transitions if(Niter.ne.0)then ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 int=0 Aincer=0.d0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle int=int+1 ist=0 do is=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(is).ne.1)cycle ist=ist+1 Aincer=Aincer+A(int,ist)*(drv(in,ilup,numup)-drv(in,illow,numlo))* ! (drv(is,ilup,numup)-drv(is,illow,numlo)) enddo !END OF parameters cycle is enddo !END OF parameters cycle in if(iMHz_or_cm.eq.0)then Aincer=2.d0*dsqrt(Aincer)*29979.2458D0 else Aincer=2.d0*dsqrt(Aincer) endif endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties c separate deltavt=0 from deltavt=/=0 transitions if(mlev(ij1).eq.mlev(ij2))then ifile=7 ifile1=17 else ifile=8 ifile1=18 endif c isigr for symmetry label determination isul2=isigup isul1=isiglow if(isigma.eq.1)then if(isigup.eq.0)then if(parAb(itupn,isigup,numup).gt.1.d-16)isul2=2 if(parAb(itupn,isigup,numup).lt.-1.d-16)isul2=3 endif if(isiglow.eq.0)then if(parAb(itlown,isiglow,numlo).gt.1.d-16)isul1=2 if(parAb(itlown,isiglow,numlo).lt.-1.d-16)isul1=3 endif c do not output symmetry forbidden transitions transitions for A species if(isigup.eq.0.or.isiglow.eq.0)then c A1<->A2 selection rules are assumed if(isul2.eq.isul1)then if(ikstfin.ne.0)write(6,*)'forbidden line',freqm(ikstfin),incl(ikstfin) cycle endif endif elseif(isigma.eq.3)then if(isigup.eq.0)then if(parAb(itupn,isigup,numup).gt.1.d-16)isul2=4 if(parAb(itupn,isigup,numup).lt.-1.d-16)isul2=5 endif if(isiglow.eq.0)then if(parAb(itlown,isiglow,numlo).gt.1.d-16)isul1=4 if(parAb(itlown,isiglow,numlo).lt.-1.d-16)isul1=5 endif if(isigup.eq.3)then if(parAb(itupn,isigup,numup).gt.1.d-16)isul2=6 if(parAb(itupn,isigup,numup).lt.-1.d-16)isul2=7 endif if(isiglow.eq.3)then if(parAb(itlown,isiglow,numlo).gt.1.d-16)isul1=6 if(parAb(itlown,isiglow,numlo).lt.-1.d-16)isul1=7 endif endif if(frc.gt.0.d0)then write(ifile,1115)pr(isul2),mlev(ij1),Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),Jlev(ij2),Kalow,Kclow,Sint,frc,aincer,Elow,Strength c this is to mark already measured lines in prediction if(ikstfin.ne.0)then if(unc(ikstfin).gt.0.d0)then freqm(ikstfin)=freqm(ikstfin)*29979.2458d0 unc(ikstfin)=unc(ikstfin)*29979.2458D0 endif if(iMHz_or_cm.eq.0.and.unc(ikstfin).gt.0.d0.or.iMHz_or_cm.eq.1.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-frc,incl(ikstfin) elseif(iMHz_or_cm.eq.1.and.unc(ikstfin).gt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-frc*29979.2458d0,incl(ikstfin) elseif(iMHz_or_cm.eq.0.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-frc/29979.2458d0,incl(ikstfin) endif endif write(ifile,3115) if(iexpect.eq.1)then c output of expectation values write(ifile1,4115)pr(isul2),mlev(ij1),Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),Jlev(ij2),Kalow,Kclow,frc if(Niter.ne.0)then ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 FRexpect=0.d0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle write(ifile1,4114)(drv(in,ilup,numup)-drv(in,illow,numlo))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,ilup,numup)-drv(in,illow,numlo)) enddo !END OF parameters cycle in if(iMHz_or_cm.eq.0)then FRexpect=FRexpect*29979.2458D0 else FRexpect=FRexpect endif endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties write(ifile1,4116)FRexpect endif 4114 format(\1x,E12.5,$) 4115 format(A2,I3,3I4,4x,A2,I3,3I4,3x,F14.4,$) 4116 format(1x,F14.4) 2115 format(\F14.4,'(',F7.4,')'1x,F10.3,I3,$) 3115 format(\,/) else write(ifile,1115)pr(isul1),mlev(ij2),Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),Jlev(ij1),Kalow,Kclow,Sint,dabs(frc),aincer,Elow,Strength c this is to mark already measured lines in prediction if(ikstfin.ne.0)then if(unc(ikstfin).gt.0.d0)then freqm(ikstfin)=freqm(ikstfin)*29979.2458d0 unc(ikstfin)=unc(ikstfin)*29979.2458D0 endif if(iMHz_or_cm.eq.0.and.unc(ikstfin).gt.0.d0.or.iMHz_or_cm.eq.1.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-dabs(frc),incl(ikstfin) elseif(iMHz_or_cm.eq.1.and.unc(ikstfin).gt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-dabs(frc)*29979.2458d0,incl(ikstfin) elseif(iMHz_or_cm.eq.0.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-dabs(frc)/29979.2458d0,incl(ikstfin) endif endif write(ifile,3115) if(iexpect.eq.1)then c output of expectation values write(ifile1,4115)pr(isul1),mlev(ij2),Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),Jlev(ij1),Kalow,Kclow,dabs(frc) if(Niter.ne.0)then ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 FRexpect=0.d0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle write(ifile1,4114)(drv(in,illow,numlo)-drv(in,ilup,numup))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,illow,numlo)-drv(in,ilup,numup)) enddo !END OF parameters cycle in if(iMHz_or_cm.eq.0)then FRexpect=FRexpect*29979.2458D0 else FRexpect=FRexpect endif endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties write(ifile1,4116)FRexpect endif endif 1115 format(A2,I3,3I4,4x,A2,I3,3I4,3x,E10.3,F14.4,'(',F8.4,')',F12.4,F10.3,$) enddo !end of experimental data cycle Jbound enddo !end of Q type calculation if(J.ne.Jup)then c R transitions do ij1=Jbound(J+1,1),Jbound(J+1,2) do ij2=Jbound(J,1),Jbound(J,2) if(mlev(ij1).ne.mlev(ij2))then if(ipred.eq.1)cycle endif c now find the levels in the list that correspond to this transitions itup=itlev(ij1) itlow=itlev(ij2) c here we determine what array section to take for particular J numup=mod(Jlev(ij1),2) numlo=mod(Jlev(ij2),2) c upper level isigup=abs(mod(idelm*nvt+mlev(ij1),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mlev(ij1).eq.isigup)ivt=0 if(mlev(ij1).eq.isigup-idelm)ivt=1 if(mlev(ij1).eq.isigup+idelm)ivt=2 itupn=nv012(isigup,Jlev(ij1),ivt,itup) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itupn.lt.0)then isigup=abs(isigup-3) itupn=abs(itupn) endif c lower level isiglow=abs(mod(idelm*nvt+mlev(ij2),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mlev(ij2).eq.isiglow)ivt=0 if(mlev(ij2).eq.isiglow-idelm)ivt=1 if(mlev(ij2).eq.isiglow+idelm)ivt=2 itlown=nv012(isiglow,Jlev(ij2),ivt,itlow) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itlown.lt.0)then isiglow=abs(isiglow-3) itlown=abs(itlown) endif c now we have ordinal numbers of the upper an lower levels of the transition we can build the matrix frc=Erottor(itupn,isigup,numup)-Erottor(itlown,isiglow,numlo) if(iMHz_or_cm.eq.0)then frc=frc*29979.2458D0 endif c check for frequency limits if(dabs(frc).lt.flower.or.dabs(frc).gt.fupper)cycle c check if we have measured transition ikstfin=0 if(frc.gt.0.d0)then Kaup=int4((itlev(ij1))/2) Kcup=Kaup-itlev(ij1)+Jlev(ij1)+1 Kalow=int4((itlev(ij2))/2) Kclow=Kalow-itlev(ij2)+Jlev(ij2)+1 c this is to mark already measured lines in prediction if(J.le.Jmax)then if(Jbnd(J,1).ne.0)then do ist=Jbnd(J,1),Jbnd(J,2) ikst=ipfr(ist) if(Jq(2,ikst).eq.Jlev(ij1).and.Jq(1,ikst).eq.Jlev(ij2).and.mq(2,ikst).eq.mlev(ij1).and.mq(1,ikst).eq.mlev(ij2))then if(Ka(1,ikst).eq.Kalow.and.Ka(2,ikst).eq.Kaup.and.Kc(1,ikst).eq.Kclow.and.Kc(2,ikst).eq.Kcup)then ikstfin=ikst exit endif endif enddo endif endif else Kaup=int4((itlev(ij2))/2) Kcup=Kaup-itlev(ij2)+Jlev(ij2)+1 Kalow=int4((itlev(ij1))/2) Kclow=Kalow-itlev(ij1)+Jlev(ij1)+1 c this is to mark already measured lines in prediction if(J+1.le.Jmax)then if(Jbnd(J+1,1).ne.0)then do ist=Jbnd(J+1,1),Jbnd(J+1,2) ikst=ipfr(ist) if(Jq(2,ikst).eq.Jlev(ij2).and.Jq(1,ikst).eq.Jlev(ij1).and.mq(2,ikst).eq.mlev(ij2).and.mq(1,ikst).eq.mlev(ij1))then if(Ka(1,ikst).eq.Kalow.and.Ka(2,ikst).eq.Kaup.and.Kc(1,ikst).eq.Kclow.and.Kc(2,ikst).eq.Kcup)then ikstfin=ikst exit endif endif enddo endif endif endif c calculation of intensities call Vintensity(Jlev(ij2),Jlev(ij1),numlo,numup,isigup,isiglow,itupn,itlown,Strength) c check for linestrength limit if(Strength.lt.Strunc.and.ikstfin.eq.0)cycle c check intensity cutoff if(frc.gt.0.d0)then c energy of the lower state Elow=Erottor(itlown,isiglow,numlo) if(ilowest.eq.1)then Elowest=Elst(isiglow) endif if(iMHz_or_cm.eq.0)then Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc/29979.2458d0)**2 else Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc)**2 endif if(Sint.lt.Vinttrunc.and.ikstfin.eq.0)cycle else Elow=Erottor(itupn,isigup,numup) if(ilowest.eq.1)then Elowest=Elst(isigup) endif if(iMHz_or_cm.eq.0)then Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc/29979.2458d0)**2 else Sint=Strength*dexp(-1.439d0*(Elow-Elowest)/Temppred)*(frc)**2 endif if(Sint.lt.Vinttrunc.and.ikstfin.eq.0)cycle endif c calculation of unceratinties for transitions if(Niter.ne.0)then ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 int=0 Aincer=0.d0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle int=int+1 ist=0 do is=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(is).ne.1)cycle ist=ist+1 Aincer=Aincer+A(int,ist)*(drv(in,ilup,numup)-drv(in,illow,numlo))* ! (drv(is,ilup,numup)-drv(is,illow,numlo)) enddo !END OF parameters cycle is enddo !END OF parameters cycle in if(iMHz_or_cm.eq.0)then Aincer=2.d0*dsqrt(Aincer)*29979.2458D0 else Aincer=2.d0*dsqrt(Aincer) endif endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties c separate deltavt=0 from deltavt=/=0 transitions if(mlev(ij1).eq.mlev(ij2))then ifile=7 ifile1=17 else ifile=8 ifile1=18 endif c isigr for symmetry label determination isul2=isigup isul1=isiglow if(isigma.eq.1)then if(isigup.eq.0)then if(parAb(itupn,isigup,numup).gt.1.d-16)isul2=2 if(parAb(itupn,isigup,numup).lt.-1.d-16)isul2=3 endif if(isiglow.eq.0)then if(parAb(itlown,isiglow,numlo).gt.1.d-16)isul1=2 if(parAb(itlown,isiglow,numlo).lt.-1.d-16)isul1=3 endif c do not output symmetry forbidden transitions transitions for A species if(isigup.eq.0.or.isiglow.eq.0)then c A1<->A2 selection rules are assumed if(isul2.eq.isul1)then if(ikstfin.ne.0)write(6,*)'forbidden line',freqm(ikstfin),incl(ikstfin) cycle endif endif elseif(isigma.eq.3)then if(isigup.eq.0)then if(parAb(itupn,isigup,numup).gt.1.d-16)isul2=4 if(parAb(itupn,isigup,numup).lt.-1.d-16)isul2=5 endif if(isiglow.eq.0)then if(parAb(itlown,isiglow,numlo).gt.1.d-16)isul1=4 if(parAb(itlown,isiglow,numlo).lt.-1.d-16)isul1=5 endif if(isigup.eq.3)then if(parAb(itupn,isigup,numup).gt.1.d-16)isul2=6 if(parAb(itupn,isigup,numup).lt.-1.d-16)isul2=7 endif if(isiglow.eq.3)then if(parAb(itlown,isiglow,numlo).gt.1.d-16)isul1=6 if(parAb(itlown,isiglow,numlo).lt.-1.d-16)isul1=7 endif endif if(frc.gt.0.d0)then write(ifile,1115)pr(isul2),mlev(ij1),Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),Jlev(ij2),Kalow,Kclow,Sint,frc,aincer,Elow,Strength if(ikstfin.ne.0)then if(unc(ikstfin).gt.0.d0)then freqm(ikstfin)=freqm(ikstfin)*29979.2458d0 unc(ikstfin)=unc(ikstfin)*29979.2458D0 endif if(iMHz_or_cm.eq.0.and.unc(ikstfin).gt.0.d0.or.iMHz_or_cm.eq.1.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-frc,incl(ikstfin) elseif(iMHz_or_cm.eq.1.and.unc(ikstfin).gt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-frc*29979.2458d0,incl(ikstfin) elseif(iMHz_or_cm.eq.0.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-frc/29979.2458d0,incl(ikstfin) endif endif write(ifile,3115) if(iexpect.eq.1)then c output of expectation values write(ifile1,4115)pr(isul2),mlev(ij1),Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),Jlev(ij2),Kalow,Kclow,frc if(Niter.ne.0)then ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 FRexpect=0.d0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle write(ifile1,4114)(drv(in,ilup,numup)-drv(in,illow,numlo))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,ilup,numup)-drv(in,illow,numlo)) enddo !END OF parameters cycle in if(iMHz_or_cm.eq.0)then FRexpect=FRexpect*29979.2458D0 else FRexpect=FRexpect endif endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties write(ifile1,4116)FRexpect endif else write(ifile,1115)pr(isul1),mlev(ij2),Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),Jlev(ij1),Kalow,Kclow,Sint,dabs(frc),aincer,Elow,Strength c this is to mark already measured lines in prediction if(ikstfin.ne.0)then if(unc(ikstfin).gt.0.d0)then freqm(ikstfin)=freqm(ikstfin)*29979.2458d0 unc(ikstfin)=unc(ikstfin)*29979.2458D0 endif if(iMHz_or_cm.eq.0.and.unc(ikstfin).gt.0.d0.or.iMHz_or_cm.eq.1.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-dabs(frc),incl(ikstfin) elseif(iMHz_or_cm.eq.1.and.unc(ikstfin).gt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-dabs(frc)*29979.2458d0,incl(ikstfin) elseif(iMHz_or_cm.eq.0.and.unc(ikstfin).lt.0.d0)then write(ifile,2115)freqm(ikstfin),unc(ikstfin),freqm(ikstfin)-dabs(frc)/29979.2458d0,incl(ikstfin) endif endif write(ifile,3115) if(iexpect.eq.1)then c output of expectation values write(ifile1,4115)pr(isul1),mlev(ij2),Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),Jlev(ij1),Kalow,Kclow,dabs(frc) if(Niter.ne.0)then ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 FRexpect=0.d0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle write(ifile1,4114)(drv(in,illow,numlo)-drv(in,ilup,numup))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,illow,numlo)-drv(in,ilup,numup)) enddo !END OF parameters cycle in if(iMHz_or_cm.eq.0)then FRexpect=FRexpect*29979.2458D0 else FRexpect=FRexpect endif endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties write(ifile1,4116)FRexpect endif endif enddo !end of experimental data cycle Jbound enddo !end of R type calculation endif deallocate (H,EGVL,EGVC) enddo !end of experimental data cycle J return end c in this subroutine the frequencies of all transitions are outputted subroutine calculation(itn) use predict use param use calc use expdat use svd real*8, allocatable:: Aincer(:),Corr(:,:),Stren(:), frc(:), Elow(:), Eup(:) integer, allocatable:: isul(:,:),JS(:),ibranch(:),Kbranch(:),iblsign(:) real*8 dlf,Smhz,Scm,Sw,Sct(Ncat) real*8 Strength,Sint,Sdeltammhz,Sdeltamcm character*2 pr(0:7) character*1 blsign(0:1) real*8 freqprev, frcalcprev, sintprev, fraccum, sintaccum,dlfprev, weightprev,parup(Ndata),parlow(Ndata) allocate (Aincer(Ndata),Corr(numpar,numpar),Stren(Ndata), frc(Ndata), Elow(Ndata), Eup(Ndata),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif allocate (isul(2,Ndata),JS(2*Jmaxdim),ibranch(2*Jmaxdim),Kbranch(Ndata),iblsign(Ndata),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif blsign(0)=' ' blsign(1)='b' iblsign=0 Symcatmhz=0.d0 Imcmhz=0 Smcatmhz=0.d0 Isymcmhz=0 Symcatcm=0.d0 Imccm=0 Smcatcm=0.d0 Isymccm=0 Sdeltammhz=0.d0 Sdeltamcm=0.d0 ideltammhz=0 ideltamcm=0 Sct=0.d0 INcat=0 Smhz=0.d0 Scm=0.d0 incllinmhz=0 incllincm=0 Sw=0.d0 Aincer=0.d0 if(Niter.eq.0)A=0.d0 c this is to mark blends in the output by branch frc=0.d0 ipfr=0 do i=1,Ndata c we consider blends only for included lines if(incl(i).eq.0)cycle ipfr(i)=i frc(i)=freqm(i) enddo c sort the frsrt array call VSRTPD (frc,Ndata,ipfr) do i=2,Ndata-1 if(frc(i).eq.0.d0)cycle if(frc(i).eq.frc(i-1))then iblsign(ipfr(i))=1 iblsign(ipfr(i-1))=1 elseif(frc(i).eq.frc(i+1))then iblsign(ipfr(i))=1 iblsign(ipfr(i+1))=1 endif enddo c this is to output in order of frequency frc=0.d0 ipfr=0 do i=1,Ndata ipfr(i)=i frc(i)=freqm(i) enddo c sort the frsrt array call VSRTPD (frc,Ndata,ipfr) frc=0.d0 c symmtery labels for output if(isigma.eq.3)then pr(0)='A ' pr(1)='E1' pr(2)='E2' pr(3)='B ' pr(4)='A1' pr(5)='A2' pr(6)='B1' pr(7)='B2' elseif(isigma.eq.1)then pr(0)='A ' pr(1)='E ' pr(2)='A1' pr(3)='A2' pr(4)='* ' pr(5)='* ' pr(6)='*' pr(7)='*' endif c initial calculation for J=0 J=0 NDIMR=(2*J+1)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif num=mod(J,3) call rotation(J,itn,num) c call parity(J,num) if(isigma.eq.1)then call labelingV3(J,itn,num) elseif(isigma.eq.3)then call labelingV6(J,itn,num) endif if(Niter.ne.0)then c calculate derivatives for fitted parameters and all levels for uncertainties only if there is not just a calculation where covariation matrix is not known call derivative(J,num) endif deallocate (H,EGVL,EGVC) do J=0,Jmax c second stage calculation for particular J NDIMR=(2*J+3)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif if(J.ne.Jmax)then num=mod(J+1,3) call rotation(J+1,itn,num) c call parity(J+1,num) if(isigma.eq.1)then call labelingV3(J+1,itn,num) elseif(isigma.eq.3)then call labelingV6(J+1,itn,num) endif if(Niter.ne.0)then c calculate derivatives for fitted parameters and all levels for uncertainties call derivative(J+1,num) endif endif if(Jbnd(J,1).eq.0)then deallocate (H,EGVL,EGVC) cycle endif do ij1=Jbnd(J,1),Jbnd(J,2) ikl=ip(ij1) c now find the levels in the list that correspond to this transitions itup=Ka(2,ikl)-Kc(2,ikl)+Jq(2,ikl)+1 itlow=Ka(1,ikl)-Kc(1,ikl)+Jq(1,ikl)+1 c here we determine what array section to take for particular J num1=mod(Jq(1,ikl),3) num2=mod(Jq(2,ikl),3) c upper level isigup=abs(mod(idelm*nvt+mq(2,ikl),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mq(2,ikl).eq.isigup)ivt=0 if(mq(2,ikl).eq.isigup-idelm)ivt=1 if(mq(2,ikl).eq.isigup+idelm)ivt=2 itupn=nv012(isigup,Jq(2,ikl),ivt,itup) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itupn.lt.0)then isigup=abs(isigup-3) itupn=abs(itupn) endif c lower level isiglow=abs(mod(idelm*nvt+mq(1,ikl),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mq(1,ikl).eq.isiglow)ivt=0 if(mq(1,ikl).eq.isiglow-idelm)ivt=1 if(mq(1,ikl).eq.isiglow+idelm)ivt=2 itlown=nv012(isiglow,Jq(1,ikl),ivt,itlow) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itlown.lt.0)then isiglow=abs(isiglow-3) itlown=abs(itlown) endif c isigr for symmetry label determination isul(2,ikl)=isigup isul(1,ikl)=isiglow parup(ikl)=parAb(itupn,isigup,num2) parlow(ikl)=parAb(itlown,isiglow,num1) if(isigma.eq.1)then if(isigup.eq.0)then if(parAb(itupn,isigup,num2).gt.1.d-16)isul(2,ikl)=2 if(parAb(itupn,isigup,num2).lt.-1.d-16)isul(2,ikl)=3 endif if(isiglow.eq.0)then if(parAb(itlown,isiglow,num1).gt.1.d-16)isul(1,ikl)=2 if(parAb(itlown,isiglow,num1).lt.-1.d-16)isul(1,ikl)=3 endif elseif(isigma.eq.3)then if(isigup.eq.0)then if(parAb(itupn,isigup,num2).gt.1.d-16)isul(2,ikl)=4 if(parAb(itupn,isigup,num2).lt.-1.d-16)isul(2,ikl)=5 endif if(isiglow.eq.0)then if(parAb(itlown,isiglow,num1).gt.1.d-16)isul(1,ikl)=4 if(parAb(itlown,isiglow,num1).lt.-1.d-16)isul(1,ikl)=5 endif if(isigup.eq.3)then if(parAb(itupn,isigup,num2).gt.1.d-16)isul(2,ikl)=6 if(parAb(itupn,isigup,num2).lt.-1.d-16)isul(2,ikl)=7 endif if(isiglow.eq.3)then if(parAb(itlown,isiglow,num1).gt.1.d-16)isul(1,ikl)=6 if(parAb(itlown,isiglow,num1).lt.-1.d-16)isul(1,ikl)=7 endif endif c if there were severe problems with labeling then we probably will not be able to get itup or itlow if(itupn.eq.0.or.itupn.gt.ndim.or.itlown.eq.0.or.itlown.gt.ndim.or.isigup.ne.isiglow)then write(6,*)'the following line had severe problems with labeling it will be omitted from calculation' write(6,1114)mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),freqm(ikl), ! incl(ikl),unc(ikl),comment(ikl) cycle endif 1114 format(I2,3I4,4x,I2,3I4,3x,F14.4,I3,F8.4,1x,A12) c now we have ordinal numbers of the upper an lower levels of the transition we can build the matrix frc(ikl)=Erottor(itupn,isigup,num2)-Erottor(itlown,isiglow,num1) c if(unc(ikl).gt.0.d0)then c frc(ikl)=frc(ikl)*29979.2458D0 c freqm(ikl)=freqm(ikl)*29979.2458D0 c endif c check whether the obs-calc changed more than 1 kHz at the last iteration if(Niter.ne.0)then if(incl(ikl).eq.1.and.dabs(frc(ikl)-frlastcal(ikl))*29979.2458d0.gt.0.001d0)then if(unc(ikl).gt.0.d0)then write(6,*)'large change',freqm(ikl)*29979.2458d0,'MHz ',(frc(ikl)-frlastcal(ikl))*29979.2458d0,'MHz' elseif(unc(ikl).lt.0.d0)then write(6,*)'large change',freqm(ikl),'cm-1',(frc(ikl)-frlastcal(ikl))*29979.2458d0,'MHz' endif endif endif c energy of the lower state Elow(ikl)=Erottor(itlown,isiglow,num1) Eup(ikl)=Erottor(itupn,isigup,num2) c calculation of unceratinties for transitions if(Niter.ne.0)then c here we determine what level we need from the level list for derivatives ilup=0 illow=0 if(Jq(1,ikl).lt.Jq(2,ikl))then jn1=Jbound(Jq(1,ikl),1) jn2=Jbound(Jq(2,ikl),2) else jn1=Jbound(Jq(2,ikl),1) jn2=Jbound(Jq(1,ikl),2) endif do i=jn1,jn2 c upper level if(mq(2,ikl).eq.mlev(i).and.Jq(2,ikl).eq.Jlev(i).and.itup.eq.itlev(i))then ilup=i if(illow.ne.0)exit endif c lower level if(mq(1,ikl).eq.mlev(i).and.Jq(1,ikl).eq.Jlev(i).and.itlow.eq.itlev(i))then illow=i if(ilup.ne.0)exit endif enddo !end of nlev cycle if(ilup.eq.0.or.illow.eq.0)write(6,*)'error of finding derivatives',freqm(ikl) ilup=ilup-Jbound(Jlev(ilup),1)+1 illow=illow-Jbound(Jlev(illow),1)+1 int=0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle int=int+1 ist=0 do is=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(is).ne.1)cycle ist=ist+1 Aincer(ikl)=Aincer(ikl)+A(int,ist)*(drv(in,ilup,num2)-drv(in,illow,num1))* ! (drv(is,ilup,num2)-drv(is,illow,num1)) enddo !END OF parameters cycle is enddo !END OF parameters cycle in Aincer(ikl)=2.d0*dsqrt(Aincer(ikl)) if(unc(ikl).gt.0.d0)Aincer(ikl)=Aincer(ikl)*29979.2458D0 endif !end of checking whether there was a fit or only calculation where we are not able to calculate uncertainties c calculation of intensities call Vintensity(Jq(1,ikl),Jq(2,ikl),num1,num2,isigup,isiglow,itupn,itlown,Strength) Stren(ikl)=Strength enddo !end of experimental data cycle Jbnd deallocate (H,EGVL,EGVC) enddo !end of experimental data cycle J Elowest=Elowest write(6,*)'Elowest=',Elowest,'cm-1' write(6,*)'Elowest is used only in intensity calculation' write(6,*)'It is not subtracted from the values given in column Elow' write(6,1116) 1116 format(7x,'Upper level',8x,'Lower level',5x,'Intensity',6x,'Measured',11x, !'Calculated',12x,'o.-c.',6x,'Elow',4x,'Strength',1x,'incl',1x,'comment') frlastcal=0.d0 freqprev=0.d0 frcalcprev=0.d0 sintprev=0.d0 fraccum=0.d0 sintaccum=0.d0 iflagblend=0 do ikst=1,Ndata c output in order of frequency ikl=ipfr(ikst) dlf=freqm(ikl)-frc(ikl) Sint=Stren(ikl)*dexp(-1.439d0*(Elow(ikl)-Elowest)/Temp)*(frc(ikl))**2 c for rms consider only included lines if(incl(ikl).eq.1)then c this is output for blended lines if(freqm(ikl).eq.freqprev)then if(iflagblend.eq.0)then fraccum=frcalcprev*sintprev+frc(ikl)*sint sintaccum=sintprev+sint else fraccum=fraccum+frc(ikl)*sint sintaccum=sintaccum+sint endif iflagblend=iflagblend+1 else c if the blend series is over output the results if(iflagblend.ne.0)then c here we save the calculated obs-cal for intensity averaged blended transitions to output by branch istr=1 do while (iflagblend.gt.-1) if(incl(ipfr(ikst-istr)).eq.1)then frlastcal(ipfr(ikst-istr))=freqprev-fraccum/sintaccum iflagblend=iflagblend-1 endif istr=istr+1 enddo if(Scat(icatprev).gt.0.d0)then write(6,1117)Sintaccum,freqprev*29979.2458D0,fraccum/sintaccum*29979.2458D0,(freqprev-fraccum/sintaccum)*29979.2458D0 else write(6,1117)Sintaccum,freqprev,fraccum/sintaccum,freqprev-fraccum/sintaccum endif c modifying different rms to take into account blended lines c we substract that contribution which was added when the first transition of the belnded line was considered c and add the contribution from the weighted transition frequency Sct(icatprev)=Sct(icatprev)-dlfprev**2+(freqprev-fraccum/sintaccum)**2 if(Scat(icatprev).gt.0.d0)then Smhz=Smhz-dlfprev**2+(freqprev-fraccum/sintaccum)**2 endif if(Scat(icatprev).lt.0.d0)then Scm=Scm-dlfprev**2+(freqprev-fraccum/sintaccum)**2 endif Sw=Sw-dlfprev**2*weightprev+(freqprev-fraccum/sintaccum)**2*weightprev iflagblend=0 fraccum=0.d0 sintaccum=0.d0 endif endif 1117 format('calculated frequency of the blend',8x,E10.3,F14.4,9x,F14.4,8x,F10.4) c this is for rms c in the symmmetry rms and m rms we consider transition not taking into account whether it is blend or not. c this is to convert from A1/A2 B1/B2 to A and B categories for symmetry rms if(isigma.eq.1)then isigl=isul(1,ikl) if(isigl.eq.2.or.isigl.eq.3)isigl=0 elseif(isigma.eq.3)then isigl=isul(1,ikl) if(isigl.eq.4.or.isigl.eq.5)isigl=0 if(isigl.eq.6.or.isigl.eq.7)isigl=3 endif if(unc(ikl).gt.0.d0)then Symcatmhz(isigl)=Symcatmhz(isigl)+dlf**2 Isymcmhz(isigl)=Isymcmhz(isigl)+1 endif if(unc(ikl).lt.0.d0)then Symcatcm(isigl)=Symcatcm(isigl)+dlf**2 Isymccm(isigl)=Isymccm(isigl)+1 endif if(mq(1,ikl).eq.mq(2,ikl))then if(unc(ikl).gt.0.d0)then Smcatmhz(mq(1,ikl))=Smcatmhz(mq(1,ikl))+dlf**2 Imcmhz(mq(1,ikl))=Imcmhz(mq(1,ikl))+1 endif if(unc(ikl).lt.0.d0)then Smcatcm(mq(1,ikl))=Smcatcm(mq(1,ikl))+dlf**2 Imccm(mq(1,ikl))=Imccm(mq(1,ikl))+1 endif else if(unc(ikl).gt.0.d0)then Sdeltammhz=Sdeltammhz+dlf**2 ideltammhz=ideltammhz+1 endif if(unc(ikl).lt.0.d0)then Sdeltamcm=Sdeltamcm+dlf**2 ideltamcm=ideltamcm+1 endif endif c the blended lines are taken into account only for the rms, wrms and rms's for measurememnt categories if(iflagblend.eq.0)then Sct(icat(ikl))=Sct(icat(ikl))+dlf**2 Incat(icat(ikl))=Incat(icat(ikl))+1 if(unc(ikl).gt.0.d0)then incllinmhz=incllinmhz+1 Smhz=Smhz+dlf**2 endif if(unc(ikl).lt.0.d0)then incllincm=incllincm+1 Scm=Scm+dlf**2 endif Sw=Sw+dlf**2*weight(ikl) c this is for blended lines freqprev=freqm(ikl) frcalcprev=frc(ikl) sintprev=sint dlfprev=dlf icatprev=icat(ikl) weightprev=weight(ikl) endif endif c convert the frequency to MHz c freqm(ikl)=freqm(ikl)*29979.2458D0 c frc=frc*29979.2458D0 c dlf=dlf*29979.2458D0 if(unc(ikl).gt.0.d0)then write(6,1115)pr(isul(2,ikl)),mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl)*29979.2458D0,unc(ikl)*29979.2458D0, ! frc(ikl)*29979.2458D0,aincer(ikl),dlf*29979.2458D0,Elow(ikl),Stren(ikl), ! incl(ikl),comment(ikl) else write(6,1115)pr(isul(2,ikl)),mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl),unc(ikl), ! frc(ikl),aincer(ikl),dlf,Elow(ikl),Stren(ikl), ! incl(ikl),comment(ikl) endif enddo ! end of ikl output experimental data cycle c this is for the last line if it wasd blend then output the result if(iflagblend.ne.0)then c here we save the calculated obs-cal for intensity averaged blended transitions to output by branch istr=1 do while (iflagblend.gt.-1) if(incl(ipfr(ikst-istr)).eq.1)then frlastcal(ipfr(ikst-istr))=freqprev-fraccum/sintaccum iflagblend=iflagblend-1 endif istr=istr+1 enddo if(unc(ikl).gt.0.d0)then write(6,1117)Sintaccum,freqprev*29979.2458D0,fraccum/sintaccum*29979.2458D0,(freqprev-fraccum/sintaccum)*29979.2458D0 else write(6,1117)Sintaccum,freqprev,fraccum/sintaccum,freqprev-fraccum/sintaccum endif Sct(icatprev)=Sct(icatprev)-dlfprev**2+(freqprev-fraccum/sintaccum)**2 c S=S-dlfprev**2+(freqprev-fraccum/sintaccum)**2 if(Scat(icatprev).gt.0.d0)then Smhz=Smhz-dlfprev**2+(freqprev-fraccum/sintaccum)**2 endif if(Scat(icatprev).lt.0.d0)then Scm=Scm-dlfprev**2+(freqprev-fraccum/sintaccum)**2 endif Sw=Sw-dlfprev**2*weightprev+(freqprev-fraccum/sintaccum)**2*weightprev iflagblend=0 fraccum=0.d0 sintaccum=0.d0 endif 1115 format(A2,I3,3I4,4x,A2,I3,3I4,3x,E10.3,F14.4,'(',F7.4,')',F14.4,'(',F6.4,')',F10.4,E12.3,F10.3,I3,1x,A12) c output different rms's Sw=dsqrt(Sw/incllines) write(6,*) write(6,*)'wrms= ',Sw,'n= ',incllines if(incllinmhz.ne.0)then Smhz=dsqrt(Smhz/incllinmhz)*29979.2458D0 write(6,*)'rms_MHz = ',Smhz,'n= ',incllinmhz endif if(incllincm.ne.0)then Scm=dsqrt(Scm/incllincm) write(6,*)'rms_cm-1 = ',Scm,'n= ',incllincm endif do ic=1,Ncat if(Incat(ic).eq.0)cycle Sct(ic)=dsqrt(Sct(ic)/Incat(ic)) if(Scat(ic).gt.0.d0)then write(6,1015)Scat(ic),Sct(ic)*29979.2458D0,Incat(ic) elseif(Scat(ic).lt.0.d0)then write(6,1015)Scat(ic),Sct(ic),Incat(ic) endif enddo write(6,*) 1015 format('rmscat ',F7.4,1x,' =',F12.4,2x,'n=',I5) write(6,*)'rms by symmetry species and by torsional state are calculated without special treatment of blends' write(6,*) write(6,*)'rms by symmetry species' do ic=0,isigma if(Isymcmhz(ic).ne.0)then Symcatmhz(ic)=dsqrt(Symcatmhz(ic)/Isymcmhz(ic)) write(6,1016)pr(ic),Symcatmhz(ic)*29979.2458D0,Isymcmhz(ic) endif if(Isymccm(ic).ne.0)then Symcatcm(ic)=dsqrt(Symcatcm(ic)/Isymccm(ic)) write(6,2016)pr(ic),Symcatcm(ic),Isymccm(ic) endif enddo 1016 format('rmscat_MHz ',A2,1x,' =',F12.4,2x,'n=',I5) 2016 format('rmscat_cm-1 ',A2,1x,' =',F12.4,2x,'n=',I5) write(6,*) write(6,*)'rms by torsional state' do ic=-9,9 if(Imcmhz(ic).ne.0)then Smcatmhz(ic)=dsqrt(Smcatmhz(ic)/Imcmhz(ic)) write(6,1017)ic,Smcatmhz(ic)*29979.2458D0,Imcmhz(ic) endif if(Imccm(ic).ne.0)then Smcatcm(ic)=dsqrt(Smcatcm(ic)/Imccm(ic)) write(6,2017)ic,Smcatcm(ic),Imccm(ic) endif enddo 1017 format('rmscat_MHz m=',I4,1x,' =',F12.4,2x,'n=',I5) 2017 format('rmscat_cm-1 m=',I4,1x,' =',F12.4,2x,'n=',I5) if(ideltammhz.ne.0)then write(6,*)'rms_MHz for intertorsional transitions' Sdeltammhz=dsqrt(Sdeltammhz/ideltammhz) write(6,1018)Sdeltammhz*29979.2458D0,ideltammhz endif if(ideltamcm.ne.0)then write(6,*)'rms_cm-1 for intertorsional transitions' Sdeltamcm=dsqrt(Sdeltamcm/ideltamcm) write(6,2018)Sdeltamcm,ideltamcm endif 1018 format('rms_MHz delta_m',1x,' =',F12.4,2x,'n=',I5) 2018 format('rms_cm-1 delta_m',1x,' =',F12.4,2x,'n=',I5) write(6,*) if(Niter.eq.0)deltap=0.d0 write(6,*)'Parameters in cm-1:' do ikl=1,numpar if(Nfloat(ikl).lt.0.or.Nstage(ikl).eq.0.or.Nfloat(ikl).eq.0)then write(6,1014)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) else write(6,1024)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3),IBpar(ikl,4),IBpar(ikl,5), ! IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),deltap(ikl),Nstage(ikl),Nfloat(ikl) endif enddo c print the parameters truncated and with confidence intervals c this need to be done only if we have more then 1 iteration and therefore calclate confidence intervals if(Niter.ne.0)then write(6,*)'Parameters in cm-1 truncated to fit confidence intervals' do ikl=1,numpar if(Nfloat(ikl).lt.0.or.Nstage(ikl).eq.0.or.Nfloat(ikl).eq.0)then if(Nfloat(ikl).eq.0.and.Nstage(ikl).ne.0)write(6,1022)Bname(ikl),Bval(ikl) else call confint(Bname(ikl),Bval(ikl),deltap(ikl)) endif enddo 1022 format(A10,2x,E26.17,' fixed') endif write(6,*)'Parameters in MHz:' do ikl=1,numpar if(Nfloat(ikl).lt.0.or.Nstage(ikl).eq.0)then write(6,1014)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) elseif(Nfloat(ikl).eq.0.and.Nstage(ikl).ne.0)then write(6,1014)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl)*29979.2458d0,Nstage(ikl),Nfloat(ikl) elseif(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.1.and.IBpar(ikl,3).eq.0.and. ! IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.1.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0.and.ispecFRHO.eq.1)then write(6,1024)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),deltap(ikl),Nstage(ikl),Nfloat(ikl) else write(6,1024)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3),IBpar(ikl,4),IBpar(ikl,5), ! IBpar(ikl,6),IBpar(ikl,7),Bval(ikl)*29979.2458d0,deltap(ikl)*29979.2458d0,Nstage(ikl),Nfloat(ikl) endif enddo 1014 format(A10,2x,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',E26.17,1x,',',11x,','I4,',',I6,',') 1024 format(A10,2x,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',E26.17,1x,',',E10.2,1x,','I4,',',I6,',') c print the parameters truncated and with confidence intervals c this need to be done only if we have more then 1 iteration and therefore calclate confidence intervals if(Niter.ne.0)then write(6,*)'Parameters in MHz truncated to fit confidence intervals' do ikl=1,numpar if(Nfloat(ikl).lt.0.or.Nstage(ikl).eq.0.or.Nfloat(ikl).eq.0)then if(Nfloat(ikl).eq.0.and.Nstage(ikl).ne.0)write(6,1022)Bname(ikl),Bval(ikl)*29979.2458d0 elseif(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.1.and.IBpar(ikl,3).eq.0.and. ! IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.1.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0.and.ispecFRHO.eq.1)then call confint(Bname(ikl),Bval(ikl),deltap(ikl)) else call confint(Bname(ikl),Bval(ikl)*29979.2458d0,deltap(ikl)*29979.2458d0) endif enddo endif c calculate confidence interval for A,B,C and rho call ABCRHOconf() write(6,*) write(6,*)'Output in the original order defined in input file' write(6,1116) do ikl=1,Ndata c output in order originally appeared in inputfile dlf=freqm(ikl)-frc(ikl) Sint=Stren(ikl)*dexp(-1.439d0*(Elow(ikl)-Elowest)/Temp)*(frc(ikl))**2 if(unc(ikl).gt.0.d0)then write(6,1115)pr(isul(2,ikl)),mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl)*29979.2458D0,unc(ikl)*29979.2458D0, ! frc(ikl)*29979.2458D0,aincer(ikl),dlf*29979.2458D0,Elow(ikl),Stren(ikl), ! incl(ikl),comment(ikl) else write(6,1115)pr(isul(2,ikl)),mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl),unc(ikl),frc(ikl),aincer(ikl),dlf,Elow(ikl),Stren(ikl), ! incl(ikl),comment(ikl) endif enddo ! end of ikl output experimental data cycle c calculate and output correlation matrix, svd matrix if(Niter.ne.0)then c svd analysis JOBU='N' JOBVT='A' allocate (Ssvd(nsvd),Usvd(nsvd,nsvd),VTsvd(nsvd,nsvd),Worksvd(5*nsvd),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif call DGESVD(JOBU,JOBVT,nsvd,nsvd,Asvd,Numpar,Ssvd, Usvd, nsvd, VTsvd, nsvd, $ WORKsvd, 5*nsvd, INFO ) write(6,*)' singular values and singular right vectors' icc=nsvd/10 if(icc*10.eq.nsvd)icc=icc-1 do icn=0,icc nppp=10+10*icn if(10+10*icn.gt.nsvd)nppp=nsvd write(6,*) ' ' write(6,313)(Ssvd(ivr),ivr=1+10*icn,nppp) write(6,*) ' ' isv=0 do in=1,numpar if(Nfloat(in).ne.1)cycle isv=isv+1 write(6,3001)isv,Bname(in) c write(6,314)(VTsvd(isv,ivr),ivr=1+10*icn,nppp) write(6,314)(VTsvd(ivr,isv),ivr=1+10*icn,nppp) enddo enddo 313 format(15x,10E11.3) 314 format(1x,10E11.3) deallocate (Asvd,Ssvd,Usvd,VTsvd,Worksvd,STAT=ierr) if(ierr.ne.0)then write(6,*)'error in deallocating',ierr stop endif c correlation matrix int=0 do in=1,numpar if(Nfloat(in).ne.1)cycle int=int+1 ist=0 do is=1,numpar if(Nfloat(is).ne.1)cycle ist=ist+1 Corr(int,ist)=A(int,ist)/dsqrt(dabs(A(int,int)*A(ist,ist))) enddo !END OF parameters cycle is enddo !END OF parameters cycle in write(6,*)' correlation matrix ' icc=int/16 do ic=0,icc write(6,3003) int=0 do in=1,numpar if(Nfloat(in).ne.1)cycle int=int+1 if(int.gt.ic*16)then write(6,3001)int,Bname(in) ist=0 do is=1,in if(Nfloat(is).ne.1)cycle ist=ist+1 if(ist.gt.ic*16.and.ist.le.(ic+1)*16)write(6,3002)Corr(int,ist) enddo !END OF parameters cycle is write(6,3003) endif enddo !END OF parameters cycle in if(ic.lt.icc)then write(6,3004)(ikl,ikl=ic*16+1,ic*16+16) else write(6,3004)(ikl,ikl=ic*16+1,int) endif enddo write(6,*)' covariation matrix ' icc=int/16 do ic=0,icc write(6,3003) int=0 do in=1,numpar if(Nfloat(in).ne.1)cycle int=int+1 if(int.gt.ic*16)then write(6,3001)int,Bname(in) ist=0 do is=1,in if(Nfloat(is).ne.1)cycle ist=ist+1 if(ist.gt.ic*16.and.ist.le.(ic+1)*16)write(6,4002)A(int,ist) enddo !END OF parameters cycle is write(6,3003) endif enddo !END OF parameters cycle in if(ic.lt.icc)then write(6,4004)(ikl,ikl=ic*16+1,ic*16+16) else write(6,4004)(ikl,ikl=ic*16+1,int) endif enddo 3001 format(I4,1x,A10,$) 3002 format(1x,F6.3,$) 4002 format(1x,E10.3,$) 3003 format(/) 3004 format(15x,16I7) 4004 format(15x,16I11) endif c save ip in ipfr for prediction if(ipred.ne.0)then ipfr=ip endif c output sorted by branch write(6,*) write(6,*)'Transitions sorted by branch' write(6,*) write(6,1116) ndata1=ndata ip=0 do ikl=1,Ndata ip(ikl)=ikl kbranch(ikl)=mq(1,ikl)*10000+mq(2,ikl)*500000+Ka(1,ikl)*10 enddo c sort the Jlev array c CALL SVIGP (Ndata,kbranch,kbranch,ip) call VSRTR (kbranch,ndata,ip) do ikl=1,Ndata kbranch(ikl)=ip(ikl) ip(ikl)=ikl enddo do while (ndata1.gt.0) iser=0 do iknl=1,Ndata c this we are doing to have the branches sorted by m and Ka values (for each m the Ka series given in order of increasing Ka) ikl=kbranch(iknl) c if(ip(ikl).eq.0) then this transitionalready belong to another series if(ip(ikl).eq.0)cycle if(iser.eq.0)then c a new series should be set up ip(ikl)=0 Ndata1=Ndata1-1 iser=iser+1 ibranch(iser)=ikl js(iser)=Jq(1,ikl) c parameters of the series Jkakc1=Jq(1,ikl)-Ka(1,ikl)-Kc(1,ikl) Jkakc2=Jq(2,ikl)-Ka(2,ikl)-Kc(2,ikl) jdel=Jq(2,ikl)-Jq(1,ikl) mup=mq(2,ikl) mlow=mq(1,ikl) Kaup=Ka(2,ikl) Kalow=Ka(1,ikl) elseif(iser.ne.0)then c check whether this transition belong to considered series if(Jkakc1.ne.Jq(1,ikl)-Ka(1,ikl)-Kc(1,ikl))cycle if(Jkakc2.ne.Jq(2,ikl)-Ka(2,ikl)-Kc(2,ikl))cycle if(jdel.ne.Jq(2,ikl)-Jq(1,ikl))cycle if(mup.ne.mq(2,ikl).or.mlow.ne.mq(1,ikl))cycle if(Kaup.ne.Ka(2,ikl).or.Kalow.ne.Ka(1,ikl))cycle c this transitoj belong to current branch ip(ikl)=0 Ndata1=Ndata1-1 iser=iser+1 ibranch(iser)=ikl js(iser)=Jq(1,ikl) endif enddo ! end of ikl c the series is picked up, sort by J c CALL SVIBP (iser,JS,JS,ibranch) call VSRTP (JS,iser,ibranch) c output the series do ikt=1,iser ikl=ibranch(ikt) dlf=freqm(ikl)-frc(ikl) Sint=Stren(ikl)*dexp(-1.439d0*(Elow(ikl)-Elowest)/Temp)*(frc(ikl))**2 if(unc(ikl).gt.0.d0)then write(6,3115)pr(isul(2,ikl)),parup(ikl),mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)),parlow(ikl), ! mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl)*29979.2458D0,unc(ikl)*29979.2458D0, ! frc(ikl)*29979.2458D0,aincer(ikl),dlf*29979.2458D0, ! Elow(ikl),Stren(ikl),incl(ikl),comment(ikl) else write(6,3115)pr(isul(2,ikl)),parup(ikl),mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)),parlow(ikl), ! mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl),unc(ikl),frc(ikl),aincer(ikl),dlf, ! Elow(ikl),Stren(ikl),incl(ikl),comment(ikl) endif if(iblsign(ikl).eq.1)then c we will output only blended lines which are included if(unc(ikl).gt.0.d0)then write(6,3116)blsign(iblsign(ikl)),frlastcal(ikl)*29979.2458D0 else write(6,3116)blsign(iblsign(ikl)),frlastcal(ikl) endif write(6,3117) else write(6,3117) endif enddo ! end of iknl c separate the series from each other write(6,*) enddo 3115 format(A2,F6.2,I3,3I4,4x,A2,F6.2,I3,3I4,3x,E10.3,F14.4,'(',F7.4,')',F14.4,'(',F6.4,')',F10.4,E12.3,F10.3,I3,1x,A12,$) 3116 format(\A1,1x,F10.4,$) 3117 format(\,/) deallocate (Aincer,Corr,Stren, frc, Elow, Eup,STAT=ierr) deallocate (isul,JS,ibranch,Kbranch,iblsign,STAT=ierr) return end subroutine ABCRHOconf() use param use calc real*8 confABC,ABC character*10 Bnam c intialization to zero in case one of the parameters will be fixed iklBmC=0 intBmc=0 iklBpC=0 intBpc=0 iklAmBpC=0 intAmBpc=0 intF=0 intRHO=0 int=0 do ikl=1,numpar if(Nfloat(ikl).eq.1)int=int+1 if(ikl.eq.iklF.and.Nfloat(ikl).eq.1)intF=int if(ikl.eq.iklRHO.and.Nfloat(ikl).eq.1)intRHO=int c save AmBpC number if(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.2.and.IBpar(ikl,3).eq.0. !and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0.and.Nfloat(ikl).ge.0)then c this should be not a composite parameter to avoid confusion with AK6 terms if(ikl.lt.numpar)then if(Nfloat(ikl+1).ge.0)then iklAmBpC=ikl if(Nfloat(ikl).eq.1)intAmBpc=int endif else c if it is the last parameter then it is single iklAmBpC=ikl if(Nfloat(ikl).eq.1)intAmBpc=int endif endif c save BpC number if(IBpar(ikl,1).eq.1.and.IBpar(ikl,2).eq.0.and.IBpar(ikl,3).eq.0. !and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0.and.Nfloat(ikl).ge.0)then c this should be not a composite parameter to avoid confusion with AK6 terms if(ikl.lt.numpar)then if(Nfloat(ikl+1).ge.0)then iklBpC=ikl if(Nfloat(ikl).eq.1)intBpc=int endif else c if it is the last parameter then it is single iklBpC=ikl if(Nfloat(ikl).eq.1)intBpc=int endif endif c save BmC number if(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.0.and.IBpar(ikl,3).eq.2. !and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0.and.Nfloat(ikl).ge.0)then c this should be a composite parameter if(ikl.lt.numpar)then if(Nfloat(ikl+1).eq.-1.and.IBpar(ikl+1,1).eq.0.and.IBpar(ikl+1,2).eq.0.and.IBpar(ikl+1,3).eq.0. !and.IBpar(ikl+1,4).eq.2.and.IBpar(ikl+1,5).eq.0.and.IBpar(ikl+1,6).eq.0.and.IBpar(ikl+1,7).eq.0. !and.Bval(ikl+1).eq.-1.d0)then if(ikl+1.lt.numpar)then if(Nfloat(ikl+2).ge.0)then iklBmC=ikl if(Nfloat(ikl).eq.1)intBmc=int endif endif endif endif endif enddo c if we fit A,B,C and not A-0.5(B+C) then return if(iklAmBpC.eq.0.or.iklBpC.eq.0.or.iklBmC.eq.0)return write(6,*) write(6,*)'A,B,C recalculated from A-0.5(B+C), 0.5(B+C), 0.5(B-C)' c Aeff or A depending on ispecFRHO confABC=0.d0 ABC=Bval(iklAmBpC)+Bval(iklBpC) if(intAmBpC.ne.0)confABC=confABC+A(intAmBpC,intAmBpC) if(intBpC.ne.0)confABC=confABC+A(intBpC,intBpC) if(intAmBpC.ne.0.and.intBpC.ne.0)confABC=confABC+2.d0*A(intAmBpC,intBpC) confABC=dsqrt(confABC) if(ispecFRHO.eq.0)then Bnam='Aeff_RAM ' else Bnam='A_RAM ' endif write(6,*) write(6,*)'in cm-1' call confint(Bnam,ABC,confABC) write(6,*) write(6,*)'in MHz' call confint(Bnam,ABC*29979.2458D0,confABC*29979.2458D0) c B confABC=0.d0 ABC=Bval(iklBpC)+Bval(iklBmC) if(intBpC.ne.0)confABC=confABC+A(intBpC,intBpC) if(intBmC.ne.0)confABC=confABC+A(intBmC,intBmC) if(intBpC.ne.0.and.intBmC.ne.0)confABC=confABC+2.d0*A(intBpC,intBmC) confABC=dsqrt(confABC) Bnam='B_RAM ' write(6,*) write(6,*)'in cm-1' call confint(Bnam,ABC,confABC) write(6,*) write(6,*)'in MHz' call confint(Bnam,ABC*29979.2458D0,confABC*29979.2458D0) c C confABC=0.d0 ABC=Bval(iklBpC)-Bval(iklBmC) if(intBpC.ne.0)confABC=confABC+A(intBpC,intBpC) if(intBmC.ne.0)confABC=confABC+A(intBmC,intBmC) if(intBpC.ne.0.and.intBmC.ne.0)confABC=confABC-2.d0*A(intBpC,intBmC) confABC=dsqrt(confABC) Bnam='C_RAM ' write(6,*) write(6,*)'in cm-1' call confint(Bnam,ABC,confABC) write(6,*) write(6,*)'in MHz' call confint(Bnam,ABC*29979.2458D0,confABC*29979.2458D0) c RHO if ispecRHO.eq.0 if(ispecFRHO.eq.0)then confABC=0.d0 ABC=-1.d0*Bval(iklRHO)/2.d0/Bval(iklF) if(intRHO.ne.0)confABC=confABC+A(intRHO,intRHO)/4.d0/Bval(iklF)**2 if(intF.ne.0)confABC=confABC+A(intF,intF)*Bval(iklRHO)**2/4.d0/Bval(iklF)**4 if(intF.ne.0.and.intRHO.ne.0)confABC=confABC-2.d0*A(intF,intRHO)*Bval(iklRHO)/4.d0/Bval(iklF)**3 confABC=dsqrt(confABC) Bnam='RHO ' write(6,*) call confint(Bnam,ABC,confABC) endif return end subroutine confint(Bnam,Bv,delp) real*8 bpow,bpowtest, Bv,delp character*10 Bnam idpower=idint(dlog10(dabs(Bv))) bpow=1.d0 do ikd=1,iabs(idpower) bpow=bpow*10.d0 enddo if(idpower.lt.0)then bpowtest=dabs(Bv)*bpow else bpowtest=dabs(Bv)/bpow endif if(bpowtest.ge.1.d0)idpower=idpower+1 idpowconf=idint(dlog10(dabs(delp))) bpow=1.d0 do ikd=1,iabs(idpowconf) bpow=bpow*10.d0 enddo if(idpowconf.lt.0)then bpowtest=dabs(delp)*bpow else bpowtest=dabs(delp)/bpow endif if(bpowtest.ge.1.d0)idpowconf=idpowconf+1 c we have powers for the value and confidental interval inumdigits=idpower-idpowconf+2 if(inumdigits.le.0)then write(6,1024)Bnam,Bv,delp return endif 1024 format(A10,2x,E26.14,E10.3,' confidence interval undetermined') bpow=1.d0 do ikd=1,iabs(idpowconf) bpow=bpow*10.d0 enddo if(idpowconf.lt.0)then bpowtest=dabs(delp)*bpow*100.d0 else bpowtest=dabs(delp)/bpow*100.d0 endif if(idnint(bpowtest).eq.100)then inumdigits=inumdigits-1 bpowtest=bpowtest/10.d0 endif write(6,1023)Bnam,Bv,idnint(bpowtest),idpower 1023 format(A10,2x,E26.,TL4,'(',I2,')',' * 10**',I3) return end subroutine parity(J,num) use calc real*8 overlap,par,der1 c setup the Hamiltonian matrix for the first diagonalization step NDIMR=(2*J+1)*nvt do isigr=0,isigma if(isigma.eq.1.and.isigr.eq.isigma)then c for degenerate parity equals 0.d0 do itl=1,ndimr parAB(itl,isigr,num)=0.d0 enddo cycle endif if(isigma.eq.3)then if(isigr.eq.1.or.isigr.eq.2)then c for degenerate parity equals 0.d0 do itl=1,ndimr parAB(itl,isigr,num)=0.d0 enddo cycle endif endif c initialization of the matrice H=0.d0 if(mod(j,2).eq.0)then jminus=1 else jminus=-1 endif do K=-J,J if(mod(K,2).eq.0)then kminus=1 else kminus=-1 endif c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 isigt=isigr if(isigma.eq.3.and.mod(K,2).ne.0)then isigt=abs(isigr-3) endif do ivt=1,nvt c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=(2*J+1)*idelvt-J-K ndelt=idelvt+(J-K)*nvt c we fill only upper triangle if(ndelt.lt.n)cycle if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 if(isigt.eq.0)then c this is for A type torsional overlaps isumpl=-ikt+ktronc+1 else c this is for B type torsional overlaps isumpl=-ikt+ktronc endif if(isumpl.le.Ndimto.and.isumpl.ge.1)overlap=overlap+EVCTOR(isum,ivt,isigt,-K)*EVCTOR(isumpl,idelvt,isigt,K) enddo !from overlap integral calculation c all other parameters H(ndelt,n)=overlap*kminus*jminus enddo !from idelvt cycle enddo !from K cycle enddo !from ivt cycle c here we restore the full matrix do in=2,NDIMR do it=1,in-1 H(it,in)=H(in,it) enddo enddo do itl=1,ndimr par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,itl,isigr,num) enddo par=par+der1*EVCrottor(in,itl,isigr,num) enddo parAB(itl,isigr,num)=par enddo !enddo itl cycle enddo !end of sigma cycle return end c calculation of intensity when several dipole moment components may be nonzero subroutine Vintensity(Jq1,Jq2,num1,num2,isigup,isiglow,itupn,itlown,Strength) use vint use param use calc use expdat real*8 FK(-1:1),pj1,Strength,der1,pk,overlap c check general symmetry requirement A<->A, B<->B, E1<->E1,E2<->E2 if(isigup.ne.isiglow)then Strength=-1.d0 return endif Strength=0.d0 c This is to speed up the process of calculation of intensities c if the jq1,jq2 etc. are not changed from previous call of the subroutine then c the matrix in H should be ok so we need just to multiply it by new eigen vectors if(jv1.eq.Jq1.and.jv2.eq.Jq2.and.isigvup.eq.isigup.and.isigvlow.eq.isiglow)then Jn=Jnv NDIMR=(2*Jn+1)*nvt goto 10 endif c we save here for skipping calculation of matrix for the same type of transition jv1=Jq1 jv2=Jq2 isigvup=isigup isigvlow=isiglow pj1=dfloat(Jq1) if(Jq2.eq.Jq1)then Jn=Jq1 c ||**2 if(Jq1.ne.0)then FJ2=0.0625d0/pj1**2/(pj1+1.d0)**2 else FJ2=0.d0 endif c Summ||**2 FM2=4.d0/3.d0*pj1*(pj1+1.d0)*(2.d0*pj1+1.d0) elseif(Jq2.gt.Jq1)then Jn=Jq2 c ||**2 FJ2=0.0625d0/(pj1+1.d0)**2/(2.d0*pj1+1.d0)/(2.d0*pj1+3.d0) c Summ||**2 FM2=4.d0*(2.d0*pj1+1.d0)*(pj1+1.d0)**2-4.d0/3.d0*pj1*(pj1+1.d0)*(2.d0*pj1+1.d0) elseif(Jq2.lt.Jq1)then Jn=Jq1 c ||**2 if(Jq1.ne.0)then FJ2=0.0625d0/pj1**2/(4.d0*pj1**2-1.d0) else FJ2=0.d0 endif c Summ||**2 FM2=4.d0*(2*pj1+1)*pj1**2-4.d0/3.d0*pj1*(pj1+1.d0)*(2.d0*pj1+1.d0) endif Strength=0.d0 c setup the matrix NDIMR=(2*Jn+1)*nvt H=0.d0 do is=1,numpar c consider only parameters that represent dipole moment components if(Nstage(is).ne.0)cycle ishm1=3*(IBpar(is,6)+IBpar(is,7)) ishm=ishm1/idelm ishpl=ishm ishmi=-ishm if(isigma.eq.3)then if(mod(IBpar(is,6),2).ne.0.or.mod(IBpar(is,7),2).ne.0)then ishm=(ishm1-3)/idelm c Nonzero only IBpar(ikl,6) or only IBpar(ikl,7) not both together c also we substract 3 in 3*(IBpar(ikl,6)+IBpar(ikl,7))-3)/idelm in order not to deal with remainings c when IBpar(ikl,6) or IBpar(ikl,7) is odd if(isigt.eq.0.or.isigt.eq.-1.or.isigt.eq.-2)then ishpl=ishm ishmi=-1-ishm endif if(isigt.eq.3.or.isigt.eq.1.or.isigt.eq.2)then ishpl=+1+ishm ishmi=-ishm endif endif endif do K=-Jq1,Jq1 pK=dfloat(K) c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 c isigt defined by the lower state isigt=isiglow if(isigma.eq.3.and.mod(K,2).ne.0)then isigt=abs(isiglow-3) if(isiglow.eq.1.or.isiglow.eq.2)isigt=-isigt endif FK=0.d0 c muz component if(IBpar(is,2).eq.1)then ideltaK=0 if(Jq2.eq.Jq1)then FK(0)=2.d0*pk elseif(Jq2.gt.Jq1)then FK(0)=2.d0*dsqrt((pj1+1.d0)**2-pk**2) elseif(Jq2.lt.Jq1)then FK(0)=2.d0*dsqrt(pj1**2-pk**2) endif endif c mux component if(IBpar(is,3).eq.1)then ideltaK=1 if(Jq2.eq.Jq1)then FK(1)=dsqrt((pj1-pk)*(pj1+pk+1.d0)) FK(-1)=dsqrt((pj1+pk)*(pj1-pk+1.d0)) elseif(Jq2.gt.Jq1)then FK(1)=-dsqrt((pj1+pk+1.d0)*(pj1+pk+2.d0)) FK(-1)=dsqrt((pj1-pk+1.d0)*(pj1-pk+2.d0)) elseif(Jq2.lt.Jq1)then FK(1)=dsqrt((pj1-pk)*(pj1-pk-1.d0)) FK(-1)=-dsqrt((pj1+pk)*(pj1+pk-1.d0)) endif endif c muy component if(IBpar(is,4).eq.1)then ideltaK=1 c we do not put imaginary unit here because muy can appear only with sin therefore i will cancel if(Jq2.eq.Jq1)then FK(1)=-dsqrt((pj1-pk)*(pj1+pk+1.d0)) FK(-1)=dsqrt((pj1+pk)*(pj1-pk+1.d0)) elseif(Jq2.gt.Jq1)then FK(1)=dsqrt((pj1+pk+1.d0)*(pj1+pk+2.d0)) FK(-1)=dsqrt((pj1-pk+1.d0)*(pj1-pk+2.d0)) elseif(Jq2.lt.Jq1)then FK(1)=-dsqrt((pj1-pk)*(pj1-pk-1.d0)) FK(-1)=-dsqrt((pj1+pk)*(pj1+pk-1.d0)) endif endif if(ideltaK.eq.0.and.IBpar(is,6)+IBpar(is,7).eq.0)then c there is no overlaps do ivt=1,nvt c n=(ivt-1)*(2*Jn+1)+K+Jn+1 n=ivt+(K+Jn)*nvt c for deltaK=0 overlap=1.d0 if there are no cos or sin terms H(n,n)=H(n,n)+Bval(is)*FK(ideltaK) enddo else c we have overlaps do ivt=1,nvt c n=(ivt-1)*(2*Jn+1)+K+Jn+1 n=ivt+(K+Jn)*nvt c cycle over deltaK values do kdelt=-ideltaK,ideltaK,2 if(K+kdelt.lt.-Jn.or.K+kdelt.gt.Jn)cycle c isigt1 is determined by the upper state of the transition isigt1=isigup if(mod(K+kdelt,2).ne.0.and.isigma.eq.3)then isigt1=abs(isigup-3) if(isigup.eq.1.or.isigup.eq.2)isigt1=-isigt1 endif c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=n+kdelt+(2*Jn+1)*(idelvt-ivt) ndelt=n+kdelt*nvt+(idelvt-ivt) if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 c if we have cos3alfa or sin3alfa then we should take EVCTOR from different isigt for V6 c for V3 isigt1 always eq isigt do ikt=-ktronc,ktronc isum=ikt+ktronc+1 isumpl=isum+ishpl isummi=isum+ishmi if(isumpl.le.Ndimto)overlap=overlap+ ! EVCTOR(isum,ivt,isigt,K)*EVCTOR(isumpl,idelvt,isigt1,K+kdelt) if(IBpar(is,7).eq.0)then if(isummi.ge.1)overlap=overlap+ ! EVCTOR(isum,ivt,isigt,K)*EVCTOR(isummi,idelvt,isigt1,K+kdelt) else c if sin term is present its imaginary unit is cancelled with imaginary unit from deltaK=+/-1 matrix elememnts for muy if(isummi.ge.1)overlap=overlap- ! EVCTOR(isum,ivt,isigt,K)*EVCTOR(isummi,idelvt,isigt1,K+kdelt) endif enddo !from overlap integral calculation c if(Jq2.ge.Jq1)then c H(n,ndelt)=H(n,ndelt)+0.5d0*overlap*Bval(is)*FK(kdelt) c elseif(Jq2.lt.Jq1)then c H(ndelt,n)=H(ndelt,n)+0.5d0*overlap*Bval(is)*FK(kdelt) c endif c here we inverted filling the matrix H in order to optimize multiplication of H by eigenvector c taking into account that most efficient way when the first index is changed most rapidly if(Jq2.ge.Jq1)then H(ndelt,n)=H(ndelt,n)+0.5d0*overlap*Bval(is)*FK(kdelt) elseif(Jq2.lt.Jq1)then H(n,ndelt)=H(n,ndelt)+0.5d0*overlap*Bval(is)*FK(kdelt) endif enddo !from idelvt cycle enddo !from Kdelt cycle enddo !end of ivt cycle endif !end from ideltaK=0 check enddo !end of K cycle enddo !end of parameter cycle c now we have a matrix with matrix elements of dipole moment components with direction cosines c now we can calculate expectation value which will be equal to desired dipole moment matrix element c we save Jn for skipping calculation of matrix for the same type of transition Jnv=Jn 10 if(Jq1.eq.Jq2)then c Q-type transitions Jq1=Jq2=Jn do n1=1,ndimr der1=0.d0 do n2=max(1,n1-kdstrength),min(n1+kdstrength,NDIMR) c der1=der1+H(n1,n2)*EVCrottor(n2,itlown,isiglow,num1) der1=der1+H(n2,n1)*EVCrottor(n2,itlown,isiglow,num1) enddo Strength=Strength+der1*EVCrottor(n1,itupn,isigup,num2) enddo elseif(Jq1.gt.Jq2)then n2=0 do K1=-Jq2,Jq2 n2n=(K1+Jn)*nvt do ivt1=1,nvt c n2=(ivt1-1)*(2*Jq2+1)+K1+Jq2+1 n2=n2+1 c n2n=(ivt1-1)*(2*Jn+1)+K1+Jn+1 n2n=n2n+1 der1=0.d0 do n1=max(1,n2n-kdstrength),min(n2n+kdstrength,NDIMR) c der1=der1+H(n2n,n1)*EVCrottor(n1,itlown,isiglow,num1) der1=der1+H(n1,n2n)*EVCrottor(n1,itlown,isiglow,num1) enddo c n1=0 c do K=-Jn,Jn c do ivt=1,nvt c n1=(ivt-1)*(2*Jn+1)+K+Jn+1 c n1=n1+1 c der1=der1+H(n2n,n1)*EVCrottor(n1,itlown,isiglow,num1) c enddo c enddo Strength=Strength+der1*EVCrottor(n2,itupn,isigup,num2) enddo enddo elseif(Jq1.lt.Jq2)then n1=0 do K1=-Jq1,Jq1 n1n=(K1+Jn)*nvt do ivt1=1,nvt c n1=(ivt1-1)*(2*Jq1+1)+K1+Jq1+1 n1=n1+1 c n1n=(ivt1-1)*(2*Jn+1)+K1+Jn+1 n1n=n1n+1 der1=0.d0 do n2=max(1,n1n-kdstrength),min(n1n+kdstrength,NDIMR) c der1=der1+H(n1n,n2)*EVCrottor(n2,itupn,isigup,num2) der1=der1+H(n2,n1n)*EVCrottor(n2,itupn,isigup,num2) enddo c n2=0 c do K=-Jn,Jn c do ivt=1,nvt c n2=(ivt-1)*(2*Jn+1)+K+Jn+1 c n2=n2+1 c der1=der1+H(n1n,n2)*EVCrottor(n2,itupn,isigup,num2) c enddo c enddo Strength=Strength+der1*EVCrottor(n1,itlown,isiglow,num1) enddo enddo endif Strength=3.d0*FJ2*FM2*Strength**2 if(isigma.eq.3)then Strength=Strength*dfloat(istweight(isiglow)) c if(isiglow.eq.0.or.isiglow.eq.2)Strength=Strength*5.d0 !Statistical weight for toluene c if(isiglow.eq.1.or.isiglow.eq.3)Strength=Strength*3.d0 !Statistical weight for toluene endif return end c This subroutine provides iteration of the fitting process subroutine fitting(itn) c USE MSIMSL use param use vint use calc use expdat use predict use svd integer itup,itlow,illow,ilup,ivtup,ivtlow,isiglow,isigup,itn,ipiv(numpar),inclfitl real*8 dlf,delp(numpar),frc,Scm,Smhz,Sw,Sct(Ncat),R,RJTH,Sint real*8 B(numpar),derp(numpar),frcalcbl,sintcalcbl,Strength,dcquadr,work(numpar) c initialization of vint to avoid occasional coincidence at first entrance to Vintensity inclfitl=0 inclfitcm=0 inclfitmhz=0 jv1=-1 jv2=-1 isigvup=-1 isigvlow=-1 A=0.d0 B=0.d0 dcquadr=29979.2458d0**2 deltap=0.d0 ijlines=0 Sct=0.d0 INcat=0 Scm=0.d0 Smhz=0.d0 Sw=0.d0 drvacc=0.d0 fracc=0.d0 sintacc=0.d0 c initial calculation for J=0 J=0 num=mod(J,3) NDIMR=(2*J+1)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif call rotation(J,itn,num) c call parity(J,num) if(isigma.eq.1)then call labelingV3(J,itn,num) elseif(isigma.eq.3)then call labelingV6(J,itn,num) endif c calculate derivatives for fitted parameters and fitted levels call derivative(J,num) deallocate (H,EGVL,EGVC) c compose the matrix of least squares process do J=0,Jmax c second stage calculation for particular J if(J.ne.Jmax)then if(Jbound(J+1,1).ne.0)then num=mod(J+1,3) NDIMR=(2*J+3)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif call rotation(J+1,itn,num) c call parity(J+1,num) if(isigma.eq.1)then call labelingV3(J+1,itn,num) elseif(isigma.eq.3)then call labelingV6(J+1,itn,num) endif c calculate derivatives for fitted parameters and fitted levels call derivative(J+1,num) c deallocate (H,EGVL,EGVC) elseif(Jbound(J+1,1).eq.0)then c this for blends we need H for intensity calculation NDIMR=(2*J+3)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif endif elseif(J.eq.Jmax)then c this for blends we need H for intensity calculation NDIMR=(2*J+3)*nvt allocate (H(ndimr,ndimr),EGVL(ndimr),EGVC(ndimr,ndimr),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif endif if(Jbnd(J,1).eq.0.or.Jbound(J,1).eq.0)then deallocate (H,EGVL,EGVC) cycle endif c if(Jbound(J,1).eq.0)cycle iflagbl=0 frcalcbl=0.d0 sintcalcbl=0.d0 do ij1=Jbnd(J,1),Jbnd(J,2) ikl=ip(ij1) c write(6,*)'J=',J,freqm(ikl)*29979.2458d0,incl(ikl) c if(freqm(ikl)*29979.2458d0.eq.8566.7622d0)then c continue c endif c consider only included lines if(incl(ikl).ne.1)cycle c now find the levels in the list that correspond to this transitions itup=Ka(2,ikl)-Kc(2,ikl)+Jq(2,ikl)+1 itlow=Ka(1,ikl)-Kc(1,ikl)+Jq(1,ikl)+1 c here we determine what array section to take for particular J num1=mod(Jq(1,ikl),3) num2=mod(Jq(2,ikl),3) c upper level isigup=abs(mod(idelm*nvt+mq(2,ikl),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivtup=0 if(mq(2,ikl).eq.isigup)ivtup=0 if(mq(2,ikl).eq.isigup-idelm)ivtup=1 if(mq(2,ikl).eq.isigup+idelm)ivtup=2 itupn=nv012(isigup,Jq(2,ikl),ivtup,itup) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itupn.lt.0)then isigup=abs(isigup-3) itupn=abs(itupn) endif c lower level isiglow=abs(mod(idelm*nvt+mq(1,ikl),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivtlow=0 if(mq(1,ikl).eq.isiglow)ivtlow=0 if(mq(1,ikl).eq.isiglow-idelm)ivtlow=1 if(mq(1,ikl).eq.isiglow+idelm)ivtlow=2 itlown=nv012(isiglow,Jq(1,ikl),ivtlow,itlow) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itlown.lt.0)then isiglow=abs(isiglow-3) itlown=abs(itlown) endif c now we determine what level we need from the level list ilup=0 illow=0 if(Jq(1,ikl).lt.Jq(2,ikl))then jn1=Jbound(Jq(1,ikl),1) jn2=Jbound(Jq(2,ikl),2) else jn1=Jbound(Jq(2,ikl),1) jn2=Jbound(Jq(1,ikl),2) endif do i=jn1,jn2 c upper level if(mq(2,ikl).eq.mlev(i).and.Jq(2,ikl).eq.Jlev(i).and.itup.eq.itlev(i))then ilup=i if(illow.ne.0)exit endif c lower level if(mq(1,ikl).eq.mlev(i).and.Jq(1,ikl).eq.Jlev(i).and.itlow.eq.itlev(i))then illow=i if(ilup.ne.0)exit endif enddo !end of nlev cycle if(ilup.eq.0.or.illow.eq.0)write(6,*)'error of finding derivatives',freqm(ikl) ilup=ilup-Jbound(Jlev(ilup),1)+1 illow=illow-Jbound(Jlev(illow),1)+1 c if there were severe problems with labeling then we probably will not be able to get itup or itlow c if(itupn.eq.0.or.itupn.gt.ndim.or.itlown.eq.0.or.itlown.gt.ndim)then if(itupn.eq.0.or.itupn.gt.ndim.or.itlown.eq.0.or.itlown.gt.ndim.or.isigup.ne.isiglow)then write(6,*)'the following line had severe problems with labeling it will be omitted from calculation' write(6,1114)mq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),mq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),freqm(ikl), ! incl(ikl),unc(ikl),comment(ikl) c we should check whether it is the last transition in the blend and if so nullify the iflagbl in order not c to interfere with the next blend if(iflagbl.ne.0)then if(freqm(ikl).eq.freqm(ip(ij1-1)).and.freqm(ikl).ne.freqm(ip(ij1+1)))then if(sintcalcbl.eq.0.d0)then frcalcbl=0.d0 sintcalcbl=0.d0 delp=0.d0 iflagbl=0 cycle !this to avoid probelms if the o-c for all components is larger than allowed endif frc=frcalcbl/sintcalcbl dlf=freqm(ikl)-frc do in=1,numpar derp(in)=delp(in)/sintcalcbl enddo frcalcbl=0.d0 sintcalcbl=0.d0 delp=0.d0 iflagbl=0 goto 15 endif !if(freqm(ikl).eq.freqm(ip(ij1-1)).and.freqm(ikl).ne.freqm(ip(ij1+1)))then endif !if(iflagbl.ne.0)then cycle endif 1114 format(I2,3I4,4x,I2,3I4,3x,F14.4,I3,F8.4,1x,A12) c now we have ordinal numbers of the upper an lower levels of the transition we can build the matrix frc=Erottor(itupn,isigup,num2)-Erottor(itlown,isiglow,num1) dlf=freqm(ikl)-frc c this is to monitor the obs-calc changes at the last iteration frlastcal(ikl)=frc if(Nrobust.ne.1)then c for labeling probelms if the labeling changes in the process of fitting c and we do not use robust fitting then simply omit the line c if(dabs(dlf).gt.ocmax)then if(dabs(dlf/unc(ikl)).gt.ocmax)then c we should check whether it is the last transition in the blend and if so nullify the iflagbl in order not c to interfere with the next blend if(iflagbl.ne.0)then if(freqm(ikl).eq.freqm(ip(ij1-1)).and.freqm(ikl).ne.freqm(ip(ij1+1)))then if(sintcalcbl.eq.0.d0)then frcalcbl=0.d0 sintcalcbl=0.d0 delp=0.d0 iflagbl=0 cycle !this to avoid probelms if the o-c for all components is larger than allowed endif frc=frcalcbl/sintcalcbl dlf=freqm(ikl)-frc do in=1,numpar derp(in)=delp(in)/sintcalcbl enddo frcalcbl=0.d0 sintcalcbl=0.d0 delp=0.d0 iflagbl=0 goto 15 endif !if(freqm(ikl).eq.freqm(ip(ij1-1)).and.freqm(ikl).ne.freqm(ip(ij1+1)))then endif !if(iflagbl.ne.0)then cycle endif !if(dabs(dlf).gt.ocmax)then endif !if(Nrobust.ne.1)then do in=1,numpar derp(in)=(drv(in,ilup,num2)-drv(in,illow,num1)) enddo c check whether this is a blend within different J if(ipbl(ikl).ne.0)then call Vintensity(Jq(1,ikl),Jq(2,ikl),num1,num2,isigup,isiglow,itupn,itlown,Strength) Sint=Strength*dexp(-1.439d0*(Erottor(itlown,isiglow,num1)-Elowest)/Temp)*(frc/29979.2458d0)**2 fracc(ipbl(ikl))=fracc(ipbl(ikl))+frc*Sint sintacc(ipbl(ikl))=sintacc(ipbl(ikl))+Sint do in=1,numpar drvacc(in,ipbl(ikl))=drvacc(in,ipbl(ikl))+derp(in)*Sint enddo if(frblend(ipbl(ikl)).ne.freqm(ikl))then write(6,*)frblend(ipbl(ikl)),freqm(ikl),'error in procerssing blends with different J' stop endif cycle endif c now we start analysis of blends within the same J; this can be analysed without additional storage. if(ij1.lt.Jbnd(J,2))then !comparison in the bounds of corresponding J if(freqm(ikl).eq.freqm(ip(ij1+1)))then !we have blended line call Vintensity(Jq(1,ikl),Jq(2,ikl),num1,num2,isigup,isiglow,itupn,itlown,Strength) Sint=Strength*dexp(-1.439d0*(Erottor(itlown,isiglow,num1)-Elowest)/Temp)*(frc/29979.2458d0)**2 if(iflagbl.eq.0)then frcalcbl=frc*Sint sintcalcbl=Sint do in=1,numpar delp(in)=derp(in)*Sint enddo iflagbl=1 cycle else frcalcbl=frcalcbl+frc*Sint sintcalcbl=sintcalcbl+Sint do in=1,numpar delp(in)=delp(in)+derp(in)*Sint enddo iflagbl=iflagbl+1 cycle endif endif endif if(iflagbl.ne.0)then !if iflagbl.ne.0 then it is the last component if(freqm(ikl).eq.freqm(ip(ij1-1)))then !we have blended line call Vintensity(Jq(1,ikl),Jq(2,ikl),num1,num2,isigup,isiglow,itupn,itlown,Strength) Sint=Strength*dexp(-1.439d0*(Erottor(itlown,isiglow,num1)-Elowest)/Temp)*(frc/29979.2458d0)**2 frcalcbl=frcalcbl+frc*Sint sintcalcbl=sintcalcbl+Sint do in=1,numpar delp(in)=delp(in)+derp(in)*Sint enddo c now we calculate weighted value of frequency and derivatives if(sintcalcbl.eq.0.d0)then frcalcbl=0.d0 sintcalcbl=0.d0 delp=0.d0 iflagbl=0 cycle !this to avoid probelms if for the o-c for all components is larger than allowed endif frc=frcalcbl/sintcalcbl dlf=freqm(ikl)-frc do in=1,numpar derp(in)=delp(in)/sintcalcbl enddo frcalcbl=0.d0 sintcalcbl=0.d0 delp=0.d0 iflagbl=0 else write(6,*)'error in blends analysis with equal J',freqm(ikl)*29979.2458d0 endif !if(freqm(ikl).eq.freqm(ip(ij1-1)))then endif !if(iflagbl.ne.0)then c here we modify weight to achieve robust weighting scheme from Watson et al. JMS 219(2003) 326-328 c here if by previous iteration he meant set of parameters of previous iteration 15 if(Nrobust.eq.1)then c uncertainties are already in cm-1 both for IR and MW data so simply take uncertainty weight(ikl)=1.d0/(unc(ikl)**2+dlf**2/3.d0) else c for labeling probelms if the labeling changes in the process of fitting c and we do not use robust fitting then simply omit the line c if(dabs(dlf).gt.ocmax)cycle if(dabs(dlf/unc(ikl)).gt.ocmax)cycle endif c write(6,1001)freqm(ikl),dlf,Jq(2,ikl),Jq(1,ikl) c1001 format(2F12.4,1x,6I4) Sct(icat(ikl))=Sct(icat(ikl))+dlf**2 Incat(icat(ikl))=Incat(icat(ikl))+1 inclfitl=inclfitl+1 if(unc(ikl).gt.0.d0)then inclfitmhz=inclfitmhz+1 Smhz=Smhz+dlf**2 else inclfitcm=inclfitcm+1 Scm=Scm+dlf**2 endif Sw=Sw+dlf**2*weight(ikl) int=0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle c do not consider dipole momemnt components if(Nstage(in).eq.0)cycle int=int+1 B(int)=B(int)+dlf*derp(in)*weight(ikl) ist=0 do is=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(is).ne.1)cycle c do not consider dipole moment components if(Nstage(is).eq.0)cycle ist=ist+1 A(int,ist)=A(int,ist)+derp(in)*derp(is)*weight(ikl) enddo !END OF parameters cycle is enddo !END OF parameters cycle in c here we modify weight to achieve robust weighting scheme from Watson et al. JMS 219(2003) 326-328 c this in case if by previous he mean the residuals of previous iteration c if(Nrobust.eq.1)then c weight(ikl)=1.d0/(unc(ikl)**2/dcquadr+dlf**2/3.d0) c endif enddo !end of experimental data cycle Jbnd deallocate (H,EGVL,EGVC) enddo !end of experimental data cycle J c here we add contribution from blended lines with different J if(ibldifj.ne.0)then do ij1=1,ibldifj c this is to avoid situation when one of the blends goes out of 20 MHz o-c when such lines are excluded if(sintacc(ij1).eq.0.d0)cycle dlf=frblend(ij1)-fracc(ij1)/sintacc(ij1) c here if by previous iteration he meant set of parameters of previous iteration if(Nrobust.eq.1)then c Scat() is either in MHz(positive) or in cm-1(negative) therefore we need to divide by speed of light if positive if(Scat(icatbl(ij1)).gt.0.d0)then weightbl(ij1)=1.d0/(Scat(icatbl(ij1))**2/dcquadr+dlf**2/3.d0) else weightbl(ij1)=1.d0/(Scat(icatbl(ij1))**2+dlf**2/3.d0) endif endif do in=1,numpar derp(in)=drvacc(in,ij1)/sintacc(ij1) enddo Sct(icatbl(ij1))=Sct(icatbl(ij1))+dlf**2 Incat(icatbl(ij1))=Incat(icatbl(ij1))+1 inclfitl=inclfitl+1 if(Scat(icatbl(ij1)).gt.0.d0)then inclfitmhz=inclfitmhz+1 Smhz=Smhz+dlf**2 else inclfitcm=inclfitcm+1 Scm=Scm+dlf**2 endif Sw=Sw+dlf**2*weightbl(ij1) int=0 do in=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(in).ne.1)cycle c do not consider dipole momemnt components if(Nstage(in).eq.0)cycle int=int+1 B(int)=B(int)+dlf*derp(in)*weightbl(ij1) ist=0 do is=1,numpar c since we put all derivative value in the drv for corresponding leading parameter c we can consider only leading included parameters c (do not need to consider their parts which have negative Nfloat(ikl)) if(Nfloat(is).ne.1)cycle c do not consider dipole moment components if(Nstage(is).eq.0)cycle ist=ist+1 A(int,ist)=A(int,ist)+derp(in)*derp(is)*weightbl(ij1) enddo !END OF parameters cycle is enddo !END OF parameters cycle in c here we modify weight to achieve robust weighting scheme from Watson et al. JMS 219(2003) 326-328 c this in case if by previous he mean the residuals of previous iteration c if(Nrobust.eq.1)then c weightbl(ij1)=1.d0/(Scat(icatbl(ij1))**2/dcquadr+dlf**2/3.d0) c endif enddo endif ! andif from check whether we have blended lines with different J c Here we save an original matrix for further SVD analysis in case that this iteration is the last c Asvd=A c nsvd=int c Here we scale the matrix to have one on diagonal as in Isabelle\s program do is=1,int delp(is)=dsqrt(A(is,is)) enddo do in=1,int do is=1,int A(in,is)=A(in,is)/delp(in)/delp(is) enddo enddo c Here we save a scaled matrix for further SVD analysis in case that this iteration is the last Asvd=A nsvd=int c Now we have the matrix for least squares. lets invert it. call DGETRF( int, int, A, Numpar, IPIV, INFO ) call DGETRI( int, A, Numpar, IPIV, WORK, Numpar, INFO ) c call DLINRG(int,A,Numpar,A,Numpar) c Backscaling of the least squares matrix do in=1,int do is=1,int A(in,is)=A(in,is)/delp(in)/delp(is) enddo enddo c here the corrections for the parameters are calculated delp=0.d0 do in=1,int do is=1,int delp(in)=delp(in)+B(is)*A(in,is) enddo enddo c here the new parameter values are calculated and uncertainties for the parameters Sw=dsqrt(Sw/(inclfitl-int)) ist=0 do ikl=1,numpar if(Nfloat(ikl).ne.1)cycle c do not consider dipole momemnt components if(Nstage(ikl).eq.0)cycle ist=ist+1 Bval(ikl)=Bval(ikl)+delp(ist) deltap(ikl)=dsqrt(A(ist,ist))*Sw R=delp(ist)/deltap(ikl) RJTH=Bval(ikl)/deltap(ikl) write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),delp(ist),deltap(ikl),R,RJTH,Nstage(ikl) c save F value for further special treatment of RHO if(ikl.eq.iklF)Fval=Bval(ikl) c save RHO value for further special treatment of F derivative if(ikl.eq.iklRHO)RHO=Bval(ikl) enddo 1012 format(1x,A10,7I3,3x,E26.16,3x,E8.2,3x,E8.2,3x,E10.2,3x,E8.2,I4) c output different rms's write(6,*) write(6,*)'wrms= ',Sw,'n= ',inclfitl if(inclfitmhz.ne.0)then Smhz=dsqrt(Smhz/inclfitmhz)*29979.2458D0 write(6,*)'rms_MHz = ',Smhz,'n= ',inclfitmhz endif if(inclfitcm.ne.0)then Scm=dsqrt(Scm/inclfitcm) write(6,*)'rms_cm-1 = ',Scm,'n= ',inclfitcm endif do ic=1,Ncat if(Incat(ic).eq.0)cycle Sct(ic)=dsqrt(Sct(ic)/Incat(ic)) c if the category in MHz then multiply by light speed if(Scat(ic).gt.0.d0)Sct(ic)=Sct(ic)*29979.2458D0 write(6,1015)Scat(ic),Sct(ic),Incat(ic) enddo write(6,*) 1015 format('rmscat ',F7.4,1x,' =',F12.4,2x,'n=',I5) c stopping criteria analysis write(6,*)'deltaSw/Sw=',dabs((Sw-Sprev)/Sw) if(dabs((Sw-Sprev)/Sw).lt.Stol)then write(6,*)'The program has converged after',itn,'iterations' itn=Niter endif c if the program has converged or it is the last iteration save varcov matrix if(itn.eq.Niter)then A=A*Sw**2 endif c save current value of S for further stopping criteria analysis Sprev=Sw write(6,*)'New set of the parameters in cm-1:' do ikl=1,numpar write(6,1014)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) enddo 1014 format(A10,2x,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',E26.17,1x,','I4,',',I6,',') c we need to sort again the parameters by magnitude since after iteration the order may change call paramsort() return end c This subroutine calculates derivatives for given J and sigma states subroutine derivative(J,num) use param use calc use expdat use band complex*16 ciy real*8 fjkxy(-kdmax:kdmax),fjkyx(-kdmax:kdmax),fiy,pkdelt,overlap1,overlap2 real*8 overlap,pjj,pJJp,pK,pkq,pkqpl,pms,pmspl,pmsmi,pj,der1,der2 integer isigcheck(0:isigma) c if there are no levels belongning to particular J cycle if(Jbound(J,1).eq.0)return c this is to assess the time needed to calculate derivatives call DATE_AND_TIME(date,time,zone,values) valinit=values c initialize for the new J value do id=1,nmaxlev do ikl=1,numpar drv(ikl,id,num)=0.d0 enddo enddo ilevnum=0 isigcheck=0 do id=Jbound(J,1),Jbound(J,2) ilevnum=ilevnum+1 c check whether the Jlev(id) values correspond to current J value if(Jlev(id).ne.J)write(6,*)'An error in derivative, Jlev(id) does not match J value' c here we determine the symmetry isigr for a given level isig=abs(mod(idelm*nvt+mlev(id),idelm)) c here we determine the ivt (analog of torsional state for our labeling scheme) ivt=0 if(mlev(id).eq.isig)ivt=0 if(mlev(id).eq.isig-idelm)ivt=1 if(mlev(id).eq.isig+idelm)ivt=2 itl=nv012(isig,Jlev(id),ivt,itlev(id)) c this takes into account V6 mixing of A<->B and E1<-> E2 if(itl.lt.0)then isig=abs(isig-3) itl=abs(itl) endif c if there were severe problems with labeling then we probably will not be able to get itup or itlow if(itl.eq.0.or.itl.gt.ndim)then write(6,*)'the following level had severe problems with labeling it will be omitted from calculation' write(6,1115)mlev(id),Jlev(id),itlev(id),itl,isig,ivt cycle endif 1115 format(3I4) levnum(1,ilevnum)=itl levnum(2,ilevnum)=isig isigcheck(isig)=1 enddo do ikl=1,numpar c do not consider dipole moment components if(Nstage(ikl).eq.0)cycle c if this parameter is fixed do not calculate derivative for it if(Nfloat(ikl).eq.0)then c but if the parameter has J dependence or repeated operator we should let it go if(Jdep(2,ikl).eq.0.and.Iprep(2,ikl).eq.0)cycle c cycle !delete endif c here we determine whether the string to the composite parameter or not if(Nfloat(ikl).lt.0.and.Nfloat(ikl+Nfloat(ikl)).eq.0)then c check whether the leading operator is floated or not if(Jdep(2,ikl).eq.0.and.Iprep(2,ikl).eq.0)cycle c cycle !delete endif if(Iprep(1,ikl).ne.0)cycle if(Jdep(1,ikl).ne.0)cycle kdbandpar=(IBpar(ikl,3)+IBpar(ikl,4)+1)*nvt-1 pJJ=dfloat(J*(J+1)) pJ=dfloat(J) c setup the Hamiltonian matrix for the first diagonalization step NDIMR=(2*J+1)*nvt c here we explicitly calculate [J*(J+1)]**p if(IBpar(ikl,1).eq.0)then pJJp=1.d0 else pJJp=pJJ**IBpar(ikl,1) endif do isigr=0,isigma if(isigcheck(isigr).eq.0)cycle c initialization of the matrice H=0.d0 if(ispecFRHO.eq.1)then if(ikl.eq.iklF.or.ikl.eq.iklRHO)EGVC=0.d0 endif c build the matrix in the second stage basis set for a given parameter c both first stage and second stage parameters are considered in the second stage basis set do K=-J,J pK=dfloat(K) c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 isigt=isigr if(isigma.eq.3.and.mod(K,2).ne.0)then isigt=abs(isigr-3) if(isigr.eq.1.or.isigr.eq.2)isigt=-isigt endif fjkxy=0.d0 fjkyx=0.d0 fiy=1.d0 ciy=(1.d0,0.d0) c here we calculate f(J,K) for given kdelt if(IBpar(ikl,3)+IBpar(ikl,4).eq.0)then fjkxy(0)=1.d0 fjkyx(0)=1.d0 else if(IBpar(ikl,3).ne.0)then if(K+1.le.J)fjkyx(1)=0.5d0*DSQRT((pJ-pK)*(pJ+pK+1.d0)) if(K-1.ge.-J)fjkyx(-1)=0.5d0*DSQRT((pJ+pK)*(pJ-pK+1.d0)) else fjkyx(0)=1.d0 endif if(IBpar(ikl,4).ne.0)then if(K+1.le.J)fjkxy(1)=0.5d0*DSQRT((pJ-pK)*(pJ+pK+1.d0)) if(K-1.ge.-J)fjkxy(-1)=-0.5d0*DSQRT((pJ+pK)*(pJ-pK+1.d0)) c this takes into account imaginary unit in the matrix element for Jy**k ciy=(0.d0,1.d0) ciy=ciy**IBpar(ikl,4) else fjkxy(0)=1.d0 ciy=(1.d0,0.d0) endif c this for the Jy**k*Jx**n term if(IBpar(ikl,3).gt.1)then do ir=1,IBpar(ikl,3)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkyx(kdelt+1)=0.d0 fjkyx(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt+1)=fjkyx(kdelt+1)+fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt-1)=fjkyx(kdelt-1)+fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif if(IBpar(ikl,4).gt.0)then do ir=IBpar(ikl,3),IBpar(ikl,3)+IBpar(ikl,4)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkyx(kdelt+1)=0.d0 fjkyx(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt+1)=fjkyx(kdelt+1)+fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt-1)=fjkyx(kdelt-1)-fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif c this for the Jx**n*Jy**k term if(IBpar(ikl,4).gt.1)then do ir=1,IBpar(ikl,4)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkxy(kdelt+1)=0.d0 fjkxy(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt+1)=fjkxy(kdelt+1)+fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt-1)=fjkxy(kdelt-1)-fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif if(IBpar(ikl,3).gt.0)then do ir=IBpar(ikl,4),IBpar(ikl,3)+IBpar(ikl,4)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkxy(kdelt+1)=0.d0 fjkxy(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt+1)=fjkxy(kdelt+1)+fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt-1)=fjkxy(kdelt-1)+fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif endif ! end of else part for if(IBpar(ikl,3)+IBpar(ikl,4).eq.0) c This takes into account imaginary unit from Jy and imaginary unit form sin if(IBpar(ikl,7).ne.0)then ciy=ciy*(0.d0,-1.d0) endif if(aimag(ciy).ne.0d0)write(6,*)'problems with imaginary unit' fiy=real(ciy,8) c here we explicitly calculate K**q, to avoid ambiguity with 0**0 if(IBpar(ikl,2).eq.0)then pkq=1.d0 else pkq=pk**IBpar(ikl,2) endif if(IBpar(ikl,3).eq.0.and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0)then c there is no torsional overlap integrals involved do ivt=1,nvt c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt H(n,n)=H(n,n)+pkq*pJJp enddo else !overlaps are involved ishm1=3*(IBpar(ikl,6)+IBpar(ikl,7)) ishm=ishm1/idelm ishpl=ishm ishmi=-ishm if(isigma.eq.3)then if(mod(IBpar(ikl,6),2).ne.0.or.mod(IBpar(ikl,7),2).ne.0)then ishm=(ishm1-3)/idelm c Nonzero only IBpar(ikl,6) or only IBpar(ikl,7) not both together c also we substract 3 in 3*(IBpar(ikl,6)+IBpar(ikl,7))-3)/idelm in order not to deal with remainings c when IBpar(ikl,6) or IBpar(ikl,7) is odd if(isigt.eq.0.or.isigt.eq.-1.or.isigt.eq.-2)then ishpl=ishm ishmi=-1-ishm endif if(isigt.eq.3.or.isigt.eq.1.or.isigt.eq.2)then ishpl=+1+ishm ishmi=-ishm endif endif endif if(IBpar(ikl,5).eq.0)then pms=1.d0 pmspl=1.d0 pmsmi=1.d0 endif do ivt=1,nvt c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c cycle over deltaK values do ir=1,IBpar(ikl,3)+IBpar(ikl,4)+1 c for n+k=0 deltaK=0 c for n+k=1 deltaK=+/-1 c for n+k=2 deltaK=+2,0,-2 c for n+k=3 deltaK=+3,+1,-1,-3 c for n+k=4 deltaK=+4,+2,0,-2,-4 kdelt=2*(ir-1)-(IBpar(ikl,3)+IBpar(ikl,4)) pkdelt=dfloat(kdelt) if(K+kdelt.lt.-J.or.K+kdelt.gt.J)cycle c here we explicitly calculate K**q, to avoid ambiguity with 0**0 if(IBpar(ikl,2).eq.0)then pkqpl=1.d0 else pkqpl=(pk+pkdelt)**IBpar(ikl,2) endif c for V3 isigt1 always eq isigt isigt1=isigt if(isigma.eq.3)then if(mod(IBpar(ikl,6),2).ne.0.or.mod(IBpar(ikl,7),2).ne.0)then isigt1=abs(abs(isigt)-3) if(mod(k+kdelt,2).ne.0)then if(isigr.eq.1.or.isigr.eq.2)isigt1=-isigt1 endif endif endif c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=n+kdelt+(2*J+1)*(idelvt-ivt) ndelt=n+kdelt*nvt+(idelvt-ivt) c we fill only upper triangle if(ndelt.lt.n)cycle if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 overlap1=0.d0 overlap2=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 isumpl=isum+ishpl isummi=isum+ishmi if(IBpar(ikl,5).ne.0)then im=ikt*idelm+isigt pms=(dfloat(im))**IBpar(ikl,5) pmspl=(dfloat(im+ishm1))**IBpar(ikl,5) pmsmi=(dfloat(im-ishm1))**IBpar(ikl,5) endif if(isumpl.le.Ndimto)then overlap=EVCTOR(isum,ivt,isigt,K)*EVCTOR(isumpl,idelvt,isigt1,K+kdelt) overlap1=overlap1+overlap*pmspl overlap2=overlap2+overlap*pms c overlap=overlap+ c ! 0.5d0*EVCTOR(isum,ivt,isigt,K)*pmspl*pkqpl*EVCTOR(isumpl,idelvt,isigt1,K+kdelt)*fjkxy(kdelt)+ c ! 0.5d0*EVCTOR(isum,ivt,isigt,K)*pms*pkq*EVCTOR(isumpl,idelvt,isigt1,K+kdelt)*fjkyx(kdelt) endif if(IBpar(ikl,7).eq.0)then if(isummi.ge.1)then overlap=EVCTOR(isum,ivt,isigt,K)*EVCTOR(isummi,idelvt,isigt1,K+kdelt) overlap1=overlap1+overlap*pmsmi overlap2=overlap2+overlap*pms c overlap=overlap+ c ! 0.5d0*EVCTOR(isum,ivt,isigt,K)*pmsmi*pkqpl*EVCTOR(isummi,idelvt,isigt1,K+kdelt)*fjkxy(kdelt)+ c ! 0.5d0*EVCTOR(isum,ivt,isigt,K)*pms*pkq*EVCTOR(isummi,idelvt,isigt1,K+kdelt)*fjkyx(kdelt) endif else if(isummi.ge.1)then overlap=EVCTOR(isum,ivt,isigt,K)*EVCTOR(isummi,idelvt,isigt1,K+kdelt) overlap1=overlap1-overlap*pmsmi overlap2=overlap2-overlap*pms c overlap=overlap- c ! 0.5d0*EVCTOR(isum,ivt,isigt,K)*pmsmi*pkqpl*EVCTOR(isummi,idelvt,isigt1,K+kdelt)*fjkxy(kdelt)- c ! 0.5d0*EVCTOR(isum,ivt,isigt,K)*pms*pkq*EVCTOR(isummi,idelvt,isigt1,K+kdelt)*fjkyx(kdelt) endif endif enddo !from overlap integral calculation overlap1=overlap1*pkqpl*fjkxy(kdelt) overlap2=overlap2*pkq*fjkyx(kdelt) overlap=0.5d0*(overlap1+overlap2) if(ikl.eq.iklF.and.ispecFRHO.eq.1)then c special treatment of F derivative, it cannot be presented as composite parameters c this is from the palfa**2 part of the derivative H(ndelt,n)=H(ndelt,n)+pJJp*0.5d0*overlap*fiy c this is for J dependences and equals EGVC(ndelt,n)=EGVC(ndelt,n)+pJJp*0.5d0*overlap*fiy c this is for the-2*RHO*palfa*Jz term of the derivative over F c here we calculate corresponding overlap integral overlap=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 pms=dfloat(ikt*idelm+isigt) overlap=overlap+EVCTOR(isum,ivt,isigt,K)*pms*pk*EVCTOR(isum,idelvt,isigt,K) enddo H(ndelt,n)=H(ndelt,n)+2.d0*plmiRHO*RHO*overlap c this is from RHO**2*Jz**2 part pf the derivative if(n.eq.ndelt)H(ndelt,n)=H(ndelt,n)+RHO**2*pk**2 elseif(ikl.eq.iklRHO.and.ispecFRHO.eq.1)then c special treatment of RHO derivative which cannot be presented as a composite parameter c this is from -2*F*palfa*Jz part of the derivative H(ndelt,n)=H(ndelt,n)+2.d0*plmiRHO*Fval*pJJp*0.5d0*overlap*fiy c this is for J dependences and equals EGVC(ndelt,n)=EGVC(ndelt,n)+pJJp*0.5d0*overlap*fiy c this is from the 2*F*RHO*Jz**2 part of the derivative if(n.eq.ndelt)H(ndelt,n)=H(ndelt,n)+2.d0*Fval*RHO*pk**2 else c all other parameters H(ndelt,n)=H(ndelt,n)+pJJp*0.5d0*overlap*fiy endif enddo !from idelvt cycle enddo !end of the deltaK cycle (ir) enddo !from ivt cycle endif !end of if statement for presence/absence of overlap integrals enddo !from K cycle c here we restore the full matrix c do in=2,NDIMR c do it=1,in-1 do in=2,NDIMR do it=max(1,in-kdbandpar),in-1 H(it,in)=H(in,it) enddo enddo if(ispecFRHO.eq.1)then if(ikl.eq.iklF.or.ikl.eq.iklRHO)then do in=2,NDIMR do it=max(1,in-kdbandpar),in-1 EGVC(it,in)=EGVC(in,it) enddo enddo endif endif isl=0 do id=Jbound(J,1),Jbound(J,2) isl=isl+1 itl=levnum(1,isl) isig=levnum(2,isl) c if this level does not belong to particular isigr if(isig.ne.isigr)cycle c now we have a Hamiltonian matrix for corresponding J and isigr and we need to calculate derivatives c using corresponding eigen vectors. c we have a number of eigen vector in a given isigr, J stack that corresponds to particular level c now we can calculate expectation value which will be equal to the derivative idt=id-Jbound(J,1)+1 der2=0.d0 do in=1,NDIMR der1=0.d0 c do it=1,NDIMR do it=max(1,in-kdbandpar),min(in+kdbandpar,NDIMR) c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,itl,isig,num) c der1=der1+H(in,it)*EVCrottor(it,itl,isig,num) enddo der2=der2+der1*EVCrottor(in,itl,isig,num) enddo if(Nfloat(ikl).lt.0)then c we put all derivative value in the drv for corresponding leading parameter drv(ikl+Nfloat(ikl),idt,num)=drv(ikl+Nfloat(ikl),idt,num)+der2*Bcompd(ikl) else drv(ikl,idt,num)=drv(ikl,idt,num)+der2*Bcompd(ikl) endif if(Iprep(2,ikl).ne.0.or.Jdep(2,ikl).ne.0)then if(ispecFRHO.eq.1)then if(ikl.eq.iklF.or.ikl.eq.iklRHO)then der2=0.d0 do in=1,NDIMR der1=0.d0 c do it=1,NDIMR do it=max(1,in-kdbandpar),min(in+kdbandpar,NDIMR) c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,itl,isig,num) c der1=der1+H(in,it)*EVCrottor(it,itl,isig,num) enddo der2=der2+der1*EVCrottor(in,itl,isig,num) enddo endif !ikl=iklF or iklRHO endif if(Iprep(2,ikl).ne.0)then iks=Iprep(2,ikl) 10 if(Nfloat(iks).lt.0)then c we put all derivative value in the drv for corresponding leading parameter drv(iks+Nfloat(iks),idt,num)=drv(iks+Nfloat(iks),idt,num)+der2*Bcompd(iks) else drv(iks,idt,num)=drv(iks,idt,num)+der2*Bcompd(iks) endif if(Iprep(2,iks).ne.0)then iks=Iprep(2,iks) goto 10 endif endif c this is for J dependents if(Jdep(2,ikl).ne.0)then iks=Jdep(2,ikl) 11 der2=der2*pJJ c J dependence can not belong to the first stage therefore we do not need to check Nstage(iks) if(Nfloat(iks).lt.0)then c we put all derivative value in the drv for corresponding leading parameter drv(iks+Nfloat(iks),idt,num)=drv(iks+Nfloat(iks),idt,num)+der2*Bcompd(iks) else drv(iks,idt,num)=drv(iks,idt,num)+der2*Bcompd(iks) endif c here we check whether the Jdependent operator has eqauls if(Iprep(2,iks).ne.0)then ikt=Iprep(2,iks) 12 if(Nfloat(ikt).lt.0)then c we put all derivative value in the drv for corresponding leading parameter drv(ikt+Nfloat(ikt),idt,num)=drv(ikt+Nfloat(ikt),idt,num)+der2*Bcompd(ikt) else drv(ikt,idt,num)=drv(ikt,idt,num)+der2*Bcompd(ikt) endif if(Iprep(2,ikt).ne.0)then ikt=Iprep(2,ikt) goto 12 endif endif c if J dependent has its own J dependence consider it if(Jdep(2,iks).ne.0)then iks=Jdep(2,iks) goto 11 endif endif endif !if there is Jdep or repeated enddo !end of experimental level cycle enddo !end of sigma cycle enddo !end of parameter cycle call DATE_AND_TIME(date,time,zone,values) c this is to assess time needed to calculate derivatives valacc2=valacc2+(values-valinit) if(valacc2(8).ge.1000)then valacc2(7)=valacc2(7)+1 valacc2(8)=valacc2(8)-1000 endif if(valacc2(8).lt.0)then valacc2(7)=valacc2(7)-1 valacc2(8)=valacc2(8)+1000 endif if(valacc2(7).ge.60)then valacc2(6)=valacc2(6)+1 valacc2(7)=valacc2(7)-60 endif if(valacc2(7).lt.0)then valacc2(6)=valacc2(6)-1 valacc2(7)=valacc2(7)+60 endif if(valacc2(6).ge.60)then valacc2(5)=valacc2(5)+1 valacc2(6)=valacc2(6)-60 endif if(valacc2(6).lt.0)then valacc2(5)=valacc2(5)-1 valacc2(6)=valacc2(6)+60 endif return end c This subroutine put labels on the eigenvalues after the second diagonalization step for V3 case c it symmetrize the levels if necessary (only those which are labeled) and c for degenerate levels on the stage of labeling takes into account parity for nondegenerate c species by adding or substracting 10**-9 of energy from degenerate pair (it does it for all states but this crucial only for degenerate ones) c subroutine labelingV3withdegeneigenvect(J,itn,num) subroutine labelingV3(J,itn,num) use param use calc use expdat real*8 overlap,par,der1,par12,tau,alpha,beta real*8 sum123(nvt) integer iperm(ndim),iperm1(ndim) real*8 sum0s1(ndim), sum1s1(ndim),sum2s1(ndim),sum3s1(ndim),bulk(ndim) call DATE_AND_TIME(date,time,zone,values) valinit=values c to check if the poor convergence connected to the jumps in labeling c if(itn.gt.1)return nrotor=(2*J+1)*nvts NDIMR=(2*J+1)*nvt c cycle over all eigenvalues do isigr=0,isigma c initialize parAB do ikl=1,ndimr parAB(ikl,isigr,num)=0.d0 enddo c check whether we need these species for given J or not if(mbound(isigr,J).eq.0)cycle c if it is not the last iteration when pure calculation is done then check whether this J is present in the list of fitted levels if(itn.lt.Niter)then if(Jbound(J,1).eq.0)return endif if(isigr.eq.0)then c building a matrix for calculating parity c setup the Hamiltonian matrix for the first diagonalization step NDIMR=(2*J+1)*nvt c initialization of the matrice H=0.d0 if(mod(j,2).eq.0)then jminus=1 else jminus=-1 endif do K=-J,J if(mod(K,2).eq.0)then kminus=1 else kminus=-1 endif c this defines what sigma we should take isigt=isigr do ivt=1,nvt c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=(2*J+1)*idelvt-J-K ndelt=idelvt+(J-K)*nvt c we fill only upper triangle if(ndelt.lt.n)cycle if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 if(isigt.eq.0)then c this is for A type torsional overlaps isumpl=-ikt+ktronc+1 else c this is for B type torsional overlaps isumpl=-ikt+ktronc endif if(isumpl.le.Ndimto.and.isumpl.ge.1)overlap=overlap+EVCTOR(isum,ivt,isigt,-K)*EVCTOR(isumpl,idelvt,isigt,K) enddo !from overlap integral calculation c all other parameters H(ndelt,n)=overlap*kminus*jminus enddo !from idelvt cycle enddo !from K cycle enddo !from ivt cycle c here we restore the full matrix do in=2,NDIMR do it=1,in-1 H(it,in)=H(in,it) enddo enddo endif !from checking whthere isigr=0 or not since for degnerate we do not need this matrix c we have formed a matrix for parity calculation sum0s1=0.d0 sum1s1=0.d0 sum2s1=0.d0 sum3s1=0.d0 do i=1,nrotor c determine the torsional state within particular symmetry species sum123=0.d0 do ivt=1,nvt c cycle over K values inside the corresponding torsional state c do it=(2*J+1)*(ivt-1)+1,(2*J+1)*ivt do it1=0,2*J it=ivt+it1*nvt sum123(ivt)=sum123(ivt)+EVCrottor(it,i,isigr,num)**2 enddo enddo sum0s1(i)=sum123(1) sum1s1(i)=sum123(2) sum2s1(i)=sum123(3) sum3s1(i)=sum123(4) enddo ! end of cycle over eigen states for given J and isigr c vt=0 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum0s1 c CALL DSVRBP (nrotor,sum0s1,bulk,iperm) call VSRTPD (sum0s1,nrotor,iperm) sum0s1=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) enddo c if there is a state with strong mixing of the vt=0 and vt=1 and this state was not assigned as vt=0 state c then this state should be assigned as a vt=1 state. For this purpose the sum0s1 is added to sum1s1 for such state c it is assumed that deltavt=1 is the leading mixing (so there is no much interaction between vt=0 and vt=2) do ij=1,nrotor-2*j-1 if(sum1s1(iperm(ij)).gt.sum2s1(iperm(ij)).and.sum0s1(iperm(ij)).gt.sum2s1(iperm(ij)))then sum1s1(iperm(ij))=sum1s1(iperm(ij))+sum0s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum0s1(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff included for vt=0 is less than ! 0.5',sum0s1(iperm(nrotor-2*j)),j,isigr endif c sort the c CALL SVIBP(2*j+1,iperm1,iperm1,iperm) call VSRTP (iperm1,2*j+1,IPerm) c calculate parity if degnerate symmetrize if(isigr.eq.0)then do ij=1,2*j+1 par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij),isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo parAB(iperm1(ij),isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(iperm1(ij)+1,isigr,num)-Erottor(iperm1(ij),isigr,num))/Erottor(iperm1(ij),isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(iperm1(ij)-1,isigr,num)-Erottor(iperm1(ij),isigr,num))/Erottor(iperm1(ij),isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(iperm1(ij),isigr,num), ! Erottor(iperm1(ij)+1,isigr,num),Erottor(iperm1(ij)-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij)+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,iperm1(ij),isigr,num) EVCrottor(ik,iperm1(ij),isigr,num)=alpha*EVCrottor(ik,iperm1(ij),isigr,num)-beta*EVCrottor(ik,iperm1(ij)+itupdown,isigr,num) EVCrottor(ik,iperm1(ij)+itupdown,isigr,num)=alpha*EVCrottor(ik,iperm1(ij)+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij),isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(iperm1(ij),isigr,num)).gt.0.0000001d0)then if(parAB(iperm1(ij),isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(iperm1(ij),isigr,num),parAB(iperm1(ij),isigr,num),par endif endif parAB(iperm1(ij),isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij)+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij)+itupdown,isigr,num) enddo parAB(iperm1(ij)+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(iperm1(ij),isigr,num)*parAB(iperm1(ij)+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(iperm1(ij),isigr,num), ! parAB(iperm1(ij)+itupdown,isigr,num),J,Erottor(iperm1(ij),isigr,num) endif endif enddo !enddo from do ij=1,2*j+1 endif !endif from checking isigr=0 c this is to avoid switching of labeling from iteration to iteration in degenerate levels of A-type if(isigr.eq.0)then do ij=1,2*j+1 bulk(ij)=Erottor(iperm1(ij),isigr,num)+parAB(iperm1(ij),isigr,num)*Erottor(iperm1(ij),isigr,num)*1.d-10 enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) endif do ij=1,2*j+1 nv012(isigr,J,0,ij)=iperm1(ij) sum1s1(iperm1(ij))=0.d0 sum2s1(iperm1(ij))=0.d0 enddo c vt=1 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum1s1 c CALL DSVRBP (nrotor,sum1s1,bulk,iperm) call VSRTPD (sum1s1,nrotor,iperm) sum1s1=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) enddo c if there is a state with strong mixing of the vt=1 and vt=2 and this state was not assigned as vt=1 state c then this state should be assigned as a vt=2 state. For this purpose the sum1s1 is added to sum2s1 for such state c it is assumed that deltavt=1 is the leading mixing (so there is no much interaction between vt=1 and vt=3) do ij=1,nrotor-2*j-1 if(sum1s1(iperm(ij)).gt.sum3s1(iperm(ij)).and.sum2s1(iperm(ij)).gt.sum3s1(iperm(ij)))then sum2s1(iperm(ij))=sum2s1(iperm(ij))+sum1s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum1s1(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff included for vt=1 is less than ! 0.5',sum1s1(iperm(nrotor-2*j)),j,isigr endif c sort the c CALL SVIBP(2*j+1,iperm1,iperm1,iperm) call VSRTP (iperm1,2*j+1,IPerm) c calculate parity if degnerate symmetrize if(isigr.eq.0)then do ij=1,2*j+1 par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij),isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo parAB(iperm1(ij),isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(iperm1(ij)+1,isigr,num)-Erottor(iperm1(ij),isigr,num))/Erottor(iperm1(ij),isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(iperm1(ij)-1,isigr,num)-Erottor(iperm1(ij),isigr,num))/Erottor(iperm1(ij),isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(iperm1(ij),isigr,num), ! Erottor(iperm1(ij)+1,isigr,num),Erottor(iperm1(ij)-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij)+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,iperm1(ij),isigr,num) EVCrottor(ik,iperm1(ij),isigr,num)=alpha*EVCrottor(ik,iperm1(ij),isigr,num)-beta*EVCrottor(ik,iperm1(ij)+itupdown,isigr,num) EVCrottor(ik,iperm1(ij)+itupdown,isigr,num)=alpha*EVCrottor(ik,iperm1(ij)+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij),isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(iperm1(ij),isigr,num)).gt.0.0000001d0)then if(parAB(iperm1(ij),isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(iperm1(ij),isigr,num),parAB(iperm1(ij),isigr,num),par endif endif parAB(iperm1(ij),isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij)+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij)+itupdown,isigr,num) enddo parAB(iperm1(ij)+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(iperm1(ij),isigr,num)*parAB(iperm1(ij)+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(iperm1(ij),isigr,num), ! parAB(iperm1(ij)+itupdown,isigr,num),J,Erottor(iperm1(ij),isigr,num) endif endif enddo !enddo from do ij=1,2*j+1 endif !endif from checking isigr=0 c this is to avoid switching of labeling from iteration to iteration in degenerate levels of A-type if(isigr.eq.0)then do ij=1,2*j+1 bulk(ij)=Erottor(iperm1(ij),isigr,num)+parAB(iperm1(ij),isigr,num)*Erottor(iperm1(ij),isigr,num)*1.d-10 enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) endif do ij=1,2*j+1 nv012(isigr,J,1,ij)=iperm1(ij) sum2s1(iperm1(ij))=0.d0 enddo c vt=2 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum2s1 c CALL DSVRBP (nrotor,sum2s1,bulk,iperm) call VSRTPD (sum2s1,nrotor,iperm) sum2s1=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) enddo c indication of problems with labeling if(sum2s1(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff included for vt=2 is less than ! 0.5',sum2s1(iperm(nrotor-2*j)),j,isigr endif c sort the c CALL SVIBP(2*j+1,iperm1,iperm1,iperm) call VSRTP (iperm1,2*j+1,IPerm) c calculate parity if degnerate symmetrize if(isigr.eq.0)then do ij=1,2*j+1 par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij),isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo parAB(iperm1(ij),isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(iperm1(ij)+1,isigr,num)-Erottor(iperm1(ij),isigr,num))/Erottor(iperm1(ij),isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(iperm1(ij)-1,isigr,num)-Erottor(iperm1(ij),isigr,num))/Erottor(iperm1(ij),isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(iperm1(ij),isigr,num), ! Erottor(iperm1(ij)+1,isigr,num),Erottor(iperm1(ij)-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij)+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,iperm1(ij),isigr,num) EVCrottor(ik,iperm1(ij),isigr,num)=alpha*EVCrottor(ik,iperm1(ij),isigr,num)-beta*EVCrottor(ik,iperm1(ij)+itupdown,isigr,num) EVCrottor(ik,iperm1(ij)+itupdown,isigr,num)=alpha*EVCrottor(ik,iperm1(ij)+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij),isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij),isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(iperm1(ij),isigr,num)).gt.0.0000001d0)then if(parAB(iperm1(ij),isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(iperm1(ij),isigr,num),parAB(iperm1(ij),isigr,num),par endif endif parAB(iperm1(ij),isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,iperm1(ij)+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,iperm1(ij)+itupdown,isigr,num) enddo parAB(iperm1(ij)+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(iperm1(ij),isigr,num)*parAB(iperm1(ij)+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(iperm1(ij),isigr,num), ! parAB(iperm1(ij)+itupdown,isigr,num),J,Erottor(iperm1(ij),isigr,num) endif endif enddo !enddo from do ij=1,2*j+1 endif !endif from checking isigr=0 c this is to avoid switching of labeling from iteration to iteration in degenerate levels of A-type if(isigr.eq.0)then do ij=1,2*j+1 bulk(ij)=Erottor(iperm1(ij),isigr,num)+parAB(iperm1(ij),isigr,num)*Erottor(iperm1(ij),isigr,num)*1.d-10 enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) endif do ij=1,2*j+1 nv012(isigr,J,2,ij)=iperm1(ij) enddo enddo ! end of isigma cycle call DATE_AND_TIME(date,time,zone,values) valacc3=valacc3+(values-valinit) if(valacc3(8).ge.1000)then valacc3(7)=valacc3(7)+1 valacc3(8)=valacc3(8)-1000 endif if(valacc3(8).lt.0)then valacc3(7)=valacc3(7)-1 valacc3(8)=valacc3(8)+1000 endif if(valacc3(7).ge.60)then valacc3(6)=valacc3(6)+1 valacc3(7)=valacc3(7)-60 endif if(valacc3(7).lt.0)then valacc3(6)=valacc3(6)-1 valacc3(7)=valacc3(7)+60 endif if(valacc3(6).ge.60)then valacc3(5)=valacc3(5)+1 valacc3(6)=valacc3(6)-60 endif if(valacc3(6).lt.0)then valacc3(5)=valacc3(5)-1 valacc3(6)=valacc3(6)+60 endif return end c This subroutine put labels on the eigenvalues after the second diagonalization step for V6 case c subroutine labelingV6withsymmetrizingdegeneigenvect(J,itn,num) c subroutine labelingV6newwithspecaddition(J,itn,num) subroutine labelingV6(J,itn,num) use param use calc use expdat real*8 overlap,par,der1,par12,tau,alpha,beta real*8 sum123(nvt),seven,sodd integer iperm(ndim), iperm1(ndim),jsign1(ndim),Jsign2(ndim) real*8 sum0s1(ndim), sum1s1(ndim), sum2s1(ndim), sum3s1(ndim),Eval1(ndim),Eval2(ndim),Env real*8 sum0s2(ndim), sum1s2(ndim), sum2s2(ndim), sum3s2(ndim),bulk(ndim) call DATE_AND_TIME(date,time,zone,values) valinit=values nrotor=(2*J+1)*nvts NDIMR=(2*J+1)*nvt c cycle over all eigenvalues do isig=0,1 c initialization of parAB array isig1=abs(isig-3) do ikl=1,ndimr parAB(ikl,isig,num)=0.d0 parAB(ikl,isig1,num)=0.d0 enddo c check whether we need these species for given J or not if(mbound(isig,J).eq.0)cycle c isig=0 stands for nondegenerate symmetry species 0 and 3, isig=1 stands for degenrate 1 and 2 c if it is not the last iteration when pure calculation is done then check whether this J is present in the list of fitted levels if(itn.lt.Niter)then if(Jbound(J,1).eq.0)return endif n1=0 n2=0 sum0s1=0.d0 sum1s1=0.d0 sum2s1=0.d0 sum3s1=0.d0 sum0s2=0.d0 sum1s2=0.d0 sum2s2=0.d0 sum3s2=0.d0 Eval1=0.d0 Eval2=0.d0 c now we will consider in parallel isigr=0 and 3 or isigr=1 and 2 i1=1 !counter for the one state i2=1 !counter for another state is=i1+i2 do while(is.ne.nrotor*2) c here we determine what of the two levels is lower and each time we consider the lower level from the two isig under consideration if(Erottor(i1,isig,num).le.Erottor(i2,abs(isig-3),num))then i=i1 isigr=isig Env=Erottor(i1,isig,num) else i=i2 isigr=abs(isig-3) Env=Erottor(i2,abs(isig-3),num) endif c determine the torsional state within isigr=0 or 1 11 seven=0.d0 sodd=0.d0 sum123=0.d0 do ivt=1,nvt c cycle over K values inside the corresponding torsional state c do it=(2*J+1)*(ivt-1)+1,(2*J+1)*ivt do it1=0,2*J it=ivt+it1*nvt sum123(ivt)=sum123(ivt)+EVCrottor(it,i,isigr,num)**2 c if J+ivt+it is even then K is even and if J+ivt+it is odd then K is odd for given basis function c this will allow to distinguish between A<->B and E1<->E2 torsion states c if(mod(J+ivt+it,2).eq.0)then if(mod(it1-J,2).eq.0)then seven=seven+EVCrottor(it,i,isigr,num)**2 else sodd=sodd+EVCrottor(it,i,isigr,num)**2 endif enddo enddo c here we determine to what torsional symmetry the state belong if(seven.gt.sodd)then isigt=isigr else isigt=abs(isigr-3) i=-i !negative means that for given isigt the level is taken from a matrix with isigr =/= isigt endif if(isigt.eq.isig)then n1=n1+1 sum0s1(n1)=sum123(1) sum1s1(n1)=sum123(2) sum2s1(n1)=sum123(3) sum3s1(n1)=sum123(4) jsign1(n1)=i Eval1(n1)=Env elseif(isigt.ne.isig)then n2=n2+1 sum0s2(n2)=sum123(1) sum1s2(n2)=sum123(2) sum2s2(n2)=sum123(3) sum3s2(n2)=sum123(4) jsign2(n2)=i Eval2(n2)=Env endif c here we update counters for the isigr if(isigr.eq.isig)then if(i1.lt.nrotor)then i1=i1+1 elseif(i2.lt.nrotor)then i2=i2+1 i=i2 isigr=abs(isig-3) Env=Erottor(i2,abs(isig-3),num) goto 11 endif else if(i2.lt.nrotor)then i2=i2+1 elseif(i1.lt.nrotor)then i1=i1+1 i=i1 isigr=isig Env=Erottor(i1,isig,num) goto 11 endif endif c number of considered states for given J is=i1+i2 enddo ! end of cycle over eigen states for given J and isig if(isig.eq.0)then NDIMR=(2*J+1)*nvt c initialization of the matrice H=0.d0 !for isigr=0 EGVC=0.d0 !for isigr=3 if(mod(j,2).eq.0)then jminus=1 else jminus=-1 endif do K=-J,J if(mod(K,2).eq.0)then kminus=1 else kminus=-1 endif c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 isigt=isig if(mod(K,2).ne.0)then isigt=abs(isig-3) endif do ivt=1,nvt c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=(2*J+1)*idelvt-J-K ndelt=idelvt+(J-K)*nvt c we fill only upper triangle if(ndelt.lt.n)cycle if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 if(isigt.eq.0)then c this is for A type torsional overlaps isumpl=-ikt+ktronc+1 else c this is for B type torsional overlaps isumpl=-ikt+ktronc endif if(isumpl.le.Ndimto.and.isumpl.ge.1)overlap=overlap+EVCTOR(isum,ivt,isigt,-K)*EVCTOR(isumpl,idelvt,isigt,K) enddo !from overlap integral calculation c all other parameters H(ndelt,n)=overlap*kminus*jminus enddo !from idelvt cycle enddo !from ivt cycle c for isigr=3 and EGVC c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 isigt=abs(isig-3) if(mod(K,2).ne.0)then isigt=isig endif do ivt=1,nvt c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=(2*J+1)*idelvt-J-K ndelt=idelvt+(J-K)*nvt c we fill only upper triangle if(ndelt.lt.n)cycle if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 if(isigt.eq.0)then c this is for A type torsional overlaps isumpl=-ikt+ktronc+1 else c this is for B type torsional overlaps isumpl=-ikt+ktronc endif if(isumpl.le.Ndimto.and.isumpl.ge.1)overlap=overlap+EVCTOR(isum,ivt,isigt,-K)*EVCTOR(isumpl,idelvt,isigt,K) enddo !from overlap integral calculation c all other parameters EGVC(ndelt,n)=overlap*kminus*jminus enddo !from idelvt cycle enddo !from ivt cycle enddo !from K cycle c here we restore the full matrix do in=2,NDIMR do it=1,in-1 H(it,in)=H(in,it) enddo enddo c here we restore the full matrix do in=2,NDIMR do it=1,in-1 EGVC(it,in)=EGVC(in,it) enddo enddo endif !endif from checking isig=0 c state 1 correspond to isigt=0 or 1, therefore takes care about m=0,-6,6,1,-5,7 c vt=0 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum0s1 c CALL DSVRBP (nrotor,sum0s1,bulk,iperm) call VSRTPD (sum0s1,nrotor,iperm) sum0s1=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) bulk(ij-nrotor+2*j+1)=Eval1(iperm(ij)) enddo c if there is a state with strong mixing of the vt=0 and vt=1 and this state was not assigned as vt=0 state c then this state should be assigned as a vt=1 state. For this purpose the sum0s1 is added to sum1s1 for such state c it is assumed that deltavt=1 is the leading mixing (so there is no much interaction between vt=0 and vt=2) do ij=1,nrotor-2*j-1 if(sum1s1(iperm(ij)).gt.sum2s1(iperm(ij)).and.sum0s1(iperm(ij)).gt.sum2s1(iperm(ij)))then sum1s1(iperm(ij))=sum1s1(iperm(ij))+sum0s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum0s1(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff for vt=0 <0.5',j,isig,sum0s1(iperm(nrotor-2*j)) endif c symmetrize vectors do ij=1,2*j+1 if(Jsign1(iperm1(ij)).gt.0)then c calculate parity if degnerate symmetrize isigr=isig istn=Jsign1(iperm1(ij)) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif elseif(Jsign1(iperm1(ij)).lt.0)then c calculate parity if degnerate symmetrize isigr=abs(isig-3) istn=abs(Jsign1(iperm1(ij))) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif endif !from checking Jsign1 positive or negative enddo c this is to avoid switching of labeling from iteration to iteration in degenerate levels do ij=1,2*j+1 if(Jsign1(iperm1(ij)).gt.0)then bulk(ij)=Eval1(iperm1(ij))+1.d-9*Eval1(iperm1(ij)) if(isig.eq.0)then isigr=isig istn=Jsign1(iperm1(ij)) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval1(iperm1(ij))*1.d-10 endif elseif(Jsign1(iperm1(ij)).lt.0)then bulk(ij)=Eval1(iperm1(ij))-1.d-9*Eval1(iperm1(ij)) if(isig.eq.0)then isigr=abs(isig-3) istn=abs(Jsign1(iperm1(ij))) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval1(iperm1(ij))*1.d-10 endif endif enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) do ij=1,2*j+1 nv012(isig,J,0,ij)=Jsign1(iperm1(ij)) sum1s1(iperm1(ij))=0.d0 sum2s1(iperm1(ij))=0.d0 enddo c vt=1 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum1s1 c CALL DSVRBP (nrotor,sum1s1,bulk,iperm) call VSRTPD (sum1s1,nrotor,iperm) sum1s1=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) bulk(ij-nrotor+2*j+1)=Eval1(iperm(ij)) enddo c if there is a state with strong mixing of the vt=1 and vt=2 and this state was not assigned as vt=1 state c then this state should be assigned as a vt=2 state. For this purpose the sum1s1 is added to sum2s1 for such state c it is assumed that deltavt=1 is the leading mixing (so there is no much interaction between vt=1 and vt=3) do ij=1,nrotor-2*j-1 if(sum1s1(iperm(ij)).gt.sum3s1(iperm(ij)).and.sum2s1(iperm(ij)).gt.sum3s1(iperm(ij)))then sum2s1(iperm(ij))=sum2s1(iperm(ij))+sum1s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum1s1(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff for vt=1 <0.5',j,isig,sum1s1(iperm(nrotor-2*j)) endif do ij=1,2*j+1 if(Jsign1(iperm1(ij)).gt.0)then c calculate parity if degnerate symmetrize isigr=isig istn=Jsign1(iperm1(ij)) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif elseif(Jsign1(iperm1(ij)).lt.0)then c calculate parity if degnerate symmetrize isigr=abs(isig-3) istn=abs(Jsign1(iperm1(ij))) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif endif !from checking Jsign1 positive or negative enddo c this is to avoid switching of labeling from iteration to iteration in degenerate levels do ij=1,2*j+1 if(Jsign1(iperm1(ij)).gt.0)then bulk(ij)=Eval1(iperm1(ij))+1.d-9*Eval1(iperm1(ij)) if(isig.eq.0)then isigr=isig istn=Jsign1(iperm1(ij)) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval1(iperm1(ij))*1.d-10 endif elseif(Jsign1(iperm1(ij)).lt.0)then bulk(ij)=Eval1(iperm1(ij))-1.d-9*Eval1(iperm1(ij)) if(isig.eq.0)then isigr=abs(isig-3) istn=abs(Jsign1(iperm1(ij))) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval1(iperm1(ij))*1.d-10 endif endif enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) do ij=1,2*j+1 nv012(isig,J,1,ij)=Jsign1(iperm1(ij)) sum2s1(iperm1(ij))=0.d0 enddo c vt=2 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum2s1 c CALL DSVRBP (nrotor,sum2s1,bulk,iperm) call VSRTPD (sum2s1,nrotor,iperm) sum2s1=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) bulk(ij-nrotor+2*j+1)=Eval1(iperm(ij)) enddo c indication of problems with labeling if(sum2s1(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff for vt=2 <0.5',j,isig,sum2s1(iperm(nrotor-2*j)) endif do ij=1,2*j+1 c calculate parity if degnerate symmetrize if(Jsign1(iperm1(ij)).gt.0)then c calculate parity if degnerate symmetrize isigr=isig istn=Jsign1(iperm1(ij)) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif elseif(Jsign1(iperm1(ij)).lt.0)then c calculate parity if degnerate symmetrize isigr=abs(isig-3) istn=abs(Jsign1(iperm1(ij))) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif endif !from checking Jsign1 positive or negative enddo c this is to avoid switching of labeling from iteration to iteration in degenerate levels do ij=1,2*j+1 if(Jsign1(iperm1(ij)).gt.0)then bulk(ij)=Eval1(iperm1(ij))+1.d-9*Eval1(iperm1(ij)) if(isig.eq.0)then isigr=isig istn=Jsign1(iperm1(ij)) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval1(iperm1(ij))*1.d-10 endif elseif(Jsign1(iperm1(ij)).lt.0)then bulk(ij)=Eval1(iperm1(ij))-1.d-9*Eval1(iperm1(ij)) if(isig.eq.0)then isigr=abs(isig-3) istn=abs(Jsign1(iperm1(ij))) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval1(iperm1(ij))*1.d-10 endif endif enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) do ij=1,2*j+1 nv012(isig,J,2,ij)=Jsign1(iperm1(ij)) enddo c state 2 correspond to isigt=3 or isigt=2, therefore take care about m=3,-3,9,2,-4,8 c vt=0 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum0s2 c CALL DSVRBP (nrotor,sum0s2,bulk,iperm) call VSRTPD (sum0s2,nrotor,iperm) sum0s2=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) bulk(ij-nrotor+2*j+1)=Eval2(iperm(ij)) enddo c if there is a state with strong mixing of the vt=0 and vt=1 and this state was not assigned as vt=0 state c then this state should be assigned as a vt=1 state. For this purpose the sum0s1 is added to sum1s1 for such state c it is assumed that deltavt=1 is the leading mixing (so there is no much interaction between vt=0 and vt=2) do ij=1,nrotor-2*j-1 if(sum1s2(iperm(ij)).gt.sum2s2(iperm(ij)).and.sum0s2(iperm(ij)).gt.sum2s2(iperm(ij)))then sum1s2(iperm(ij))=sum1s2(iperm(ij))+sum0s2(iperm(ij)) endif enddo c indication of problems with labeling if(sum0s2(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff for vt=0 <0.5',j,abs(isig-3),sum0s2(iperm(nrotor-2*j)) endif do ij=1,2*j+1 if(Jsign2(iperm1(ij)).gt.0)then c calculate parity if degnerate symmetrize isigr=abs(isig-3) istn=Jsign2(iperm1(ij)) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif elseif(Jsign2(iperm1(ij)).lt.0)then c calculate parity if degnerate symmetrize isigr=isig istn=abs(Jsign2(iperm1(ij))) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif endif !from checking Jsign1 positive or negative enddo c this is to avoid switching of labeling from iteration to iteration in degenerate levels do ij=1,2*j+1 if(Jsign2(iperm1(ij)).gt.0)then bulk(ij)=Eval2(iperm1(ij))+1.d-9*Eval2(iperm1(ij)) if(isig.eq.0)then isigr=abs(isig-3) istn=Jsign2(iperm1(ij)) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval2(iperm1(ij))*1.d-10 endif elseif(Jsign2(iperm1(ij)).lt.0)then bulk(ij)=Eval2(iperm1(ij))-1.d-9*Eval2(iperm1(ij)) if(isig.eq.0)then isigr=isig istn=abs(Jsign2(iperm1(ij))) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval2(iperm1(ij))*1.d-10 endif endif enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) do ij=1,2*j+1 nv012(abs(isig-3),J,0,ij)=Jsign2(iperm1(ij)) sum1s2(iperm1(ij))=0.d0 sum2s2(iperm1(ij))=0.d0 enddo c vt=1 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum1s2 c CALL DSVRBP (nrotor,sum1s2,bulk,iperm) call VSRTPD (sum1s2,nrotor,iperm) sum1s2=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) bulk(ij-nrotor+2*j+1)=Eval2(iperm(ij)) enddo c if there is a state with strong mixing of the vt=1 and vt=2 and this state was not assigned as vt=1 state c then this state should be assigned as a vt=2 state. For this purpose the sum1s1 is added to sum2s1 for such state c it is assumed that deltavt=1 is the leading mixing (so there is no much interaction between vt=1 and vt=3) do ij=1,nrotor-2*j-1 if(sum1s2(iperm(ij)).gt.sum3s2(iperm(ij)).and.sum2s2(iperm(ij)).gt.sum3s2(iperm(ij)))then sum2s2(iperm(ij))=sum2s2(iperm(ij))+sum1s2(iperm(ij)) endif enddo c indication of problems with labeling if(sum1s2(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff for vt=1 <0.5',j,abs(isig-3),sum1s2(iperm(nrotor-2*j)) endif do ij=1,2*j+1 if(Jsign2(iperm1(ij)).gt.0)then c calculate parity if degnerate symmetrize isigr=abs(isig-3) istn=Jsign2(iperm1(ij)) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif elseif(Jsign2(iperm1(ij)).lt.0)then c calculate parity if degnerate symmetrize isigr=isig istn=abs(Jsign2(iperm1(ij))) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif endif !from checking Jsign1 positive or negative enddo c this is to avoid switching of labeling from iteration to iteration in degenerate levels do ij=1,2*j+1 if(Jsign2(iperm1(ij)).gt.0)then bulk(ij)=Eval2(iperm1(ij))+1.d-9*Eval2(iperm1(ij)) if(isig.eq.0)then isigr=abs(isig-3) istn=Jsign2(iperm1(ij)) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval2(iperm1(ij))*1.d-10 endif elseif(Jsign2(iperm1(ij)).lt.0)then bulk(ij)=Eval2(iperm1(ij))-1.d-9*Eval2(iperm1(ij)) if(isig.eq.0)then isigr=isig istn=abs(Jsign2(iperm1(ij))) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval2(iperm1(ij))*1.d-10 endif endif enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) do ij=1,2*j+1 nv012(abs(isig-3),J,1,ij)=Jsign2(iperm1(ij)) sum2s2(iperm1(ij))=0.d0 enddo c vt=2 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum2s2 c CALL DSVRBP (nrotor,sum2s2,bulk,iperm) call VSRTPD (sum2s2,nrotor,iperm) sum2s2=bulk iperm1=ndim+1 c take 2n+1 first whichj have the largest vt coefficients do ij=nrotor-2*j,nrotor iperm1(ij-nrotor+2*j+1)=iperm(ij) bulk(ij-nrotor+2*j+1)=Eval2(iperm(ij)) enddo c indication of problems with labeling if(sum2s2(iperm(nrotor-2*j)).lt.0.5d0)then write(6,*)'the lowest vt coeff for vt=2 <0.5',j,abs(isig-3),sum2s2(iperm(nrotor-2*j)) endif do ij=1,2*j+1 if(Jsign2(iperm1(ij)).gt.0)then c calculate parity if degnerate symmetrize isigr=abs(isig-3) istn=Jsign2(iperm1(ij)) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+EGVC(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif elseif(Jsign2(iperm1(ij)).lt.0)then c calculate parity if degnerate symmetrize isigr=isig istn=abs(Jsign2(iperm1(ij))) if(isigr.eq.0.or.isigr.eq.3)then par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo parAB(istn,isigr,num)=par c now we check whether the vector should be symmetrized and symmetrize it if necessary if(dabs(par).lt.0.9999999d0)then c it is assumed that we have pairs of A1/A2 degenerate levels that have problems c therefore value of par is the main criteria of degenracy (not energy difference, c since there may be degenerate levels of the same parity for which we do not need to symmetrize). c now we need to determine which level upper/lower this particular is degenerate with c it is more logical that with upper since we go up in energy itupdown=0 if(dabs((Erottor(istn+1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=1 elseif(dabs((Erottor(istn-1,isigr,num)-Erottor(istn,isigr,num))/ ! Erottor(istn,isigr,num)).lt.1.d-8)then itupdown=-1 endif if(itupdown.eq.0)then c we have a problem in degenerate level, namely, the parity is not 1.0 but the level is not degenerate to within 8 digits write(6,*)J,isigr,Erottor(istn,isigr,num), ! Erottor(istn+1,isigr,num),Erottor(istn-1,isigr,num),'problem in degeneracy pair',par endif c calculate the cross parity for the degenerate pair par12=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par12=par12+der1*EVCrottor(in,istn,isigr,num) enddo c calculate alpha and beta for tau=0.5d0*datan(-1.d0*par12/par) alpha=dcos(tau) beta=dsin(tau) c calculate symmetrized eigenvectors do ik=1,ndimr der1=EVCrottor(ik,istn,isigr,num) EVCrottor(ik,istn,isigr,num)=alpha*EVCrottor(ik,istn,isigr,num)-beta*EVCrottor(ik,istn+itupdown,isigr,num) EVCrottor(ik,istn+itupdown,isigr,num)=alpha*EVCrottor(ik,istn+itupdown,isigr,num)+beta*der1 enddo c now calculate parity for the new vectors for labeling purposes par=0.d0 c now we have a Hamiltonian matrix for corresponding J and isigr c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn,isigr,num) enddo par=par+der1*EVCrottor(in,istn,isigr,num) enddo c now we would like to check whether the rotation was made in a proper direction, i.e. if before par=+0.9 then after rotation par=+1.0 and not -1.0 if(abs(parAB(istn,isigr,num)).gt.0.0000001d0)then if(parAB(istn,isigr,num)*par.lt.0.d0)then write(6,*)'degenerate vector was rotated in a wrong direction', ! J,Erottor(istn,isigr,num),parAB(istn,isigr,num),par endif endif parAB(istn,isigr,num)=par par=0.d0 c using corresponding eigen vectors. do in=1,NDIMR der1=0.d0 do it=1,NDIMR c since H(in,it)=H(it,in) according to our restoration of the matrix we can use either H(it,in) or H(in,it) der1=der1+H(it,in)*EVCrottor(it,istn+itupdown,isigr,num) enddo par=par+der1*EVCrottor(in,istn+itupdown,isigr,num) enddo parAB(istn+itupdown,isigr,num)=par c check that indeed we had degenerate levels with different symmerties and that after symmetrization we got what we wnated i.e. levels with different symmetires if(parAB(istn,isigr,num)*parAB(istn+itupdown,isigr,num).gt.0.d0)then write(6,*)'the pair with the same symmetry was symmetrized',parAB(istn,isigr,num), ! parAB(istn+itupdown,isigr,num),J,Erottor(istn,isigr,num) endif endif endif endif !from checking Jsign1 positive or negative enddo c this is to avoid switching of labeling from iteration to iteration in degenerate levels do ij=1,2*j+1 if(Jsign2(iperm1(ij)).gt.0)then bulk(ij)=Eval2(iperm1(ij))+1.d-9*Eval2(iperm1(ij)) if(isig.eq.0)then isigr=abs(isig-3) istn=Jsign2(iperm1(ij)) bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval2(iperm1(ij))*1.d-10 endif elseif(Jsign2(iperm1(ij)).lt.0)then bulk(ij)=Eval2(iperm1(ij))-1.d-9*Eval2(iperm1(ij)) if(isig.eq.0)then istn=abs(Jsign2(iperm1(ij))) isigr=isig bulk(ij)=bulk(ij)+parAB(istn,isigr,num)*Eval2(iperm1(ij))*1.d-10 endif endif enddo c sort the call VSRTPD (bulk,2*j+1,iperm1) do ij=1,2*j+1 nv012(abs(isig-3),J,2,ij)=Jsign2(iperm1(ij)) enddo enddo ! end of isigma cycle call DATE_AND_TIME(date,time,zone,values) valacc3=valacc3+(values-valinit) if(valacc3(8).ge.1000)then valacc3(7)=valacc3(7)+1 valacc3(8)=valacc3(8)-1000 endif if(valacc3(8).lt.0)then valacc3(7)=valacc3(7)-1 valacc3(8)=valacc3(8)+1000 endif if(valacc3(7).ge.60)then valacc3(6)=valacc3(6)+1 valacc3(7)=valacc3(7)-60 endif if(valacc3(7).lt.0)then valacc3(6)=valacc3(6)-1 valacc3(7)=valacc3(7)+60 endif if(valacc3(6).ge.60)then valacc3(5)=valacc3(5)+1 valacc3(6)=valacc3(6)-60 endif if(valacc3(6).lt.0)then valacc3(5)=valacc3(5)-1 valacc3(6)=valacc3(6)+60 endif return end c In this subroutine the rotation-torsion part (second stage diagonalization) is considered. subroutine rotation(J,itn,num) use expdat use param use calc use band integer J,itn,num complex*16 ciy real*8 fjkxy(-kdmax:kdmax),fjkyx(-kdmax:kdmax),fiy,pkdelt,dm,dmpl,dmmi real*8 overlap,pjj,pJJp,pK,pkq,pkqpl,pms,pmspl,pmsmi,pj,drptol,overlap1,overlap2 real*8 pJmult,pKmult c band diagonalization definitions JOBZband='V' UPLOband='L' kdband=nvt*(kdmax+1)-1 !number of subdiagonals (the main diagonal is not counted) NDIMR=(2*J+1)*nvt allocate(work(201*ndimr),Aband(2*kdband+1,ndimr),subdiagtri(ndimr-1)) c if it is not the last iteration when pure calculation is done then check whether this J is present in the list of fitted levels c J=0,1 we need for Elowest if(itn.lt.Niter.and.J.gt.1)then if(Jbound(J,1).eq.0)then deallocate(work,Aband,subdiagtri) return endif endif pJ=dfloat(J) pJJ=dfloat(J*(J+1)) do isigr=0,isigma c this is to assess the time needed to set up the rotation matrix call DATE_AND_TIME(date,time,zone,values) valinit=values c check whether we need current isigr for given J if(isigr.eq.0.or.isigr.eq.3)then c J=0,1 we need for Elowest if(mbound(0,J).eq.0.and.J.gt.1)cycle endif if(isigr.eq.1.or.isigr.eq.2)then c J=0,1 we need for Elowest if(mbound(1,J).eq.0.and.J.gt.1)cycle endif c initialization of the matrices c H=0.d0 Aband=0.d0 c setup the Hamiltonian matrix for the first diagonalization step do itm=1,Numpar c we consider parameters in order of their absolute value ikl=ispar(itm) c if it is J or K dependence of some other parameter, cycle if(Iprep(1,ikl).ne.0)cycle if(Jdep(1,ikl).ne.0)cycle if(Kdep(1,ikl).ne.0)cycle c we consider only parameters belonging to the second stage if(Nstage(ikl).ne.2)then c but if the parameter has J or K dependence we should let it go if(Jdep(2,ikl).eq.0.and.Iprep(2,ikl).eq.0.and.Kdep(2,ikl).eq.0)cycle endif c if(Nstage(ikl).ne.2)cycle c here we explicitly calculate [J*(J+1)]**p if(IBpar(ikl,1).eq.0)then pJJp=1.d0 else pJJp=pJJ**IBpar(ikl,1) endif fjkxy=0.d0 fjkyx=0.d0 fiy=1.d0 ciy=(1.d0,0.d0) do K=-J,J pK=dfloat(K) c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 isigt=isigr if(isigma.eq.3.and.mod(K,2).ne.0)then isigt=abs(isigr-3) if(isigr.eq.1.or.isigr.eq.2)isigt=-isigt endif c here we calculate f(J,K) for given kdelt if(IBpar(ikl,3)+IBpar(ikl,4).eq.0)then fjkxy(0)=1.d0 fjkyx(0)=1.d0 else if(IBpar(ikl,3).ne.0)then if(K+1.le.J)fjkyx(1)=0.5d0*DSQRT((pJ-pK)*(pJ+pK+1.d0)) if(K-1.ge.-J)fjkyx(-1)=0.5d0*DSQRT((pJ+pK)*(pJ-pK+1.d0)) else fjkyx(0)=1.d0 endif if(IBpar(ikl,4).ne.0)then if(K+1.le.J)fjkxy(1)=0.5d0*DSQRT((pJ-pK)*(pJ+pK+1.d0)) if(K-1.ge.-J)fjkxy(-1)=-0.5d0*DSQRT((pJ+pK)*(pJ-pK+1.d0)) c this takes into account imaginary unit in the matrix element for Jy**k ciy=(0.d0,1.d0) ciy=ciy**IBpar(ikl,4) else fjkxy(0)=1.d0 ciy=(1.d0,0.d0) endif c this for the Jy**k*Jx**n term if(IBpar(ikl,3).gt.1)then do ir=1,IBpar(ikl,3)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkyx(kdelt+1)=0.d0 fjkyx(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt+1)=fjkyx(kdelt+1)+fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt-1)=fjkyx(kdelt-1)+fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif if(IBpar(ikl,4).gt.0)then do ir=IBpar(ikl,3),IBpar(ikl,3)+IBpar(ikl,4)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkyx(kdelt+1)=0.d0 fjkyx(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt+1)=fjkyx(kdelt+1)+fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkyx(kdelt).ne.0.d0)fjkyx(kdelt-1)=fjkyx(kdelt-1)-fjkyx(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif c this for the Jx**n*Jy**k term if(IBpar(ikl,4).gt.1)then do ir=1,IBpar(ikl,4)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkxy(kdelt+1)=0.d0 fjkxy(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt+1)=fjkxy(kdelt+1)+fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt-1)=fjkxy(kdelt-1)-fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif if(IBpar(ikl,3).gt.0)then do ir=IBpar(ikl,4),IBpar(ikl,3)+IBpar(ikl,4)-1 c clean the corresponding cells of the fjk array do kdelt=-ir,ir,2 fjkxy(kdelt+1)=0.d0 fjkxy(kdelt-1)=0.d0 enddo c calculate the fjk values for the necessary set of deltaK values do kdelt=-ir,ir,2 pkdelt=dfloat(kdelt) c check for K+kdelt+/-2 make sure that the current K+deltaK within J limits c check for fjk(kdelt).ne.0.d0 make sure that at the previous step the K+deltaK was within J limits if(K+kdelt+1.le.J.and.K+kdelt+1.ge.-J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt+1)=fjkxy(kdelt+1)+fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ-(pK+pKdelt))*(pJ+(pK+pkdelt)+1.d0)) if(K+kdelt-1.ge.-J.and.K+kdelt-1.le.J.and.fjkxy(kdelt).ne.0.d0)fjkxy(kdelt-1)=fjkxy(kdelt-1)+fjkxy(kdelt)* ! 0.5d0*DSQRT((pJ+(pK+pKdelt))*(pJ-(pK+pkdelt)+1.d0)) enddo enddo endif endif ! end of else part for if(IBpar(ikl,3)+IBpar(ikl,4).eq.0) c This takes into account imaginary unit from Jy and imaginary unit form sin if(IBpar(ikl,7).ne.0)then ciy=ciy*(0.d0,-1.d0) endif if(aimag(ciy).ne.0.d0)write(6,*)'problems with imaginary unit' fiy=real(ciy,8) c here we explicitly calculate K**q, to avoid ambiguity with 0**0 if(IBpar(ikl,2).eq.0)then pkq=1.d0 else pkq=pk**IBpar(ikl,2) endif if(IBpar(ikl,3).eq.0.and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0)then do ivt=1,nvt c do ivt=1,nvt c do K=-J,J c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c there is no torsional overlap integrals involved c H(n,n)=H(n,n)+pkq*pJJp*Bval(ikl)*Bcomp(ikl) if(Nstage(ikl).eq.2)then Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(ikl)*Bcomp(ikl) endif c this is for repeating operators if(Iprep(2,ikl).ne.0)then iks=Iprep(2,ikl) 15 if(Nstage(iks).eq.2)Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(iks)*Bcomp(iks) if(Iprep(2,iks).ne.0)then iks=Iprep(2,iks) goto 15 endif endif c this is for J dependents if(Jdep(2,ikl).ne.0)then iks=Jdep(2,ikl) pJmult=1.d0 16 pJmult=pJmult*pJJ c J dependence can not belong to first stage therefore we do not need to check Nstage(iks) Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(iks)*Bcomp(iks)*pJmult c here we check whether the Jdependent operator has eqauls c this is for repeating operators if(Iprep(2,iks).ne.0)then ikt=Iprep(2,iks) 17 Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(ikt)*Bcomp(ikt)*pJmult if(Iprep(2,ikt).ne.0)then ikt=Iprep(2,ikt) goto 17 endif endif c if Jdependent has its own Jdependent then consider it if(Jdep(2,iks).ne.0)then iks=Jdep(2,iks) goto 16 endif endif c this is for K dependents if(Kdep(2,ikl).ne.0)then iks=Kdep(2,ikl) pKmult=1.d0 26 pKmult=pKmult*pk*pk if(Nstage(iks).eq.2)Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(iks)*Bcomp(iks)*pKmult c here we check whether the Kdependent operator has eqauls c this is for repeating operators if(Iprep(2,iks).ne.0)then ikt=Iprep(2,iks) 27 if(Nstage(ikt).eq.2)Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(ikt)*Bcomp(ikt)*pKmult if(Iprep(2,ikt).ne.0)then ikt=Iprep(2,ikt) goto 27 endif endif c here we check whether the Kdependent parameter has J dependence if(Jdep(2,iks).ne.0)then ikt=Jdep(2,iks) pJmult=1.d0 36 pJmult=pJmult*pJJ c J dependence can not belong to first stage therefore we do not need to check Nstage(iks) Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(ikt)*Bcomp(ikt)*pJmult*pKmult c here we check whether the Jdependent operator has eqauls c this is for repeating operators if(Iprep(2,ikt).ne.0)then ikm=Iprep(2,ikt) 37 Aband(1,n)=Aband(1,n)+pkq*pJJp*Bval(ikm)*Bcomp(ikm)*pJmult*pKmult if(Iprep(2,ikm).ne.0)then ikm=Iprep(2,ikm) goto 37 endif endif c if Jdependent has its own Jdependent then consider it if(Jdep(2,ikt).ne.0)then ikt=Jdep(2,ikt) goto 36 endif endif c if Kdependent has its own Kdependent then consider it if(Kdep(2,iks).ne.0)then iks=Kdep(2,iks) goto 26 endif endif enddo else !we have overlaps ishm1=3*(IBpar(ikl,6)+IBpar(ikl,7)) ishm=ishm1/idelm ishpl=ishm ishmi=-ishm if(isigma.eq.3)then if(mod(IBpar(ikl,6),2).ne.0.or.mod(IBpar(ikl,7),2).ne.0)then ishm=(ishm1-3)/idelm c Nonzero only IBpar(ikl,6) or only IBpar(ikl,7) not both together c also we substract 3 in 3*(IBpar(ikl,6)+IBpar(ikl,7))-3)/idelm in order not to deal with remainings c when IBpar(ikl,6) or IBpar(ikl,7) is odd if(isigt.eq.0.or.isigt.eq.-1.or.isigt.eq.-2)then ishpl=ishm ishmi=-1-ishm endif if(isigt.eq.3.or.isigt.eq.1.or.isigt.eq.2)then ishpl=+1+ishm ishmi=-ishm endif endif endif if(IBpar(ikl,5).eq.0)then pms=1.d0 pmspl=1.d0 pmsmi=1.d0 endif do ivt=1,nvt c do ivt=1,nvt c do K=-J,J c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt c cycle over deltaK values do ir=1,IBpar(ikl,3)+IBpar(ikl,4)+1 c for n+k=0 deltaK=0 c for n+k=1 deltaK=+/-1 c for n+k=2 deltaK=+2,0,-2 c for n+k=3 deltaK=+3,+1,-1,-3 c for n+k=4 deltaK=+4,+2,0,-2,-4 kdelt=2*(ir-1)-(IBpar(ikl,3)+IBpar(ikl,4)) pkdelt=dfloat(kdelt) if(K+kdelt.lt.-J.or.K+kdelt.gt.J)cycle c here we explicitly calculate K**q, to avoid ambiguity with 0**0 if(IBpar(ikl,2).eq.0)then pkqpl=1.d0 else pkqpl=(pk+pkdelt)**IBpar(ikl,2) endif c for V3 isigt1 always eq isigt isigt1=isigt if(isigma.eq.3)then if(mod(IBpar(ikl,6),2).ne.0.or.mod(IBpar(ikl,7),2).ne.0)then isigt1=abs(abs(isigt)-3) if(mod(k+kdelt,2).ne.0)then if(isigr.eq.1.or.isigr.eq.2)isigt1=-isigt1 endif endif endif c cycle over all torsional states under consideration do idelvt=1,nvt c ndelt=n+kdelt+(2*J+1)*(idelvt-ivt) ndelt=n+kdelt*nvt+(idelvt-ivt) c here we fill only lower triangle if(ndelt.lt.n)cycle if(ndelt.lt.1.or.ndelt.gt.NDIMR)cycle c here we calculate corresponding overlap integral overlap=0.d0 overlap1=0.d0 overlap2=0.d0 do ikt=-ktronc,ktronc isum=ikt+ktronc+1 isumpl=isum+ishpl isummi=isum+ishmi if(IBpar(ikl,5).ne.0)then dm=dfloat(ikt*idelm+isigt) pms=dm**IBpar(ikl,5) dmpl=dm+dfloat(ishm1) pmspl=dmpl**IBpar(ikl,5) dmmi=dm-dfloat(ishm1) pmsmi=dmmi**IBpar(ikl,5) endif if(isumpl.le.Ndimto)then overlap=EVCTOR(isum,ivt,isigt,K)*EVCTOR(isumpl,idelvt,isigt1,K+kdelt) overlap1=overlap1+overlap*pmspl overlap2=overlap2+overlap*pms endif if(IBpar(ikl,7).eq.0)then if(isummi.ge.1)then overlap=EVCTOR(isum,ivt,isigt,K)*EVCTOR(isummi,idelvt,isigt1,K+kdelt) overlap1=overlap1+overlap*pmsmi overlap2=overlap2+overlap*pms endif else if(isummi.ge.1)then overlap=EVCTOR(isum,ivt,isigt,K)*EVCTOR(isummi,idelvt,isigt1,K+kdelt) overlap1=overlap1-overlap*pmsmi overlap2=overlap2-overlap*pms endif endif enddo !from overlap integral calculation overlap1=overlap1*pkqpl*fjkxy(kdelt) overlap2=overlap2*pkq*fjkyx(kdelt) overlap=overlap1+overlap2 if(Nstage(ikl).eq.2)then c H(ndelt,n)=H(ndelt,n)+pJJp*0.5d0*overlap*Bval(ikl)*Bcomp(ikl)*fiy Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(ikl)*Bcomp(ikl)*fiy endif c this is for repeated parameters if(Iprep(2,ikl).ne.0)then iks=Iprep(2,ikl) 10 if(Nstage(iks).eq.2)Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(iks)*Bcomp(iks)*fiy if(Iprep(2,iks).ne.0)then iks=Iprep(2,iks) goto 10 endif endif c this is for J dependents if(Jdep(2,ikl).ne.0)then iks=Jdep(2,ikl) 11 overlap=overlap*pJJ c J dependence can not belong to the first stage therefore we do not need to check Nstage(iks) Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(iks)*Bcomp(iks)*fiy c here we check whether the Jdependent operator has eqauls if(Iprep(2,iks).ne.0)then ikt=Iprep(2,iks) 12 Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(ikt)*Bcomp(ikt)*fiy if(Iprep(2,ikt).ne.0)then ikt=Iprep(2,ikt) goto 12 endif endif c if J dependent has its own J dependence consider it if(Jdep(2,iks).ne.0)then iks=Jdep(2,iks) goto 11 endif endif c this is for K dependents if(Kdep(2,ikl).ne.0)then iks=Kdep(2,ikl) 21 overlap1=overlap1*(pk+pkdelt)*(pk+pkdelt) overlap2=overlap2*pk*pk overlap=overlap1+overlap2 if(Nstage(iks).eq.2)Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(iks)*Bcomp(iks)*fiy c here we check whether the Kdependent operator has eqauls if(Iprep(2,iks).ne.0)then ikt=Iprep(2,iks) 22 if(Nstage(ikt).eq.2)Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(ikt)*Bcomp(ikt)*fiy if(Iprep(2,ikt).ne.0)then ikt=Iprep(2,ikt) goto 22 endif endif c this is for J dependents of K dependents if(Jdep(2,iks).ne.0)then ikt=Jdep(2,iks) 31 overlap=overlap*pJJ c J dependence can not belong to the first stage therefore we do not need to check Nstage(iks) Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(ikt)*Bcomp(ikt)*fiy c here we check whether the Jdependent operator has eqauls if(Iprep(2,ikt).ne.0)then ikm=Iprep(2,ikt) 32 Aband(1+ndelt-n,n)=Aband(1+ndelt-n,n)+pJJp*0.25d0*overlap*Bval(ikm)*Bcomp(ikm)*fiy if(Iprep(2,ikm).ne.0)then ikm=Iprep(2,ikm) goto 32 endif endif c if J dependent has its own J dependence consider it if(Jdep(2,ikt).ne.0)then ikt=Jdep(2,ikt) goto 31 endif endif c if K dependent has its own K dependence consider it if(Kdep(2,iks).ne.0)then iks=Kdep(2,iks) goto 21 endif endif enddo !from idelvt cycle enddo enddo !from ivt cycle endif !end of if statement for presence/absence of overlap integrals c contribution from the parameters of the first diagonalization step c we add it at the last moment since it is the biggest so if to add it at the beginning c we can loose some information because of round off errors. c H(n,n)=H(n,n)+ETORM(ivt,isigt,K) c Aband(1,n)=Aband(1,n)+ETORM(ivt,isigt,K) enddo !from K cycle enddo !from parameter cycle c This is to add dioganal contribution from the first stage do K=-J,J c this defines what sigma we should take c for even K the same as rotational c for odd K 0<->3 and 1<->2 isigt=isigr if(isigma.eq.3.and.mod(K,2).ne.0)then isigt=abs(isigr-3) if(isigr.eq.1.or.isigr.eq.2)isigt=-isigt endif do ivt=1,nvt c do ivt=1,nvt c do K=-J,J c n=(ivt-1)*(2*J+1)+K+J+1 n=ivt+(K+J)*nvt Aband(1,n)=Aband(1,n)+ETORM(ivt,isigt,K) enddo enddo c here we restore the full matrix (in fact tred2, tql2 need only lower rectangle). c do in=1,NDIMR c do it=in+1,NDIMR c H(in,it)=H(it,in) c enddo c enddo c here we restore H matrix from band for checking purpose c H=0.d0 c do in=1,kdband+1 c do it=1,ndimr+1-in c H(in+it-1,it)=Aband(in,it) c H(it,in+it-1)=H(in+it-1,it) c enddo c enddo c write(6,*)' J=',J,' isigr=',isigr c do in=1,ndimr c write(6,1009)(in-1)/nvt-J,mod(in-1,nvt) c do it=1,ndimr c write(6,1010)H(in,it) c enddo c write(6,1012) c enddo c1009 format(1x,'K=',I3,'vt=',I3,$) c1010 format(1x,E22.16,$) c1012 format() call DATE_AND_TIME(date,time,zone,values) c this is to assess time needed to setup rotational matrix valacc1=valacc1+(values-valinit) if(valacc1(8).ge.1000)then valacc1(7)=valacc1(7)+1 valacc1(8)=valacc1(8)-1000 endif if(valacc1(8).lt.0)then valacc1(7)=valacc1(7)-1 valacc1(8)=valacc1(8)+1000 endif if(valacc1(7).ge.60)then valacc1(6)=valacc1(6)+1 valacc1(7)=valacc1(7)-60 endif if(valacc1(7).lt.0)then valacc1(6)=valacc1(6)-1 valacc1(7)=valacc1(7)+60 endif if(valacc1(6).ge.60)then valacc1(5)=valacc1(5)+1 valacc1(6)=valacc1(6)-60 endif if(valacc1(6).lt.0)then valacc1(5)=valacc1(5)-1 valacc1(6)=valacc1(6)+60 endif call DATE_AND_TIME(date,time,zone,values) valinit=values c here is the routine from SBR package (2*kdband LDA in Aband is strongly recommended) JOBZband='U' drptol=0.d0 EGVC=0.d0 do in=1,ndimr EGVC(in,in)=1.d0 enddo NB=0 call DSBRDT( JOBZband,ndimr,min(kdband,ndimr-1),Aband,2*kdband+1,DRPTOL,EGVL,subdiagtri,EGVC,ndimr, NB, > WORK, 201*ndimr, INFO ) if(INFO.lt.0)then write(6,*)J,isigr,'error of reduction of the band matrix to tridiagonal form',info endif JOBZband='V' call dsteqr(JOBZband, ndimr, EGVL, subdiagtri, EGVC, ndimr, work, info) if(INFO.ne.0)then write(6,*)J,isigr,'error of diagonalizing tridiagonal matrix' endif call DATE_AND_TIME(date,time,zone,values) valacc=valacc+(values-valinit) if(valacc(8).ge.1000)then valacc(7)=valacc(7)+1 valacc(8)=valacc(8)-1000 endif if(valacc(8).lt.0)then valacc(7)=valacc(7)-1 valacc(8)=valacc(8)+1000 endif if(valacc(7).ge.60)then valacc(6)=valacc(6)+1 valacc(7)=valacc(7)-60 endif if(valacc(7).lt.0)then valacc(6)=valacc(6)-1 valacc(7)=valacc(7)+60 endif if(valacc(6).ge.60)then valacc(5)=valacc(5)+1 valacc(6)=valacc(6)-60 endif if(valacc(6).lt.0)then valacc(5)=valacc(5)-1 valacc(6)=valacc(6)+60 endif c search for the lowest energy level among calculated if(J.eq.0.or.J.eq.1)then ! it is assumed that from J=0 and 1 stacks we can get the lowest levels do ike=1,ndimr c we assume that we have positive energies and negative we obtain only for crazy parameters and c these crazy values are usually correspond to high torsional states if(Elowest.gt.EGVL(ike).and.EGVL(ike).ge.0.d0)Elowest=Egvl(ike) !we need elowest for blends at each iteration enddo c write(6,*)'Elowest=',Elowest,J,isigr c this is for the predictions in case of supersonic expansion if(itn.eq.Niter.or.Niter.eq.0)then if(ilowest.eq.1)then do ike=1,ndimr c we assume that we have positive energies and negative we obtain only for crazy parameters and c these crazy values are usually correspond to high torsional states if(Elst(isigr).gt.EGVL(ike).and.EGVL(ike).ge.0.d0)Elst(isigr)=Egvl(ike) !we need elowest for each symmetry in case of very low temperatures enddo endif endif endif c write(6,*)IERR c this printout is for H**2 checking c write(6,*)'isigr=',isigr,'J=',J c do in=1,ndimr c write(6,5000)EGVL(in),EGVL(in)+1.0d0*EGVL(in)**2 c enddo c5000 format('E=',E22.16,' E+eps*E**2=',E22.16,' eps=1.0d0') do in=1,NDIMR Erottor(in,isigr,num)=EGVL(in) do it=1,NDIMR EVCrottor(it,in,isigr,num)=EGVC(it,in) enddo enddo enddo !from isig cycle deallocate(work,Aband,subdiagtri) return end c In this subroutine the torsion part (first stage diagonalization) is considered. subroutine torsion() use param use calc use band integer ierr real*8 pkq, pms, pmspl, pmsmi,vrc(ndim),dfk,dfm,dfmpl,dfmmi UPLOband='U' allocate(work(2*ndimto),subdiagtri(ndimto-1),tau(ndimto)) allocate (H(ndimto,ndimto),EGVL(ndimto),EGVC(ndimto,ndimto),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif do isigt=0,isigma do k=-Jmax,Jmax c initialization of the matrices H=0.d0 dfk=dfloat(k) c setup the Hamiltonian matrix for the first diagonalization step do ikt=-ktronc,ktronc m=ikt*idelm+isigt dfm=dfloat(m) n=ikt+ktronc+1 do itm=1,Numpar c we consider parameters in order of their absolute value ikl=ispar(itm) c we consider only parameters belonging to the first stage if(Nstage(ikl).ne.1)cycle c here we determine whether the string to the composite parameter or not c deltam is determined by the cos(idelm*t*alfa) ndelt=(3*IBpar(ikl,6))/idelm dfmpl=dfloat(m+ndelt*idelm) dfmmi=dfloat(m-ndelt*idelm) c here we explicitly calculate K**q, to avoid ambiguity with 0**0 if(IBpar(ikl,2).eq.0)then pkq=1.0d0 else pkq=dfk**IBpar(ikl,2) endif c here we explicitly calculate m**s, to avoid ambiguity with 0**0 if(IBpar(ikl,5).eq.0)then pms=1.d0 pmspl=1.d0 pmsmi=1.d0 else pms=dfm**IBpar(ikl,5) pmspl=dfmpl**IBpar(ikl,5) pmsmi=dfmmi**IBpar(ikl,5) endif if(ndelt.ne.0)then if(n+ndelt.le.NDIMTO)then H(n+ndelt,n)=H(n+ndelt,n)+0.25d0*(pkq*pmspl+pkq*pms)*Bval(ikl)*Bcomp(ikl) endif if(n-ndelt.ge.1)then H(n-ndelt,n)=H(n-ndelt,n)+0.25d0*(pkq*pmsmi+pkq*pms)*Bval(ikl)*Bcomp(ikl) endif else if(ikl.eq.iklRHO.and.ispecFRHO.eq.1)then c special treatment of RHO parameter because of F*(palfa-RHO*Jz)**2=F*palfa**2+F*RHO**2*Jz**2-2F*RHO*palfa*Jz c F*palfa**2 we get automaticaly from our scheme but for RHO=0,1,0,0,1,0,0 we should make modifications c Rho is initially considered as not a composite parameter H(n,n)=H(n,n)+dfloat(k**2)*Bval(ikl)**2*Fval+2.d0*plmiRHO*Fval*Bval(ikl)*pkq*pms else c Bcomp takes into account composite parameters H(n,n)=H(n,n)+pkq*pms*Bval(ikl)*Bcomp(ikl) endif endif enddo !from parameter cycle enddo !from ikt cycle c print out matrix c write(6,*)' K=',K,' isigt=',isigt c do in=1,ndimto c do it=1,ndimto c write(6,1010)H(in,it) c enddo c write(6,1012) c enddo c1010 format(1x,E22.16,$) c1012 format() call dsytrd(uploband, ndimto, H, ndimto, EGVL, subdiagtri, tau, work, 2*ndimto, info) EGVC=H call dorgtr(uploband, ndimto, EGVC, ndimto, tau, work, 2*ndimto, info) JOBZband='V' call dsteqr(JOBZband, ndimto, EGVL, subdiagtri, EGVC, ndimto, work, info) c this printout is for H**2 checking c write(6,*)'isigt=',isigt,'K=',K c do in=1,ndimto c write(6,5000)EGVL(in),EGVL(in)+0.01d0*EGVL(in)**2 c enddo c5000 format('E=',E22.16,' E+eps*E**2=',E22.16,' eps=0.01d0') c write(6,*)'isigt=',isigt,'K=',K c do in=1,ndimto c write(6,5000)EGVL(in),EGVL(in)+0.01d0*EGVL(in)**2 c do it=1,ndimto c write(6,5001)(it-ktronc-1)*idelm+isigt,EGVC(it,in) c enddo c enddo c5001 format('m=',I5,' coef=',E22.16) c save eigenvalues and eigenvectors of nvt lowest states this is torsional approach do ivt=1,nvt ETORM(ivt,isigt,K)=EGVL(ivt) if(isigma.eq.3)then if(isigt.eq.1.or.isigt.eq.2)ETORM(ivt,-isigt,-K)=EGVL(ivt) endif c write(6,*)isigt,'k=',K,'ivt=',ivt do it=1,NDIMTO c write(6,*)EGVC(it,ivt) EVCTOR(it,ivt,isigt,K)=EGVC(it,ivt) if(isigma.eq.3)then if(isigt.eq.1.or.isigt.eq.2)EVCTOR(it,ivt,-isigt,-K)=EGVC(NDIMTO+1-it,ivt) endif enddo c if(isigt.eq.3)then c write(6,*)ivt,Egvl(ivt),'ivt, isigt, K',isigt,K c do it=1,ndimto c write(6,1212)(it-ktronc-1)*idelm+isigt,EGVC(it,ivt) c enddo c1212 format(I4,F12.5) c endif c do it=1,NDIMTO c vrc(it)=EGVC(it,ivt) c enddo c continue enddo enddo !from K cycle enddo !from isig cycle deallocate (H,EGVL,EGVC) deallocate(subdiagtri,work,tau) c stop !stop from a printing matrix part, to avoid problems with labeling during tests return end c sorting of the levels included in the fit subroutine levsort(in) c use msimsl use expdat use calc use param integer iperm(2*Ndat),ipt(2*Ndat),in Nlev=0 mlev=0 Jlev=0 itlev=0 intc=0 do i=1,Ndata c if in=0 then we consider only included levels c if in=-1 then we consider all levels if(in.eq.incl(i))cycle intc=intc+1 c now we save the information about fitted energy levels to speed up the calculation of the derivatives if(intc.eq.1)then !do not check for the first transition just save levels Nlev=Nlev+1 mlev(Nlev)=mq(1,i) Jlev(Nlev)=Jq(1,i) itlev(Nlev)=Ka(1,i)-Kc(1,i)+Jq(1,i)+1 Nlev=Nlev+1 mlev(Nlev)=mq(2,i) Jlev(Nlev)=Jq(2,i) itlev(Nlev)=Ka(2,i)-Kc(2,i)+Jq(2,i)+1 endif c if it is not the first transition then check whether the energy levels are already in the list c lower level iflev=0 do ikn=1,Nlev if(mlev(ikn).eq.mq(1,i).and.Jlev(ikn).eq.Jq(1,i).and.itlev(ikn).eq.Ka(1,i)-Kc(1,i)+Jq(1,i)+1)iflev=1 enddo if(iflev.eq.0)then Nlev=Nlev+1 mlev(Nlev)=mq(1,i) Jlev(Nlev)=Jq(1,i) itlev(Nlev)=Ka(1,i)-Kc(1,i)+Jq(1,i)+1 endif c upper level iflev=0 do ikn=1,Nlev if(mlev(ikn).eq.mq(2,i).and.Jlev(ikn).eq.Jq(2,i).and.itlev(ikn).eq.Ka(2,i)-Kc(2,i)+Jq(2,i)+1)iflev=1 enddo if(iflev.eq.0)then Nlev=Nlev+1 mlev(Nlev)=mq(2,i) Jlev(Nlev)=Jq(2,i) itlev(Nlev)=Ka(2,i)-Kc(2,i)+Jq(2,i)+1 endif enddo if(in.eq.0)then write(6,*)'Number of levels included in the fit =',Nlev elseif(in.eq.-1)then write(6,*)'Number of levels in all transitions =',Nlev endif c initialize iperm do i=1,nlev iperm(i)=i enddo c sort the Jlev array c CALL SVIBP (nlev,Jlev,Jlev,IPERM) call VSRTP (Jlev,nlev,IPerm) c permute in the same order mlev, itlev arrays do i=1,nlev ipt(i)=mlev(i) enddo do i=1,nlev mlev(i)=ipt(iperm(i)) enddo do i=1,nlev ipt(i)=itlev(i) enddo do i=1,nlev itlev(i)=ipt(iperm(i)) enddo c now we will determine the bounds for each J value and what isig are present for each J c if there is no fitted levels within given J we put 0,0 i=1 Jbound=0 mbound=0 nmaxlev=0 do J=0,Jmax if(Jlev(i).eq.J.and.Jbound(J,1).eq.0)Jbound(J,1)=i if(Jlev(i).eq.J.and.Jbound(J,2).eq.0)Jbound(J,2)=i do while(Jlev(i).eq.J) c here we dtermine whether degenrate nondegenerate species are present for each J isig=abs(mod(idelm*nvt+mlev(i),idelm)) if(isig.eq.0.or.isig.eq.3)mbound(0,J)=1 if(isig.eq.1.or.isig.eq.2)mbound(1,J)=1 i=i+1 if(i.gt.nlev)exit enddo if(Jbound(J,1).ne.0)Jbound(J,2)=i-1 if(nmaxlev.lt.Jbound(J,2)-Jbound(J,1)+1)nmaxlev=Jbound(J,2)-Jbound(J,1)+1 enddo write(6,*)'maximum number of levels among J stacks=',nmaxlev return end c here we sort the by J of the lower level all transitions from the input file c this is done in order to keep only J-1,J,J+1 eigen vectors at each J and reduce the size of arrays subroutine jsort() c use msimsl use expdat use param integer JS(Ndata+1),Jmaxup real*8 frsrt(Ndata+1) c this to determine maximum J among included lines JS=0 ip=0 do i=1,Ndata ip(i)=i JS(i)=Jq(2,i) enddo c sort the Jlev array c CALL SVIBP (Ndata,JS,JS,IP) call VSRTP (JS,Ndata,IP) Jmaxup=JS(Ndata) c now sort by J JS=0 ip=0 c initialize ip do i=1,Ndata ip(i)=i JS(i)=Jq(1,i) enddo c CALL SVIBP (Ndata,JS,JS,IP) call VSRTP (JS,Ndata,IP) c set Jmax equal to maximum J available in the data set if(JS(Ndata).gt.Jmaxup)Jmaxup=JS(Ndata) if(Jmax.gt.Jmaxup)then Jmax=Jmaxup write(6,*)'Maximum J among included lines is Jmax=',Jmax endif c now we will determine the bounds for each J value c if there is no levels within given J we put 0,0 i=1 Jbnd=0 do J=0,JS(Ndata) if(JS(i).eq.J.and.Jbnd(J,1).eq.0)Jbnd(J,1)=i if(JS(i).eq.J.and.Jbnd(J,2).eq.0)Jbnd(J,2)=i do while(JS(i).eq.J) i=i+1 if(i.gt.Ndata)exit enddo if(Jbnd(J,1).ne.0)Jbnd(J,2)=i-1 enddo c now we will sort by frequency in each J stack to provide treatment of degenerate transitions. do J=0,JS(Ndata) c if there are no transitions for particular J cycle if(Jbnd(J,1).eq.0)cycle frsrt=0.d0 ipfr=0 do i=Jbnd(J,1),Jbnd(J,2) if(incl(ip(i)).eq.1)frsrt(i-Jbnd(J,1)+1)=freqm(ip(i)) ipfr(i-Jbnd(J,1)+1)=ip(i) enddo c sort the frsrt array c CALL DSVRBP (Jbnd(J,2)-Jbnd(J,1)+1,frsrt,frsrt,ipfr) call VSRTPD (frsrt,Jbnd(J,2)-Jbnd(J,1)+1,ipfr) do i=Jbnd(J,1),Jbnd(J,2) ip(i)=ipfr(i-Jbnd(J,1)+1) enddo enddo c initialize ipfr frsrt=0.d0 ipfr=0 do i=1,Ndata ipfr(i)=i if(incl(i).eq.1)frsrt(i)=freqm(i) enddo c sort the frsrt array c CALL DSVRBP (Ndata,frsrt,frsrt,ipfr) call VSRTPD (frsrt,Ndata,ipfr) c count a number of blended lines iblines=0 jlines=0 ibldifj=0 ipbl=0 if(frsrt(1).eq.frsrt(2).and.frsrt(1).ne.0.d0)then iblines=1 if(unc(ipfr(1)).ne.unc(ipfr(2)))then if(unc(ipfr(1)).gt.0.d0)then write(6,*)'different uncertainties for the same line',frsrt(1)*29979.2458d0,'MHz' else write(6,*)'different uncertainties for the same line',frsrt(1),'cm-1' endif endif if(Jq(1,ipfr(1)).eq.Jq(1,ipfr(2)))then jlines=jlines+1 else ibldifj=ibldifj+1 ipbl(1)=ibldifj ipbl(2)=ibldifj endif endif incllines=0 if(incl(ipfr(1)).eq.1)incllines=1 do i=2,Ndata-1 c consider only included lines (at the sorting stage we have set to zero frequencies of excluded lines) if(frsrt(i).eq.0)cycle incllines=incllines+1 c if the frequencies are equal then a blended line if(frsrt(i).eq.frsrt(i+1))then iblines=iblines+1 incllines=incllines-1 if(unc(ipfr(i)).ne.unc(ipfr(i+1)))then if(unc(ipfr(i)).gt.0.d0)then write(6,*)'different uncertainties for the same line',frsrt(i)*29979.2458d0,'MHz' else write(6,*)'different uncertainties for the same line',frsrt(i),'cm-1' endif endif c it does not matter whether the Jq(2,...) will be equal since even if they not this blend may be treated without additional storage if(Jq(1,ipfr(i)).eq.Jq(1,ipfr(i+1)))then jlines=jlines+1 if(ipbl(ipfr(i)).ne.0)then ipbl(ipfr(i+1))=ibldifj jlines=jlines-1 endif else c this is for blends with different J if(ipbl(ipfr(i)).eq.0)then c if current transition was not marked as a blend with different J then it is a new blend with dif J ibldifj=ibldifj+1 ipbl(ipfr(i))=ibldifj ipbl(ipfr(i+1))=ibldifj c now we should check the situation when it is the last component of the large blend when c previous were blends with the same J ikt=1 do while (frsrt(i).eq.frsrt(i-ikt)) ipbl(ipfr(i-ikt))=ipbl(ipfr(i)) jlines=jlines-1 if(i-ikt.gt.1)then ikt=ikt+1 else exit endif enddo else c if current transition was already marked as blend with different J then it is next component of this blend ipbl(ipfr(i+1))=ipbl(ipfr(i)) endif !if(ipbl(ipfr(i)).eq.0) endif !if(Jq(1,ipfr(i)).eq.Jq(1,ipfr(i+1))) c if the frequency is equal to the previous one then this blended line already counted if(frsrt(i).eq.frsrt(i-1))then iblines=iblines-1 if(ipbl(ipfr(i)).eq.0)jlines=jlines-1 endif endif !if(frsrt(i).eq.frsrt(i+1)) enddo if(incl(ipfr(Ndata)).eq.1)incllines=incllines+1 write(6,*)'number of measured line frequencies among included=',incllines write(6,*)'number of lines corresponding to blended transitions=',iblines write(6,*)'number of lines corresponding to blends with the same J=',jlines write(6,*)'number of blends corresponding to different J=',ibldifj c output blends with different J c do ikl=1,Ndata c if(ipbl(ikl).ne.0)write(6,*)freqm(ikl)*29979.2458d0 c enddo return end c here we sort the parameters by their ahbsolute value to minimize the round off error in the setting of Hamiltonian matrix subroutine paramsort() c use msimsl use param real*8 Bparam(Numpar) Bparam=0.d0 ispar=0 c initialize the arrays for sorting do i=1,numpar ispar(i)=i if(Nfloat(i).lt.0)then c if it is a composite parameter then use the value of its leading term Bparam(i)=dabs(Bval(i+Nfloat(i))) else Bparam(i)=dabs(Bval(i)) endif enddo c sort the Bparam array c CALL DSVRBP (numpar,Bparam,Bparam,ispar) call VSRTPD (Bparam,numpar,ispar) do ikl=1,numpar c here we determine whether the string to the composite parameter or not if(Nfloat(ikl).lt.0)then c if this is a part of composite parameter then we should multiply by value of the leading parameter Bcomp(ikl)=Bval(ikl+Nfloat(ikl)) Bcompd(ikl)=Bval(ikl) else c if this is not a part fo composite parameter then we should multiply by 1.d0 final matrix elements Bcomp(ikl)=1.d0 Bcompd(ikl)=1.d0 endif enddo c analysis what is J and K dependences of low order parameters c the J dependence has preference above K dependence since it is easier to upgrade calculate matrix elements for it Jdep=0 Kdep=0 IPrep=0 do is=1,numpar-1 c do not consider dipole moment if(Nstage(is).eq.0)cycle if(Iprep(1,is).ne.0)cycle i=is 10 do ikl=i+1,numpar c do not consider dipole moment if(Nstage(ikl).eq.0)cycle if(Iprep(1,ikl).ne.0)cycle c this is for equal if(IBpar(ikl,1).eq.IBpar(i,1).and.IBpar(ikl,2).eq.IBpar(i,2).and.IBpar(ikl,3).eq.IBpar(i,3). ! and.IBpar(ikl,4).eq.IBpar(i,4).and.IBpar(ikl,5).eq.IBpar(i,5).and.IBpar(ikl,6).eq.IBpar(i,6). ! and.IBpar(ikl,7).eq.IBpar(i,7))then c operators i and ikl are the same c this shows the number of the first in a list Iprep(1,ikl)=i c this shows the number of next in a list Iprep(2,i)=ikl if(ikl.ne.numpar)then i=ikl goto 10 else exit endif endif enddo enddo do i=1,numpar c do not consider dipole moment if(Nstage(is).eq.0)cycle c J dependence only for first parameters among equal if(Iprep(1,i).ne.0)cycle do ikl=1,numpar c do not consider dipole moment if(Nstage(ikl).eq.0)cycle c J dependence only for first parameters among equal if(Iprep(1,ikl).ne.0)cycle if(ikl.eq.i)cycle c this is J dependence if(IBpar(ikl,1).eq.IBpar(i,1)+1.and.IBpar(ikl,2).eq.IBpar(i,2).and.IBpar(ikl,3).eq.IBpar(i,3). ! and.IBpar(ikl,4).eq.IBpar(i,4).and.IBpar(ikl,5).eq.IBpar(i,5).and.IBpar(ikl,6).eq.IBpar(i,6). ! and.IBpar(ikl,7).eq.IBpar(i,7))then c we have J dependence of parameter i c this shows the number of the lower order parameter Jdep(1,ikl)=i c this shows the number of J depndent parameter Jdep(2,i)=ikl endif enddo enddo do i=1,numpar c do not consider dipole moment if(Nstage(is).eq.0)cycle c K dependence only for first parameters among equal if(Iprep(1,i).ne.0)cycle c We do not consider K dependences of parameters which are J dependences of some other parameters if(Jdep(1,i).ne.0)cycle do ikl=1,numpar c do not consider dipole moment if(Nstage(ikl).eq.0)cycle c K dependence only for first parameters among equal if(Iprep(1,ikl).ne.0)cycle c We do not consider K dependences of parameters which are J dependences of some other parameters if(Jdep(1,ikl).ne.0)cycle if(ikl.eq.i)cycle c this is J dependence if(IBpar(ikl,1).eq.IBpar(i,1).and.IBpar(ikl,2).eq.IBpar(i,2)+2.and.IBpar(ikl,3).eq.IBpar(i,3). ! and.IBpar(ikl,4).eq.IBpar(i,4).and.IBpar(ikl,5).eq.IBpar(i,5).and.IBpar(ikl,6).eq.IBpar(i,6). ! and.IBpar(ikl,7).eq.IBpar(i,7))then c we have J dependence of parameter i c this shows the number of the lower order parameter Kdep(1,ikl)=i c this shows the number of J depndent parameter Kdep(2,i)=ikl endif enddo enddo return end c In this subroutine the input file is readed. subroutine inputdata() use predict use expdat use param use calc use svd use vint integer iord(0:20) c maximum deltaK value kdmax=0 Bslope=0.d0 ifitparam=0 c the file with input is called input.txt open(unit=5,file='input.txt',access='sequential',status='old') write(6,*)'Maximum allowed J=',Jmaxdim,', maximum allowed vt= 2' read(5,*)isigma,idelm if(isigma.eq.3)then nsigma=-2 elseif(isigma.eq.1)then nsigma=0 endif read(5,*)ktronc,nvt,ispecFRHO if(ispecFRHO.eq.1)then write(6,*)'F and RHO will be treated as F*(pa+RHO*Jz)**2' plmiRHO=1.d0 elseif(ispecFRHO.eq.-1)then write(6,*)'F and RHO will be treated as F*(pa-RHO*Jz)**2' plmiRHO=-1.d0 c everywhere we use ispecFRHO=0 or 1, so change from -1 to 1 (since sign already saved in plmiRHO) ispecFRHO=1 else write(6,*)'F and RHO parameters will be treated as Fpa**2+RHO*pa*Jz' endif c if nvt is negative then torsional states are selected on the base of eigenvector information c if nvt is positive torsional states are selected on the base of energy prdering only Ndimto=ktronc*2+1 c nvts*(2J+1) - number of states which will be searched by diagonalization routine nvts=9 read(5,*)Npar,Ndat,Ncatm,norder read(5,*)stol,ocmax write(6,*)'isigma=',isigma,' idelm=',idelm write(6,*)'ktronc =',ktronc write(6,*)'nvt= ',nvt write(6,*)'allowed number of parameters =',Npar write(6,*)'allowed number of lines =',Ndat write(6,*)'number of data categorires =',Ncatm c order should be even norder=(norder/2)*2 c not more than 14 if(norder.gt.14)norder=14 write(6,*)'maximum order of parameters n=l+m =',norder write(6,*)'relative change of rms for stopping criterium=',stol write(6,*) write(6,*)'maximum ratio of o-c to the measurement uncertainty' write(6,*)'allowed at the fitting stage (if larger then' write(6,*)'the transition is omitted from the fit) =',ocmax write(6,*) allocate (freqm(Ndat),unc(Ndat),weight(Ndat),Scat(Ncatm),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (mq(2,Ndat),Jq(2,Ndat),Ka(2,Ndat),Kc(2,Ndat),incl(Ndat),Incat(Ncatm),icat(Ndat),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (comment(Ndat),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (IBpar(Npar,7),Nfloat(Npar),Nstage(Npar),ispar(Npar),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (Bname(Npar),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (Bval(Npar),deltap(Npar),Bcomp(Npar),Bcompd(Npar),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif c pass by next six lines with comments read(5,*) read(5,*) read(5,*) read(5,*) read(5,*) read(5,*) do ikl=1,Npar read(5,*,err=1001,end=1001)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) if(Bname(ikl).eq.'&&&END')exit c if Nstage.eq.0 then it is dipole moment, for dipole moment special checks if(Nstage(ikl).eq.0)then c the dipole moments are not fitted if(Nfloat(ikl).ne.0)Nfloat(ikl)=0 c the x,y,z, components are specified by 1 in corresponding position if(IBpar(ikl,2)+IBpar(ikl,3)+IBpar(ikl,4).ne.1)then write(6,*)'You should specify what component of dipole moment you need' write(6,*)'Choose z,x,y component by putting 1 in 2, or 3, or 4 position' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif if(IBpar(ikl,6).ne.0.and.IBpar(ikl,7).ne.0)then write(6,*)'the cos(3talfa)*sin(3lalfa) terms are not allowed' write(6,*)'this term equivalent to the sum of two sin term' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif c check symmetry reuirememnts for dipole moment components if(isigma.eq.3)then if(IBpar(ikl,3).eq.1.and.mod(IBpar(ikl,6),2).ne.1)then write(6,*)'x component should be combined only with cos(3+6n)alfa term by symmetry' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif if(IBpar(ikl,4).eq.1.and.mod(IBpar(ikl,7),2).ne.1)then write(6,*)'y component should be combined only with sin(3+6n)alfa term by symmetry' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif if(IBpar(ikl,2).eq.1.and.mod(IBpar(ikl,6),2).ne.0)then write(6,*)'z component can be combined only with cos(6n*alfa) term by symmetry' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif elseif(isigma.eq.1)then if(IBpar(ikl,6).ne.0.and.IBpar(ikl,4).eq.1)then write(6,*)'y component can not be combined with cos3alfa by symmetry' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif if(IBpar(ikl,7).ne.0.and.IBpar(ikl,4).ne.1)then write(6,*)'sin3alfa by symmetry can be combined only with y component' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif if(IBpar(ikl,7).eq.0.and.IBpar(ikl,4).eq.1)then write(6,*)'y component can appear only with sin3alfa' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif c is everything ok go to next parameter write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) cycle endif c check whether the term is of A1 symmetry and whether it is invariant under time reversal operation if(isigma.eq.3)then c this is for time reversal if(mod(IBpar(ikl,2)+IBpar(ikl,3)+IBpar(ikl,4)+IBpar(ikl,5),2).ne.0)then write(6,*)'The following parameter does not satisfy time reversal operation:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif c this is for symmetry if(IBpar(ikl,7).eq.0)then c if IBpar(ikl,7).eq.0 then the factor because of sin is of A1 (since there is no sin at all) if(mod(IBpar(ikl,2)+IBpar(ikl,5),2).eq.0)then c the A2 terms Jz and palfa give A1 symmetry so the A1 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpar(ikl,3),2).ne.0.or.mod(IBpar(ikl,4)+IBpar(ikl,6),2).ne.0)then write(6,*)'The following parameter does not satisfy symmerty requirements:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif else c the A2 terms Jz and palfa give A2 symmetry so the A2 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpar(ikl,3),2).eq.0.or.mod(IBpar(ikl,4)+IBpar(ikl,6),2).eq.0)then write(6,*)'The following parameter does not satisfy symmerty requirements:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif !endif from if(mod(IBpar(ikl,2)+IBpar(ikl,5),2).eq.0)then else !else from if(IBpar(ikl,7).eq.0)then if(mod(IBpar(ikl,7),2).eq.0)then c if IBpar(ikl,7) even then the factor because of sin is of A2 if(mod(IBpar(ikl,2)+IBpar(ikl,5)+1,2).eq.0)then c the A2 terms Jz,palfa and sin3alfa give A1 symmetry so the A1 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpar(ikl,3),2).ne.0.or.mod(IBpar(ikl,4)+IBpar(ikl,6),2).ne.0)then write(6,*)'The following parameter does not satisfy symmerty requirements:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif else c the A2 terms Jz,palfa and sin3alfa give A2 symmetry so the A2 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpar(ikl,3),2).eq.0.or.mod(IBpar(ikl,4)+IBpar(ikl,6),2).eq.0)then write(6,*)'The following parameter does not satisfy symmerty requirements:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif !endif from if(mod(IBpar(ikl,2)+IBpar(ikl,5),2).eq.0)then elseif(mod(IBpar(ikl,7),2).ne.0)then c if IBpar(ikl,7) odd then the factor because of sin is of B2 if(mod(IBpar(ikl,2)+IBpar(ikl,5),2).eq.0)then c the A2 terms Jz,palfa give A1 symmetry so the A1 symmetry should give B terms Jx,Jy,cos3alfa, sin6alfa if(mod(IBpar(ikl,3)+IBpar(ikl,7),2).ne.0.or.mod(IBpar(ikl,4)+IBpar(ikl,6),2).ne.0)then write(6,*)'The following parameter does not satisfy symmerty requirements:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif else c the A2 terms Jz,palfa give A2 symmetry so the A2 symmetry should give B terms Jx,Jy,cos3alfa,sin6alfa if(mod(IBpar(ikl,3)+IBpar(ikl,7),2).eq.0.or.mod(IBpar(ikl,4)+IBpar(ikl,6),2).eq.0)then write(6,*)'The following parameter does not satisfy symmerty requirements:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif !endif from if(mod(IBpar(ikl,2)+IBpar(ikl,5),2).eq.0)then endif !endif from (mod(IBpar(ikl,7),2).eq.0) endif !end of IBpar(ikl,7).eq.0 elseif(isigma.eq.1)then c for V3 problem we should have even number for sum of powers of Jz, Jx, palfa and sin (since they all of A2 in G6) c here we should take into account that all sin are of A2 sin3alfa, sin6alfa etc. if(IBpar(ikl,7).ne.0)then if(mod(IBpar(ikl,2)+IBpar(ikl,3)+IBpar(ikl,5),2).eq.0)then write(6,*)'The following parameter is not allowed by symmetry:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif else if(mod(IBpar(ikl,2)+IBpar(ikl,3)+IBpar(ikl,5),2).ne.0)then write(6,*)'The following parameter is not allowed by symmetry:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif c and in addition the sum of powers of Jx,Jy,Jz,palfa should be even to satisfy time reversal requirememnt if(mod(IBpar(ikl,2)+IBpar(ikl,3)+IBpar(ikl,4)+IBpar(ikl,5),2).ne.0)then write(6,*)'The following parameter is not allowed by time reversal requirement:' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif c it is not allowed that both IBpar(ikl,6) and IBpar(ikl,7) are nonzero check this if(IBpar(ikl,6).ne.0.and.IBpar(ikl,7).ne.0)then write(6,*)'the cos(3talfa)*sin(3lalfa) terms are not allowed' write(6,*)'this term equivalent to the sum of two sin term' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) write(6,*)'so present this term as two terms containing: sin(3(t+l)alfa) and sin(3(t-l)alfa)' stop endif c check that for V6 in the first stage appear only even values of t in cos3talfa if(isigma.eq.3)then if(mod(IBpar(ikl,6),2).ne.0.and.Nstage(ikl).eq.1)then write(6,*)'The following parameter can not be put to the first stage' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) write(6,*)'It will be put in the second stage' Nstage(ikl)=2 endif if(IBpar(ikl,7).ne.0.and.Nstage(ikl).eq.1)then write(6,*)'The following parameter can not be put to the first stage' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) write(6,*)'It will be put in the second stage' Nstage(ikl)=2 endif endif c if the parameter is composed from operators coded by different strings check for consistency c the additional string is characterized by negative Nfloat(ikl) index c if(Nfloat(ikl).eq.-1)then Nfloat(ikl-1)should be 0 or 1 c if(Nfloat(ikl).eq.-2)then Nfloat(ikl-1)should be -1 c if(Nfloat(ikl).eq.-3)then Nfloat(ikl-1)should be -2 and so on c Also all strings should belong to the same stage if(Nfloat(ikl).lt.0)then if(ikl.eq.1)then write(6,*)'The list of parameters can not be started from non-leading part of composite operator' stop endif if(Nfloat(ikl)+1.lt.0)then c the previous string is not the leading parameter if(Nfloat(ikl)+1.ne.Nfloat(ikl-1))then write(6,*)'The order of strings in the composite operator is wrong' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif c the previous string is the leading parameter elseif(Nfloat(ikl)+1.eq.0)then if(Nfloat(ikl-1).lt.0)then write(6,*)'the previous parameters should be leading, but it is not' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) stop endif endif if(Nstage(ikl).ne.Nstage(ikl+Nfloat(ikl)))then write(6,*)'The stage of this part fo composite parameter differ from the stage of the leading operator' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) write(6,*)'It will be assigned the same stage as leading operator of this composite parameter' Nstage(ikl)=Nstage(ikl+Nfloat(ikl)) endif endif c check whether this parameter is allowed for the first stage of diagonalization c it allowed if it does not contain J**2n, Jx**n, Jy**k if(IBpar(ikl,1).ne.0.and.Nstage(ikl).eq.1.or.IBpar(ikl,3).ne.0. !and.Nstage(ikl).eq.1.or.IBpar(ikl,4).ne.0.and.Nstage(ikl).eq.1.or.IBpar(ikl,7).ne.0.and.Nstage(ikl).eq.1)then write(6,*)'The following parameter can not be put to the first stage' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) write(6,*)'It will be put in the second stage' Nstage(ikl)=2 cycle endif c determine maximum deltaK if(IBpar(ikl,3)+IBpar(ikl,4).gt.kdmax)kdmax=IBpar(ikl,3)+IBpar(ikl,4) c output the parameter which you have read write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) if(Nfloat(ikl).eq.1)ifitparam=ifitparam+1 cycle 1001 write(6,*)'An error occured in reading the parameters' stop enddo if(ikl-1.eq.Npar.and.Bname(ikl-1).ne.'&&&END')then write(6,*)'Too many parameters or missing &&&END statement' stop endif Numpar=ikl-1 write(6,*)'Number of fitted parameters= ',ifitparam c analysis of the set of parameters in order to determine number of parameters of different orders c order of complex parameter is determined by the highest order among components, therefore order of (1-cos3a) will be 2 ikl=1 iord=0 do while (ikl.le.Numpar) if(Nfloat(ikl).le.0)then c we analyze only included parameters ikl=ikl+1 cycle endif iparorder=IBpar(ikl,1)*2+IBpar(ikl,2)+IBpar(ikl,3)+IBpar(ikl,4)+IBpar(ikl,5)+IBpar(ikl,6)*2+IBpar(ikl,7)*2 c now we should check whether the parameter is composite if(ikl+1.le.Numpar)then is=1 do while (Nfloat(ikl+is).lt.0) iparorder1=IBpar(ikl+is,1)*2+IBpar(ikl+is,2)+IBpar(ikl+is,3)+IBpar(ikl+is,4)+ ! IBpar(ikl+is,5)+IBpar(ikl+is,6)*2+IBpar(ikl+is,7)*2 if(iparorder1.gt.iparorder)iparorder=iparorder1 if(ikl+is.eq.Numpar)exit is=is+1 enddo endif if(iparorder.le.20)then iord(iparorder)=iord(iparorder)+1 else write(6,*)'there are parameters of order greater than 20' write(6,1012)Bname(ikl),IBpar(ikl,1),IBpar(ikl,2),IBpar(ikl,3), ! IBpar(ikl,4),IBpar(ikl,5),IBpar(ikl,6),IBpar(ikl,7),Bval(ikl),Nstage(ikl),Nfloat(ikl) endif ikl=ikl+1 enddo write(6,*)'among fitted parameters we have:' do ikl=0,20 if(iord(ikl).eq.0)cycle write(6,*)iord(ikl),' parameters of ',ikl,' order' enddo c allocate arrays which will keep track of what is J and K dependence of what c Npar dimension is needed for testparam c the arrays are initialized in sortparam allocate (Jdep(2,Npar),Kdep(2,Npar),Iprep(2,Npar),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif c here we determine the size of the band for the linestrength calculation matrix H kdstrength=0 kdst=0 do is=1,numpar c consider only parameters that represent dipole moment components if(Nstage(is).ne.0)cycle if(IBpar(is,2).eq.1)then c muz component if(IBpar(is,6)+IBpar(is,7).eq.0)then c without cos/sin dependences kdst=0 else c with cos/sin dependences kdst=nvt-1 endif endif c mux,muy components if(IBpar(is,3).eq.1.or.IBpar(is,4).eq.1)then kdst=2*nvt-1 endif if(kdstrength.lt.kdst)kdstrength=kdst enddo do ikl=1,numpar c save RHO value for further special treatment of F derivative if(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.1.and.IBpar(ikl,3).eq.0. !and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.1.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0)then c this should be not a composite parameter to avoid confusion with AK6 terms if(ikl.lt.numpar)then if(Nfloat(ikl+1).ge.0)then RHO=Bval(ikl) iklRHO=ikl c Rho should be put at the first stage if(Nstage(ikl).ne.1)Nstage(ikl)=1 endif else c if it is the last parameter then it is single RHO=Bval(ikl) iklRHO=ikl c Rho should be put at the first stage if(Nstage(ikl).ne.1)Nstage(ikl)=1 endif endif c save F value for further special treatment of RHO if(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.0.and.IBpar(ikl,3).eq.0. !and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.2.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0)then c this should be not a composite parameter to avoid confusion with AK7 terms if(ikl.lt.numpar)then if(Nfloat(ikl+1).ge.0)then Fval=Bval(ikl) iklF=ikl c F should be put at the first stage if(Nstage(ikl).ne.1)Nstage(ikl)=1 endif else c if it is the last parameter then it is single Fval=Bval(ikl) iklF=ikl c F should be put at the first stage if(Nstage(ikl).ne.1)Nstage(ikl)=1 endif endif c if we decide to substarct (B+C)/2 we should comment next several lines if(IBpar(ikl,1).eq.1.and.IBpar(ikl,2).eq.0.and.IBpar(ikl,3).eq.0. !and.IBpar(ikl,4).eq.0.and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0)then c this should be not a composite parameter to avoid confusion with FV for example if(ikl.lt.numpar)then if(Nfloat(ikl+1).ge.0)then Bslope=Bslope+Bval(ikl) endif else c the last mean single Bslope=Bslope+Bval(ikl) endif endif c if(IBpar(ikl,1).eq.0.and.IBpar(ikl,2).eq.0.and.IBpar(ikl,3).eq.2.and.IBpar(ikl,4).eq.0. c !and.IBpar(ikl,5).eq.0.and.IBpar(ikl,6).eq.0.and.IBpar(ikl,7).eq.0.and.Nfloat(ikl).ge.0.and.ikl.lt.numpar)then c if(IBpar(ikl+1,1).eq.0.and.IBpar(ikl+1,2).eq.0.and.IBpar(ikl+1,3).eq.0.and.IBpar(ikl+1,4).eq.2. c !and.IBpar(ikl+1,5).eq.0.and.IBpar(ikl+1,6).eq.0.and.IBpar(ikl+1,7).eq.0.and.Nfloat(ikl+1).eq.-1)then c this should be all for a composite parameter to avoid confusion with c2 for example c if(ikl+1.lt.numpar)then c if(Nfloat(ikl+2).ge.0)then c Bslope=Bslope+Bval(ikl) c endif c else c the last mean waht we need c Bslope=Bslope+Bval(ikl) c endif c endif c endif enddo c check whether we have repeatition of the same operator in the list c for composite parameter it will spoil derivative (additional factor of 2) c for leading parameters it will give ill conditioned fit (linear dependence) c do itm=1,numpar-1 c do itl=itm+1,numpar c if(IBpar(itm,1).eq.IBpar(itl,1).and.IBpar(itm,2).eq.IBpar(itl,2).and. c ! IBpar(itm,3).eq.IBpar(itl,3).and.IBpar(itm,4).eq.IBpar(itl,4).and. c ! IBpar(itm,5).eq.IBpar(itl,5).and.IBpar(itm,6).eq.IBpar(itl,6).and. c ! IBpar(itm,7).eq.IBpar(itl,7))then c write(6,*)'There are two identical operators in the list' c write(6,1012)Bname(itm),IBpar(itm,1),IBpar(itm,2),IBpar(itm,3), c ! IBpar(itm,4),IBpar(itm,5),IBpar(itm,6),IBpar(itm,7),Bval(itm),Nstage(itm),Nfloat(itm) c write(6,1012)Bname(itl),IBpar(itl,1),IBpar(itl,2),IBpar(itl,3), c ! IBpar(itl,4),IBpar(itl,5),IBpar(itl,6),IBpar(itl,7),Bval(itl),Nstage(itl),Nfloat(itl) c write(6,*)'If they belong to one composite operator the derivative will be wrong' c write(6,*)'If these are two leading operators there will give linear correlation in the fit' c stop c endif c enddo c enddo write(6,*) read(5,*)Jmax if(Jmax.gt.Jmaxdim)then write(6,*)'The Jmax=',Jmax,' exceeds the maximum allowed ' write(6,*)'by array dimensions J value=',Jmaxdim stop endif write(6,*)'Jmax= ',Jmax read(5,*)Niter Nrobust=0 if(Niter.lt.0)then Niter=-Niter Nrobust=1 endif write(6,*)'Number of iterations=',Niter 1012 format(1x,A10,7I4,3x,E26.16,2I4) c read the necessary input data for predictions read(5,*)Temp,Strunc,Vinttrunc c if temperature is negative then use for each symmetry its own Elowest Temppred=Temp ilowest=0 if(Temp.lt.20.d0)then Temppred=dabs(Temp) c the analysis of blends is performed for room temperature Temp=300.d0 ilowest=1 endif c stat weights if(isigma.eq.3)then istweight=1 read(5,*)istweight(0),istweight(3),istweight(1),istweight(2) write(6,*)'Following statistical weights will be applied' write(6,1122)istweight(0),istweight(3),istweight(1),istweight(2) 1122 format(' A1/A2=',I4,3x,' B1/B2=',I4,3x,' E1=',I4,3x,' E2=',I4) elseif(isigma.eq.1)then istweight=1 read(5,*) endif read(5,*)Flower,Fupper,iMHz_or_cm read(5,*)Jlo,Jup,vtlo,vtup read(5,*)ipred, iexpect if(abs(ipred).eq.1)then if(vtup.gt.2)then write(6,*)'The vtup=',vtup,' exceeds the maximum allowed value= 2' vtup=2 endif if(Jup.gt.Jmaxdim)then write(6,*)'The Jup=',Jup,' exceeds the maximum allowed value=',Jmaxdim Jup=Jmaxdim endif if(Jlo.gt.Jup)Jlo=0 if(vtlo.gt.vtup)vtlo=0 write(6,*) write(6,*)'Predictions will be made with following parameters' write(6,2001)Temppred,Strunc,Vinttrunc if(ilowest.eq.1)then write(6,*)'For each symmetry its own lowest energy level will be used' endif write(6,2002)Flower,Fupper if(iMHz_or_cm.eq.0)then write(6,*)'Predictions in MHz' else write(6,*)'Predictions in cm-1' endif write(6,2003)Jlo,Jup,vtlo,vtup else write(6,*)'Temperature=',Temp endif 2001 format('Temperature=',F6.1,5x,'Linestregth cutoff=',E10.3,5x,'Intensity cutoff=',E10.3) 2002 format('Lower frequency=',F12.3,3x,'Upper frequency=',F12.3) 2003 format('Jlow=',I4,2x,'Jup=',I4,2x,'vtlow=',I4,2x,'vtup=',I4) write(6,*) c Now we read transition assignments, measured frequencies, weights, etc. c pass by next three lines with comments read(5,*) read(5,*) read(5,*) i=0 included=0 Nlev=0 Ncat=1 1014 format(F12.4,4I5,3x,4I5,6x,I1,3x,F8.4,1x,A12) c1014 format(F12.4,4I5,3x,4I5,6x,I1,3x,F7.3,1x,A12) do while (i.ne.Ndat) i=i+1 read(5,1014,err=1002,end=1002)freqm(i),mq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) c check whether it is an empty line in the input file or not if(freqm(i).eq.0.d0.and.unc(i).eq.0.d0.and.incl(i).eq.0.d0.and.mq(2,i).eq.0.and.Jq(2,i).eq.0. ! and.mq(1,i).eq.0.and.Jq(1,i).eq.0)then i=i-1 cycle endif c if J is negative stop read the data if(Jq(2,i).lt.0.or.Jq(1,i).lt.0)exit c if the transition do not fall in the quantum number range omit it if(Jq(2,i).gt.Jmax.or.Jq(1,i).gt.Jmax)then i=i-1 cycle endif c check the correspondence of Ka, Kc numbers with J Ka+Kc= J or J+1 if(Ka(2,i)+Kc(2,i).ne.Jq(2,i))then if(Ka(2,i)+Kc(2,i).ne.Jq(2,i)+1)then write(6,*)'wrong Ka, Kc labels' write(6,1115)freqm(i),mq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif endif if(Ka(1,i)+Kc(1,i).ne.Jq(1,i))then if(Ka(1,i)+Kc(1,i).ne.Jq(1,i)+1)then write(6,*)'wrong Ka, Kc labels' write(6,1115)freqm(i),mq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif endif 1115 format(F13.4,4I4,2x,4I4,I5,F10.4,1x,A12) c check now the uncertainty and calculate weight if(unc(i).ne.0.d0.and.incl(i).eq.1)then if(unc(i).gt.0.d0)then c microwave in MHz weight(i)=29979.2458d0**2/unc(i)**2 else c IR in cm-1 weight(i)=1.d0/unc(i)**2 endif c this is to decide which parameters are essential for a small fraction of high J high Ka transitions c weight(i)=(Jq(1,i)+1)*(Ka(1,i)+1)*29979.2458d0**2/unc(i)**2 elseif(unc(i).eq.0.d0.and.incl(i).eq.1)then write(6,*)'zero uncertainty for included line - the line excluded' write(6,1115)freqm(i),mq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) incl(i)=0 endif if(incl(i).ne.0)then included=included+1 c Now we divide the input lines included in the by categories according to their uncertainties c In order to have an opportunity to calculate standard deviation for each group of data if(i.eq.1)then Scat(1)=unc(1) icat(1)=1 if(unc(i).gt.0.d0)then c if in MHz then convert freqm(i)=freqm(i)/29979.2458D0 unc(i)=unc(i)/29979.2458D0 endif cycle endif iflag=0 do ik=1,Ncat if(unc(i).eq.Scat(ik))then iflag=1 icat(i)=ik endif enddo if(iflag.eq.0)then Ncat=Ncat+1 if(Ncat.gt.Ncatm)then write(6,*)'There are more sets of data with different uncertainites' write(6,*)'than allowed=',Ncatm stop endif Scat(Ncat)=unc(i) icat(i)=Ncat endif endif c convert the frequency to wave numbers to be consistent with parameter units if(unc(i).gt.0.d0)then c if in MHz then convert freqm(i)=freqm(i)/29979.2458D0 unc(i)=unc(i)/29979.2458D0 endif enddo if(i.eq.Ndat)then write(6,*)' There are more lines with J<=Jmax in the input file than it is reserved' write(6,*)' in corresponding array, Ndatmax=',Ndat stop endif 1002 Ndata=i-1 write(6,*)'Number of transitions in the file with J<=Jmax =',Ndata write(6,*)'Number of included in the fit transitions =',included if(included.lt.Numpar)then write(6,*)'There are less included lines =',included write(6,*)'in the fit than fitted parameters =',numpar write(6,*)'A calculation will be done, number of iterations is set to zero' endif ndim=(2*Jmax+1)*nvt allocate (Jlev(2*Ndata+1),mlev(2*Ndata),itlev(2*Ndata),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (mbound(0:1,0:Jmax),Jbnd(0:Jmax,2),ip(Ndata),ipfr(Ndata),ipbl(Ndata),frlastcal(Ndata),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif c initializing ipbl ipbl=0 allocate (nv012(0:isigma,0:Jmax,0:2,2*Jmax+1),Jbound(0:Jmax,2),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (Etorm(nvt,nsigma:isigma,-Jmax:Jmax),Evctor(Ndimto,nvt,nsigma:isigma,-Jmax:Jmax),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (Erottor(ndim,0:isigma,0:2),Evcrottor(ndim,ndim,0:isigma,0:2),parAB(ndim,0:isigma,0:2),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif allocate (A(numpar,numpar),Asvd(numpar,numpar),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif i=0 call levsort(i) call jsort() call paramsort() allocate (drvacc(numpar,ibldifj),fracc(ibldifj),sintacc(ibldifj),weightbl(ibldifj), ! frblend(ibldifj),icatbl(ibldifj),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif c fill in the data for blended lines do ikl=1,Ndata if(ipbl(ikl).ne.0)then weightbl(ipbl(ikl))=weight(ikl) frblend(ipbl(ikl))=freqm(ikl) icatbl(ipbl(ikl))=icat(ikl) endif enddo allocate (drv(numpar,nmaxlev,0:2),levnum(2,nmaxlev),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif close(5) return end c this subroutine generates a list of the allowed by symmetry parameters subroutine allowedparam() use param use paramtest norder1=norder write(10,*)'maximum order of parameters n=l+m =',norder1 Npardim=0 do n=1,norder1/2 Npardim=Npardim+8*n**3+2*n enddo allocate (IBpartest(Npardim,7),Nfloattest(Npardim),Nstagetest(Npardim),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif allocate (Bnametest(Npardim),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif allocate (Bvaltest(Npardim),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif c clear the storage for parameters IBpartest=0 Nfloattest=0 Nstagetest=0 Bnametest='test ' Bvaltest=0.d0 write(10,*) write(10,*)'Parameters allowed in the Hamiltonian' c now we consider parameters allowed in Hamiltonian ikl=0 do ikl1=0,norder1/2 do ikl2=0,norder1 do ikl3=0,norder1 do ikl4=0,norder1 do ikl5=0,norder1 do ikl6=0,norder1/2 do ikl7=0,norder1/2 if(ikl1*2+ikl2+ikl3+ikl4+ikl5+ikl6*2+ikl7*2.gt.norder1)cycle ikl=ikl+1 Bnametest(ikl)='test ' IBpartest(ikl,1)=ikl1 IBpartest(ikl,2)=ikl2 IBpartest(ikl,3)=ikl3 IBpartest(ikl,4)=ikl4 IBpartest(ikl,5)=ikl5 IBpartest(ikl,6)=ikl6 IBpartest(ikl,7)=ikl7 Bvaltest(ikl)=0.d0 Nstagetest(ikl)=2 Nfloattest(ikl)=0 c check whether the term is of A1 symmetry and whether it is invariant under time reversal operation if(isigma.eq.3)then c this is for time reversal if(mod(IBpartest(ikl,2)+IBpartest(ikl,3)+IBpartest(ikl,4)+IBpartest(ikl,5),2).ne.0)then ikl=ikl-1 cycle endif c this is for symmetry if(IBpartest(ikl,7).eq.0)then c if IBpartest(ikl,7).eq.0 then the factor because of sin is of A1 (since there is no sin at all) if(mod(IBpartest(ikl,2)+IBpartest(ikl,5),2).eq.0)then c the A2 terms Jz and palfa give A1 symmetry so the A1 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpartest(ikl,3),2).ne.0.or.mod(IBpartest(ikl,4)+IBpartest(ikl,6),2).ne.0)then ikl=ikl-1 cycle endif else c the A2 terms Jz and palfa give A2 symmetry so the A2 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpartest(ikl,3),2).eq.0.or.mod(IBpartest(ikl,4)+IBpartest(ikl,6),2).eq.0)then ikl=ikl-1 cycle endif endif !endif from if(mod(IBpartest(ikl,2)+IBpartest(ikl,5),2).eq.0)then else !else from if(IBpartest(ikl,7).eq.0)then if(mod(IBpartest(ikl,7),2).eq.0)then c if IBpartest(ikl,7) even then the factor because of sin is of A2 if(mod(IBpartest(ikl,2)+IBpartest(ikl,5)+1,2).eq.0)then c the A2 terms Jz,palfa and sin3alfa give A1 symmetry so the A1 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpartest(ikl,3),2).ne.0.or.mod(IBpartest(ikl,4)+IBpartest(ikl,6),2).ne.0)then ikl=ikl-1 cycle endif else c the A2 terms Jz,palfa and sin3alfa give A2 symmetry so the A2 symmetry should give B terms Jx,Jy,cos3alfa if(mod(IBpartest(ikl,3),2).eq.0.or.mod(IBpartest(ikl,4)+IBpartest(ikl,6),2).eq.0)then ikl=ikl-1 cycle endif endif !endif from if(mod(IBpartest(ikl,2)+IBpartest(ikl,5),2).eq.0)then elseif(mod(IBpartest(ikl,7),2).ne.0)then c if IBpartest(ikl,7) odd then the factor because of sin is of B2 if(mod(IBpartest(ikl,2)+IBpartest(ikl,5),2).eq.0)then c the A2 terms Jz,palfa give A1 symmetry so the A1 symmetry should give B terms Jx,Jy,cos3alfa, sin6alfa if(mod(IBpartest(ikl,3)+IBpartest(ikl,7),2).ne.0.or.mod(IBpartest(ikl,4)+IBpartest(ikl,6),2).ne.0)then ikl=ikl-1 cycle endif else c the A2 terms Jz,palfa give A2 symmetry so the A2 symmetry should give B terms Jx,Jy,cos3alfa,sin6alfa if(mod(IBpartest(ikl,3)+IBpartest(ikl,7),2).eq.0.or.mod(IBpartest(ikl,4)+IBpartest(ikl,6),2).eq.0)then ikl=ikl-1 cycle endif endif !endif from if(mod(IBpartest(ikl,2)+IBpartest(ikl,5),2).eq.0)then endif !endif from (mod(IBpartest(ikl,7),2).eq.0) endif !end of IBpartest(ikl,7).eq.0 elseif(isigma.eq.1)then c for V3 problem we should have even number for sum of powers of Jz, Jx, palfa and sin (since they all of A2 in G6) c here we should take into account that all sin are of A2 sin3alfa, sin6alfa etc. if(IBpartest(ikl,7).ne.0)then if(mod(IBpartest(ikl,2)+IBpartest(ikl,3)+IBpartest(ikl,5),2).eq.0)then ikl=ikl-1 cycle endif else if(mod(IBpartest(ikl,2)+IBpartest(ikl,3)+IBpartest(ikl,5),2).ne.0)then ikl=ikl-1 cycle endif endif c and in addition the sum of powers of Jx,Jy,Jz,palfa should be even to satisfy time reversal requirememnt if(mod(IBpartest(ikl,2)+IBpartest(ikl,3)+IBpartest(ikl,4)+IBpartest(ikl,5),2).ne.0)then ikl=ikl-1 cycle endif endif ! end from isigma if c it is not allowed that both IBpartest(ikl,6) and IBpartest(ikl,7) are nonzero check this if(IBpartest(ikl,6).ne.0.and.IBpartest(ikl,7).ne.0)then ikl=ikl-1 cycle endif c determine maximum deltaK if(IBpartest(ikl,3)+IBpartest(ikl,4).gt.kdmax)kdmax=IBpartest(ikl,3)+IBpartest(ikl,4) c determine whether this parameter already used or not do ist=1,numpar if(IBpartest(ikl,1).eq.IBpar(ist,1).and.IBpartest(ikl,2).eq.IBpar(ist,2).and.IBpartest(ikl,3).eq.IBpar(ist,3).and. ! IBpartest(ikl,4).eq.IBpar(ist,4).and.IBpartest(ikl,5).eq.IBpar(ist,5).and.IBpartest(ikl,6).eq.IBpar(ist,6).and. ! IBpartest(ikl,7).eq.IBpar(ist,7))then Nfloattest(ikl)=1 exit endif enddo enddo enddo enddo enddo enddo enddo enddo Numpartest=ikl write(10,*)'We output J**2, J**4 etc. terms but we do not count them' write(10,*)'since they can be obtained as linear combinations of other terms' do n=0,norder1 inumber=0 do ikl=1,Numpartest ir=IBpartest(ikl,1)*2+IBpartest(ikl,2)+IBpartest(ikl,3)+IBpartest(ikl,4) it=IBpartest(ikl,5)+IBpartest(ikl,6)*2+IBpartest(ikl,7)*2 in=ir+it if(in.ne.n)cycle c for counting purposes we do not count terms which contain J**2, J**4 etc. since they can be obtained by linear combination c of other terms containing Jx**2, Jy**2, Jz**2 if(IBpartest(ikl,1).eq.0)inumber=inumber+1 c output the parameter which you have found write(10,1014)Bnametest(ikl),IBpartest(ikl,1),IBpartest(ikl,2),IBpartest(ikl,3), ! IBpartest(ikl,4),IBpartest(ikl,5),IBpartest(ikl,6),IBpartest(ikl,7),Bvaltest(ikl),Nstagetest(ikl),Nfloattest(ikl),in,it,ir enddo write(10,*)'Number of linear independent terms of ',n,' order is ',inumber write(10,*) enddo 1014 format(A10,2x,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',E26.17,1x,','I4,',',I6,',',5x,3I4) return end C Sorting routine SUBROUTINE VSRTPD (A,LA,IR) C SPECIFICATIONS FOR ARGUMENTS INTEGER LA,IR(LA) DOUBLE PRECISION A(LA) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER IU(21),IL(21),I,M,J,K,IJ,IT,L,ITT DOUBLE PRECISION T,TT REAL R C FIRST EXECUTABLE STATEMENT C FIND ABSOLUTE VALUES OF ARRAY A IF (LA.LE.0) RETURN DO 5 I=1,LA IF (A(I) .LT. 0.0) A(I)=-A(I) 5 CONTINUE M=1 I=1 J=LA R=.375 10 IF (I .EQ. J) GO TO 55 15 IF (R .GT. .5898437) GO TO 20 R=R+3.90625E-2 GO TO 25 20 R=R-.21875 25 K=I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ=I+(J-I)*R T=A(IJ) IT=IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I) .LE. T) GO TO 30 A(IJ)=A(I) A(I)=T T=A(IJ) IR(IJ)=IR(I) IR(I)=IT IT=IR(IJ) 30 L=J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (A(J) .GE. T) GO TO 40 A(IJ)=A(J) A(J)=T T=A(IJ) IR(IJ)=IR(J) IR(J)=IT IT=IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I) .LE. T) GO TO 40 A(IJ)=A(I) A(I)=T T=A(IJ) IR(IJ)=IR(I) IR(I)=IT IT=IR(IJ) GO TO 40 35 IF (A(L).EQ.A(K)) GO TO 40 TT=A(L) A(L)=A(K) A(K)=TT ITT=IR(L) IR(L)=IR(K) IR(K)=ITT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 40 L=L-1 IF (A(L) .GT. T) GO TO 40 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 45 K=K+1 IF (A(K) .LT. T) GO TO 45 C INTERCHANGE THESE ELEMENTS IF (K .LE. L) GO TO 35 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I .LE. J-K) GO TO 50 IL(M)=I IU(M)=L I=K M=M+1 GO TO 60 50 IL(M)=K IU(M)=J J=L M=M+1 GO TO 60 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 55 M=M-1 IF (M .EQ. 0) RETURN I=IL(M) J=IU(M) 60 IF (J-I .GE. 11) GO TO 25 IF (I .EQ. 1) GO TO 10 I=I-1 65 I=I+1 IF (I .EQ. J) GO TO 55 T=A(I+1) IT=IR(I+1) IF (A(I) .LE. T) GO TO 65 K=I 70 A(K+1)=A(K) IR(K+1)=IR(K) K=K-1 IF (T .LT. A(K)) GO TO 70 A(K+1)=T IR(K+1)=IT GO TO 65 END c my modification for sorting integer array by absolute value C SUBROUTINE VSRTP (A,LA,IR) C SPECIFICATIONS FOR ARGUMENTS INTEGER LA,IR(LA) integer A(LA) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER IU(21),IL(21),I,M,J,K,IJ,IT,L,ITT REAL R integer T,TT C FIRST EXECUTABLE STATEMENT C FIND ABSOLUTE VALUES OF ARRAY A IF (LA.LE.0) RETURN DO 5 I=1,LA IF (A(I) .LT. 0) A(I)=-A(I) 5 CONTINUE M=1 I=1 J=LA R=.375 10 IF (I .EQ. J) GO TO 55 15 IF (R .GT. .5898437) GO TO 20 R=R+3.90625E-2 GO TO 25 20 R=R-.21875 25 K=I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ=I+(J-I)*R T=A(IJ) IT=IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I) .LE. T) GO TO 30 A(IJ)=A(I) A(I)=T T=A(IJ) IR(IJ)=IR(I) IR(I)=IT IT=IR(IJ) 30 L=J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (A(J) .GE. T) GO TO 40 A(IJ)=A(J) A(J)=T T=A(IJ) IR(IJ)=IR(J) IR(J)=IT IT=IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I) .LE. T) GO TO 40 A(IJ)=A(I) A(I)=T T=A(IJ) IR(IJ)=IR(I) IR(I)=IT IT=IR(IJ) GO TO 40 35 IF (A(L).EQ.A(K)) GO TO 40 TT=A(L) A(L)=A(K) A(K)=TT ITT=IR(L) IR(L)=IR(K) IR(K)=ITT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 40 L=L-1 IF (A(L) .GT. T) GO TO 40 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 45 K=K+1 IF (A(K) .LT. T) GO TO 45 C INTERCHANGE THESE ELEMENTS IF (K .LE. L) GO TO 35 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I .LE. J-K) GO TO 50 IL(M)=I IU(M)=L I=K M=M+1 GO TO 60 50 IL(M)=K IU(M)=J J=L M=M+1 GO TO 60 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 55 M=M-1 IF (M .EQ. 0) RETURN I=IL(M) J=IU(M) 60 IF (J-I .GE. 11) GO TO 25 IF (I .EQ. 1) GO TO 10 I=I-1 65 I=I+1 IF (I .EQ. J) GO TO 55 T=A(I+1) IT=IR(I+1) IF (A(I) .LE. T) GO TO 65 K=I 70 A(K+1)=A(K) IR(K+1)=IR(K) K=K-1 IF (T .LT. A(K)) GO TO 70 A(K+1)=T IR(K+1)=IT GO TO 65 END c i have corrected to deal with integers C SUBROUTINE VSRTR (A,LA,IR) C SPECIFICATIONS FOR ARGUMENTS INTEGER LA,IR(*) integer A(*) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER IU(21),IL(21),I,M,J,K,IJ,IT,L,ITT REAL R integer T,TT C FIRST EXECUTABLE STATEMENT IF (LA.LE.0) RETURN M = 1 I = 1 J = LA R = .375 5 IF (I.EQ.J) GO TO 45 IF (R.GT..5898437) GO TO 10 R = R+3.90625E-2 GO TO 15 10 R = R-.21875 15 K = I C SELECT A CENTRAL ELEMENT OF THE C ARRAY AND SAVE IT IN LOCATION T IJ = I+(J-I)*R T = A(IJ) IT = IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I).LE.T) GO TO 20 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) 20 L = J C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T IF (A(J).GE.T) GO TO 30 A(IJ) = A(J) A(J) = T T = A(IJ) IR(IJ) = IR(J) IR(J) = IT IT = IR(IJ) C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T IF (A(I).LE.T) GO TO 30 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) GO TO 30 25 IF (A(L).EQ.A(K)) GO TO 30 TT = A(L) A(L) = A(K) A(K) = TT ITT = IR(L) IR(L) = IR(K) IR(K) = ITT C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T 30 L = L-1 IF (A(L).GT.T) GO TO 30 C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T 35 K = K+1 IF (A(K).LT.T) GO TO 35 C INTERCHANGE THESE ELEMENTS IF (K.LE.L) GO TO 25 C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED IF (L-I.LE.J-K) GO TO 40 IL(M) = I IU(M) = L I = K M = M+1 GO TO 50 40 IL(M) = K IU(M) = J J = L M = M+1 GO TO 50 C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY 45 M = M-1 IF (M.EQ.0) RETURN I = IL(M) J = IU(M) 50 IF (J-I.GE.11) GO TO 15 IF (I.EQ.1) GO TO 5 I = I-1 55 I = I+1 IF (I.EQ.J) GO TO 45 T = A(I+1) IT = IR(I+1) IF (A(I).LE.T) GO TO 55 K = I 60 A(K+1) = A(K) IR(K+1) = IR(K) K = K-1 IF (T.LT.A(K)) GO TO 60 A(K+1) = T IR(K+1) = IT GO TO 55 END * * ********************************************************************** * SUBROUTINE DSBRDT( JOB, N, B, A, LDA, DRPTOL, > D, E, > U, LDU, NB, > WORK, LWORK, INFO ) * * ---------------------------------------------------------------------- * * Description: * * Given a symmetric n-by-n matrix A with b sub(or super-) diagonals, * dsbrdt reduces A to tridiagonal form using a sequence of orthogonal * similarity transformations. If desired, the same transformations are * also applied from the right to the matrix U. That is, if initially U * was the identity, then the resulting tridiagonal matrix T and the * updated U fulfill the equation * * T * U * A * U = T . * * A must be given in the LAPACK packed storage scheme for lower * triangular banded matrices. * * Author: Bruno Lang * Aachen University of technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Parameters: * CHARACTER*1 JOB INTEGER N, B, LDA, LDU, NB, LWORK, INFO DOUBLE PRECISION DRPTOL DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), U( LDU, * ), > WORK( * ) * * job (in) character*1 * Specifies whether U is required or not. * job = 'U' : Update U. * = 'N' : Do not update U. * * n (in) integer * The order of the matrix A. * n >= 0. * * b (in) integer * The number of sub(super-)diagonals of A. * 0 <= b < n, if n >= 1. * b = 0 , if n = 0. * * a (in/out) double precision array, dimension ( lda, n ) * On entry, this array contains the symmetric matrix A. The * leading ( b+1 )-by-n part of a contains the lower triangle * of A with A( i, j ) stored in a( 1+i-j, j ), and the * strictly upper triangle is not referenced. * On exit, for i = 1, ..., min( 2*b, n, lda ), the first * n - i + 1 elements in the i-th row of a are destroyed. * * lda (in) integer * The leading dimension of the array a. * lda >= b+1. * For optimum performance, we recommend lda >= 2*b. * * drptol (in) double precision * The threshold for dropping Householder transformations: if * the norm of the vector to be eliminated is already smaller * than drptol then the transform is skipped. * drptol >= 0.0. * If you do not know, use 0.0. * * d (out) double precision array, dimension ( n ) * On exit, d( 1 .. n ) contains the main diagonal of the * reduced tridiagonal matrix. * * e (out) double precision array, dimension ( n-1 ) * On exit, e( 1 .. n-1 ) contains the sub(super-)diagonal of * the reduced tridiagonal matrix. * * u (in/out) double precision array, dimension ( ldu, n ) * On entry, u contains some n-by-n matrix U. * On exit, U is postmultiplied with all orthogonal transforms * that were used to reduce the bandwidth of A. * Accessed only if the update of U is required. * * ldu (in) integer * The leading dimension of the array u. * ldu >= max( n, 1 ). * * nb (in) integer * The blocking factor nb, as suggested by the user, for the * update of U (nb is accessed only if U is required). * nb >= 0. * = 0 : User does not know how many Householder transforms * should be blocked for reasonable performance. Let * the routine figure it out (depending on the * workspace available). * = 1 : Do not block the update of U. * > 1 : Try to block nb Householder transforms (if the * workspace is not sufficient then a smaller * blocking factor will be used). * * work (workspace) double precision array, dimension ( lwork ) * * lwork (in) integer * The size of the workspace (must be provided on entry). * If lda >= 2*b, then * lwork >= 2 * b, if U is not required. * lwork >= b + n, if U is required and is updated with * non-blocked Householder transforms. * lwork >= 2 * nb * ( n + b + nb - 1 ), if U is updated * with nb-blocked transforms. * If lda < 2*b, then ADDITIONAL ( n/b + 1 )*szsub + nsave * elements of workspace are needed to buffer * intermediate elements. Here, nsave = 2*b-lda, * and szsub = (nsave*(nsave-1))/2. * Note that this is roughly n*(2*b-lda)/2 * elements. * * info (out) integer * On exit, info indicates the consistence of the arguments. * info = - 1 : job is none of 'U', 'N' (upper/lower case). * = - 2 : n is out of range (negative). * = - 3 : b is out of range (negative or * >= n, while n > 0 ). * = - 5 : lda is too small ( < min( b+1, n ) ). * = - 6 : drptol is out of range (negative). * = -10 : ldu is too small ( < n or < 1 ). * = -11 : nb is out of range (negative). * = -13 : workspace is too small (see above). * info >= 1 : All arguments are OK. * In this case, info returns the blocking factor * that was used in the update of U (if job='U'), * or info = 1 (if job='N'). * * ---------------------------------------------------------------------- * * Local variables: * * --- constants --- * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * * --- for the reduction part --- * INTEGER NSAVE, NSAVE1, IDIAG, ISUB, SZSUB, ID, IC, > IX, NBLK, HEIGHT, WIDTH, K, J, I, J0 DOUBLE PRECISION TAU * * nsave the number of diagonals that must be saved * nsave1 = nsave + 1 * idiag points to the portion of the workspace that holds the part * of the current diagonal block of the band * isub points to the portion of the workspace that holds the part * of the subdiagonal blocks of the band * szsub number of elements that must be saved from each subdiagonal * block * id diagonal position of the element to save * ic column position of the element to save * ix position in the workspace for saving the element * nblk number of the block to process next * height height of the block to process next * width width of the subdiagonal block * k numbers the columns to be eliminated * j counter for the "progress" of the bulge chasing * tau scaling factor of the current Householder transform * * --- for updating U --- * LOGICAL NEEDU, BLOCK, ONFLY INTEGER NB0, IV, IY, IW, ITAU, IWORK, LDWY0, > K0, IFIRST, NB1, LDWY, NB2, V DOUBLE PRECISION BETA * * needu is U needed ? * block is U needed, and is there enough workspace for blocking the * updates ? * onfly is U needed, and is blocking prohibited by small workspace ? * nb0 blocking factor that is ultimately used in the update * iv points to the portion of work that will hold the Householder * vectors for nb consecutive "eliminate & chase" sweeps * (required size for this buffer : n * nb0) * iy points to the portion of work that will hold the block * transform Y in the WY representation (required size for this * buffer : ( b + nb0 - 1 ) * nb0) * iw points to the portion of work that will hold the block * transform W in the WY representation (required size for this * buffer : ( b + nb0 - 1 ) * nb0) * itau points to the portion of work that will hold the scaling * factors (required size for this buffer: nb0) * iwork points to the protion of work that may be used as working * space by the routines dlarfx, dsyrf, and dgewy. * (required size for this buffer : n * nb0, if U is needed, * b otherwise) * ldwy0 = b + nb0 - 1, the leading dimension of "full" block * Householder reflectors W and Y, resp. * k0 number of the first sweep that contributed to the the * current block transform * ifirst first row affected by the current block transform * nb1 number of transforms in the current block update (usually * = nb0, except for the one at the bottom or the last sweeps) * ldwy size of the current block transform (usually = ldwy0, * except for the last block transform of the sweep) * nb2 number of nonzero transforms in the current block update * (usually = nb1, except for special matrices) * v points to the portion of work that holds the current * Householder vector * beta coefficient in the quadratic equation for determining the * maximum possible blocking factor * * The workspace is used as follows: * * If lda < 2 * b then some of the intermediate fill-in is held in the * workspace. More precisely, nsave = 2 * b - lda is the size of the * (triangular) blocks that extend beyond the array a. Then * nsave-by-nsave blocks of the band must be swapped between the array * a and the workspace. Note that actually only (nsave-1)-by-(nsave-1) * blocks of size szsub = ( ( nsave - 1 ) * nsave ) / 2 must be saved * as the remaining nsave elements are made zero by the algorithm. * - The first szsub + nsave elements of the workspace are used to * buffer a triangular portion of the current diagonal block, and * - the next ( n / b ) * szsub elements hold n / b triangular * (nsave-1)-by-(nsave-1) portions of the subdiagonal blocks. * If lda >= 2 * b then the whole fill-in fits into the array a, and * the above-mentioned buffers are not needed. * * If U is not needed (or U is needed, but its update is non-blocked) * then the next b places of work hold the current Householder vector * and the following b (or n, resp.) places are used as workspace for * applying the transformation. * * If U is updated via blocked Householder transforms (comprising nb0 * Householder transforms) * T * (affected part of) U = U * ( I + W * Y ) * then in the current implementation * - the next n * nb0 places hold the Householder vectors for * nb0 successive "eliminate & chase" sweeps down the band, * - the next ( b + nb0 - 1 ) * nb0 places hold the block Y, * - the next ( b + nb0 - 1 ) * nb0 places hold W, * - the next n * nb0 places are alternatively used as workspace for * the routines dsyrf (b elements), dlarfx (b elements), and dgewyr * (n * nb0 elements), and * - the buffer for nb0 scaling factors is overlapped with the first * nb0 elements of the "multiuse" workspace. * * Routines called: * LOGICAL LSAME INTEGER NBDFLT EXTERNAL LSAME, NBDFLT * * lsame case-insensitive character matching (BLAS) * nbdflt determine default blocking factor * EXTERNAL DCOPY, DGBWYG, DGEWY, DLARFX, DLBRFG, > DSYRF * * dcopy vector copy (BLAS) * dgbwyg generate WY block reflector (SBR) * dgewy apply WY block reflector (SBR) * dlbrfg determine Householder vector (SBR) * dsyrf apply two-sided transform to a symmetric matrix (SBR) * dlarfx apply Householder transform (LAPACK) * INTRINSIC DBLE, INT, MAX, MIN, MOD, SQRT * * ---------------------------------------------------------------------- * * --- check for errors in input --- * NEEDU = LSAME( JOB, 'U' ) * IF ( .NOT. ( NEEDU .OR. LSAME( JOB, 'N' ) ) ) THEN INFO = -1 ELSEIF ( N .LT. 0 ) THEN INFO = -2 ELSEIF ( ( B .LT. 0 ) .OR. ( ( N .GT. 0 ) .AND. ( B .GE. N ) ) ) > THEN INFO = -3 ELSEIF ( LDA .LT. ( B+1 ) ) THEN INFO = -5 ELSEIF ( DRPTOL .LT. ZERO ) THEN INFO = -6 ELSEIF ( LDU .LT. MAX( N, 1 ) ) THEN INFO = -10 ELSEIF ( NEEDU .AND. ( NB .LT. 0 ) ) THEN INFO = -11 ELSE INFO = 1 ENDIF * IF ( INFO .NE. 1 ) GOTO 999 * * --- check for quick return --- * IF ( N .EQ. 0 ) THEN GOTO 999 ELSEIF ( B .EQ. 0 ) THEN CALL DCOPY( N, A( 1, 1 ), LDA, D, 1 ) DO 10 J = 1, N-1 E( J ) = ZERO 10 CONTINUE GOTO 999 ELSEIF ( B .EQ. 1 ) THEN CALL DCOPY( N, A( 1, 1 ), LDA, D, 1 ) CALL DCOPY( N-1, A( 2, 1 ), LDA, E, 1 ) GOTO 999 ENDIF * * --- check if workspace is sufficient --- * NSAVE = 2 * B - LDA IF ( NSAVE .GT. 0 ) THEN SZSUB = ( ( NSAVE - 1 ) * NSAVE ) / 2 IX = SZSUB + NSAVE + ( N / B ) * SZSUB ELSE SZSUB = 0 IX = 0 ENDIF IF ( ( LWORK .LT. ( IX+2*B ) ) .OR. > ( NEEDU .AND. ( LWORK .LT. ( IX+B+N ) ) ) ) THEN INFO = -13 GOTO 999 ENDIF * * --- compute the final blocking factor for updating U --- * IF ( NEEDU ) THEN * * --- first determine the maximum possible value nb0 * (for blocking nb0 updates, we need * 2 * nb0 * ( n + b + nb0 - 1 ) workspace). --- * BETA = DBLE( N + B - 1 ) NB0 = INT( ( SQRT( BETA**2 + 2.0D0*( LWORK-IX ) ) - BETA ) > / 2.0D0 ) * * --- adjust to the user-supplied or default value --- * IF ( NB .GT. 0 ) THEN NB0 = MIN( NB, NB0, N-2 ) ELSE NB0 = MIN( NBDFLT( 'SBRDT', 'DoublePrec', 'BlockingFactor', > N, B, 1, .TRUE. ), > NB0 ) ENDIF * IF ( NB0 .LT. 1 ) NB0 = 1 * * --- OK, now we are done --- * BLOCK = ( NB0 .GT. 1 ) ONFLY = ( .NOT. BLOCK ) INFO = NB0 ELSE NB0 = 1 BLOCK = .FALSE. ONFLY = .FALSE. ENDIF * * --- set up pointers to the submatrices stored in work * (the data layout is pointed out above) --- * IF ( NSAVE .GT. 0 ) THEN IDIAG = 1 ISUB = IDIAG + ( SZSUB + NSAVE ) IV = ISUB + ( N / B ) * SZSUB ELSE IDIAG = -1 ISUB = -1 IV = 1 ENDIF * LDWY0 = B + NB0 - 1 IF ( BLOCK ) THEN IY = IV + N * NB0 IW = IY + LDWY0 * NB0 IWORK = IW + LDWY0 * NB0 ITAU = IWORK ELSE IY = -1 IW = -1 IWORK = IV + B ITAU = -1 ENDIF V = IV * * --- make sure that the "bulge buffer" is empty --- * DO 30 J = 2, N-B DO 20 K = B+2, MIN( 2*B, LDA, N-J+1 ) A( K, J ) = ZERO 20 CONTINUE 30 CONTINUE * DO 40 IX = 1, IV-1 WORK( IX ) = ZERO 40 CONTINUE * * ...................................................................... * K0 = 1 * * --- in the k-th pass of the following main loop, * the k-th column of the band is zeroed and the * resulting bulge is chased down the band --- * DO 700 K = 1, N-2 * * --- determine the length of the column and the * Householder vector --- * HEIGHT = MIN( B, N-K ) CALL DLBRFG( HEIGHT, A( 2, K ), A( 3, K ), 1, TAU, DRPTOL ) * * --- save the vector and zero column of A --- * IF ( BLOCK ) THEN V = IV + ( K - K0 ) * ( N - K0 + 1 ) ENDIF WORK( V ) = ONE CALL DCOPY( HEIGHT-1, A( 3, K ), 1, WORK( V+1 ), 1 ) DO 110 I = 3, HEIGHT+1 A( I, K ) = ZERO 110 CONTINUE * * --- save the new tridiagonal elements --- * D( K ) = A( 1, K ) E( K ) = A( 2, K ) * IF ( TAU .NE. ZERO ) THEN * * --- apply the Householder transform to both sides * of the first diagonal block --- * CALL DSYRF( 'Lower', HEIGHT, WORK( V ), 1, TAU, > A( 1, K+1 ), LDA - 1, WORK( IWORK ) ) * * --- if the transformations of U are not blocked * then apply them as they are generated --- * IF ( ONFLY ) THEN CALL DLARFX( 'Right', N, HEIGHT, WORK( V ), TAU, > U( 1, K+1 ), LDU, WORK( IWORK ) ) ENDIF ENDIF * * --- start the bulge chasing --- * DO 500 J = K+1, N-B, B NBLK = 1 + ( J - K - 1 ) / B * * --- determine the size of the subdiagonal block --- * WIDTH = HEIGHT HEIGHT = MIN( B, N-J-(B-1) ) * * --- if lda is too small then parts of the diagonal * block must be saved ... --- * NSAVE = B + HEIGHT - LDA NSAVE1 = NSAVE + 1 IX = IDIAG DO 220 J0 = 1, NSAVE IC = J + J0 DO 210 ID = 1, NSAVE1-J0 WORK( IX ) = A( ID, IC ) IX = IX + 1 210 CONTINUE 220 CONTINUE * * --- ... and the subdiagonal block must be restored --- * IX = ISUB + ( NBLK - 1 ) * SZSUB IF ( HEIGHT .EQ. B ) THEN DO 230 J0 = 1, NSAVE A( NSAVE1-J0, J+J0 ) = ZERO 230 CONTINUE DO 250 J0 = 2, NSAVE IC = J + J0 - 1 DO 240 ID = 1, NSAVE1-J0 A( ID, IC ) = WORK( IX ) IX = IX + 1 240 CONTINUE 250 CONTINUE ELSE DO 270 J0 = 1, NSAVE IC = J + J0 DO 260 ID = 1, NSAVE1-J0 A( ID, IC ) = WORK( IX ) IX = IX + 1 260 CONTINUE 270 CONTINUE ENDIF * IF ( TAU .NE. ZERO ) THEN * * --- apply the previous Householder transform * to the subdiagonal block (from the right) --- * CALL DLARFX( 'Right', HEIGHT, WIDTH, WORK( V ), TAU, > A( B+1, J ), LDA-1, WORK( IWORK ) ) ENDIF * * --- save the previous scaling factor --- * WORK( V ) = TAU * * --- generate a new Householder transform to * zero the first column of the subdiagonal block --- * CALL DLBRFG( HEIGHT, A( B+1, J ), A( B+2, J ), 1, > TAU, DRPTOL ) * IF ( BLOCK ) THEN V = IV + ( K - K0 ) * ( N - K0 + 1 ) + NBLK * B ENDIF WORK( V ) = ONE CALL DCOPY( HEIGHT-1, A( B+2, J ), 1, WORK( V+1 ), 1 ) DO 310 I = B+2, B+HEIGHT A( I, J ) = ZERO 310 CONTINUE * IF ( TAU .NE. ZERO ) THEN * * --- apply the transform to the subdiagonal block * (from the left) --- * CALL DLARFX( 'Left', HEIGHT, WIDTH-1, WORK( V ), TAU, > A( B, J+1 ), LDA-1, WORK( IWORK ) ) ENDIF * * --- if lda is too small then the subdiagonal block * must be saved ... --- * IX = ISUB + ( NBLK - 1 ) * SZSUB DO 420 J0 = 2, NSAVE IC = J + J0 DO 410 ID = 1, NSAVE1-J0 WORK( IX ) = A( ID, IC ) IX = IX + 1 410 CONTINUE 420 CONTINUE * * --- ... and the diagonal block must be restored --- * IX = IDIAG DO 440 J0 = 1, NSAVE IC = J + J0 DO 430 ID = 1, NSAVE1-J0 A( ID, IC ) = WORK( IX ) IX = IX + 1 430 CONTINUE 440 CONTINUE IF ( TAU .NE. ZERO ) THEN * * --- apply the transform to the diagonal block * (two-sided) --- * CALL DSYRF( 'Lower', HEIGHT, WORK( V ), 1, TAU, > A( 1, J+B ), LDA-1, WORK( IWORK ) ) * * --- if the transformations of U are not blocked * then apply them as they are generated --- * IF ( ONFLY ) THEN CALL DLARFX( 'Right', N, HEIGHT, WORK( V ), TAU, > U( 1, J+B ), LDU, WORK( IWORK ) ) ENDIF ENDIF * 500 CONTINUE * * --- save the last scaling factor --- * WORK( V ) = TAU * * ...................................................................... * IF ( BLOCK ) THEN * * --- (delayed) update of the transformation matrix U. * To allow blocked operations, the update is only * done in every nb0-th pass through the k loop --- * IF ( ( MOD( K, NB0 ) .EQ. 0 ) .OR. ( K .EQ. ( N-2 ) ) ) > THEN * * --- the following loop applies block transforms * reversely to their generation, e.g., starting * at the bottom and working up. * First, determine which columns ifirst ... * are affected by the block transform and * how many (nb1) transforms it contains --- * DO 600 IFIRST = N-MOD( N-K0-1, B ), K0+1, -B * * --- how many Householder transforms contribute * to the current block transform ? --- * NB1 = MIN( K-K0+1, N-IFIRST+1 ) LDWY = MIN( LDWY0, N-IFIRST+1 ) * * --- determine the block Householder reflector * corresponding to these nb1 vectors --- * V = IFIRST - K0 - 1 + IV CALL DCOPY( NB1, WORK( V ), N-K0+1, WORK( ITAU ), 1 ) CALL DGBWYG( LDWY, NB1, B-1, > WORK( V ), N-K0, WORK( ITAU ), > WORK( IW ), LDWY, WORK( IY ), LDWY, NB2 ) * * --- update U by postmultiplying --- * CALL DGEWY( 'Right', N, LDWY, NB2, > U( 1, IFIRST ), LDU, > WORK( IW ), LDWY, WORK( IY ), LDWY, > WORK( IWORK ) ) * 600 CONTINUE * K0 = K0 + NB0 * ENDIF ENDIF * * ...................................................................... * 700 CONTINUE * * --- end of the main loop: cleanup for the very tail * of the band --- * D( N-1 ) = A( 1, N-1 ) E( N-1 ) = A( 2, N-1 ) * D( N ) = A( 1, N ) * 999 RETURN END * * ********************************************************************** * SUBROUTINE DSY2BC( UPLO, N, B, AFULL, LDFULL, ABAND, LDBAND, > INFO ) * * ---------------------------------------------------------------------- * * Description: * * dsy2bc copies a symmetric banded A matrix from (upper or lower) * symmetric (full) storage to lower banded storage. * * Note that afull and aband must refer to different memory locations, * i.e., A may NOT be repacked within the same array. * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Parameters: * CHARACTER*1 UPLO INTEGER N, B, LDFULL, LDBAND, INFO DOUBLE PRECISION AFULL( LDFULL, * ), ABAND( LDBAND, * ) * * uplo (in) character*1 * Is the matrix A stored in the upper or lower triangle of the * array afull ? * uplo = 'U' : Upper triangle. * = 'L' : Lower triangle. * * n (in) integer * The size of the matrix A. * n >= 0. * * b (in) integer * The (semi-)bandwidth of the matrix A. * 0 <= b < n, if n >= 1. * b = 0 , if n = 0. * * afull (in) double precision array, dimension ( ldfull, n ) * The symmetric banded matrix A in upper or lower symmetric * storage. * * ldfull (in) integer * The leading dimension of the array afull. * ldfull >= max( n, 1 ). * * aband (out) double precision array, dimension ( ldband, n ) * The symmetric banded matrix A in lower banded storage (upper * banded storage is not supported). * * ldband (in) * The leading dimension of the array aband. * ldband >= b + 1. * * info (out) integer * On exit, info indicates the consistency of the arguments. * info = -1 : uplo was none of 'U', 'L' (upper/lower case). * = -2 : n was out of range (negative). * = -3 : b was out of range (negative or >= n ). * = -5 : ldfull was out of range ( < n or < 1 ). * = -7 : ldband was out of range ( < b + 1 ). * info = 1 : All arguments were ok. * * ---------------------------------------------------------------------- * * Local variables: * LOGICAL UPPER INTEGER J, I * * upper is A given in upper symmetric storage ? * * Routines called: * LOGICAL LSAME EXTERNAL LSAME * * lsame case-insensitive character matching (BLAS) * INTRINSIC MAX, MIN * * ---------------------------------------------------------------------- * * --- check for errors in the parameters --- * UPPER = LSAME( UPLO, 'U' ) * IF ( .NOT. ( UPPER .OR. ( LSAME( UPLO, 'L' ) ) ) ) THEN INFO = - 1 ELSEIF ( N .LT. 0 ) THEN INFO = - 2 ELSEIF ( ( B .LT. 0 ) .OR. > ( ( N .GT. 0 ) .AND. ( B .GE. N ) ) ) THEN INFO = - 3 ELSEIF ( LDFULL .LT. MAX( N, 1 ) ) THEN INFO = - 5 ELSEIF ( LDBAND .LT. ( B+1 ) ) THEN INFO = - 7 ELSE INFO = 1 ENDIF * IF ( INFO .NE. 1 ) GOTO 999 * * --- check for quick return --- * IF ( N .EQ. 0 ) GOTO 999 * * --- non-trivial case --- * IF ( UPPER ) THEN * * --- "upper to lower" --- * DO 110 J = 1, N DO 100 I = MAX( J-B, 1 ), J ABAND( 1+J-I, I ) = AFULL( I, J ) 100 CONTINUE 110 CONTINUE ELSE * * --- "lower to lower" --- * DO 210 J = 1, N DO 200 I = J, MIN( J+B, N ) ABAND( 1+I-J, J ) = AFULL( I, J ) 200 CONTINUE 210 CONTINUE ENDIF * 999 RETURN END * * ********************************************************************** * SUBROUTINE DSY2BI( UPLO, N, B, A, LDFULL, LDBAND, INFO ) * * ---------------------------------------------------------------------- * * Description: * * dsy2bi copies a symmetric banded A matrix from (upper or lower) * symmetric (full) storage to lower banded storage within the same * array a (i.e., in-place). * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Parameters: * CHARACTER*1 UPLO INTEGER N, B, LDFULL, LDBAND, INFO DOUBLE PRECISION A( * ) * * uplo (in) character*1 * Is the matrix A stored in the upper or lower triangle of the * array a ? * uplo = 'U' : Upper triangle. * = 'L' : Lower triangle. * * n (in) integer * The size of the matrix A. * n >= 0. * * b (in) integer * The (semi-)bandwidth of the matrix A. * 0 <= b < n, if n >= 1. * b = 0 , if n = 0. * * a (in/out) double precision array, * dimension ( max( ldfull, ldband), n ) * On entry, the symmetric banded matrix A in upper or lower * symmetric storage. * On exit, the symmetric banded matrix A in lower banded * storage (upper banded storage is not supported). * Note that this routine treats a as a one-dimensional array. * * ldfull (in) integer * The leading dimension of the array a (in full storage). * ldfull >= max( n, 1 ). * * ldband (in) * The leading dimension of the array a (in banded storage). * ldband >= b + 1. * * info (out) integer * On exit, info indicates the consistency of the arguments. * info = -1 : uplo was none of 'U', 'L' (upper/lower case). * = -2 : n was out of range (negative). * = -3 : b was out of range (negative or >= n ). * = -5 : ldfull was out of range ( < n or < 1 ). * = -6 : ldband was out of range ( < b + 1 ). * info = 1 : All arguments were ok. * * ---------------------------------------------------------------------- * * Local variables: * LOGICAL UPPER INTEGER B1, IBAND, IFULL, J, I * * upper is A given in upper symmetric storage ? * b1 = b + 1 * iband iband + i points to the next entry in a (banded storage) * ifull ifull + i points to the next entry in a (full storage) * * Routines called: * LOGICAL LSAME EXTERNAL LSAME * * lsame case-insensitive character matching (BLAS) * EXTERNAL DSB2BI * * dsb2bi in-place repacking from banded to banded storage (SBR) * INTRINSIC MAX, MIN * * ---------------------------------------------------------------------- * * --- check for errors in the parameters --- * UPPER = LSAME( UPLO, 'U' ) B1 = B + 1 * IF ( .NOT. ( UPPER .OR. ( LSAME( UPLO, 'L' ) ) ) ) THEN INFO = - 1 ELSEIF ( N .LT. 0 ) THEN INFO = - 2 ELSEIF ( ( B .LT. 0 ) .OR. > ( ( N .GT. 0 ) .AND. ( B .GE. N ) ) ) THEN INFO = - 3 ELSEIF ( LDFULL .LT. MAX( N, 1 ) ) THEN INFO = - 5 ELSEIF ( LDBAND .LT. B1 ) THEN INFO = - 6 ELSE INFO = 1 ENDIF * IF ( INFO .NE. 1 ) GOTO 999 * * --- check for quick return --- * IF ( N .EQ. 0 ) GOTO 999 * * --- non-trivial case --- * IF ( UPPER ) THEN * * --- "upper to lower"; avoid overwriting by first * packing the band as tight as possible (i.e., * leading dimension b + 1) and then "stretching" * to leading dimension ldband --- * DO 110 J = 1, N IBAND = ( J - 1 ) * B1 + 1 - J DO 100 I = J, MIN( J+B, N ) A( IBAND+I ) = A( (I-1)*LDFULL+J ) 100 CONTINUE 110 CONTINUE * IF ( LDBAND .GT. B1 ) THEN CALL DSB2BI( 'Lower', N, B, A, B1, LDBAND, INFO ) ENDIF * ELSE * * --- "lower to lower"; avoid overwriting by * copying the columns in the "safe" order --- * IF ( LDBAND .LE. ( LDFULL+1 ) ) THEN DO 210 J = 1, N IBAND = ( J - 1 ) * LDBAND + 1 - J IFULL = ( J - 1 ) * LDFULL DO 200 I = J, MIN( J+B, N ) A( IBAND+I ) = A( IFULL+I ) 200 CONTINUE 210 CONTINUE ELSE DO 310 J = N, 1, -1 IBAND = ( J - 1 ) * LDBAND + 1 - J IFULL = ( J - 1 ) * LDFULL DO 300 I = MIN( J+B, N ), J, -1 A( IBAND+I ) = A( IFULL+I ) 300 CONTINUE 310 CONTINUE ENDIF * ENDIF * 999 RETURN END * ********************************************************************** * INTEGER FUNCTION NBDFLT( ALGO, PREC, REQEST, N, B1, B2, NEEDU ) * * ---------------------------------------------------------------------- * * Description: * * Determine an appropriate default blocking factor or crossover point * or intermediate bandwidth for the reduction routine specified in * algo. * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Note: >>> This routine performs no sanity checks on its arguments. <<< * * ---------------------------------------------------------------------- * * Parameters: * CHARACTER*5 ALGO CHARACTER*1 PREC, REQEST INTEGER N, B1, B2 LOGICAL NEEDU * * algo (in) character*5 * For which SBR routine do we need a control parameter ? * algo = 'SYRDB' : Reduction full -> banded. * = 'SBRDB' : Reduction banded -> banded. * = 'SBRDT' : Reduction banded -> tridiagonal. * = 'SYRDD' : Driver for reducing full matrices. * = 'SBRDD' : Driver for reducing banded matrices. * * prec (in) character*1 * Is it the single or double precision routine ? * prec = 'D' : Double precision. * = 'S' : Single precision. * * reqest (in) character*1 * Which control parameter is required ? * reqest = 'B' : Blocking factor or intermediate bandwidth. * = 'C' : Crossover point to LAPACK code. * * n (in) integer * The size of the matrix to reduce. * n >= 0. * * b1 (in) integer * The bandwidth of the matrix before the reduction. * 0 <= b1 < n. * * b2 (in) integer * The bandwidth of the matrix after the reduction. * 1 <= b2 <= b1 or b1 = b2 = 0. * * needu (in) logical * Do we update the transformation matrix ? * needu = .true. : Yes. * = .false. : No. * * ---------------------------------------------------------------------- * * Local variables: * LOGICAL SINGLE INTEGER DELTAB * * single single or double precision routine ? * deltab number of diagonals to reduce * * Routines called: * LOGICAL LSAME EXTERNAL LSAME * * lsame case-insensitive character matching (BLAS) * * ---------------------------------------------------------------------- * SINGLE = LSAME( PREC, 'SinglePrecision' ) DELTAB = B1 - B2 * IF ( ( ALGO .EQ. 'SYRDB' ) .AND. > ( LSAME( REQEST, 'BlockingFactor' ) ) ) THEN * * --- block size for reduction from full to banded --- * IF ( NEEDU ) THEN IF ( SINGLE ) THEN NBDFLT = 32 ELSE NBDFLT = 32 ENDIF ELSE IF ( SINGLE ) THEN NBDFLT = 32 ELSE NBDFLT = 32 ENDIF ENDIF * ELSEIF ( ( ALGO .EQ. 'SBRDB' ) .AND. > ( LSAME( REQEST, 'BlockingFactor' ) ) ) THEN * * --- block size for bandwidth reduction --- * IF ( NEEDU ) THEN IF ( SINGLE ) THEN NBDFLT = ( ( DELTAB + 7 ) / 8 ) * 2 ELSE NBDFLT = ( ( DELTAB + 7 ) / 8 ) * 2 ENDIF IF ( NBDFLT .LT. 4 ) NBDFLT = 4 IF ( NBDFLT .GT. DELTAB ) NBDFLT = DELTAB ELSE IF ( SINGLE ) THEN NBDFLT = ( ( DELTAB + 7 ) / 8 ) * 2 ELSE NBDFLT = ( ( DELTAB + 7 ) / 8 ) * 2 ENDIF IF ( NBDFLT .LT. 4 ) NBDFLT = 4 IF ( NBDFLT .GT. DELTAB ) NBDFLT = DELTAB ENDIF IF ( NBDFLT .LT. 1 ) NBDFLT = 1 * ELSEIF ( ( ALGO .EQ. 'SBRDT' ) .AND. > ( LSAME( REQEST, 'BlockingFactor' ) ) ) THEN * * --- block size for reduction to tridiagonal form --- * IF ( NEEDU ) THEN IF ( SINGLE ) THEN NBDFLT = ( ( B1 + 5 ) / 6 ) * 2 ELSE NBDFLT = ( ( B1 + 5 ) / 6 ) * 2 ENDIF IF ( NBDFLT .LT. 4 ) NBDFLT = 4 IF ( NBDFLT .GT. DELTAB ) NBDFLT = DELTAB ELSE NBDFLT = 1 ENDIF * ELSEIF ( ( ALGO .EQ. 'SYRDD' ) .AND. > ( LSAME( REQEST, 'Bandwidth' ) ) ) THEN * * --- intermediate bandwidth in the reduction driver --- * IF ( NEEDU ) THEN NBDFLT = 1 ELSE IF ( ( N .GE. 300 ) .OR. ( B2 .GT. 1 ) ) THEN IF ( SINGLE ) THEN NBDFLT = 32 ELSE NBDFLT = 32 ENDIF ELSE NBDFLT = 1 ENDIF ENDIF * ELSEIF ( ( ALGO .EQ. 'SBRDD' ) .AND. > ( LSAME( REQEST, 'Bandwidth' ) ) ) THEN * * --- intermediate bandwidth in the reduction driver --- * IF ( NEEDU ) THEN NBDFLT = 1 ELSE IF ( SINGLE ) THEN NBDFLT = 32 ELSE NBDFLT = 32 ENDIF ENDIF * ELSEIF ( ( ALGO .EQ. 'SBRDD' ) .AND. > ( LSAME( REQEST, 'CrossoverPoint' ) ) ) THEN * * --- crossover point from SBRDT to SBTRD --- * IF ( NEEDU ) THEN IF ( SINGLE ) THEN NBDFLT = 8 ELSE NBDFLT = 8 ENDIF ELSE IF ( SINGLE ) THEN NBDFLT = 16 ELSE NBDFLT = 16 ENDIF ENDIF * ELSE NBDFLT = 1 ENDIF * RETURN END * * ********************************************************************** * SUBROUTINE DLBRFG( N, ALPHA, X, INCX, TAU, DRPTOL ) * * ---------------------------------------------------------------------- * * Description: * * dlbrfg generates an elementary reflector H of order n, such that * * T * H * ( alpha ) = ( beta ) , H * H = I , * ( x ) ( 0 ) * * where alpha and beta are scalars, and x is an ( n - 1 )-element * vector. H is represented in the form * * T * H = I - tau * ( 1 ) * ( 1 v ) , * ( v ) * * where tau is a scalar and v is an ( n - 1 )-element vector. * * If the elements of x are all zero, or the 2-norm of x does not * exceed drptol, then x is simply zeroed out, tau is set to 0, * indicating that H is the identity matrix. In this case, the * transformation is effectively skipped. * * Otherwise 1 <= tau <= 2. * * This routine is a modified version of dlbrfg by Bischof/Sun which * in turn is a modified version of the LAPACK routine dlarfg. * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Note: >>> This routine performs no sanity checks on its arguments. <<< * * Parameters: * INTEGER N, INCX DOUBLE PRECISION ALPHA, TAU, DRPTOL DOUBLE PRECISION X( * ) * * n (in) integer * The order of the elementary reflector. * n >= 0. * * alpha (in/out) double precision * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * x (in/out) double precision array, dimension ( 1+(n-2)*incx ) * On entry, the vector x. * On exit, the "x elements" are overwritten with the vector v. * * incx (in) integer * The increment between elements of x. * incx > 0. * * tau (out) double precision * The scaling factor tau. * * drptol (in) double precision * Threshold for dropping Householder transforms. * If the norm of the vector to eliminate is already <= drptol * then the transform is skipped. * drptol >= 0.0. * If you do not know, use 0.0. * * ---------------------------------------------------------------------- * * Local variables: * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * DOUBLE PRECISION XNORM, BETA, SAFMIN, RSAFMN INTEGER CNT, J * * xnorm 2-norm of x * beta the computed value beta * safmin safe minimum (such that relative accuracy can be guaranteed) * rsafmn 1 / safmin * cnt counts the rescaling steps * * Routines called: * DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2, DSCAL * * dlamch determine machine parameters (LAPACK) * dlapy2 stable 2-norm of 2-vector (LAPACK) * dnrm2 2-norm of a vector (BLAS) * dscal vector scaling (BLAS) * INTRINSIC SIGN, ABS * * ---------------------------------------------------------------------- * * --- check for quick exit --- * IF ( N .LE. 1 ) THEN TAU = ZERO ELSE * XNORM = DNRM2( N-1, X, INCX ) * IF ( XNORM .LE. DRPTOL ) THEN * * --- H = I --- * TAU = ZERO DO 10 J = 1, N-1 X( 1+(J-1)*INCX ) = ZERO 10 CONTINUE * ELSE * * --- general case --- * BETA = - SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) * IF ( ABS( BETA ) .LT. SAFMIN ) THEN * * --- xnorm, beta may be inaccurate; scale x * and recompute them --- * RSAFMN = ONE / SAFMIN CNT = 0 * 100 CONTINUE CNT = CNT + 1 ALPHA = ALPHA * RSAFMN CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA * RSAFMN IF ( ABS( BETA ) .LT. SAFMIN ) GOTO 100 * * --- now abs( beta ) is at least safmin --- * XNORM = DNRM2( N-1, X, INCX ) BETA = - SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA - ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * --- if alpha is subnormal, it may lose * relative accuracy --- * ALPHA = BETA * DO 110 J = 1, CNT ALPHA = ALPHA * SAFMIN 110 CONTINUE * ELSE * TAU = ( BETA - ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA * ENDIF * ENDIF * ENDIF * RETURN END * * ********************************************************************** * SUBROUTINE DSYRF( UPLO, N, V, INCV, TAU, > A, LDA, WORK ) * * ---------------------------------------------------------------------- * * Description: * * T * Apply the Householder transform H = I - tau * v * v from both * sides to the symmetric matrix A, i.e., update * * T * A := H * A * H ( = H * A * H ) . * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Note: >>> This routine performs no sanity checks on its arguments. <<< * * ---------------------------------------------------------------------- * * Parameters: * CHARACTER*1 UPLO INTEGER N, INCV, LDA DOUBLE PRECISION TAU DOUBLE PRECISION V( * ), A( LDA, * ), WORK( * ) * * uplo (in) character*1 * Is the upper or lower triangle of A stored ? * uplo = 'U' : Upper triangle. * = 'L' : Lower triangle. * * n (in) integer * The dimension of the matrix A. * n >= 0. * * v (in) double precision array, dimension ( 1+(n-1)*incv ) * The Householder vector associated with H. * Usually, v( 1 ) = 1, and v( 2:n ) contains the "mantissa" of * the transform. * * incv (in) integer * The increment between the elements of v. * incv > 0. * * tau (in) double precision * The scaling factor for the transform. * * a (in/out) double precision array, dimension ( lda, n ) * On entry, an n-by-n symmetric matrix A with either the lower * or the upper triangle stored. * On exit, the leading A is overwritten with H * A * H. * * lda (in) integer * The leading dimension of the array a. * lda >= max( n, 1 ). * * work (workspace) double precision array, dimension ( n ) * * ---------------------------------------------------------------------- * * Local variables: * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * DOUBLE PRECISION ALPHA * * alpha auxiliary factor * * Routines called: * DOUBLE PRECISION DDOT EXTERNAL DAXPY, DDOT, DSYMV, DSYR2 * * daxpy add multiple of a vector to another vector (BLAS) * ddot dot product of two vectors (BLAS) * dsymv symmetric matrix-vector product (BLAS) * dsyr2 symmetric rank-2 update (BLAS) * * ---------------------------------------------------------------------- * IF ( ( N .GT. 0 ) .AND. ( TAU .NE. ZERO ) ) THEN * * --- work( 1:n ) := x = tau * A * v --- * CALL DSYMV( UPLO, N, TAU, A, LDA, V, INCV, ZERO, WORK, 1 ) * * T * --- work( 1:n ) := w = x - 1/2 * tau * ( x * v ) * v --- * ALPHA = -0.5D0 * TAU * DDOT( N, WORK, 1, V, INCV ) CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 ) * * T T * --- A := A - v * w - w * v --- * CALL DSYR2( UPLO, N, -ONE, V, INCV, WORK, 1, A, LDA ) * ENDIF * RETURN END * * ********************************************************************** * SUBROUTINE DGBWYG( M, N, D, A, LDA, TAU, > W, LDW, Y, LDY, K ) * * ---------------------------------------------------------------------- * * Description: * * Given a set of Householder vectors as returned by dgbqr2, this * routine returns W and Y such that * * T * Q = I + W * Y * * where Q is the product of the Householder matrices. * * Each Householder transformation is represented by a vector vj and * a scalar tau( j ) such that * T T T * H( j ) = I - tau( j ) * ( 1, vj ) * ( 1, vj ) . * * The matrix Q is accumulated as * T * Q( j + 1 ) = I + W( j + 1 ) * Y( j + 1 ) = Q( j ) * H( j ) * * where * T T * Y( j + 1 ) = [ Y( j ), y ] with y = [ 0, vj ] and * * W( j + 1 ) = [ W( j ), w ] with w = - tau( j ) * Q( j ) * y. * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Note: >>> This routine performs no sanity checks on its arguments. <<< * * Parameters: * INTEGER M, N, D, LDA, LDW, LDY, K DOUBLE PRECISION A( LDA, * ), TAU( * ), > W( LDW, * ), Y( LDY, * ) * * m (in) integer * The number of rows of the matrix A. * m >= 0. * * n (in) integer * The number of columns of the matrix A. * n >= 0. * * d (in) integer * The number of subdiagonals of the matrix A (as the vectors * vj are stored in these subdiagonals, d is the length of * these transforms, minus 1). * 0 <= d <= m - 1, if m > 0. * d = 0 , if m = 0. * * a (in/out) double precision array, dimension ( lda, n ) * On entry, the d subdiagonals of the m-by-n matrix A contain * the Householder vectors vj. * On exit, A is zero below the main diagonal. * * lda (in) integer * The leading dimension of the array A. * lda >= max( m, 1 ). * * tau (in/out) double precision array, dimension ( n ) * On entry, tau contains the scaling factors for the * Householder transforms. * On exit, tau is destroyed. * * w (out) double precision array, dimension ( ldw, n ) * On exit, the first k columns of w contain the block * reflector W (zero below the d-th subdiagonal). * * ldw (in) integer * The leading dimension of the array w. * ldw >= max( m, 1 ). * * y (out) double precision array, dimension ( ldy, n ) * On exit, the first k columns of y contain the block * reflector Y (zero above the main diagonal and below the d-th * subdiagonal). * * ldy (in) integer * The leading dimension of the array y. * ldy >= max( m, 1 ). * * k (out) integer * On exit, k is the "active blocksize" * = the number of valid columns in W and Y * = the number of nontrivial Householder transforms contained * in W and Y * = the number of nonzero tau entries in the input. * 0 <= k <= n. * * ---------------------------------------------------------------------- * * Local variables: * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * INTEGER I, J, LEN * * len length of the vector v( j ) * * Routines called: * EXTERNAL DGEMV, DSWAP * * dgemv matrix-vector product (BLAS) * dswap swap two vectors (BLAS) * INTRINSIC MIN * * ---------------------------------------------------------------------- * K = 0 * DO 200 J = 1, MIN( M-1, N ) * IF ( TAU( J ) .NE. ZERO ) THEN * * --- W and Y grow --- * K = K + 1 LEN = MIN( M-J, D ) * * --- copy vj to Y( :, k ) and zero A( j+1:j+d, j ) --- * DO 110 I = 1, M Y( I, K ) = ZERO 110 CONTINUE Y( J, K ) = ONE CALL DSWAP( LEN, A( J+1, J ), 1, Y( J+1, K ), 1 ) * * --- W( :, k ) = - tau( j ) * Y( :, k ) --- * DO 120 I = 1, J-1 W( I, K ) = ZERO 120 CONTINUE DO 130 I = J, J+LEN W( I, K ) = -TAU( J ) * Y( I, K ) 130 CONTINUE DO 140 I = J+LEN+1, M W( I, K ) = ZERO 140 CONTINUE * * --- W( :, k ) = - tau( j ) * Q( j-1 ) * y( j ) * T * = ( I + W( j-1 ) * Y( k-1 ) ) * W( :, k ) --- * CALL DGEMV( 'Transpose', LEN+J, K-1, > ONE, Y, LDY, W( 1, K ), 1, ZERO, TAU, 1 ) CALL DGEMV( 'NoTranspose', LEN+J, K-1, > ONE, W, LDW, TAU, 1, ONE, W( 1, K ), 1 ) * ENDIF * 200 CONTINUE * RETURN END * * ********************************************************************** * SUBROUTINE DGEWY( SIDE, M, N, K, A, LDA, > W, LDW, Y, LDY, > WORK ) * * ---------------------------------------------------------------------- * * Description: * * Apply a WY block transform to the matrix A (from the left or from * the right), i.e., update A as * * T T * A := ( I + W * Y ) * A , or * * T * A := A * ( I + W * Y ) , resp. * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Note: >>> This routine performs no sanity checks on its arguments. <<< * * Parameters: * CHARACTER*1 SIDE INTEGER M, N, K, LDA, LDW, LDY DOUBLE PRECISION A( LDA, * ), W( LDW, * ), Y( LDY, * ), > WORK( * ) * * side (in) character*1 * Apply the transforms from the left or from the right ? * side = 'L' : From the left. * = 'R' : From the right. * * m (in) integer * The number of rows of the matrix A. * m >= 0. * * n (in) integer * The number of columns of the matrix A. * n >= 0. * * k (in) integer * The number of columns of the matrices W and Y. * k >= 0. * * a (in/out) double precision array, dimension ( lda, n ) * On entry, the matrix A. * T T * On exit, ( I + W * Y ) * A, if side = 'L', or * T * A * ( I + W * Y ), if side = 'R'. * * lda (in) integer * The leading dimension of the array a. * lda >= max( m, 1 ). * * w (in) double precision array, dimension ( ldw, k ) * The matrix W. * * ldw (in) integer * The leading dimension of the array w. * ldw >= max( m, 1 ), if side = 'L'. * >= max( n, 1 ), if side = 'R'. * (W has row dimension m or n, resp.) * * y (in) double precision array, dimension ( ldy, k ) * The matrix Y. * * ldy (in) integer * The leading dimension of the array y. * ldy >= max( m, 1 ), if side = 'L'. * >= max( n, 1 ), if side = 'R'. * (Y has row dimension m or n, resp.) * * work (workspace) double precision array, * dimension ( n*k ), if side = 'L'. * ( m*k ), if side = 'R'. * * ---------------------------------------------------------------------- * * Local variables: * DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * * Routines called: * LOGICAL LSAME EXTERNAL LSAME * * lsame case-insensitive character matching (BLAS) * EXTERNAL DGEMM * * dgemm matrix-matrix product (BLAS) * * ---------------------------------------------------------------------- * IF ( ( K .GT. 0 ) .AND. ( M .GT. 0 ) .AND. ( N .GT. 0 ) ) THEN * IF ( LSAME( SIDE, 'L' ) ) THEN * * T * --- work = W * A --- * CALL DGEMM( 'Transpose', 'NoTranspose', K, N, M, > ONE, W, LDW, A, LDA, ZERO, WORK, K ) * * --- A = Y * work + A --- * CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, K, > ONE, Y, LDY, WORK, K, ONE, A, LDA ) * ELSE * * --- work = A * W --- * CALL DGEMM( 'NoTranspose', 'NoTranspose', M, K, N, > ONE, A, LDA, W, LDW, ZERO, WORK, M ) * * T * --- A = A + work * Y --- * CALL DGEMM( 'NoTranspose', 'Transpose', M, N, K, > ONE, WORK, M, Y, LDY, ONE, A, LDA ) * ENDIF ENDIF * RETURN END * * ********************************************************************** * SUBROUTINE DSB2BI( UPLO, N, B, A, LDSRC, LDDST, INFO ) * * ---------------------------------------------------------------------- * * Description: * * dsb2bi copies a symmetric banded A matrix from upper or lower banded * storage to lower banded storage within the same array a (i.e., * in-place). It may be used to pack the matrix tightly by setting * lddst accordingly. * * Author: Bruno Lang * Aachen University of Technology * na.blang@na-net.ornl.gov * Date: May 17, 2000 * Version: SBR Toolbox, Rev. 1.4.1 * * Parameters: * CHARACTER*1 UPLO INTEGER N, B, LDSRC, LDDST, INFO DOUBLE PRECISION A( * ) * * uplo (in) character*1 * Is the matrix A given in the upper or lower banded storage ? * uplo = 'U' : Upper banded storage. * = 'L' : Lower banded storage. * * n (in) integer * The size of the matrix A. * n >= 0. * * b (in) integer * The (semi-)bandwidth of the matrix A. * 0 <= b < n. * * a (in/out) double precision array, * dimension ( max( ldsrc, lddst ), n ) * On entry, the symmetric banded matrix A in upper or lower * banded storage. * On exit, the symmetric banded matrix A in lower banded * storage (upper banded storage is not supported). * Note that this routine treats a as a one-dimensional array. * * ldsrc (in) integer * The leading dimension of the array a (input storage scheme). * ldsrc >= b + 1. * * lddst (in) integer * The leading dimension of the array a (output storage * scheme). * lddst >= b + 1. * * info (out) integer * On exit, info indicates the consistency of the arguments. * info = -1 : uplo was none of 'U', 'L' (upper/lower case). * = -2 : n was out of range (negative). * = -3 : b was out of range (negative or >= n ). * = -5 : ldsrc was out of range ( < b + 1 ). * = -6 : lddst was out of range ( < b + 1 ). * info = 1 : All arguments were ok. * * ---------------------------------------------------------------------- * * Local variables: * LOGICAL UPPER INTEGER B1, LDSRC1, ISRC, IDST, J, I * * upper is A given in upper banded storage ? * b1 = b + 1 * ldsrc1 leading dimension of the current source, minus 1 * isrc isrc + i points to the next source element in a * idst idst + something points to the next destination element in a * * Routines called: * LOGICAL LSAME EXTERNAL LSAME * * lsame case-insensitive character matching (BLAS) * INTRINSIC MAX, MIN * * ---------------------------------------------------------------------- * * --- check for errors in the parameters --- * UPPER = LSAME( UPLO, 'U' ) B1 = B + 1 * IF ( .NOT. ( UPPER .OR. ( LSAME( UPLO, 'L' ) ) ) ) THEN INFO = - 1 ELSEIF ( N .LT. 0 ) THEN INFO = - 2 ELSEIF ( ( B .LT. 0 ) .OR. > ( ( N .GT. 0 ) .AND. ( B .GE. N ) ) ) THEN INFO = - 3 ELSEIF ( LDSRC .LT. B1 ) THEN INFO = - 5 ELSEIF ( LDDST .LT. B1 ) THEN INFO = - 6 ELSE INFO = 1 ENDIF * IF ( INFO .NE. 1 ) GOTO 999 * * --- check for quick return --- * IF ( N .EQ. 0 ) GOTO 999 * * --- non-trivial case --- * IF ( UPPER ) THEN * * --- "upper to lower" --- * IF ( LDDST .LE. LDSRC ) THEN * * --- no danger of overwriting --- * LDSRC1 = LDSRC - 1 DO 110 J = 1, N IDST = ( J - 1 ) * LDDST ISRC = ( J - 2 ) * LDSRC + B + 2 DO 100 I = 1, MIN( B1, N-J+1 ) A( IDST+I ) = A( ISRC+I*LDSRC1 ) 100 CONTINUE 110 CONTINUE ELSE * * --- first copy to upper storage, then transpose --- * DO 210 J = N, 1, -1 IDST = ( J - 1 ) * LDDST ISRC = ( J - 1 ) * LDSRC DO 200 I = B1, MAX( B1-J+1, 1 ), -1 A( IDST+I ) = A( ISRC+I ) 200 CONTINUE 210 CONTINUE * LDSRC1 = LDDST - 1 DO 230 J = 1, N IDST = ( J - 1 ) * LDDST ISRC = ( J - 2 ) * LDDST + B + 2 DO 220 I = 1, MIN( B1, N-J+1 ) A( IDST+I ) = A( ISRC+I*LDSRC1 ) 220 CONTINUE 230 CONTINUE ENDIF * ELSE * * --- "lower to lower"; avoid overwriting by * copying the columns in the "safe" order --- * IF ( LDDST .LE. LDSRC ) > THEN DO 310 J = 1, N IDST = ( J - 1 ) * LDDST ISRC = ( J - 1 ) * LDSRC DO 300 I = 1, MIN( B1, N-J+1 ) A( IDST+I ) = A( ISRC+I ) 300 CONTINUE 310 CONTINUE ELSE DO 410 J = N, 1, -1 IDST = ( J - 1 ) * LDDST ISRC = ( J - 1 ) * LDSRC DO 400 I = MIN( B1, N-J+1 ), 1, -1 A( IDST+I ) = A( ISRC+I ) 400 CONTINUE 410 CONTINUE ENDIF * ENDIF * 999 RETURN END