c parameters idelm=3 and isigma=1 give usual C3v with Cs frame c + we need to change the check of symmetry and time reversal consistency of Hamiltonian terms in the input c for V6 problem idelm=6 and isigma=3 c for V3 problem idelm=3 and isigma=1 module dimens integer, parameter:: Jmaxdim=180 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(-15:15),Symcatcm(0:3),Smcatcm(-15:15) integer Isymcmhz(0:3), Imcmhz(-15:15),Isymccm(0:3), Imccm(-15:15) real*8, allocatable:: freqm(:),unc(:),weight(:),Scat(:),frlastcal(:),sintbllast(:),Signrmscat(:,:) real*8, allocatable:: Fq(:,:), Relqint(:) integer Ncat,Nlev,Ndata,nmaxlev,included,iblines,incllines,jlines,ibldifj integer, allocatable:: mq(:,:),Jq(:,:),Ka(:,:),Kc(:,:),incl(:),Incat(:),Isigncat(:,:) 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,Fspin 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(:),deltaptest(:) integer Numpartest end module paramtest module calc use dimens integer, allocatable:: nv012(:,:,:,:),Jbound(:,:) real*8 Elowest,dsw 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(:),sintaccpr(:) integer valacc(8),valacc1(8),valacc2(8),valacc3(8),values(8),valinit(8),valinit1(8),ilowest character*10 date, time, zone end module calc PROGRAM V6 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 now consider all levels not only included for uncertainty calculation 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) 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.or.abs(ipred).eq.4.or.abs(ipred).eq.5)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:4,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(0:ndim+1,0:isigma,0:1),Evcrottor(ndim,0:ndim+1,0:isigma,0:1),parAB(0:ndim+1,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 if(abs(ipred).eq.3)then if(isigma.eq.1)then deallocate (nv012,drv) call QpartitionV3(itn) elseif(isigma.eq.3)then call QpartitionV6(itn) endif else Jmax=Jmaxsave call jsort() ipfr=ip if(abs(ipred).eq.1)then call predictionH(itn) elseif(abs(ipred).eq.2)then call predictionR(itn) endif endif 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 this subroutine calculates partition function for V6 case subroutine QpartitionV6(itn) use predict use calc use param use expdat use vint real*8, allocatable:: Qpart(:,:),Qpart1(:) real*8 Edif,pjf,Temp1 integer itn,item c this is need to run rotation subroutine Jbound=1 mbound=1 item=temppred/10+1 write(6,*)'Elowest=',Elowest,'cm-1' write(6,*)'Up to temperature=',Temppred if(ilowest.eq.1)then allocate (Qpart(0:isigma,1:item),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif Qpart=0.d0 write(6,*)'Elowest for each symmerty=' do i=0,isigma write(6,*)'isigR=',i,'Elowest=',Elst(i) enddo else allocate (Qpart1(1:item),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif Qpart1=0.d0 write(6,*)'Elowest=',Elowest,'cm-1' endif c compose the matrix of least squares process do J=0,Jup pjf=dfloat(2*J+1) c second stage calculation for particular J num=mod(J,2) NDIMR=(2*J+1)*nvt c initialize Erottor to be sure that we went through calculation at each J do isigr=0,isigma do in=1,NDIMR Erottor(in,isigr,num)=0.d0 enddo enddo 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) deallocate (H,EGVL,EGVC) c now we have calculated levels for current J if(ilowest.eq.1)then nomit=0 do isigr=0,isigma do in=1,ndimr Edif=Erottor(in,isigr,num)-Elst(isigr) if(Edif.lt.0.d0)then write(6,*)Erottor(in,isigr,num),in,isigr,num nomit=nomit+1 cycle endif Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 Qpart(isigr,it)=Qpart(isigr,it)+pjf*dexp(-1.439d0*Edif/Temp1)*dfloat(istweight(isigr)) enddo enddo enddo else nomit=0 do isigr=0,isigma do in=1,ndimr Edif=Erottor(in,isigr,num)-Elowest if(Edif.lt.0.d0)then write(6,*)Erottor(in,isigr,num),in,isigr,num nomit=nomit+1 cycle endif Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 Qpart1(it)=Qpart1(it)+pjf*dexp(-1.439d0*Edif/Temp1)*dfloat(istweight(isigr)) enddo enddo enddo endif write(6,*)'J=',J,'number of omitted states',nomit if(ilowest.eq.1)then Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 do isigr=0,isigma write(6,*)'T= ',Temp1,'Q for isigr=',isigr,Qpart(isigr,it) enddo enddo else Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 write(6,*)'T= ',Temp1,'Q = ',Qpart1(it) enddo endif enddo write(6,*) write(6,*)'Total' write(6,*) if(ilowest.eq.1)then Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 do isigr=0,isigma write(6,*)'T= ',Temp1,'Q for isigr=',isigr,Qpart(isigr,it) enddo enddo else Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 write(6,*)'T= ',Temp1,'Q= ',Qpart1(it) enddo endif if(ilowest.eq.1)then deallocate(Qpart) else deallocate(Qpart1) endif return end c this subroutine calculates partition function for V3 case subroutine QpartitionV3(itn) use predict use calc use param use expdat real*8, allocatable:: Qpart(:,:),Qpart1(:) real*8 Edif,pjf,Temp1 integer itn,item c this is need to run rotation subroutine Jbound=1 mbound=1 item=temppred/10+1 write(6,*)'Elowest=',Elowest,'cm-1' write(6,*)'Up to temperature=',Temppred if(ilowest.eq.1)then allocate (Qpart(0:isigma,1:item),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif Qpart=0.d0 write(6,*)'Elowest for each symmerty=' do i=0,isigma write(6,*)'isigR=',i,'Elowest=',Elst(i) enddo else allocate (Qpart1(1:item),STAT=ierr) if(ierr.ne.0)then write(6,*)'error in allocating',ierr stop endif Qpart1=0.d0 write(6,*)'Elowest=',Elowest,'cm-1' endif c compose the matrix of least squares process do J=0,Jup pjf=dfloat(2*J+1) c second stage calculation for particular J num=mod(J,2) NDIMR=(2*J+1)*nvt c initialize Erottor to be sure that we went through calculation at each J do isigr=0,isigma do in=1,NDIMR Erottor(in,isigr,num)=0.d0 enddo enddo 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) deallocate (H,EGVL,EGVC) c now we have calculated levels for current J if(ilowest.eq.1)then nomit=0 do isigr=0,isigma do in=1,ndimr Edif=Erottor(in,isigr,num)-Elst(isigr) if(Edif.lt.0.d0)then write(6,*)Erottor(in,isigr,num),in,isigr,num nomit=nomit+1 cycle endif Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 Qpart(isigr,it)=Qpart(isigr,it)+pjf*dexp(-1.439d0*Edif/Temp1) enddo enddo enddo else nomit=0 do isigr=0,isigma do in=1,ndimr Edif=Erottor(in,isigr,num)-Elowest if(Edif.lt.0.d0)then write(6,*)Erottor(in,isigr,num),in,isigr,num nomit=nomit+1 cycle endif Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 Qpart1(it)=Qpart1(it)+pjf*dexp(-1.439d0*Edif/Temp1) enddo enddo enddo endif write(6,*)'J=',J,'number of omitted states',nomit if(ilowest.eq.1)then Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 do isigr=0,isigma write(6,*)'T= ',Temp1,'Q for isigr=',isigr,Qpart(isigr,it) enddo enddo else Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 write(6,*)'T= ',Temp1,'Q = ',Qpart1(it) enddo endif enddo write(6,*) write(6,*)'Total' write(6,*) if(ilowest.eq.1)then Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 do isigr=0,isigma write(6,*)'T= ',Temp1,'Q for isigr=',isigr,Qpart(isigr,it) enddo enddo else Temp1=0.d0 do it=1,item Temp1=Temp1+10.d0 write(6,*)'T= ',Temp1,'Q= ',Qpart1(it) enddo endif if(ilowest.eq.1)then deallocate(Qpart) else deallocate(Qpart1) endif return end c in this subroutine the predictions without hyperfine structure are calculated subroutine predictionR(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,1116) if(ipred.eq.-2)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 write(8,*)'Elowest is subtracted from Elow for each transition, for each symmetry its own Elowest is used' else write(8,*)'Elowest is subtracted from Elow for each transition' endif write(8,1116) if(iexpect.eq.1)then c to output expectation values for different operators used in the 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',/) c unblock calculation in rotation subroutine 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.2)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 if(mlev(ij1).eq.isigup-2*idelm)ivt=3 if(mlev(ij1).eq.isigup+2*idelm)ivt=4 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 if(mlev(ij2).eq.isiglow-2*idelm)ivt=3 if(mlev(ij2).eq.isiglow+2*idelm)ivt=4 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(Fq(1,ikst).ne.-1.d0)cycle !consider only pure rotational transitions 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(Fq(1,ikst).ne.-1.d0)cycle !consider only pure rotational transitions 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 if(Nstage(in).eq.-1)cycle !do not consider quadrupole 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 if(Nstage(is).eq.-1)cycle !do not consider quadrupole 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)then if(unc(ikstfin).gt.0.d0)then write(6,*)'forbidden line',freqm(ikstfin)*29979.2458d0,incl(ikstfin) else write(6,*)'forbidden line',freqm(ikstfin),incl(ikstfin) endif endif 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-Elowest,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-Elowest,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,3x,E10.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.2)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 if(mlev(ij1).eq.isigup-2*idelm)ivt=3 if(mlev(ij1).eq.isigup+2*idelm)ivt=4 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 if(mlev(ij2).eq.isiglow-2*idelm)ivt=3 if(mlev(ij2).eq.isiglow+2*idelm)ivt=4 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(Fq(1,ikst).ne.-1.d0)cycle !consider only pure rotational transitions 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(Fq(1,ikst).ne.-1.d0)cycle !consider only pure rotational transitions 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 if(Nstage(in).eq.-1)cycle !do not consider quadrupole 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 if(Nstage(is).eq.-1)cycle !do not consider quadrupole 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)then if(unc(ikstfin).gt.0.d0)then write(6,*)'forbidden line',freqm(ikstfin)*29979.2458d0,incl(ikstfin) else write(6,*)'forbidden line',freqm(ikstfin),incl(ikstfin) endif endif 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-Elowest,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-Elowest,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 predictions with hyperfine structure are calculated subroutine predictionH(itn) use predict use param use calc use expdat real*8 Aincer real*8 frc, Elow,Strength,Sint,Frexpect,frcR real*8 accqint,f1,f2,fqint,Stren1 real*8 yup,ylow,Equadrlow,Equadrup,deriv1,deriv2 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,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 write(8,*)'Elowest is subtracted from Elow for each transition, for each symmetry its own Elowest is used' else write(8,*)'Elowest is subtracted from Elow for each transition' endif write(8,1116) if(iexpect.eq.1)then c to output expectation values for different operators used in the 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',/) c unblock calculation in rotation subroutine 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 c 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) c 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 c if(Niter.ne.0)then c calculate derivatives for fitted parameters and all levels for uncertainties call derivative(J+1,num) c 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 if(mlev(ij1).eq.isigup-2*idelm)ivt=3 if(mlev(ij1).eq.isigup+2*idelm)ivt=4 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 if(mlev(ij2).eq.isiglow-2*idelm)ivt=3 if(mlev(ij2).eq.isiglow+2*idelm)ivt=4 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 frcR=Erottor(itupn,isigup,numup)-Erottor(itlown,isiglow,numlo) if(iMHz_or_cm.eq.0)then frcR=frcR*29979.2458D0 endif c check for frequency limits if(dabs(frcR).lt.flower.or.dabs(frcR).gt.fupper)cycle c calculation of intensities call Vintensity(Jlev(ij2),Jlev(ij1),numlo,numup,isigup,isiglow,itupn,itlown,Strength) Stren1=Strength c we need this for derivatives of quadrupole parameters which are used in calculation of components ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 c we have rotational quantum numbers and now we need to calculate hyperfine structure components c first we calculate sum of intensities of the quadrupole components c quadrupole hyperfine component we need to calculate relative intensity c we need to calculate intensities of all possible components to get relative intensity of desired component accqint=0.d0 Isplit=Jlev(ij2)+1+idint(Fspin-dabs(dfloat(Jlev(ij2))-Fspin)) f1=dabs(dfloat(Jlev(ij2))-Fspin)-1.d0 do is1=1,Isplit !cycle over allowed lower F components f1=f1+1.d0 do it1=-1,1 !the selection rules allow deltaF=0,+/-1 f2=f1+dfloat(it1) if(f2.le.dfloat(Jlev(ij1))+Fspin.and.f2.ge.dabs(dfloat(Jlev(ij1))-Fspin))then c we have a legal hyperfine component and we need to calculate intensity for it call quadrint(Jlev(ij2),Jlev(ij1),Fspin,f1,f2,fqint) accqint=accqint+fqint else cycle endif enddo !enddo from is cycle enddo !enddo from it cycle if(accqint.eq.0.d0)cycle c we accqint intensity of all hyperfine components now we can cycle over individual ones f1=dabs(dfloat(Jlev(ij2))-Fspin)-1.d0 do is1=1,Isplit !cycle over allowed lower F components f1=f1+1.d0 do it1=-1,1 !the selection rules allow deltaF=0,+/-1 f2=f1+dfloat(it1) if(f2.gt.dfloat(Jlev(ij1))+Fspin.or.f2.lt.dabs(dfloat(Jlev(ij1))-Fspin))cycle c calculate intensity of the component call quadrint(Jlev(ij2),Jlev(ij1),Fspin,f1,f2,fqint) Strength=Stren1*fqint/accqint c this hyperfine component therefore we need to calculate quadrupole energy addition ylow=0.d0 if(Fspin.ne.0.5d0.and.Jlev(ij2).ne.0)then call casimir(Jlev(ij2),Fspin,f1,ylow) endif yup=0.d0 if(Fspin.ne.0.5d0.and.Jlev(ij1).ne.0)then call casimir(Jlev(ij1),Fspin,f2,yup) endif Equadrlow=0.d0 if(ylow.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrlow=Equadrlow+Bval(is)*drv(is,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) enddo endif Equadrup=0.d0 if(yup.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrup=Equadrup+Bval(is)*drv(is,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) enddo endif frc=Erottor(itupn,isigup,numup)+Equadrup-Erottor(itlown,isiglow,numlo)-Equadrlow if(iMHz_or_cm.eq.0)then frc=frc*29979.2458D0 endif 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(Fq(1,ikst).eq.-1.d0)cycle !we consider only hyperfine components 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(Fq(1,ikst).eq.f1.and.Fq(2,ikst).eq.f2. ! and.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(Fq(1,ikst).eq.-1.d0)cycle !we consider only hyperfine components 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(Fq(1,ikst).eq.f2.and.Fq(2,ikst).eq.f1. ! and.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 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 Aincer=0.d0 if(Niter.ne.0)then 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 if(Nstage(in).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor deriv1=0.d0 if(yup.ne.0.d0)then deriv1=drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) endif if(ylow.ne.0.d0)then deriv1=deriv1-drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) endif else deriv1=drv(in,ilup,numup)-drv(in,illow,numlo) endif 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 if(Nstage(is).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor deriv2=0.d0 if(yup.ne.0.d0)then deriv2=drv(is,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) endif if(ylow.ne.0.d0)then deriv2=deriv2-drv(is,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) endif else deriv2=drv(is,ilup,numup)-drv(is,illow,numlo) endif ist=ist+1 Aincer=Aincer+A(int,ist)*deriv1*deriv2 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)then if(unc(ikstfin).gt.0.d0)then write(6,*)'forbidden line',freqm(ikstfin)*29979.2458d0,incl(ikstfin) else write(6,*)'forbidden line',freqm(ikstfin),incl(ikstfin) endif endif 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 c if(idint(f2-f1).ne.Jlev(ij1)-Jlev(ij2))cycle !only deltaJ=deltaF components are output if(frc.gt.0.d0)then write(ifile,1115)pr(isul2),mlev(ij1),f2,Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),f1,Jlev(ij2),Kalow,Kclow,Sint,frc,aincer,Elow-Elowest,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),f2,Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),f1,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 if(Nstage(in).eq.-1)then write(ifile1,4114)(drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) ! -drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) ! -drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1)) else 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)) endif 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,f6.1,3I4,4x,A2,I3,f6.1,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),f1,Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),f2,Jlev(ij1),Kalow,Kclow,Sint,dabs(frc),aincer,Elow-Elowest,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),f1,Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),f2,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 if(Nstage(in).eq.-1)then write(ifile1,4114)(drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) ! -drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) ! -drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1)) else 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)) endif 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,f6.1,3I4,4x,A2,I3,f6.1,3I4,3x,E10.3,F14.4,'(',F8.4,')',F12.4,3x,E10.3,$) enddo !enddo of is1 cycle over hyperfine components enddo !enddo of it1 cycle over hyperfine components 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 if(mlev(ij1).eq.isigup-2*idelm)ivt=3 if(mlev(ij1).eq.isigup+2*idelm)ivt=4 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 if(mlev(ij2).eq.isiglow-2*idelm)ivt=3 if(mlev(ij2).eq.isiglow+2*idelm)ivt=4 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 frcR=Erottor(itupn,isigup,numup)-Erottor(itlown,isiglow,numlo) if(iMHz_or_cm.eq.0)then frcR=frcR*29979.2458D0 endif c check for frequency limits if(dabs(frcR).lt.flower.or.dabs(frcR).gt.fupper)cycle c calculation of intensities call Vintensity(Jlev(ij2),Jlev(ij1),numlo,numup,isigup,isiglow,itupn,itlown,Strength) Stren1=Strength c we need this for derivatives of quadrupole parameters which are used in calculation of components ilup=ij1-Jbound(Jlev(ij1),1)+1 illow=ij2-Jbound(Jlev(ij2),1)+1 c we have rotational quantum numbers and now we need to calculate hyperfine structure components c first we calculate sum of intensities of the quadrupole components c quadrupole hyperfine component we need to calculate relative intensity c we need to calculate intensities of all possible components to get relative intensity of desired component accqint=0.d0 Isplit=Jlev(ij2)+1+idint(Fspin-dabs(dfloat(Jlev(ij2))-Fspin)) f1=dabs(dfloat(Jlev(ij2))-Fspin)-1.d0 do is1=1,Isplit !cycle over allowed lower F components f1=f1+1.d0 do it1=-1,1 !the selection rules allow deltaF=0,+/-1 f2=f1+dfloat(it1) if(f2.le.dfloat(Jlev(ij1))+Fspin.and.f2.ge.dabs(dfloat(Jlev(ij1))-Fspin))then c we have a legal hyperfine component and we need to calculate intensity for it call quadrint(Jlev(ij2),Jlev(ij1),Fspin,f1,f2,fqint) accqint=accqint+fqint else cycle endif enddo !enddo from is1 cycle enddo !enddo from it1 cycle if(accqint.eq.0.d0)cycle c we accqint intensity of all hyperfine components now we can cycle over individual ones f1=dabs(dfloat(Jlev(ij2))-Fspin)-1.d0 do is1=1,Isplit !cycle over allowed lower F components f1=f1+1.d0 do it1=-1,1 !the selection rules allow deltaF=0,+/-1 f2=f1+dfloat(it1) if(f2.gt.dfloat(Jlev(ij1))+Fspin.or.f2.lt.dabs(dfloat(Jlev(ij1))-Fspin))cycle c calculate intensity of the component call quadrint(Jlev(ij2),Jlev(ij1),Fspin,f1,f2,fqint) Strength=Stren1*fqint/accqint c this hyperfine component therefore we need to calculate quadrupole energy addition ylow=0.d0 if(Fspin.ne.0.5d0.and.Jlev(ij2).ne.0)then call casimir(Jlev(ij2),Fspin,f1,ylow) endif yup=0.d0 if(Fspin.ne.0.5d0.and.Jlev(ij1).ne.0)then call casimir(Jlev(ij1),Fspin,f2,yup) endif Equadrlow=0.d0 if(ylow.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrlow=Equadrlow+Bval(is)*drv(is,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) enddo endif Equadrup=0.d0 if(yup.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrup=Equadrup+Bval(is)*drv(is,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) enddo endif frc=Erottor(itupn,isigup,numup)+Equadrup-Erottor(itlown,isiglow,numlo)-Equadrlow if(iMHz_or_cm.eq.0)then frc=frc*29979.2458D0 endif 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(Fq(1,ikst).eq.-1.d0)cycle !we consider only hyperfine components 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(Fq(1,ikst).eq.f1.and.Fq(2,ikst).eq.f2. ! and.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(Fq(1,ikst).eq.-1.d0)cycle !we consider only hyperfine components 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(Fq(1,ikst).eq.f2.and.Fq(2,ikst).eq.f1. ! and.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 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 Aincer=0.d0 if(Niter.ne.0)then 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 if(Nstage(in).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor deriv1=0.d0 if(yup.ne.0.d0)then deriv1=drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) endif if(ylow.ne.0.d0)then deriv1=deriv1-drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) endif else deriv1=drv(in,ilup,numup)-drv(in,illow,numlo) endif 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 if(Nstage(is).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor deriv2=0.d0 if(yup.ne.0.d0)then deriv2=drv(is,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) endif if(ylow.ne.0.d0)then deriv2=deriv2-drv(is,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) endif else deriv2=drv(is,ilup,numup)-drv(is,illow,numlo) endif ist=ist+1 Aincer=Aincer+A(int,ist)*deriv1*deriv2 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)then if(unc(ikstfin).gt.0.d0)then write(6,*)'forbidden line',freqm(ikstfin)*29979.2458d0,incl(ikstfin) else write(6,*)'forbidden line',freqm(ikstfin),incl(ikstfin) endif endif 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 c if(idint(f2-f1).ne.Jlev(ij1)-Jlev(ij2))cycle !only deltaJ=deltaF components are output if(frc.gt.0.d0)then write(ifile,1115)pr(isul2),mlev(ij1),f2,Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),f1,Jlev(ij2),Kalow,Kclow,Sint,frc,aincer,Elow-Elowest,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),f2,Jlev(ij1),Kaup,Kcup,pr(isul1), ! mlev(ij2),f1,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 if(Nstage(in).eq.-1)then write(ifile1,4114)(drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) ! -drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1) ! -drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1)) else 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)) endif 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),f1,Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),f2,Jlev(ij1),Kalow,Kclow,Sint,dabs(frc),aincer,Elow-Elowest,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),f1,Jlev(ij2),Kaup,Kcup,pr(isul2), ! mlev(ij1),f2,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 if(Nstage(in).eq.-1)then write(ifile1,4114)(drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) ! -drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1))*Bval(in)*29979.2458D0 FRexpect=FRexpect+Bval(in)*(drv(in,illow,numlo)*2.d0*ylow/dfloat(Jlev(ij2))/dfloat(Jlev(ij2)+1) ! -drv(in,ilup,numup)*2.d0*yup/dfloat(Jlev(ij1))/dfloat(Jlev(ij1)+1)) else 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)) endif 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 !enddo of is1 cycle over hyperfine components enddo !enddo of it1 cycle over hyperfine components 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(:), frc1(:), Elow(:), Eup(:) integer, allocatable:: isul(:,:),JS(:),ibranch(:),Kbranch(:),iblsign(:),inul(:,:),isr(:,:),kpar(:,:) integer, allocatable:: istore(:,:,:), kvt_ov(:,:,:),k_ov(:,:,:),kp_ov(:,:,:) real*8 dlf,Smhz,Scm,Sw,Sct(Ncat) real*8 yup,ylow,Equadrlow,Equadrup,deriv1,deriv2 real*8 Strength,Sint,Sdeltammhz,Sdeltamcm character*2 pr(0:7) character*1 blsign(0:1),prsign(0:2) real*8 freqprev, frcalcprev, sintprev, fraccum, sintaccum,dlfprev, weightprev,parup(Ndata),parlow(Ndata) allocate (Aincer(Ndata),Corr(numpar,numpar),Stren(Ndata), frc1(Ndata), Elow(Ndata), Eup(Ndata),STAT=ierr) if(ierr.ne.0)then write(10,*)'error in allocating',ierr stop endif allocate (isul(2,Ndata),inul(2,Ndata),isr(2,Ndata),JS(Ndata),ibranch(Ndata),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 Isigncat=0 Signrmscat=0.d0 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 frc1=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 frc1(i)=freqm(i) enddo c sort the frsrt array call VSRTPD (frc1,Ndata,ipfr) do i=2,Ndata-1 if(frc1(i).eq.0.d0)cycle if(frc1(i).eq.frc1(i-1))then iblsign(ipfr(i))=1 iblsign(ipfr(i-1))=1 elseif(frc1(i).eq.frc1(i+1))then iblsign(ipfr(i))=1 iblsign(ipfr(i+1))=1 endif enddo c this is to output in order of frequency frc1=0.d0 ipfr=0 do i=1,Ndata ipfr(i)=i frc1(i)=freqm(i) enddo c sort the frsrt array call VSRTPD (frc1,Ndata,ipfr) frc1=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 c 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) !we need derivatives for calculation quadrupole addition c 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 c if(Niter.ne.0)then c calculate derivatives for fitted parameters and all levels for uncertainties call derivative(J+1,num) !we need derivatives for calculation quadrupole addition c 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 if(mq(2,ikl).eq.isigup-2*idelm)ivt=3 if(mq(2,ikl).eq.isigup+2*idelm)ivt=4 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 if(mq(1,ikl).eq.isiglow-2*idelm)ivt=3 if(mq(1,ikl).eq.isiglow+2*idelm)ivt=4 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 isr(2,ikl)=isigup isr(1,ikl)=isiglow inul(2,ikl)=itupn inul(1,ikl)=itlown 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)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 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 c now we have ordinal numbers of the upper an lower levels of the transition we can build the matrix c frc1(ikl)=Erottor(itupn,isigup,num2)-Erottor(itlown,isiglow,num1) c now we have ordinal numbers of the upper an lower levels of the transition if(Fq(1,ikl).eq.-1.d0)then c hypothetical unsplit rotational transition, we check at the input that both Fq(1,ikl) and Fq(2,ikl) equal -1 frc1(ikl)=Erottor(itupn,isigup,num2)-Erottor(itlown,isiglow,num1) c Elow(ikl)=Erottor(itlown,isiglow,num1) c Eup(ikl)=Erottor(itupn,isigup,num2) else c this hyperfine component therefore we need to calculate quadrupole energy addition ylow=0.d0 if(Fspin.ne.0.5d0.and.Jq(1,ikl).ne.0)then call casimir(Jq(1,ikl),Fspin,Fq(1,ikl),ylow) endif yup=0.d0 if(Fspin.ne.0.5d0.and.Jq(2,ikl).ne.0)then call casimir(Jq(2,ikl),Fspin,Fq(2,ikl),yup) endif Equadrlow=0.d0 if(ylow.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrlow=Equadrlow+Bval(is)*drv(is,illow,num1)*2.d0*ylow/dfloat(Jq(1,ikl))/dfloat(Jq(1,ikl)+1) enddo endif Equadrup=0.d0 if(yup.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrup=Equadrup+Bval(is)*drv(is,ilup,num2)*2.d0*yup/dfloat(Jq(2,ikl))/dfloat(Jq(2,ikl)+1) enddo endif frc1(ikl)=Erottor(itupn,isigup,num2)+Equadrup-Erottor(itlown,isiglow,num1)-Equadrlow c Elow(ikl)=Erottor(itlown,isiglow,num1)+Equadrlow c Eup(ikl)=Erottor(itupn,isigup,num2)+Equadrup endif c we assume that population due to Boltzman factor is only negligibly affected by the quadrupole energy contribution c that is why we use Elow and Eup without Equadrlow,Equadrup corrections Elow(ikl)=Erottor(itlown,isiglow,num1) Eup(ikl)=Erottor(itupn,isigup,num2) 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(frc1(ikl)-frlastcal(ikl))*29979.2458d0.gt.0.001d0)then if(unc(ikl).gt.0.d0)then write(6,*)'large change in frequency at last iteration',freqm(ikl)*29979.2458d0,'MHz ',(frc1(ikl)-frlastcal(ikl))*29979.2458d0,'MHz' elseif(unc(ikl).lt.0.d0)then write(6,*)'large change in frequency at last iteration',freqm(ikl),'cm-1',(frc1(ikl)-frlastcal(ikl))*29979.2458d0,'MHz' endif endif endif c energy of the lower state c calculation of unceratinties for transitions if(Niter.ne.0)then 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 if(Nstage(in).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor deriv1=0.d0 if(yup.ne.0.d0)then deriv1=drv(in,ilup,num2)*2.d0*yup/dfloat(Jq(2,ikl))/dfloat(Jq(2,ikl)+1) endif if(ylow.ne.0.d0)then deriv1=deriv1-drv(in,illow,num1)*2.d0*ylow/dfloat(Jq(1,ikl))/dfloat(Jq(1,ikl)+1) endif c if this is pure rotational transition the contribution from quadrupole coupling constants is zero if(Fq(2,ikl).eq.-1.d0)deriv1=0.d0 else deriv1=drv(in,ilup,num2)-drv(in,illow,num1) endif 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 if(Nstage(is).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor deriv2=0.d0 if(yup.ne.0.d0)then deriv2=drv(is,ilup,num2)*2.d0*yup/dfloat(Jq(2,ikl))/dfloat(Jq(2,ikl)+1) endif if(ylow.ne.0.d0)then deriv2=deriv2-drv(is,illow,num1)*2.d0*ylow/dfloat(Jq(1,ikl))/dfloat(Jq(1,ikl)+1) endif c if this is pure rotational transition the contribution from quadrupole coupling constants is zero if(Fq(2,ikl).eq.-1.d0)deriv2=0.d0 else deriv2=drv(is,ilup,num2)-drv(is,illow,num1) endif ist=ist+1 Aincer(ikl)=Aincer(ikl)+A(int,ist)*deriv1*deriv2 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) if(fq(1,ikl).ne.-1.d0)Strength=Strength*Relqint(ikl) Stren(ikl)=Strength enddo !end of experimental data cycle Jbnd deallocate (H,EGVL,EGVC) enddo !end of experimental data cycle J c Elowest=Elowest write(6,*)'Elowest=',Elowest,'cm-1' write(6,*)'Elowest is used only in intensity calculation' write(6,1116) 1116 format(13x,'Upper level',14x,'Lower level',5x,'Intensity',6x,'Measured',13x, !'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)-frc1(ikl) Sint=Stren(ikl)*dexp(-1.439d0*(Elow(ikl)-Elowest)/Temp)*(frc1(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+frc1(ikl)*sint sintaccum=sintprev+sint else fraccum=fraccum+frc1(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(dlfprev.ge.0.d0)then Isigncat(1,icatprev)=Isigncat(1,icatprev)-1 Signrmscat(1,icatprev)=Signrmscat(1,icatprev)-dlfprev**2 else Isigncat(2,icatprev)=Isigncat(2,icatprev)-1 Signrmscat(2,icatprev)=Signrmscat(2,icatprev)-dlfprev**2 endif if(freqprev-fraccum/sintaccum.ge.0.d0)then Isigncat(1,icatprev)=Isigncat(1,icatprev)+1 Signrmscat(1,icatprev)=Signrmscat(1,icatprev)+(freqprev-fraccum/sintaccum)**2 else Isigncat(2,icatprev)=Isigncat(2,icatprev)+1 Signrmscat(2,icatprev)=Signrmscat(2,icatprev)+(freqprev-fraccum/sintaccum)**2 endif 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',20x,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(dlf.ge.0.d0)then Isigncat(1,icat(ikl))=Isigncat(1,icat(ikl))+1 Signrmscat(1,icat(ikl))=Signrmscat(1,icat(ikl))+dlf**2 else Isigncat(2,icat(ikl))=Isigncat(2,icat(ikl))+1 Signrmscat(2,icat(ikl))=Signrmscat(2,icat(ikl))+dlf**2 endif 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=frc1(ikl) sintprev=sint dlfprev=dlf icatprev=icat(ikl) weightprev=weight(ikl) endif endif if(unc(ikl).gt.0.d0)then write(6,1115)pr(isul(2,ikl)),mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl)*29979.2458D0,unc(ikl)*29979.2458D0, ! frc1(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),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl),unc(ikl), ! frc1(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,F6.1,3I4,4x,A2,I3,F6.1,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(Isigncat(1,ic).ne.0)Signrmscat(1,ic)=dsqrt(Signrmscat(1,ic)/Isigncat(1,ic)) if(Isigncat(2,ic).ne.0)Signrmscat(2,ic)=dsqrt(Signrmscat(2,ic)/Isigncat(2,ic)) if(Scat(ic).gt.0.d0)then write(6,1015)Scat(ic),Sct(ic)*29979.2458D0,Incat(ic), ! 100.d0*float(Isigncat(1,ic))/float(Incat(ic)),Signrmscat(1,ic)*29979.2458d0, ! 100.d0*float(Isigncat(2,ic))/float(Incat(ic)),Signrmscat(2,ic)*29979.2458d0 elseif(Scat(ic).lt.0.d0)then write(6,1015)Scat(ic),Sct(ic),Incat(ic), ! 100.d0*float(Isigncat(1,ic))/float(Incat(ic)),Signrmscat(1,ic), ! 100.d0*float(Isigncat(2,ic))/float(Incat(ic)),Signrmscat(2,ic) endif enddo write(6,*) 1015 format('rmscat ',F7.4,1x,' =',F12.5,2x,'n=',I5,2x,'n+%= ',F6.2,1x,'rms+= ',F12.5,2x,'n-%= ',F6.2,1x,'rms-= ',F12.5) 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.5,2x,'n=',I5) 2016 format('rmscat_cm-1 ',A2,1x,' =',F12.5,2x,'n=',I5) write(6,*) write(6,*)'rms by torsional state' do ic=-15,15 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.5,2x,'n=',I5) 2017 format('rmscat_cm-1 m=',I4,1x,' =',F12.5,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.5,2x,'n=',I5) 2018 format('rms_cm-1 delta_m',1x,' =',F12.5,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.3,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)-frc1(ikl) Sint=Stren(ikl)*dexp(-1.439d0*(Elow(ikl)-Elowest)/Temp)*(frc1(ikl))**2 if(unc(ikl).gt.0.d0)then write(6,1115)pr(isul(2,ikl)),mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl)*29979.2458D0,unc(ikl)*29979.2458D0, ! frc1(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),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl),unc(ikl),frc1(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 ipfr=ip c this is separate output for the obs-cal plot open(unit=9,file='obscal.txt',access='sequential',status='unknown') c we recalculate rms deviation for different m and symmetry taking into account special treatment of blends Symcatmhz=0.d0 Isymcmhz=0 Symcatcm=0.d0 Isymccm=0 Smcatmhz=0.d0 Imcmhz=0 Smcatcm=0.d0 Imccm=0 Sdeltammhz=0.d0 ideltammhz=0 Sdeltamcm=0.d0 ideltamcm=0 c output sorted by branch write(6,*) write(6,*)'Transitions sorted by branch' write(6,*) write(6,3136) 3136 format(19x,'Upper level',20x,'Lower level',5x,'Intensity',6x,'Measured',13x, !'Calculated',12x,'o.-c.',6x,'Elow',4x,'Strength',1x,'incl',1x,'comment') 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 call VSRTP (JS,iser,ibranch) c output the series do ikt=1,iser ikl=ibranch(ikt) dlf=freqm(ikl)-frc1(ikl) Sint=Stren(ikl)*dexp(-1.439d0*(Elow(ikl)-Elowest)/Temp)*(frc1(ikl))**2 if(unc(ikl).gt.0.d0)then write(6,3115)pr(isul(2,ikl)),parup(ikl),mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)),parlow(ikl), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl)*29979.2458D0,unc(ikl)*29979.2458D0, ! frc1(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),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl),pr(isul(1,ikl)),parlow(ikl), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),Sint,freqm(ikl),unc(ikl),frc1(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 c this is for rms deviation taking into account special treatment of blends if(incl(ikl).ne.0)then if(iblsign(ikl).eq.1)dlf=frlastcal(ikl) if(unc(ikl).gt.0.d0)then Symcatmhz(isr(1,ikl))=Symcatmhz(isr(1,ikl))+dlf**2 Isymcmhz(isr(1,ikl))=Isymcmhz(isr(1,ikl))+1 endif if(unc(ikl).lt.0.d0)then Symcatcm(isr(1,ikl))=Symcatcm(isr(1,ikl))+dlf**2 Isymccm(isr(1,ikl))=Isymccm(isr(1,ikl))+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 this is for obs-cal plot if(iblsign(ikl).eq.1)then if(unc(ikl).gt.0.d0)then write(9,4119)mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),freqm(ikl)*29979.2458D0, ! unc(ikl)*29979.2458D0,dabs(frlastcal(ikl)/unc(ikl)) else write(9,4119)mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),freqm(ikl),unc(ikl),dabs(frlastcal(ikl)/unc(ikl)) endif else if(unc(ikl).gt.0.d0)then write(9,4119)mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),freqm(ikl)*29979.2458D0, ! unc(ikl)*29979.2458D0,dabs(dlf/unc(ikl)) else write(9,4119)mq(2,ikl),Fq(2,ikl),Jq(2,ikl),Ka(2,ikl),Kc(2,ikl), ! mq(1,ikl),Fq(1,ikl),Jq(1,ikl),Ka(1,ikl),Kc(1,ikl),freqm(ikl),unc(ikl),dabs(dlf/unc(ikl)) endif endif !if(iblsign(ikl).eq.1) endif !if included if(incl(ikl).ne.0) 4119 format(I3,F6.1,3I4,4x,I3,F6.1,3I4,3x,F14.4,2x,F7.4,2x,F14.4) enddo ! end of iknl c separate the series from each other write(6,*) enddo 3115 format(A2,F6.2,I3,F6.1,3I4,4x,A2,F6.2,I3,F6.1,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(\,/) write(6,*)'rms by symmetry species and by torsional state with 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 write(6,*) write(6,*)'rms by torsional state' do ic=-15,15 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 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 write(6,*) 1000 deallocate (Aincer,Corr,Stren, frc1, Elow, Eup,STAT=ierr) deallocate (isul,inul,isr,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 c calculation of intensity for V3 variant 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 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) der1=der1+H(n1,n2n)*EVCrottor(n1,itlown,isiglow,num1) 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 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)) endif return end c subroutine for calculating the Casimir function subroutine casimir(j,fsp,fj,y) integer j real*8 y,cf,fsp,fj cf=fj*(fj+1.d0)-dfloat(J*(J+1))-fsp*(fsp+1.d0) y=(0.75D0*cf*(cf+1.D0)-fsp*(fsp+1.d0)*dfloat(J*(J+1)))/ 1 2.D0/dfloat(2*J-1)/dfloat(2*J+3)/fsp/(2.d0*fsp-1.d0) return end c This subroutine provides iteration of the fitting process subroutine fitting(itn) 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 yup,ylow,Equadrlow,Equadrup 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 Elowest=1.d+38 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 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 if(mq(2,ikl).eq.isigup-2*idelm)ivtup=3 if(mq(2,ikl).eq.isigup+2*idelm)ivtup=4 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 if(mq(1,ikl).eq.isiglow-2*idelm)ivtlow=3 if(mq(1,ikl).eq.isiglow+2*idelm)ivtlow=4 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 if(itupn.eq.0.or.itupn.gt.ndim.or.itlown.eq.0.or.itlown.gt.ndim.or.isigup.ne.isiglow)then c if(itupn.eq.0.or.itupn.gt.ndim.or.itlown.eq.0.or.itlown.gt.ndim)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 if(itn.gt.1.and.dsw.lt.1.d-4)then c if(dabs((sintcalcbl-sintbllast(ikl))/sintcalcbl).gt.1.d-4)then c if(unc(ikl).gt.0.d0)then c write(6,*)'Warning',freqm(ikl)*29979.2458d0,'large change in intensity of the blend' c else c write(6,*)'Warning',freqm(ikl),'large change in intensity of the blend' c endif c write(6,*)'Probably not all components of the cluster are included' c endif sintbllast(ikl)=sintcalcbl else sintbllast(ikl)=sintcalcbl endif 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 yup=0.d0 ylow=0.d0 if(Fq(1,ikl).eq.-1.d0)then c hypothetical unsplit rotational transition, we check at the input that both Fq(1,ikl) and Fq(2,ikl) equal -1 frc=Erottor(itupn,isigup,num2)-Erottor(itlown,isiglow,num1) else c this hyperfine component therefore we need to calculate quadrupole energy addition ylow=0.d0 if(Fspin.ne.0.5d0.and.Jq(1,ikl).ne.0)then call casimir(Jq(1,ikl),Fspin,Fq(1,ikl),ylow) endif yup=0.d0 if(Fspin.ne.0.5d0.and.Jq(2,ikl).ne.0)then call casimir(Jq(2,ikl),Fspin,Fq(2,ikl),yup) endif Equadrlow=0.d0 if(ylow.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrlow=Equadrlow+Bval(is)*drv(is,illow,num1)*2.d0*ylow/dfloat(Jq(1,ikl))/dfloat(Jq(1,ikl)+1) enddo endif Equadrup=0.d0 if(yup.ne.0.d0)then !we have nonzero contribution to the quadrupole energy c we need to consider quadrupole coupling parameters do is=1,numpar if(Nstage(is).ne.-1)cycle !consider only quadrupole coupling parameters if(Nfloat(is).lt.0)cycle !conisder only leading parameter since all derivative of composite parameter is put to the leading Equadrup=Equadrup+Bval(is)*drv(is,ilup,num2)*2.d0*yup/dfloat(Jq(2,ikl))/dfloat(Jq(2,ikl)+1) enddo endif frc=Erottor(itupn,isigup,num2)+Equadrup-Erottor(itlown,isiglow,num1)-Equadrlow endif 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 if(itn.gt.1.and.dsw.lt.1.d-4)then c if(dabs((sintcalcbl-sintbllast(ikl))/sintcalcbl).gt.1.d-4)then c if(unc(ikl).gt.0.d0)then c write(6,*)'Warning',freqm(ikl)*29979.2458d0,'large change in intensity of the blend' c else c write(6,*)'Warning',freqm(ikl),'large change in intensity of the blend' c endif c write(6,*)'Probably not all components of the cluster are included' c endif sintbllast(ikl)=sintcalcbl else sintbllast(ikl)=sintcalcbl endif 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/unc(ikl)).gt.ocmax)then endif !if(Nrobust.ne.1)then c derivatives for the fitting process if(Fq(1,ikl).eq.-1.d0)then do in=1,numpar if(Nstage(in).eq.-1)then derp(in)=0.d0 else derp(in)=(drv(in,ilup,num2)-drv(in,illow,num1)) endif enddo else do in=1,numpar if(Nstage(in).eq.-1)then c this is quadrupole parameters we need to multiply them by additional factor derp(in)=0.d0 if(Jq(2,ikl).ne.0)then derp(in)=drv(in,ilup,num2)*2.d0*yup/dfloat(Jq(2,ikl))/dfloat(Jq(2,ikl)+1) endif if(Jq(1,ikl).ne.0)then derp(in)=derp(in)-drv(in,illow,num1)*2.d0*ylow/dfloat(Jq(1,ikl))/dfloat(Jq(1,ikl)+1) endif else derp(in)=(drv(in,ilup,num2)-drv(in,illow,num1)) endif enddo endif 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) if(fq(1,ikl).ne.-1.d0)Strength=Strength*Relqint(ikl) c we do not take into account quadrupole addition in Elow c we assume that population due to Boltzman factor is affected negligibly by hyperfine splitting Sint=Strength*dexp(-1.439d0*(Erottor(itlown,isiglow,num1)-Elowest)/Temp)*(frc)**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 processing 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) if(fq(1,ikl).ne.-1.d0)Strength=Strength*Relqint(ikl) c we do not take into account quadrupole addition in Elow Sint=Strength*dexp(-1.439d0*(Erottor(itlown,isiglow,num1)-Elowest)/Temp)*(frc)**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) if(fq(1,ikl).ne.-1.d0)Strength=Strength*Relqint(ikl) Sint=Strength*dexp(-1.439d0*(Erottor(itlown,isiglow,num1)-Elowest)/Temp)*(frc)**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 if(itn.gt.1.and.dsw.lt.1.d-4)then c if(dabs((sintcalcbl-sintbllast(ikl))/sintcalcbl).gt.1.d-4)then c if(unc(ikl).gt.0.d0)then c write(6,*)'Warning',freqm(ikl)*29979.2458d0,'large change in intensity of the blend' c else c write(6,*)'Warning',freqm(ikl),'large change in intensity of the blend' c endif c write(6,*)'Probably not all components of the cluster are included' c endif sintbllast(ikl)=sintcalcbl else sintbllast(ikl)=sintcalcbl endif 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 if(itn.gt.1.and.dsw.lt.1.d-4)then c if(dabs((sintacc(ij1)-sintaccpr(ij1))/sintacc(ij1)).gt.1.d-4)then c if(Scat(icatbl(ij1)).gt.0.d0)then c write(6,*)'Warning',frblend(ij1)*29979.2458d0,'large change in intensity of the blend' c else c write(6,*)'Warning',frblend(ij1),'large change in intensity of the blend' c endif c write(6,*)'Probably not all components of the cluster are included' c endif sintaccpr(ij1)=sintacc(ij1) else sintaccpr(ij1)=sintacc(ij1) endif 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) c save for checking relative changes in total intensity of the blends dsw=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 if(mlev(id).eq.isig-2*idelm)ivt=3 if(mlev(id).eq.isig+2*idelm)ivt=4 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 if(Nstage(ikl).ne.-1)then !for quadrupole parameters we need derivatives even if fixed c if this parameter is fixed do not calculate derivative for it, exception is quadrupole parameters 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 endif !check whether it is quadrupole 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 labelingV3withdegeneigenvect1(J,itn,num) c This is the latest version 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),sum4s1(ndim),sum5s1(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 sum4s1=0.d0 sum5s1=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) sum4s1(i)=sum123(5) sum5s1(i)=sum123(6) 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 c write(6,*)'the lowest vt coeff included for vt=0 is less than c ! 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 if(itupdown.ne.0)then 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 endif !checking itupdown.ne.0 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 sum3s1(iperm1(ij))=0.d0 sum4s1(iperm1(ij))=0.d0 sum5s1(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 c write(6,*)'the lowest vt coeff included for vt=1 is less than c ! 0.5',sum1s1(iperm(nrotor-2*j)),j,isigr endif c sort the 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 if(itupdown.ne.0)then 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 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 sum3s1(iperm1(ij))=0.d0 sum4s1(iperm1(ij))=0.d0 sum5s1(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 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(sum2s1(iperm(ij)).gt.sum4s1(iperm(ij)).and.sum3s1(iperm(ij)).gt.sum4s1(iperm(ij)))then sum3s1(iperm(ij))=sum3s1(iperm(ij))+sum2s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum2s1(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff included for vt=2 is less than c ! 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 if(itupdown.ne.0)then 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 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) sum3s1(iperm1(ij))=0.d0 sum4s1(iperm1(ij))=0.d0 sum5s1(iperm1(ij))=0.d0 enddo c vt=3 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum3s1 c CALL DSVRBP (nrotor,sum2s1,bulk,iperm) call VSRTPD (sum3s1,nrotor,iperm) sum3s1=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(sum3s1(iperm(ij)).gt.sum5s1(iperm(ij)).and.sum4s1(iperm(ij)).gt.sum5s1(iperm(ij)))then sum4s1(iperm(ij))=sum4s1(iperm(ij))+sum3s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum3s1(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff included for vt=3 is less than c ! 0.5',sum3s1(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 if(itupdown.ne.0)then 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 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,3,ij)=iperm1(ij) sum4s1(iperm1(ij))=0.d0 sum5s1(iperm1(ij))=0.d0 enddo c vt=4 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum4s1 c CALL DSVRBP (nrotor,sum2s1,bulk,iperm) call VSRTPD (sum4s1,nrotor,iperm) sum4s1=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(sum4s1(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff included for vt=4 is less than c ! 0.5',sum4s1(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 if(itupdown.ne.0)then 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 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,4,ij)=iperm1(ij) sum5s1(iperm1(ij))=0.d0 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) real*8 sum4s1(ndim), sum5s1(ndim), sum4s2(ndim), sum5s2(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 sum4s1=0.d0 sum5s1=0.d0 sum0s2=0.d0 sum1s2=0.d0 sum2s2=0.d0 sum3s2=0.d0 sum4s2=0.d0 sum5s2=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) sum4s1(n1)=sum123(5) sum5s1(n1)=sum123(6) 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) sum4s2(n2)=sum123(5) sum5s2(n2)=sum123(6) 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 c 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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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 sum3s1(iperm1(ij))=0.d0 sum4s1(iperm1(ij))=0.d0 sum5s1(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 c 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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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 sum3s1(iperm1(ij))=0.d0 sum4s1(iperm1(ij))=0.d0 sum5s1(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 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(sum2s1(iperm(ij)).gt.sum4s1(iperm(ij)).and.sum3s1(iperm(ij)).gt.sum4s1(iperm(ij)))then sum3s1(iperm(ij))=sum3s1(iperm(ij))+sum2s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum2s1(iperm(nrotor-2*j)).lt.0.5d0)then c 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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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)) sum3s1(iperm1(ij))=0.d0 sum4s1(iperm1(ij))=0.d0 sum5s1(iperm1(ij))=0.d0 enddo c vt=3 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum3s1 c CALL DSVRBP (nrotor,sum1s1,bulk,iperm) call VSRTPD (sum3s1,nrotor,iperm) sum3s1=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(sum3s1(iperm(ij)).gt.sum5s1(iperm(ij)).and.sum4s1(iperm(ij)).gt.sum5s1(iperm(ij)))then sum4s1(iperm(ij))=sum4s1(iperm(ij))+sum3s1(iperm(ij)) endif enddo c indication of problems with labeling if(sum3s1(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff for vt=3 <0.5',j,isig,sum3s1(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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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,3,ij)=Jsign1(iperm1(ij)) sum4s1(iperm1(ij))=0.d0 sum5s1(iperm1(ij))=0.d0 enddo c vt=4 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum4s1 c CALL DSVRBP (nrotor,sum1s1,bulk,iperm) call VSRTPD (sum4s1,nrotor,iperm) sum4s1=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(sum4s1(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff for vt=4 <0.5',j,isig,sum4s1(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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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,4,ij)=Jsign1(iperm1(ij)) sum5s1(iperm1(ij))=0.d0 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 c 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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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 sum3s2(iperm1(ij))=0.d0 sum4s2(iperm1(ij))=0.d0 sum5s2(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 c 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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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 sum3s2(iperm1(ij))=0.d0 sum4s2(iperm1(ij))=0.d0 sum5s2(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 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(sum2s2(iperm(ij)).gt.sum4s2(iperm(ij)).and.sum3s2(iperm(ij)).gt.sum4s2(iperm(ij)))then sum3s2(iperm(ij))=sum3s2(iperm(ij))+sum2s2(iperm(ij)) endif enddo c indication of problems with labeling if(sum2s2(iperm(nrotor-2*j)).lt.0.5d0)then c 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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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)) sum3s2(iperm1(ij))=0.d0 sum4s2(iperm1(ij))=0.d0 sum5s2(iperm1(ij))=0.d0 enddo c vt=3 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum3s2 c CALL DSVRBP (nrotor,sum1s2,bulk,iperm) call VSRTPD (sum3s2,nrotor,iperm) sum3s2=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(sum3s2(iperm(ij)).gt.sum5s2(iperm(ij)).and.sum4s2(iperm(ij)).gt.sum5s2(iperm(ij)))then sum4s2(iperm(ij))=sum4s2(iperm(ij))+sum3s2(iperm(ij)) endif enddo c indication of problems with labeling if(sum3s2(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff for vt=3 <0.5',j,abs(isig-3),sum3s2(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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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,3,ij)=Jsign2(iperm1(ij)) sum4s2(iperm1(ij))=0.d0 sum5s2(iperm1(ij))=0.d0 enddo c vt=4 do ij=1,nrotor iperm(ij)=ij enddo c sort the sum123 the vt coefficients bulk=sum4s2 c CALL DSVRBP (nrotor,sum1s2,bulk,iperm) call VSRTPD (sum4s2,nrotor,iperm) sum4s2=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(sum4s2(iperm(nrotor-2*j)).lt.0.5d0)then c write(6,*)'the lowest vt coeff for vt=4 <0.5',j,abs(isig-3),sum4s2(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 if(itupdown.ne.0)then 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 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 if(itupdown.ne.0)then 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 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,4,ij)=Jsign2(iperm1(ij)) sum5s2(iperm1(ij))=0.d0 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 c we can initialize ciy once here for all K because sin terms do not appear without Jy terms c and if Jy operator present ciy is set for each K 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 rotational levels included in the fit =',Nlev elseif(in.eq.-1)then write(6,*)'Number of rotational 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 rotational 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 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 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 c do not consider quadrupole coupling parameters if(Nstage(is).eq.-1)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 c do not consider quadrupole coupling parameters if(Nstage(ikl).eq.-1)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(i).eq.0)cycle c do not consider quadrupole coupling parameters if(Nstage(i).eq.-1)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 do not consider quadrupole coupling parameters if(Nstage(ikl).eq.-1)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(i).eq.0)cycle c do not consider quadrupole coupling parameters if(Nstage(i).eq.-1)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 do not consider quadrupole coupling parameters if(Nstage(ikl).eq.-1)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 subroutine Relquadrint() use expdat use param real*8 accqint,f1,f2,fqint do ikl=1,Ndata if(Fq(1,ikl).eq.-1.d0)then c rotational unsplit transitions Relqint(ikl)=1.d0 else c quadrupole hyperfine component we need to calculate relative intensity c we need to calculate intensities of all possible components to get relative intensity of desired component accqint=0.d0 Isplit=Jq(1,ikl)+1+idint(Fspin-dabs(dfloat(Jq(1,ikl))-Fspin)) f1=dabs(dfloat(Jq(1,ikl))-Fspin)-1.d0 do is=1,Isplit !cycle over allowed lower F components f1=f1+1.d0 do it=-1,1 !the selection rules allow deltaF=0,+/-1 f2=f1+dfloat(it) if(f2.le.dfloat(Jq(2,ikl))+Fspin.and.f2.ge.dabs(dfloat(Jq(2,ikl))-Fspin))then c we have a legal hyperfine component and we need to calculate intensity for it call quadrint(Jq(1,ikl),Jq(2,ikl),Fspin,f1,f2,fqint) accqint=accqint+fqint else cycle endif enddo !enddo from is cycle enddo !enddo from it cycle c we have sum of intensity of all components now we can calculate relative intensity of desired transition if(accqint.ne.0.d0)then call quadrint(Jq(1,ikl),Jq(2,ikl),Fspin,Fq(1,ikl),Fq(2,ikl),fqint) Relqint(ikl)=fqint/accqint else Relqint(ikl)=0.d0 !zero intensity if there is not quadrupole components with intensity happens for 0-0 transition endif endif !endif from checking whether we have unsplit rotational transition enddo !enddo from ikl cycle return end subroutine quadrint(J1,J2,Fspin,f1,f2,fqint) real*8 Fspin,f1,f2,fqint fqint=0.d0 if(J1.eq.J2)then c we have Q transition if(f1.eq.f2)then if(f1.eq.0.d0)then fqint=0.d0 else fqint=(dfloat(J1*(J1+1))+f1*(f1+1.d0)-Fspin*(Fspin+1.d0))**2*(2.d0*f1+1.d0)/f1/(f1+1.d0) endif elseif(f1.lt.f2)then if(f2.eq.0.d0)then fqint=0.d0 else fqint=-1.d0*(dfloat(j1)+f2+Fspin+1.d0)*(dfloat(j1)+f2-Fspin)*(dfloat(j1)-f2+Fspin+1.d0)* ! (dfloat(j1)-f2-Fspin)/f2 endif elseif(f1.gt.f2)then fqint=-1.d0*(dfloat(j1)+f2+Fspin+2.d0)*(dfloat(j1)+f2-Fspin+1.d0)*(dfloat(j1)-f2+Fspin)* ! (dfloat(j1)-f2-Fspin-1.d0)/(f2+1.d0) endif elseif(j1.lt.j2)then c we have R transition if(f1.lt.f2)then if(f2.eq.0.d0)then fqint=0.d0 else fqint=(dfloat(j2)+f2+Fspin+1.d0)*(dfloat(j2)+f2+Fspin)*(dfloat(j2)+f2-Fspin)* ! (dfloat(j2)+f2-Fspin-1.d0)/f2 endif elseif(f1.eq.f2)then if(f2.eq.0.d0)then fqint=0.d0 else fqint=-1.d0*(dfloat(j2)+f2+Fspin+1.d0)*(dfloat(j2)+f2-Fspin)*(dfloat(j2)-f2+Fspin)* ! (dfloat(j2)-f2-Fspin-1.d0)*(2.d0*f2+1.d0)/f2/(f2+1.d0) endif elseif(f1.gt.f2)then fqint=(dfloat(j2)-f2+Fspin)*(dfloat(j2)-f2+Fspin-1.d0)*(dfloat(j2)-f2-Fspin-1.d0)* ! (dfloat(j2)-f2-Fspin-2.d0)/(f2+1.d0) endif elseif(j1.gt.j2)then c we have P transition if(f1.eq.f2)then if(f2.eq.0.d0)then fqint=0.d0 else fqint=-1.d0*(dfloat(j1)+f2+Fspin+1.d0)*(dfloat(j1)+f2-Fspin)*(dfloat(j1)-f2+Fspin)* ! (dfloat(j1)-f2-Fspin-1.d0)*(2.d0*f2+1.d0)/f2/(f2+1.d0) endif elseif(f1.gt.f2)then if(f1.eq.0.d0)then fqint=0.d0 else fqint=(dfloat(j1)+f1+Fspin+1.d0)*(dfloat(j1)+f1+Fspin)*(dfloat(j1)+f1-Fspin)* ! (dfloat(j1)+f1-Fspin-1.d0)/f1 endif elseif(f1.lt.f2)then fqint=(dfloat(j1)-f1+Fspin)*(dfloat(j1)-f1+Fspin-1.d0)*(dfloat(j1)-f1-Fspin-1.d0)* ! (dfloat(j1)-f1-Fspin-2.d0)/(f1+1.d0) endif endif 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= 4' read(5,*)isigma,idelm,Fspin 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 will be treated as F*pa**2+RHO*pa*Jz' endif 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,' spin=',Fspin 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(iabs(norder).gt.14)norder=sign(14,norder) 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 allowed at the fitting stage - ' write(6,*)'if larger the transition is omitted at particular iteration=',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),Fq(2,Ndat),Jq(2,Ndat),Ka(2,Ndat),Kc(2,Ndat),incl(Ndat),Incat(Ncatm), ! Isigncat(2,Ncatm),Signrmscat(2,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 requirememnts 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 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 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.2.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.4)then write(6,*)'The vtup=',vtup,' exceeds the maximum allowed value= 2' vtup=4 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,I5,F6.1,3I5,3x,I5,F6.1,3I5,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),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(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),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(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),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(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,I5,F6.1,3I5,2x,I5,F6.1,3I5,I5,F10.4,1x,A12) c check that both levels are presented as hypothetical rotational or like hyperfine split if(Fq(2,i).eq.-1.d0.and.Fq(1,i).ne.-1.d0)then write(6,*)'Fup and Flow should either both equal -1 or both correspond to F quantum number' write(6,1115)freqm(i),mq(2,i),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif if(Fq(1,i).eq.-1.d0.and.Fq(2,i).ne.-1.d0)then write(6,*)'Fup and Flow should either both equal -1 or both correspond to F quantum number' write(6,1115)freqm(i),mq(2,i),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif c check correspondence of F values and J values. if(Fq(2,i).ne.-1.d0)then !If F=-1 then we work with hypothetical rotational transition iflagFq=0 fqtest=dabs(dfloat(Jq(2,i))-Fspin) do while (fqtest.le.dfloat(Jq(2,i))+Fspin) if(Fq(2,i).eq.fqtest)then iflagFq=1 exit endif fqtest=fqtest+1.d0 enddo if(iflagFq.eq.0)then write(6,*)'wrong Fup label' write(6,1115)freqm(i),mq(2,i),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif endif if(Fq(1,i).ne.-1.d0)then !If F=-1 then we work with hypothetical rotational transition iflagFq=0 fqtest=dabs(dfloat(Jq(1,i))-Fspin) do while (fqtest.le.dfloat(Jq(1,i))+Fspin) if(Fq(1,i).eq.fqtest)then iflagFq=1 exit endif fqtest=fqtest+1.d0 enddo if(iflagFq.eq.0)then write(6,*)'wrong Flow label' write(6,1115)freqm(i),mq(2,i),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif endif c check selection rules for F if(dabs(Fq(2,i)-Fq(1,i)).gt.1.d0)then write(6,*)'F quantum number do not satisfy allowed selection rules 0,+/-1' write(6,1115)freqm(i),mq(2,i),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(1,i),Jq(1,i),Ka(1,i),Kc(1,i),incl(i),unc(i),comment(i) i=i-1 cycle endif 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),Fq(2,i),Jq(2,i),Ka(2,i),Kc(2,i), ! mq(1,i),Fq(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 uncertainties' 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+1),itlev(2*Ndata+1),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),Relqint(Ndata),ip(Ndata),ipfr(Ndata), ! ipbl(Ndata),frlastcal(Ndata),sintbllast(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:4,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(0:ndim+1,0:isigma,0:2),Evcrottor(ndim,0:ndim+1,0:isigma,0:2),parAB(0:ndim+1,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() call Relquadrint() allocate (drvacc(numpar,ibldifj),fracc(ibldifj),sintacc(ibldifj),weightbl(ibldifj), ! frblend(ibldifj),icatbl(ibldifj),sintaccpr(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=abs(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 goto 333 c first we would like to get the terms for the contact transformations and print them since we do not need to keep them for further evaluation write(10,*)'Possible contact transformation terms' write(10,*)'We do not output J**2, J**4 etc. terms and we do not count them' write(10,*)'since they are obtained as linear combinations of other terms' 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 change sign 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.1)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.1)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 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 if(IBpartest(ikl,1).ne.0)cycle 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 c clear the storage for parameters IBpartest=0 Nfloattest=0 Nstagetest=0 Bnametest='test ' Bvaltest=0.d0 333 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 are 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 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