C============================================================================== C C X I A M C C Rotational, Centrifugal Distortion, Internal Rotation Calculation (V2.5e) C Holger Hartwig 08-Nov-96 (hartwig@phc.uni-kiel.de) C C Please cite: H.Hartwig and H.Dreizler, Z.Naturforsch, 51a (1996) 923. C C============================================================================== C C This file collects the constituent modules for XIAM in the order: C C iam iamio iamint iamadj iamm iamv iamv2 iamfit mgetx iamsys iamlib C C Three remaining INCLUDEd modules: C C iam_.for, iamdata_.for, mgetx_.for C C are in separate files and have to be available on compilation. C Simplest compilation command with Compaq Visual Fortran is: C C df -fast -static xiamall C zk C------------------------------------------------------------------------------ C C module IAM.FOR C C------------------------------------------------------------------------------ C program xiam C Fitting of Rotational Constants and Centrifugal Distortion Constants C and Internal-rotation parameters of a 3 fold top C Syntax of Input-File: C C Phase Convention: =0.5*dsqrt(J*(J+1)-K*(K+1)) C implicit none include 'iam_.for' C arrays for fit-proc C DIMFIT: Dimension for paramaters to be fitted simultaneouly real*8 covar(DIMFIT,DIMFIT), alpha(DIMFIT,DIMFIT), $ evec(DIMFIT,DIMFIT), w(DIMFIT), $ beta(DIMFIT), freed(DIMFIT) C One fit paramater is a linearcombination of the parameters a C PArameter Linear Combinations as fit parameters C DIMPLC maximum number parameters in one fitparameters real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) C dfit controls the differences quotient calculation integer dfit(DIMFIT) C a is the parameter array for the Hamiltonian real*8 a(DIMPAR,DIMVB), anew(DIMPAR,DIMVB), da(DIMPAR,DIMVB) C ifit controls if analytic derivatives are to be calculated integer ifit(DIMPAR,DIMVB) C real*8 ab(DIMPAR) real*8 chi2(DIMVB,DIMVV,2),wght(DIMVB,DIMVV,2) integer ndat(DIMVB,DIMVV,2) real*8 sigsq,sigsqold,stepw,cmax integer npar,i,izyk,j,iconv,iq,nsvfit,fstat,ift,nfit,itop,deriv integer myints,oib,maxf,maxb,maxg,ifunpr,ming integer ij,ib,iv,is,jc,ic,i2f,isf real*8 maxchn character*15 astr character*12 dstr character*12 binfname logical sortend real*8 pi,indeg,inkj,inkc,incm,fold,condno integer myand,myor external myand,myor integer sig_stat common/sig_com/sig_stat include 'iamdata_.for' call mysignal() pi=dacos(-1.0d0) inkj=3.9903132D-04 inkc=3.9903132D-04/4.186903D0 indeg=180.0d0/pi incm=1.0d0/29.97925d0 write(*,'(A,A)') $ ' Rotational, Centrifugal Distortion,' $ ,' Internal Rotation Calculation (V2.5e)' write(*,'(23X,A)') $ 'Holger Hartwig 08-Nov-96 (hartwig@phc.uni-kiel.de)' write(*,'(/,2A,/)') ' Please cite:', $ ' H.Hartwig and H.Dreizler, Z.Naturforsch, 51a (1996) 923.' write(*,'(A,$)') ' Calculation date and time: ' call mydate() write(*,'(A)') ' Type help now for the list of parameters : ' call parinp(a,palc,pali,ifit,dfit,npar,nfit) call mysignal() C the array todo is the list of (good) quantum no.s which C have to be calculated to assign all transitions C the good quantum no.s are j, f, b and sigma, no symmetry adapted k used size(S_MAXK)=0 ncalc=0 maxf=0 maxg=0 maxb=0 ming=100 C qlin is the list of transitions do ic=1, DIMTDO todo(ic,Q_STAT)=0 end do C copy qlin into todo do i=1, ctlint(C_NDATA) do iq=Q_UP, Q_LO if (maxg.lt.qlin(i,Q_S,iq)) maxg=qlin(i,Q_S,iq) if (ming.gt.qlin(i,Q_S,iq)) ming=qlin(i,Q_S,iq) if (maxb.lt.qlin(i,Q_B,iq)) maxb=qlin(i,Q_B,iq) if (maxf.lt.qlin(i,Q_F,iq)) maxf=qlin(i,Q_F,iq) c vb(qlin(i,Q_B,iq))=qlin(i,Q_V1,iq) if (size(S_MAXK).lt.qlin(i,Q_J,iq)) $ size(S_MAXK)=qlin(i,Q_J,iq) do ic=1, ncalc if ((qlin(i,Q_J,iq).eq.todo(ic,Q_J)) $ .and.(qlin(i,Q_S,iq).eq.todo(ic,Q_S)) $ .and.(qlin(i,Q_B,iq).eq.todo(ic,Q_B)) $ .and.(qlin(i,Q_F,iq).eq.todo(ic,Q_F))) then goto 50 end if end do ncalc=ncalc+1 if (ncalc.gt.DIMTDO) stop 'ERROR: todo >DIMTDO' todo(ncalc,Q_J)=qlin(i,Q_J,iq) todo(ncalc,Q_S)=qlin(i,Q_S,iq) todo(ncalc,Q_B)=qlin(i,Q_B,iq) todo(ncalc,Q_F)=qlin(i,Q_F,iq) ic=ncalc 50 continue if ((dln(i,LN_ERR).ne.NOFIT).or.(ctlint(C_DFRQ).gt.0)) $ todo(ic,Q_STAT)=myor(todo(ic,Q_STAT),2) end do end do C for intensities all j,b,f,gam are needed if (ctlint(C_INTS).ge.2) then write(*,'(/,A)') ' Intensity Calculation Mode ' if (ctlint(C_NZYK).ne.1) then ctlint(C_NZYK)=1 write(*,'(A)') ' Number of iteration cylcles reset to one !' end if c if (ctlint(C_NTOP).gt.0) ming=min(1,ming) do ib=1, size(S_NB) ! maxb do ij=0,size(S_MAXK) C because nq-hfs intensities are not implemented: ignore f C do i2f= i2f=-1 isf=0 if (ctlint(C_INTS).eq.2) isf=1 do is=isf, size(S_G) do ic=1, ncalc if ( (ij.eq.todo(ic,Q_J)) $ .and.(is.eq.todo(ic,Q_S)) $ .and.(ib.eq.todo(ic,Q_B)) $ .and.(i2f.eq.todo(ic,Q_F))) goto 51 end do ncalc=ncalc+1 if (ncalc.gt.DIMTDO) stop 'ERROR: todo >DIMTDO' todo(ncalc,Q_J)=ij todo(ncalc,Q_S)=is todo(ncalc,Q_B)=ib todo(ncalc,Q_F)=i2f 51 continue end do C end do end do end do end if C sort b values in first place, followed by ascending J values do iq=1, ncalc sortend=.true. do i=2, ncalc if (todo(i-1,Q_B).gt.todo(i,Q_B)) then call swptdo(i,i-1) sortend=.false. end if end do if (sortend) goto 13 end do 13 continue do iq=1, ncalc sortend=.true. do i=2, ncalc if ((todo(i-1,Q_J).gt.todo(i,Q_J)) $ .and.(todo(i-1,Q_B).eq.todo(i,Q_B))) then call swptdo(i,i-1) sortend=.false. end if end do if (sortend) goto 12 end do 12 continue do iq=1, ncalc sortend=.true. do i=2, ncalc if ((todo(i-1,Q_S).gt.todo(i,Q_S)) $ .and.(todo(i-1,Q_J).eq.todo(i,Q_J)) $ .and.(todo(i-1,Q_B).eq.todo(i,Q_B))) then call swptdo(i,i-1) sortend=.false. end if end do if (sortend) goto 11 end do 11 continue write(*,'(/,2X,A,I4)') '\\ Maximal K = J =',size(S_MAXK) if (myand(ctlint(C_PRI),AP_ST).ne.0) then write(*,'(/,A)') ' ToDo: list of quantum no.' write(*,'(3X,A)') ' J Sym B F Stat' do i=1,ncalc write(*,'(3X,5I4)') todo(i,Q_J),todo(i,Q_S) $ ,todo(i,Q_B),todo(i,Q_F),todo(i,Q_STAT) end do end if C -------------------------------------------------------------- oib =-1 do ic=1, ncalc ib =todo(ic,Q_B) if (ib.ne.oib) then oib=ib ctlint(C_WOODS)=ctlnb(CB_WDS,ib) ctlint(C_ADJF) =ctlnb(CB_ADJ,ib) write(*,'(2X,2(A,I3))') '\\ B=',ib,' adj=',ctlint(C_ADJF) if (ctlint(C_NTOP).le.0) goto 33 if (myand(ctlint(C_WOODS),1).ne.0) write(*,'(2X,A)') $ '\\ (1) calculate torsional integrals ' if (myand(ctlint(C_WOODS),2).ne.0) write(*,'(2X,A)') $ '\\ (2) use scaled torsional integrals ' if (myand(ctlint(C_WOODS),4).ne.0) write(*,'(2X,A)') $ '\\ (4) use torsional integrals in the rotation matrix ' if (myand(ctlint(C_WOODS),8).ne.0) write(*,'(2X,A)') $ '\\ (8) use torsional integrals in H_ir for other top(s)' if (myand(ctlint(C_WOODS),16).ne.0) write(*,'(2X,A)') $ '\\ (16)use torsional integrals in twotop terms' if (myand(ctlint(C_WOODS),32).ne.0) write(*,'(2X,A)') $ '\\ (32)use torsional integrals in rigid rotor H_rr ' if (myand(ctlint(C_WOODS),64).ne.0) write(*,'(2X,A)') $ '\\ (64)multiply torsional integrals like Demaison' 33 continue end if end do do i=1, DIMPAR do ib=1, size(S_NB) anew(i,ib)=a(i,ib) end do end do sigsqold=1.0d30 iconv=1 deriv=1 fstat=0 stepw=1.0d0 myints=ctlint(C_INTS) ctlint(C_INTS)=0 do izyk=1, ctlint(C_NZYK) ifunpr=0 if (ctlint(C_EVAL).ne.0) write(20,'(/,A,i5)') ' Iteration',izyk if (izyk.ne.1) write(*,'(/,A,/,A,i3)') $ ' -------------------------------------------------------', $ ' Iteration :', izyk-1 xcy=0 if (myand(ctlint(C_XPR),XP_EC).ne.0) xcy=1 if ((izyk.eq.1).and.(myand(ctlint(C_XPR),XP_FI).ne.0)) xcy=1 if ((iconv.ge.2).and.(myand(ctlint(C_XPR),XP_LA).ne.0)) xcy=1 if ((myand(ctlint(C_PRI),AP_PC).ne.0).and.(xcy.ge.1)) $ call prpar(a) C -- calc. the spectrum if (ctlint(C_NZYK).eq.1) ctlint(C_INTS)=myints if (iconv.eq.2) ctlint(C_INTS)=myints call calc1(anew,ifit,dfit,npar,nfit,palc,pali,0) if (ctlint(C_NZYK).eq.1) goto 40 C -- get sigsq fstat=0 call lmfit(ctlint(C_NDATA),npar,size(S_NB) $ ,DIMFIT,DIMPAR,DIMVB,DIMPLC $ ,ctlint(C_PRI),nsvfit,nfit,ifit,dfit $ ,alpha,covar,evec,beta,w,a,anew,da,freed,palc,pali $ ,ctlpar(C_ROFIT),sigsq,sigsqold,ctlpar(C_EPS) $ ,stepw,fstat,ctlint(C_ORGER),0 $ ,ctlpar(C_LMBDA),ctlint(C_FITSC),ctlint(C_SVDER)) C -- test if sigsq was improved if ((sigsq/sigsqold).le.ctlpar(C_CNVG)) iconv=1 if (((sigsq/sigsqold).gt.ctlpar(C_CNVG)) $ .and.((sigsq/sigsqold).le.(2.0d0-ctlpar(C_CNVG)))) $ iconv=iconv+1 C -- switch to better derivatives if the fit is not converging if ((sigsq/sigsqold).gt.(2.0d0-ctlpar(C_CNVG))) then if (iconv.gt.0) iconv=0 if (iconv.le.0) iconv=iconv-1 end if C-- set deriv to 3 at the the first time; deriv is set to 2 later on. if ((iconv.eq.-3).and.(deriv.eq.1)) then deriv=3 write(*,*)'Switching to better derivatives (takes more time)' end if if ((sigsq.lt.sigsqold).and.(myand(ctlint(C_XPR),XP_CC).ne.0)) $ xcy=1 write(*,'(A,D12.6,A,F8.6,A,I2)') $ ' Sigma:',sqrt(sigsq) $ ,' Sigma/OldSigma:',sqrt(sigsq/sigsqold) $ ,' conv:',iconv C -- print the parameters if anew is better than before if ((izyk.ne.1).and.(xcy.ge.1)) then write(*,'(/,15X,A,5X,A)') 'Parameters','Change' call pra(anew,da,ifit,myand(ctlint(C_PRI),AP_PL),1,0) end if C -- print the parameter with the max change if (izyk.ne.1) then maxchn=0.0 ic=0 do i=1, npar do ib=1, size(S_NB) if ((anew(i,ib).ne.0.0).and.(ifit(i,ib).ne.0)) then if (abs(da(i,ib)/anew(i,ib)).gt.maxchn) then maxchn=abs(da(i,ib)/anew(i,ib)) ic=i ij=ib end if end if end do end do if (ic.gt.0) then call pra_f(anew(ic,ij),da(ic,ij),astr,dstr) write(*,'(1X,2A,I1,4A,F8.3,A)') parstr(ic),'(',ij,')' $ ,astr,' ',dstr,maxchn*100.0,'% Max. Change' end if end if C -- print the transitions if (((myand(ctlint(C_PRI),AP_TL).ne.0).and.(xcy.ge.1)).or. $ ((myand(ctlint(C_PRI),AP_TF).ne.0).and.(izyk.eq.1))) then write(*,*) ifunpr=1 call funpr(ctlpar(C_ROFIT),ndat,chi2,wght) end if C -- if sigsq is better then oldsigsq calc the dqu derivatives if ((sigsq.lt.sigsqold).or.(ctlint(C_DFRQ).gt.1) $ .or.(deriv.eq.3)) then call calc1(anew,ifit,dfit,npar,nfit,palc,pali,deriv) if (ctlint(C_DFRQ).ne.0) then write(21,'(/,A,i5)') ' Iteration',izyk call prderiv(dfit,nfit) end if end if if (deriv.eq.3) deriv=2 C -- if convergence is achived: fstat=-1 to calc. the errors fstat=1 if (iconv.gt.2) fstat=-1 if (izyk.eq.ctlint(C_NZYK)) fstat=-1001 if (sig_stat.eq.1) fstat=-1002 if (ctlpar(C_LMBDA).gt.1.0d3) fstat=-1003 call lmfit(ctlint(C_NDATA),npar,size(S_NB) $ ,DIMFIT,DIMPAR,DIMVB,DIMPLC $ ,ctlint(C_PRI) $ ,nsvfit,nfit,ifit,dfit $ ,alpha,covar,evec,beta,w,a,anew,da,freed,palc,pali $ ,ctlpar(C_ROFIT),sigsq,sigsqold,ctlpar(C_EPS) $ ,stepw,fstat,ctlint(C_ORGER),0 $ ,ctlpar(C_LMBDA),ctlint(C_FITSC),ctlint(C_SVDER)) if (fstat.ge.0) then do ib=1, size(S_NB) call adjusta(anew(1,ib),npar,ctlnb(CB_ADJ,ib)) end do end if condno=0.0d0 do i = 1,nfit if (w(i).gt.0.0d0) then condno=w(nfit)/w(i) goto 60 end if end do 60 continue write(*,'(/,A,I3,A,F6.4,A,D9.3,A,D9.3)') $ ' indep.par:',nsvfit, $ ' stepw:',stepw, $ ' lambda:',ctlpar(C_LMBDA), $ ' cond.no:',condno if (((myand(ctlint(C_PRI),AP_SV).ne.0).and.(xcy.ge.1)) $ .and.(fstat.gt.-1)) then write(*,'(/,A,A,/)') ' Eigenvalues and ' $ ,'Eigenvector Matrix of SVD-FIT ' do i = 1, nfit write(*,'(1D12.6,2X,30F6.3)') w(i), $ (evec(j,i),j=1,nfit) end do end if if (sigsq.lt.sigsqold) sigsqold=sigsq C -- stop here if convergence if (fstat.lt.0) goto 20 end do 30 continue write(*,'(/,A)') ' No Convergence, fit aborted ' 20 continue if ((iconv.eq.0).or.(ctlint(C_INTS).ne.myints) $ .or.(sigsq.gt.sigsqold)) then ctlint(C_INTS)=myints ifunpr=0 write(*,'(/,A)') ' Recalculation of the spectrum' call calc2(a,ifit,dfit,npar,nfit,palc,pali,0) end if izyk=izyk-1 write(*,'(A,/,A,I3,/)') $ '##########################################################', $ ' End at Cycle ',izyk 40 continue if (ifunpr.eq.0) then call funpr(ctlpar(C_ROFIT),ndat,chi2,wght) end if if (nfit.gt.0) then write(*,'(/,A)')' RMS deviations (MHz), B and V sorted' do j=1, 2 if (j.eq.1) write(*,'(2A3,A4,A)') 'B','V','n',' splittings MHz' if (j.eq.2) write(*,'(2A3,A4,A)') 'B','V','n',' abs. freq. MHz' do ib=1, DIMVB do iv=1, DIMVV if (ndat(ib,iv,j).ne.0) then write(*,'(2I3,I4,2F18.6)') ib,iv,ndat(ib,iv,j) $ ,sqrt(chi2(ib,iv,j)/wght(ib,iv,j))*1.D3 $ ,sqrt(chi2(ib,iv,j)/wght(ib,iv,j))*1.D3 $ *(ndat(ib,iv,j)+nfit)/ndat(ib,iv,j) end if end do end do end do end if if (ctlint(C_NZYK).eq.1) goto 100 if (nsvfit.ne.nfit) then write(*,'(/,A,I3,A,I3,A)')' **** Warning **** : only',nsvfit $ ,' of',nfit,' Parameters are linear independent!' if (ctlint(C_SVDER).ne.0) write(*,'(A)') $ ' Errors may be wrong! set ''svderr'' to 0 recommended' end if write(*,'(/,12X,A)') 'Parameters and Errors' call pra(a,da,ifit,min(myand(ctlint(C_PRI),AP_PL)+1,5),1,0) write(*,'(/,A,F15.6,A,/)') ' Standard Deviation' $ ,dsqrt(sigsqold)*1000.0d0,' MHz' do ib=1, size(S_NB) write(*,'(A,I3)')'------------------------------------- B =',ib call adjusta(a(1,ib),npar,ctlnb(CB_ADJ,ib)) call prrrp(a(1,ib),da(1,ib),covar,palc,pali,nfit,ib) if (ctlint(C_NTOP).gt.0) then call prirp(a(1,ib),da(1,ib),indeg) call prpot(a(1,ib),da(1,ib),inkj,inkc,incm) if (ctlint(C_NTOP).gt.1) then fold=a(P1_F,ib) call adjusta(a(1,ib),npar,myor(ctlnb(CB_ADJ,ib),1)) if (a(P1_F,ib).ne.fold) write(*,'(A,/,20X,A)') $ '**** Warning **** : F values not consistent ' $ ,'Use adjf = 1 to keep F values right.' do itop=1, ctlint(C_NTOP) ift=DIMPIR*(itop-1) write(*,'(A,1F18.9)') 'F(calc) ',a(P1_F+ift,ib) end do if (ctlint(C_NTOP).gt.2) write(*,'(A,1F18.9)') $ 'F12(calc)',a(P_FF,ib) end if end if end do write(*,'(/,A)') ' Errors of fitted linear combinations' write(*,'(5F15.9)') $ (anew(mod(i-1,DIMPAR)+1,int((i-1)/DIMPAR)+1),i=1, nfit) write(*,'(/,A)') $ ' Correlation Matrix of fitted linear combinations ' cmax=0.0 do i=1, nfit do j=1, i-1 if (abs(covar(j,i)).gt.cmax) then ic=i jc=j cmax=abs(covar(j,i)) end if end do write(*,'(1X,A6,$)') parstr(pali(i,1,1)) write(*,'(20F7.3)') (covar(j,i), j=1,i-1),1.0d0 end do write(*,'(A,I3,A,I3,A,F7.4,A)') ' strongest correlation between' $ ,ic,' and',jc,' (',covar(jc,ic),')' write(*,'(/,A)') ' Freedom Cofreedom Matrix of linear comb.' cmax=2.0 do i=1, nfit do j=1, i-1 if (covar(i,j).lt.cmax) then ic=i jc=j cmax=covar(i,j) end if end do write(*,'(1X,A6,$)') parstr(pali(i,1,1)) write(*,'(20F7.3)') (covar(i,j), j=1,i) end do write(*,'(A,I3,A,I3,A,F7.4,A)') ' minimum cofreedom between' $ ,ic,' and',jc,' (',cmax,')' write(*,'(/,A,A,/)') ' Eigenvalues and ' $ ,'Eigenvector Matrix of SVD-FIT ' do i = 1, nfit write(*,'(1D12.6,2X,30F6.3)') w(i), $ (evec(j,i),j=1,nfit) end do 100 continue write(*,*) if (myand(ctlint(C_PRI),AP_LT).ne.0) call ltxpr(ctlpar(C_ROFIT)) if (myand(ctlint(C_INTS),16).eq.0) then do i=1, ncalc call binnam(todo(i,Q_J),todo(i,Q_S),todo(i,Q_F),todo(i,Q_B) $ ,binfname) c write(*,*) binfname open(99,file=binfname) close(99,status='delete') end do end if stop end C---------------------------------------------------------------------- subroutine sig_func(sig_no) C called with signal(2)=SIGINT=control C C see procedure mysignal() in iamsys.f implicit none integer sig_stat,sig_no common/sig_com/sig_stat sig_stat=1 write(0,*)'Signal no.',sig_no write(0,*)'Control-C: premature termiation of xiam, finishing...' write(*,*)'Control-C: premature termiation of xiam, finishing...' return end C---------------------------------------------------------------------- subroutine funcs(ix,df,dfda,a,sig,nfit,ifit,dfit,idfrq) C interface subroutine between LM Fit and the dnv matrix implicit none include 'iam_.for' integer ix, nfit, idfrq integer ifit(DIMPAR,DIMVB),dfit(DIMFIT) real*8 df, sig, dfda(DIMFIT),a(DIMPAR,DIMVB) C local.. real*8 dfdao(DIMFIT) real*8 dfobs,dfcal,dupda(DIMFIT),dloda(DIMFIT),dfsig,dfor,dfcr integer avg,i,ref logical firstt save firstt external myand,myor integer myand,myor data firstt/.true./ dfor=0.0d0 dfcr=0.0d0 do i=1, nfit dfdao(i)=0.0d0 dfda(i)=0.0d0 end do dfobs=dln(ix,LN_FREQ) dfsig=dln(ix,LN_ERR) C average of the data, normaly avg=ix: this has no effect avg=qlin(ix,Q_AVG,Q_UP) if (avg.eq.0) avg = ix dfcal=((dnv(avg,NV_ENG,Q_UP)-dnv(avg,NV_ENG,Q_LO)) $ +(dnv(ix,NV_ENG,Q_UP)-dnv(ix,NV_ENG,Q_LO)))/2.0d0 do i=1, nfit dupda(i)=(dnv(avg,i+NV_DEF,Q_UP)+dnv(ix,i+NV_DEF,Q_UP))/2.0d0 dloda(i)=(dnv(avg,i+NV_DEF,Q_LO)+dnv(ix,i+NV_DEF,Q_LO))/2.0d0 end do C check if a difference is fitted ref=qlin(ix,Q_REF,Q_UP) if ((ref.ne.0).and.(ref.ne.ix)) then dfor=dln(ref,LN_FREQ) dfcr=dnv(ref,NV_ENG,Q_UP)-dnv(ref,NV_ENG,Q_LO) do i=1, nfit dfdao(i)=-(dnv(ref,i+NV_DEF,Q_UP)-dnv(ref,i+NV_DEF,Q_LO)) end do end if sig=dfsig if ((myand(qlin(ix,Q_STAT,Q_LO),1).ne.1).or. $ (myand(qlin(ix,Q_STAT,Q_UP),1).ne.1)) sig=NOFIT df=dfobs-dfor-dfcal+dfcr if ((ref.ne.0).and.(ref.ne.ix).and.(sig.lt.1d3*ctlpar(C_DEFER))) $ then if (abs(dfor-dfobs-dfcal+dfcr).lt.abs(df)) then if (firstt) write(*,'(/,A,A,/)') ' *Warning*:' $ ,' possible assignment error in line(s) marked with ''x''' if (firstt) firstt=.false. qlin(ix,Q_STAT,Q_UP)=myor(qlin(ix,Q_STAT,Q_UP),8) end if end if do i=1, nfit dfda(i)=dfdao(i)+dupda(i)-dloda(i) end do return end C---------------------------------------------------------------------- subroutine calc1(a,ifit,dfit,npar,nfit,palc,pali,istat) C simple calculation of the spectrum if istat .le. 0 C calculation of derivatives if istat.gt.0 C if istat.gt.1 better derivatives are used implicit none include 'iam_.for' real*8 a(DIMPAR,DIMVB) integer ifit(DIMPAR,DIMVB),dfit(DIMFIT),npar,nfit,istat real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) C local .. integer ifitmp(DIMPAR,DIMVB) real*8 ad(DIMPAR,DIMVB) real*8 dnvtmp(DIMLIN,Q_UP:Q_LO),dnvsav(DIMLIN,Q_UP:Q_LO) integer i,j,pri,ib real*8 diffup,difflo,delta,dsum,devar(DIMPAR) integer myand real*8 myrand external myand,myrand save devar, dnvsav data devar /DIMPAR*1.0/ if (istat.le.0) then C clear the old eigenvalues und derivativs do i=1, ctlint(C_NDATA) do j=1,DIMDNV dnv(i,j,Q_UP)=0.0d0 dnv(i,j,Q_LO)=0.0d0 end do end do xde=0 if (xcy.ge.1) xde=1 ! For output control C calculate with original values, obtain derivatives if dfit(i).gt.0 call calc2(a,ifit,dfit,npar,nfit,palc,pali,0) C save the original frequencies do i=1, ctlint(C_NDATA) dnvsav(i,Q_UP)=dnv(i,NV_ENG,Q_UP) dnvsav(i,Q_LO)=dnv(i,NV_ENG,Q_LO) end do else C calculate derivatives with difference quotient if dfit(i).lt.0 C but do not calc. analtic deriv. here do ib=1, DIMVB do i=1, DIMPAR ifitmp(i,ib)=0 end do end do xde=0 if ((myand(ctlint(C_PRI),XP_DE).ne.0).and.(xcy.ge.1)) xde=1 pri=ctlint(C_PRI) ctlint(C_PRI)=myand(pri,not(AP_EH)) ctlint(C_PRI)=myand(pri,not(AP_MH)) C calculate the ad = parameters + delta do i=1, nfit if (dfit(i).lt.0) then devar(i)=-devar(i) dsum=0.0d0 do j=1, pali(i,0,1) dsum=dsum+dabs(a(pali(i,j,1),pali(i,j,2))*palc(i,j)) end do delta=(palc(i,0)/100.0d0)*dsum*devar(i)/dble(pali(i,0,1)) do ib=1, size(S_NB) do j=1, npar ad(j,ib)=a(j,ib) end do end do do j=1, pali(i,0,1) ad(pali(i,j,1),pali(i,j,2)) $ =ad(pali(i,j,1),pali(i,j,2))+delta*palc(i,j) end do call calc2(ad,ifitmp,dfit,npar,nfit,palc,pali,i) C do an opposite variation for precise derivatives if ((dfit(i).le.-2).or.(istat.gt.1)) then do ib=1, size(S_NB) do j=1, npar ad(j,ib)=a(j,ib) end do end do do j=1, pali(i,0,1) ad(pali(i,j,1),pali(i,j,2)) $ =ad(pali(i,j,1),pali(i,j,2))-delta*palc(i,j) end do do j=1, ctlint(C_NDATA) dnvtmp(j,Q_UP)=dnv(j,NV_ENG,Q_UP) dnvtmp(j,Q_LO)=dnv(j,NV_ENG,Q_LO) end do call calc2(ad,ifitmp,dfit,npar,nfit,palc,pali,i) C calculate differential quotient do j=1,ctlint(C_NDATA) diffup=dnvtmp(j,Q_UP)-dnv(j,NV_ENG,Q_UP) difflo=dnvtmp(j,Q_LO)-dnv(j,NV_ENG,Q_LO) dnv(j,i+NV_DEF,Q_UP)=diffup/(2.0d0*delta) dnv(j,i+NV_DEF,Q_LO)=difflo/(2.0d0*delta) end do else C calculate differential quotient do j=1,ctlint(C_NDATA) diffup=dnv(j,NV_ENG,Q_UP)-dnvsav(j,Q_UP) difflo=dnv(j,NV_ENG,Q_LO)-dnvsav(j,Q_LO) dnv(j,i+NV_DEF,Q_UP)=diffup/delta dnv(j,i+NV_DEF,Q_LO)=difflo/delta end do end if end if end do ctlint(C_PRI)=pri C restore the original frequencies do i=1, ctlint(C_NDATA) dnv(i,NV_ENG,Q_UP)=dnvsav(i,Q_UP) dnv(i,NV_ENG,Q_LO)=dnvsav(i,Q_LO) end do end if return end C---------------------------------------------------------------------- subroutine calc2(a,ifit,dfit,npar,nfit,palc,pali,fistat) C calculation of the eigenvalues C the evalues are put in the field of dnv(1..ndata,NV_ENG,Q_UP/LO) C the deviations DE/DPi in dnv(1..ndata,2-DIMPAR,Q_UP/LO(i)) implicit none include 'iam_.for' real*8 a(DIMPAR,DIMVB) integer ifit(DIMPAR,DIMVB),dfit(DIMFIT),npar,nfit,fistat real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) C work real*8 h(DIMTOT,DIMTOT),evh(DIMTOT) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer qmv(DIMV),oldj(DIMTOP) real*8 ints integer j,gam,qf,ib,oib,ic,i,itop,maxi,mini,iv,ntop integer myand,not external myand save evalv,ovv,rotm,rott,tori,qmv,oib do i=1,ctlint(C_NDATA) qlin(i,Q_STAT,Q_UP)=myand(qlin(i,Q_STAT,Q_UP),(not(1))) qlin(i,Q_STAT,Q_LO)=myand(qlin(i,Q_STAT,Q_LO),(not(1))) qlin(i,Q_STAT,Q_UP)=myand(qlin(i,Q_STAT,Q_UP),(not(8))) qlin(i,Q_STAT,Q_LO)=myand(qlin(i,Q_STAT,Q_LO),(not(8))) qlin(i,Q_GK,Q_UP)=-1000 qlin(i,Q_GK,Q_LO)=-1000 end do do i=1, size(S_G) gamma(i,0)=0 end do oib =-1 do ic=1, ncalc j =todo(ic,Q_J) gam=todo(ic,Q_S) qf =todo(ic,Q_F) ib =todo(ic,Q_B) if ((myand(todo(ic,Q_STAT),2).eq.0).and. $ (fistat.ne.0)) goto 99 ctlint(C_WOODS)=ctlnb(CB_WDS,ib) ctlint(C_ADJF) =ctlnb(CB_ADJ,ib) size(S_VV)=1 do iv=1, DIMVV if (qvv(iv,1,ib).eq.-1) goto 11 size(S_VV)=iv end do 11 continue if (size(S_VV).gt.DIMVV) stop ' max VV > DIM VV' do itop=1, ctlint(C_NTOP) size(S_V+itop)=0 end do do itop=1, ctlint(C_NTOP) mini=99 maxi=-1 do iv=1, size(S_VV) if (qvv(iv,itop,ib).lt.mini) mini=qvv(iv,itop,ib) if (qvv(iv,itop,ib).gt.maxi) maxi=qvv(iv,itop,ib) end do size(S_V+itop)=maxi-mini+1 size(S_MINV+itop)=mini if (size(S_V+itop).lt.0) stop 'error in calc2' end do if (ib.ne.oib) then oib=ib do itop=1,ctlint(C_NTOP) oldj(itop)=0 end do call adjusta(a(1,ib),npar,ctlint(C_ADJF)) if ((myand(ctlint(C_PRI),AP_PC).ne.0) $ .and.(xde.ne.0)) then write(*,'(2(A,I3))') 'Parameter for B=',ib $ ,' deriv.=',fistat write(*,'(A,3F18.9)') 'BJ BK B- ' $ ,a(P_BJ,ib),a(P_BK,ib),a(P_BD,ib) do itop=1, ctlint(C_NTOP) write(*,'(A,3F18.9)') 'rho gamma beta' $ ,a(P1_RHO +DIMPIR*(itop-1),ib) $ ,a(P1_GAMA+DIMPIR*(itop-1),ib) $ ,a(P1_BETA+DIMPIR*(itop-1),ib) end do end if C calc the |m> and |K> part in the rho-system call calmk(ib,h,evalv,ovv,rotm,rott,tori $ ,a(1,ib),qmv,ifit(1,ib),npar,fistat,0) C and save the torsional integrals for the intensities if ((ctlint(C_INTS).gt.1).and.(fistat.eq.0)) $ call wrtori(tori,ib) end if C set up the rotation matrix do itop=1,ctlint(C_NTOP) call rotate(rotm(-DIMJ,-DIMJ,1,itop) $ ,a(P1_BETA+DIMPIR*(itop-1),ib),j,oldj(itop)) end do C !!!!!!!!!!!!!!!!!! ntop !!!!!!!!!!!!!!!!!!! ntop=ctlint(C_NTOP) if (gam.eq.0) ctlint(C_NTOP)=0 C this is the main routine to calculate the spectrum call calvjk(j,gam,qf,ib,h,evalv,ovv,rotm,rott,tori $ ,a(1,ib),qmv,ifit(1,ib),dfit,palc,pali,npar,fistat,evh) C calc the intensities for this ib of all eigenvalues are done if (((ic.eq.ncalc).or.(ib.ne.todo(ic+1,Q_B))) $ .and.(fistat.eq.0).and.(ctlint(C_INTS).ge.1)) then do i=1,ctlint(C_NDATA) if ((qlin(i,Q_B,Q_UP).eq.ib).and.(qlin(i,Q_B,Q_LO).eq.ib)) $ then call intens(i,ints,a(P_MUX,ib),a(P_MUY,ib),a(P_MUZ,ib) $ ,tori) dln(i,LN_INT)=ints end if end do end if ctlint(C_NTOP)=ntop C !!!!!!!!!!!!!!!!!! ntop !!!!!!!!!!!!!!!!!!! 99 continue end do C test if all eigenvalues are calculated and assigned do i=1,ctlint(C_NDATA) if ((myand(qlin(i,Q_STAT,Q_UP),16).eq.16) $ .or.(myand(qlin(i,Q_STAT,Q_LO),16).eq.16) $ .or.(fistat.eq.0)) then if ((myand(qlin(i,Q_STAT,Q_UP),1).ne.1) $ .or.(myand(qlin(i,Q_STAT,Q_LO),1).ne.1)) $ write(*,'(A,I4,A,2I4)') $ ' Assign error at line',i,' reason', $ qlin(i,Q_STAT,Q_UP),qlin(i,Q_STAT,Q_LO) end if end do C call the routines for intensity calculation if ((ctlint(C_INTS).gt.1).and.(fistat.eq.0)) then if (ctlint(C_INTS).eq.2) $ call intall(a(P_MUX,ib),a(P_MUY,ib),a(P_MUZ,ib) $ ,ctlpar(C_TEMP)) if (ctlint(C_INTS).eq.3) $ call intal2(a(P_MUX,ib),a(P_MUY,ib),a(P_MUZ,ib) $ ,ctlpar(C_TEMP)) end if return end C---------------------------------------------------------------------- subroutine calmk(ib,h,evalv,ovv,rotm,rott,tori $ ,a,qmv,ifit,npar,fistat,imaxm) C calculation of the eigenvalues and matrixelements C of the internal rotation part implicit none include 'iam_.for' integer ib,imaxm integer ifit(DIMPAR),npar,fistat integer qmv(DIMV) real*8 a(DIMPAR) real*8 h(DIMTOT,DIMTOT) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work real*8 am(DIMPM) real*8 mvec(DIMM,DIMV,-DIMJ:DIMJ) integer imfit(DIMOVV),sigma,maxm integer i,itop,k,ip,ivc,ivr,isig,im integer sdone(-20:20,DIMTOP) integer myand external myand do itop=1,ctlint(C_NTOP) do isig=-20,20 sdone(isig,itop)=0 end do end do do isig=1,size(S_G) do itop=1,ctlint(C_NTOP) if (myand(ctlint(C_WOODS),4).eq.0) then size(S_FIRV+itop)=size(S_MINV+itop) size(S_MAXV+itop)=size(S_V+itop) else size(S_FIRV+itop)=1 if (size(S_MAXV+itop).eq.0) $ size(S_MAXV+itop)=size(S_V+itop) end if if (size(S_FIRV+itop).le.0) then write(*,'(A,I3)') 'FIRST V: spezify V lines for B=',ib stop 'FIRST V < 0 error' end if sigma=gamma(isig,itop) if (sdone(sigma,itop).eq.0) then sdone(sigma,itop)=1 if (imaxm.eq.0) then maxm=size(S_MAXM+itop) end if if (imaxm.lt.0) then maxm=size(S_MINV+itop)-1+size(S_V+itop) end if if (imaxm.gt.0) then maxm=imaxm end if do i=1, DIMPM am(i)=a(DIMPRR+(itop-1)*DIMPIR+i) imfit(i)=ifit(DIMPRR+(itop-1)*DIMPIR+i) end do imfit(PM_PI)=ifit(P_FF) if (a(P_FF).ne.0.0) imfit(PM_PI)=1 imfit(PM_COS)=ifit(P_VCC) if (a(P_VCC).ne.0.0) imfit(PM_COS)=1 imfit(PM_SIN)=ifit(P_VSS) if (a(P_VSS).ne.0.0) imfit(PM_SIN)=1 do k=-size(S_MAXK),size(S_MAXK) call calcm(sigma,h $ ,evalv(1,sigma,k,itop) $ ,ovv(1,1,1,sigma,k,itop) $ ,mvec(1,1,k) $ ,am $ ,qmv $ ,imfit $ ,k $ ,maxm $ ,size(S_FIRV+itop) $ ,size(S_MAXV+itop)) end do if ((myand(ctlint(C_PRI),AP_MO).ne.0).and.(xde.ge.1)) then write(*,'(A,5I3)') ' itop,sigma,k,B,fistat' $ ,itop,sigma,k,ib,fistat do ip=1,DIMOVV do ivr= 1, size(S_MAXV+itop) write(*,'(I3,A,30F11.6)') ip,' ovv', $ ((ovv(ivr,ivc,ip,sigma,k,itop) $ ,k=-size(S_MAXK),size(S_MAXK)) $ ,ivc=1, size(S_MAXV+itop)) end do end do write(*,*) 'mvec' do im=1,2*size(S_MAXM+itop)+1 write(*,'(40F10.6)') ((mvec(im,ivc,k) $ ,k=-size(S_MAXK),size(S_MAXK)) $ ,ivc=1, size(S_MAXV+itop)) end do end if call caltori(sigma,itop,mvec,tori,fistat $ ,maxm,size(S_FIRV+itop), size(S_MAXV+itop)) end if end do ! itop end do ! isig if ((myand(ctlint(C_PRI),AP_EO).ne.0).and.(xde.ge.1)) then do itop=1, ctlint(C_NTOP) write(*,'(/,A,I3)')' Eigenvalues of one Top. B=',ib do k=-size(S_MAXK),size(S_MAXK) do i=1, size(S_MAXV+itop) do isig=1, size(S_G) if (gamma(isig,itop).eq.-NaQN) goto 10 write(*,'(F15.6,$)') $ evalv(i,gamma(isig,itop),k,itop) end do 10 continue end do write(*,*) end do end do end if return end C---------------------------------------------------------------------- subroutine caltori(sigma,itop,mvec,tori,fistat,maxm,minv,sizv) C calculation of the eigenvalues of one matrix with specified j,k,m C the evalues are put in the field of dnv(1..ndata,NV_ENG,Q_UP/LO) C the deviations DE/DPi in dnv(1..ndata,2-DIMPAR,Q_UP/LO(i)) implicit none include 'iam_.for' integer sigma,itop,fistat,maxm,minv,sizv real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) real*8 mvec(DIMM,DIMV,-DIMJ:DIMJ) integer kr,kc,vr,vc,im real*8 sum1,sum2, scale integer myand external myand if (myand(ctlint(C_WOODS),1).ne.0) then C calc the torsional integrals do kr=-size(S_MAXK), size(S_MAXK) do kc=-size(S_MAXK), size(S_MAXK) do vr=1, sizv do vc=1, sizv tori(kr,kc,vr,vc,sigma,itop)=0.0d0 do im=1, 2*maxm+1 tori(kr,kc,vr,vc,sigma,itop) = $ tori(kr,kc,vr,vc,sigma,itop) $ +mvec(im,vr,kr)*mvec(im,vc,kc) end do end do end do end do end do do kr=-size(S_MAXK), size(S_MAXK) do vr=1,sizv do vc=vr+1,sizv tori(kr,kr,vr,vc,sigma,itop)=0.0d0 tori(kr,kr,vc,vr,sigma,itop)=0.0d0 end do end do do vr=1,sizv tori(kr,kr,vr,vr,sigma,itop)=1.0d0 end do end do if ((myand(ctlint(C_PRI),AP_TI).ne.0).and.(xde.ge.1)) then write(*,'(/,2(A,I3,3X))') ' torsional integrals sigma=',sigma $ ,'deriv.=',fistat do vr=1,sizv do kr=-size(S_MAXK), size(S_MAXK) write(*,'(20F8.5)') $ ((tori(kr,kc,vr,vc,sigma,itop) $ ,kc=-size(S_MAXK), size(S_MAXK)) $ ,vc=1,sizv) end do end do end if end if if (myand(ctlint(C_WOODS),1).eq.0) then do kr=-size(S_MAXK), size(S_MAXK) do kc=-size(S_MAXK), size(S_MAXK) do vr=1,sizv do vc=1,sizv tori(kr,kc,vr,vc,sigma,itop)=0.0d0 end do end do end do end do do kr=-size(S_MAXK), size(S_MAXK) do kc=-size(S_MAXK), size(S_MAXK) do vr=1,sizv tori(kr,kc,vr,vr,sigma,itop)=1.0d0 end do end do end do end if if (myand(ctlint(C_WOODS),2).ne.0) then do kr=-size(S_MAXK), size(S_MAXK) do kc= -size(S_MAXK), size(S_MAXK) do vr=1,sizv sum1=0.0d0 sum2=0.0d0 do vc=1,vr-1 sum1=sum1+tori(kr,kc,vr,vc,sigma,itop)**2 end do do vc=vr,sizv sum2=sum2+tori(kr,kc,vr,vc,sigma,itop)**2 end do do vc=vr,sizv scale=(dsqrt(1.0d0-sum1))/dsqrt(sum2) tori(kr,kc,vr,vc,sigma,itop)= $ tori(kr,kc,vr,vc,sigma,itop)*scale if (vr.ne.vc) $ tori(kc,kr,vc,vr,sigma,itop)= $ tori(kr,kc,vr,vc,sigma,itop) end do end do end do end do if ((myand(ctlint(C_PRI),AP_TI).ne.0).and.(xde.ge.1)) then write(*,'(/,A)') '----- scaled torsional integrals -----' do vr=1,sizv do kr=-size(S_MAXK), size(S_MAXK) write(*,'(20F8.5)') $ ((tori(kr,kc,vr,vc,sigma,itop) $ ,kc=-size(S_MAXK), size(S_MAXK)) $ ,vc=1,sizv) end do end do end if end if return end C --------------------------------------------------------------------- subroutine maxof(mat, dimrow, dimcol, nrow, fcol, ncol, $ besti, scndi, bestv, scndv) C find the biggest and second abs values in column=fcol..fcol+ncol-1 implicit none integer dimrow,dimcol,nrow,fcol,ncol integer besti(ncol), scndi(ncol) real*8 mat(dimrow,dimcol), bestv(ncol), scndv(ncol) C work integer ic,ir,i if ((ncol+fcol-1).gt.dimcol) stop ' ERROR: DIMCOL exceeded' if (nrow.gt.dimrow) stop ' ERROR: DIMROW exceeded' do ic=1, ncol besti(ic)=1 scndi(ic)=0 bestv(ic)=0.0d0 scndv(ic)=0.0d0 end do do ir=1, nrow do i=1, ncol ic=i+fcol-1 if (scndv(i).le.dabs(mat(ir,ic))) then if (bestv(i).le.dabs(mat(ir,ic))) then scndi(i)=besti(i) scndv(i)=bestv(i) besti(i)=ir bestv(i)=dabs(mat(ir,ic)) else scndi(i)=ir scndv(i)=dabs(mat(ir,ic)) end if end if end do end do do i=1, ncol ic=i+fcol-1 bestv(i)=mat(besti(i),ic) scndv(i)=mat(scndi(i),ic) end do return end C---------------------------------------------------------------------- subroutine savepsi(i,psi) implicit none real*8 psi integer i include 'iam_.for' dln(i,LN_PSI)=psi return end C-------------------------------------------------------------- subroutine swptdo(i,j) implicit none include 'iam_.for' integer i,j,itmp itmp=todo(i,Q_J) todo(i,Q_J)=todo(j,Q_J) todo(j,Q_J)=itmp itmp=todo(i,Q_S) todo(i,Q_S)=todo(j,Q_S) todo(j,Q_S)=itmp itmp=todo(i,Q_B) todo(i,Q_B)=todo(j,Q_B) todo(j,Q_B)=itmp itmp=todo(i,Q_F) todo(i,Q_F)=todo(j,Q_F) todo(j,Q_F)=itmp itmp=todo(i,Q_STAT) todo(i,Q_STAT)=todo(j,Q_STAT) todo(j,Q_STAT)=itmp return end C===================================================================== block data bdata C --------------------------------------------------------------------- include 'iam_.for' include 'iamdata_.for' integer idat data gamstr(1)/'G'/ data gamstr(2)/'S'/ data gamstr(3)/'G'/ data gamstr(4)/'S'/ data gamstr(5)/'G'/ data gamstr(6)/'S'/ C data gamstr /DIMTOP*'G'/ data parstr(P_BJ ) /'BJ '/, parfit(P_BJ ) /0/ data parstr(P_BK ) /'BK '/, parfit(P_BK ) /0/ data parstr(P_BD ) /'B- '/, parfit(P_BD ) /0/ data parstr(P_DJ ) /'DJ '/, parfit(P_DJ ) /0/ data parstr(P_DJK ) /'DJK '/, parfit(P_DJK ) /0/ data parstr(P_DK ) /'DK '/, parfit(P_DK ) /0/ data parstr(P_DJD ) /'dj '/, parfit(P_DJD ) /0/ data parstr(P_DKD ) /'dk '/, parfit(P_DKD ) /0/ C data parstr(P_R6 ) /'R6 '/, parfit(P_R6 ) /0/ data parstr(P_HJ ) /'H_J '/, parfit(P_HJ ) /0/ data parstr(P_HJK ) /'HJK '/, parfit(P_HJK ) /0/ data parstr(P_HKJ ) /'HKJ '/, parfit(P_HKJ ) /0/ data parstr(P_HK ) /'H_K '/, parfit(P_HK ) /0/ data parstr(P_HJD ) /'h_j '/, parfit(P_HJD ) /0/ data parstr(P_HJKD ) /'hjk '/, parfit(P_HJKD ) /0/ data parstr(P_HKD ) /'h_k '/, parfit(P_HKD ) /0/ data parstr(P_QZ ) /'chi_z '/, parfit(P_QZ ) /0/ data parstr(P_QD ) /'chi_- '/, parfit(P_QD ) /0/ data parstr(P_QXY ) /'chi_xy '/, parfit(P_QXY ) /0/ data parstr(P_QXZ ) /'chi_xz '/, parfit(P_QXZ ) /0/ data parstr(P_QYZ ) /'chi_yz '/, parfit(P_QYZ ) /0/ data parstr(P_FF ) /'F12 '/, parfit(P_FF ) /1/ data parstr(P_VSS ) /'Vss '/, parfit(P_VSS ) /1/ data parstr(P_VCC ) /'Vcc '/, parfit(P_VCC ) /1/ data parstr(P_CP ) /'C+ '/, parfit(P_CP ) /0/ data parstr(P_CZ ) /'C_z '/, parfit(P_CZ ) /0/ data parstr(P_CD ) /'C- '/, parfit(P_CD ) /0/ data parstr(P_MUX ) /'mu_x '/, parfit(P_MUX ) /9/ data parstr(P_MUY ) /'mu_y '/, parfit(P_MUY ) /9/ data parstr(P_MUZ ) /'mu_z '/, parfit(P_MUZ ) /9/ data parstr(P_PX ) /'P_x '/, parfit(P_PX ) /0/ data parstr(P_PY ) /'P_y '/, parfit(P_PY ) /0/ data parstr(P_PZ ) /'P_z '/, parfit(P_PZ ) /0/ data parstr(P1_VN1 ) /'V1n_1 '/, parfit(P1_VN1 ) /1/ data parstr(P1_VN2 ) /'V2n_1 '/, parfit(P1_VN2 ) /1/ data parstr(P1_F ) /'F_1 '/, parfit(P1_F ) /1/ data parstr(P1_RHO ) /'rho_1 '/, parfit(P1_RHO ) /1/ data parstr(P1_BETA ) /'beta_1 '/, parfit(P1_BETA ) /1/ data parstr(P1_GAMA ) /'gamma_1'/, parfit(P1_GAMA ) /1/ data parstr(P1_DPIJ ) /'Dpi2J_1'/, parfit(P1_DPIJ ) /1/ data parstr(P1_DPIK ) /'Dpi2K_1'/, parfit(P1_DPIK ) /1/ data parstr(P1_DPID ) /'Dpi2-_1'/, parfit(P1_DPID ) /1/ c data parstr(P1_DPI4 ) /'Dpi4_1 '/, parfit(P1_DPI4 ) /1/ c data parstr(P1_DPIC ) /'Dpi2c_1'/, parfit(P1_DPIC ) /1/ data parstr(P1_DC3J ) /'Dc3J_1 '/, parfit(P1_DC3J ) /1/ data parstr(P1_F0 ) /'F0_1 '/, parfit(P1_F0 ) /1/ data parstr(P1_ANGX ) /'epsil_1'/, parfit(P1_ANGX ) /1/ data parstr(P1_ANGZ ) /'delta_1'/, parfit(P1_ANGZ ) /1/ data parstr(P2_VN1 ) /'V1n_2 '/, parfit(P2_VN1 ) /1/ data parstr(P2_VN2 ) /'V2n_2 '/, parfit(P2_VN2 ) /1/ data parstr(P2_F ) /'F_2 '/, parfit(P2_F ) /1/ data parstr(P2_RHO ) /'rho_2 '/, parfit(P2_RHO ) /1/ data parstr(P2_BETA ) /'beta_2 '/, parfit(P2_BETA ) /1/ data parstr(P2_GAMA ) /'gamma_2'/, parfit(P2_GAMA ) /1/ data parstr(P2_DPIJ ) /'Dpi2J_2'/, parfit(P2_DPIJ ) /1/ data parstr(P2_DPIK ) /'Dpi2K_2'/, parfit(P2_DPIK ) /1/ data parstr(P2_DPID ) /'Dpi2-_2'/, parfit(P2_DPID ) /1/ c data parstr(P2_DPI4 ) /'Dpi4_2 '/, parfit(P2_DPI4 ) /1/ c data parstr(P2_DPIC ) /'Dpi2c_2'/, parfit(P2_DPIC ) /1/ data parstr(P2_DC3J ) /'Dc3J_2 '/, parfit(P2_DC3J ) /1/ data parstr(P2_F0 ) /'F0_2 '/, parfit(P2_F0 ) /1/ data parstr(P2_ANGX ) /'epsil_2'/, parfit(P2_ANGX ) /1/ data parstr(P2_ANGZ ) /'delta_2'/, parfit(P2_ANGZ ) /1/ data parstr(P3_VN1 ) /'V1n_3 '/, parfit(P3_VN1 ) /1/ data parstr(P3_VN2 ) /'V2n_3 '/, parfit(P3_VN2 ) /1/ data parstr(P3_F ) /'F_3 '/, parfit(P3_F ) /1/ data parstr(P3_RHO ) /'rho_3 '/, parfit(P3_RHO ) /1/ data parstr(P3_BETA ) /'beta_3 '/, parfit(P3_BETA ) /1/ data parstr(P3_GAMA ) /'gamma_3'/, parfit(P3_GAMA ) /1/ data parstr(P3_DPIJ ) /'Dpi2J_3'/, parfit(P3_DPIJ ) /1/ data parstr(P3_DPIK ) /'Dpi2K_3'/, parfit(P3_DPIK ) /1/ data parstr(P3_DPID ) /'Dpi2-_3'/, parfit(P3_DPID ) /1/ c data parstr(P3_DPI4 ) /'Dpi4_3 '/, parfit(P3_DPI4 ) /1/ c data parstr(P3_DPIC ) /'Dpi2c_3'/, parfit(P3_DPIC ) /1/ data parstr(P3_DC3J ) /'Dc3J_3 '/, parfit(P3_DC3J ) /1/ data parstr(P3_F0 ) /'F0_3 '/, parfit(P3_F0 ) /1/ data parstr(P3_ANGX ) /'epsil_3'/, parfit(P3_ANGX ) /1/ data parstr(P3_ANGZ ) /'delta_3'/, parfit(P3_ANGZ ) /1/ data ctlstr(C_NZYK ) /'nzyk '/ data ctlstr(C_NCYCL) /'ncycl '/ data ctlstr(C_PRI) /'aprint'/ data ctlstr(C_PRINT) /'print '/ data ctlstr(C_XPR) /'xprint'/ data ctlstr(C_INTS ) /'ints '/ data ctlstr(C_ORGER) /'orger '/ data ctlstr(C_EVAL ) /'eval '/ data ctlstr(C_DFRQ ) /'dfreq '/ data ctlstr(C_MAXM ) /'maxm '/ c data ctlstr(C_MAXM1) /'maxm1 '/ c data ctlstr(C_MAXM2) /'maxm2 '/ c data ctlstr(C_MAXM3) /'maxm3 '/ data ctlstr(C_MAXV) /'maxvm '/ c data ctlstr(C_MAXV1) /'maxvm1'/ c data ctlstr(C_MAXV2) /'maxvm2'/ c data ctlstr(C_MAXV3) /'maxvm3'/ data ctlstr(C_WOODS) /'woods '/ c data ctlstr(C_WOOD1) /'woods1'/ c data ctlstr(C_WOOD2) /'woods2'/ c data ctlstr(C_WOOD3) /'woods3'/ c data ctlstr(C_WOOD4) /'woods4'/ data ctlstr(C_NDATA) /'ndata '/ data ctlstr(C_NFOLD) /'nfold '/ data ctlstr(C_SPIN ) /'spin '/ data ctlstr(C_NTOP ) /'ntop '/ data ctlstr(C_ADJF ) /'adjf '/ c data ctlstr(C_ADJ1 ) /'adjf1 '/ c data ctlstr(C_ADJ2 ) /'adjf2 '/ c data ctlstr(C_ADJ3 ) /'adjf3 '/ c data ctlstr(C_ADJ4 ) /'adjf4 '/ data ctlstr(C_ROFIT) /'rofit '/ data ctlstr(C_DEFER) /'defer '/ data ctlstr(C_EPS ) /'eps '/ data ctlstr(C_WEIGF) /'weigf '/ data ctlstr(C_CNVG ) /'convg '/ data ctlstr(C_LMBDA) /'lambda'/ data ctlstr(C_FITSC) /'fitscl'/ data ctlstr(C_FRQLO) /'freq_l'/ data ctlstr(C_FRQUP) /'freq_h'/ data ctlstr(C_INTLM) /'limit '/ data ctlstr(C_SVDER) /'svderr'/ data ctlstr(C_TEMP ) /'temp '/ data ctlstr(C_RED ) /'reduct'/ data qnostr( 1 ) /'Jup '/ data qnostr( 2 ) /'K-up '/ data qnostr( 3 ) /'K+up '/ data qnostr( 4 ) /'Jlo '/ data qnostr( 5 ) /'K-lo '/ data qnostr( 6 ) /'K+lo '/ data qnostr( 7 ) /'= '/ data qnostr( 8 ) /'Err '/ data qnostr( 9 ) /'Sup '/ data qnostr(10 ) /'Slo '/ data qnostr(11 ) /'V1up '/ data qnostr(12 ) /'V1lo '/ data qnostr(13 ) /'V2up '/ data qnostr(14 ) /'V2lo '/ data qnostr(15 ) /'Bup '/ data qnostr(16 ) /'Blo '/ data qnostr(17 ) /'Fup '/ data qnostr(18 ) /'Flo '/ data qnostr(19 ) /'Tup '/ data qnostr(20 ) /'Tlo '/ data qnostr(21 ) /'tup '/ data qnostr(22 ) /'tlo '/ data qnostr(23 ) /'# '/ data qnostr(24 ) /'& '/ data qnostr(25 ) /'Kup '/ data qnostr(26 ) /'Klo '/ data qnostr(27 ) /'diff '/ data qnostr(28 ) /'GHz '/ data qnostr(29 ) /'MHz '/ data qnostr(30 ) /'cm-1 '/ data (qnostr(MAXQC+idat),idat=1,DIMGAM) /DIMGAM*' '/ data (q_q(idat),idat=1,MAXQC) $ /Q_J ,0 ,0 ,Q_J ,0 ,0 $ ,0 ,0 ,Q_S, Q_S, Q_V1,Q_V1,Q_V2,Q_V2 $ ,Q_B, Q_B, Q_F, Q_F, Q_T ,Q_T ,Q_TJ,Q_TJ $ ,Q_REF,Q_AVG, Q_K, Q_K $ ,0,0,0,0/ data (q_q(MAXQC+idat),idat=1,DIMGAM) /DIMGAM*0/ data (qul(idat),idat=1,MAXQC) /Q_UP,0 ,0 ,Q_LO,0 ,0 $ ,0 ,0 ,Q_UP,Q_LO,Q_UP,Q_LO,Q_UP,Q_LO $ ,Q_UP,Q_LO,Q_UP,Q_LO,Q_UP,Q_LO,Q_UP,Q_LO $ ,0 ,0 , Q_UP,Q_LO $ ,0,0,0,0/ data (qul(MAXQC+idat),idat=1,DIMGAM) /DIMGAM*0/ c data q_q /Q_J, Q_K, Q_J, Q_K c $ ,Q_V1,Q_V2,Q_B, Q_S, Q_V1,Q_V2,Q_B, Q_S c $ ,Q_F, Q_F, Q_T, Q_T, Q_TJ, Q_TJ, Q_REF, Q_AVG c $ ,0,0,0,0,0,0,0,0,0,0,0/ c data qul /Q_UP,Q_UP,Q_LO,Q_LO c $ ,Q_UP,Q_UP,Q_UP, Q_UP,Q_LO,Q_LO,Q_LO, Q_LO c $ ,Q_UP,Q_LO,Q_UP,Q_LO,Q_UP, Q_LO, 0, 0 c $ ,0,0,0,0,0,0,0,0,0,0,0 / C data rpstr(1) /'Ir (a,b,c <-> z,x,y) '/ C data rpstr(2) /'IIr (a,b,c <-> y,z,x) '/ C data rpstr(3) /'IIIr (a,b,c <-> x,y,z) '/ end C C------------------------------------------------------------------------------ C C module IAMIO.FOR C C------------------------------------------------------------------------------ C C ---------------------------------------------------------- subroutine parinp(a,palc,pali,ifit,dfit,npar,nfit) implicit none include 'iam_.for' real*8 a(DIMPAR,DIMVB) real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) integer ifit(DIMPAR,DIMVB), dfit(DIMFIT),npar, nfit integer i,j,iq,iv,ib,ndata,nsplit,ift,apri,xpri,sizeb,ffree real*8 indeg,inkj,pi real*8 msplit,efdata,m2split C local variables: header character*10 helpstr C local variables: reading list of control variables real*8 dctl(DIMCPAR+DIMCINT) integer cdone(DIMCPAR+DIMCINT) integer adj C local variables: reading list of parameters integer padone(DIMPAR,DIMVB) C local variables: reading definition of gammas real*8 dgam(2*DIMTOP) integer gdone(2*DIMTOP),is,it,itop character*10 symstr C local variables: reading linear comb. of parameters to fit real*8 afit(DIMPAR,DIMVB) real*8 sum integer ix,gl,gm,oldix,df,no character*10 fitstr,spaz C local variables: reading list of transitions real*8 dqno(DIMQC) integer qdone(DIMQC),ilr,ila,ilx,iqq,il character*40 fmtstr logical stpflg integer getd,geti,getc,getbuf,myand,myor,s_mark,len_c logical getend external geti,getd,getbuf,getc,myand,myor,s_mark,len_c external getend C include 'iamdata_.for' pi=dacos(-1.0d0) inkj=3.9903132D-04 indeg=180.0d0/pi call fillsp(spaz) do i=1, DIMFIT do j=1, DIMPLC palc(i,j)=0.0d0 pali(i,j,1)=0 pali(i,j,2)=0 end do dfit(i)=0 end do do i=1, DIMPAR do j=1, DIMVB ifit(i,j)=0 end do end do C Header of Input File do while (.true.) if (getbuf(gu,ui).le.0) goto 4 call writebuf(6) call fillsp(helpstr) i=getc(gu,helpstr) if ((helpstr.eq."help").or. $ (helpstr.eq."Help").or. $ (helpstr.eq."HELP")) then write(*,'(A)') ' possible parameters: ' do i=1,DIMPAR write(*,'(X,A)') parstr(i) end do write(*,'(/,A,I3)') ' DIMTOP ',DIMTOP write(*,'(A,I3)') ' DIMJ ',DIMJ write(*,'(/,A)') $ ' See help file "xiam_v25.txt" for more information' stop end if end do 4 continue do i=1, DIMCINT+DIMCPAR cdone(i)=0 dctl(i)=0.0d0 end do do while (.true.) if (getbuf(gu,ui).le.0) goto 6 call getln(gu,ctlstr,dctl,cdone,DIMCINT+DIMCPAR) end do 6 continue do i=1, DIMCINT ctlint(i)=0 end do do i=DIMCINT+1, DIMCINT+DIMCPAR ctlpar(i)=0.0d0 end do ctlint(C_MAXM)=8 ctlint(C_NZYK )=1 ctlint(C_PRI)=0 ctlint(C_XPR)=0 ctlint(C_PRINT)=3 ctlint(C_NFOLD)=3 ctlint(C_FITSC)=0 ctlint(C_WOODS)=33 ctlint(C_ADJF)=0 ctlpar(C_EPS)=1.0d-12 ctlpar(C_DEFER)=1.0d-5 ctlpar(C_CNVG)=0.999d0 ctlpar(C_LMBDA)=0.00001d0 ctlpar(C_FRQLO)=6.0d0 ctlpar(C_FRQUP)=40.0d0 ctlpar(C_INTLM)=0.1d0 ctlpar(C_TEMP)=273.0d0 do i=1, DIMCINT if (cdone(i).ne.0) then ctlint(i)=int(dctl(i)) end if end do do i= DIMCINT+1, DIMCINT+DIMCPAR if (cdone(i).ne.0) then ctlpar(i)=dctl(i) end if end do apri=0 xpri=0 if (ctlint(C_PRINT).eq.1) apri=1 if (ctlint(C_PRINT).eq.2) apri=1 + AP_TL if (ctlint(C_PRINT).ge.2) xpri=XP_CC if (ctlint(C_PRINT).eq.3) apri=1 + AP_TF if (ctlint(C_PRINT).eq.4) apri=2 + AP_TF if (ctlint(C_PRINT).eq.5) apri=2 + AP_TF + AP_TL if (ctlint(C_PRINT).eq.6) apri=2 + AP_TL + AP_LT ctlint(C_PRI)=myor(ctlint(C_PRI),apri) ctlint(C_XPR)=myor(ctlint(C_XPR),xpri) ctlint(C_NZYK)=max(ctlint(C_NZYK),ctlint(C_NCYCL)) do i=1, DIMCINT if (mod(i,4).eq.1) write(*,*) if (ctlstr(i)(1:1).ne.'_') $ write(*,'(3X,A,3X,I5,$)') ctlstr(i),ctlint(i) end do C write(*,*) j=0 do i= DIMCINT+1, DIMCINT+DIMCPAR j=j+1 if (mod(j,3).eq.1) write(*,*) if (len(ctlstr(i)).ne.0) write(*,'(3X,A,3X,D12.7,$)') $ ctlstr(i),ctlpar(i) end do write(*,*) npar=DIMPRR+ctlint(C_NTOP)*DIMPIR if (ctlint(C_NTOP).eq.3) then if (myand(ctlint(C_ADJF),4).ne.0) write(*,*) $ ' I recommend to set adj to 4 for a three top molecule!' end if if (ctlint(C_NTOP).gt.DIMTOP) stop 'ERROR: ntop > DIMTOP' do itop=1, DIMTOP if ((2*ctlint(C_MAXM)+1).gt.DIMM) stop 'ERROR: 2maxm+1 > DIMM' end do if (ctlint(C_EVAL).ne.0) then write(*,'(A)') '\\ writing eigenvalues in file eval.out ' open(20,file='eval.out',status='unknown') end if if (ctlint(C_DFRQ).ne.0) then write(*,'(A,A)') '\\ writing deviation of frequencies in', $ ' file dfreq.out' open(21,file='dfreq.out',status='unknown') end if C set the parameter name acoording to the reduction A or S if (ctlint(C_RED).eq.1) then c parstr(P_DKD)='R6 ' write(*,*) 'Using Watson S Reduction ' end if if (ctlint(C_RED).eq.2) then parstr(P_DKD)='R6 ' write(*,*) 'Using van Eijck-Typke Reduction ' end if if (ctlint(C_RED).eq.0) then write(*,*) 'Using Watson A Reduction ' end if do itop=1, ctlint(C_NTOP) size(S_MAXM+itop)=ctlint(C_MAXM) size(S_MAXV+itop)=ctlint(C_MAXV) end do C -------------- write(*,*) do j=1, DIMVB do i=1, DIMPAR padone(i,j)=0 a(i,j)=0.0d0 end do end do do i=1,DIMPAR+1 if (getbuf(gu,ui).lt.0) stop 'reading a' if (getend(gu)) goto 5 call getxln(gu,parstr,a,padone,DIMPAR,DIMVB) end do 5 continue C fill parameters of not used tops with zeros do ib=1, DIMVB do i=DIMPRR+DIMPIR*ctlint(C_NTOP)+1,DIMPAR a(i,ib)=0.0d0 ifit(i,ib)=0 end do if (ctlint(C_NTOP).le.1) then a(P_FF,ib)=0.0d0 a(P_VSS,ib)=0.0d0 a(P_VCC,ib)=0.0d0 end if end do C get a preliminary value of sizeb sizeb=1 do i=1, DIMPRR+DIMPIR*ctlint(C_NTOP) do ib= DIMVB, 2, -1 if ((a(i,ib).ne.a(i,(ib-1))).and.(a(i,ib).ne.0.0d0)) $ sizeb=max(sizeb,ib) end do end do size(S_NB)=sizeb write(*,*) 'assumed sizeb',sizeb do ib=1, size(S_NB) adj=ctlint(C_ADJF) if ((ctlint(C_INTS).ne.0) .and. (a(P_MUX,ib).eq.0.0d0) $ .and. (a(P_MUY,ib).eq.0.0d0).and. (a(P_MUZ,ib).eq.0.0d0)) $ stop 'ERROR: need mu_x mu_y or mu_z for intensities' if (a(P_BJ,ib).eq.0.0d0) stop 'ERROR: BJ can not be zero' if (ctlint(C_NTOP).ge.1) then C if (a(P_FF,j).eq.a(P1_F,j)) a(P_FF,j)=0.0d0 C if (a(P1_F0,j).eq.a(P1_F,j)) a(P1_F0,j)=0.0d0 if (padone(P_FF,ib).ge.DIMTOP) a(P_FF,ib)=0.0d0 if (padone(P1_F0,ib).ge.2) a(P1_F0,ib)=0.0d0 if (padone(P2_F0,ib).ge.3) a(P2_F0,ib)=0.0d0 if (((a(P1_ANGZ,ib).ne.0.0d0).or.(a(P1_ANGX,ib).ne.0.0d0)) $ .and. $ (a(P1_BETA,ib).eq.0.0d0).and.(a(P1_GAMA,ib).eq.0.0d0) $ .and.(myand(adj,16).eq.0)) then adj=myor(adj,16) write(*,'(A)') ' \\ set (adj or 16)' end if if ((a(P1_F0,ib).ne.0.0d0).and.(a(P1_RHO,ib).eq.0.0d0) $ .and.(myand(adj,8).eq.0)) then adj=myor(adj,8) write(*,'(A)') ' \\ set (adj or 8)' end if if ((a(P1_F,ib).eq.0.0d0).and.(myand(adj,1).eq.0)) then adj=myor(adj,1) write(*,'(A)') ' \\ set (adj or 1)' end if end if if (ctlint(C_NTOP).ge.2) then if ((a(P_FF,ib).eq.0.0d0).and.(myand(adj,2).eq.0)) then adj=myor(adj,2) write(*,'(A)') ' \\ set (adj or 2)' end if end if c if ((a(P1_F0).eq.0.0d0).and.(a(P1_F).eq.0.0d0) c $ .and.(myand(ctlint(C_ADJF),1).eq.0)) then c ctlint(C_ADJF)=myor(ctlint(C_ADJF),1) c write(*,'(A)') ' \\ set (adj or 1)' c end if ctlnb(CB_ADJ,ib)=adj ctlnb(CB_WDS,ib)=ctlint(C_WOODS) call adjusta(a(1,ib),npar,adj) if (myand(adj,1).ne.0) write(*,*) $ '\\ adj 1: adjust F according to rho, beta and gamma' if (myand(adj,2).ne.0) write(*,*) $ '\\ adj 2: adjust F12 according to rho, beta and gamma' if (myand(adj,4).ne.0) write(*,*) $ '\\ adj 4: adjust F (one top case) and ignore F'' ' if (myand(adj,8).ne.0) write(*,*) $ '\\ adj 8: adjust rho according to F0 = 1/(2 I_alpha)' if (myand(adj,16).ne.0) write(*,*) $ '\\ adj 16: adjust beta and gamma according delta + epsil' write(*,'(A,I4)') ' new adj :',adj end do do ib=sizeb+1, DIMVB ctlnb(CB_ADJ,ib)=adj ctlnb(CB_WDS,ib)=ctlint(C_WOODS) end do call pra(a,a,ifit,3,0,0) write(*,*) C ------ do i=1,DIMFIT+1 do is=1, DIMPAR do ib=1, DIMVB padone(is,ib)=0 afit(is,ib)=0.0d0 end do end do if (getbuf(gu,ui).lt.0) stop ' Error reading fit parameters ' if (getend(gu)) goto 8 dfit(i)=0 df=0 gl=getc(gu,fitstr) if (fitstr.eq.'dqx') df=-2 if (fitstr.eq.'dqu') df=-1 if (fitstr.eq.'fit') df=1 if ((i.gt.DIMFIT).and.(df.ne.0)) $ stop ' maximum number (DIMFIT) of fit variables exceeded !' dfit(i)=df if (dfit(i).eq.0) goto 8 C palc(i,0): stepwidth in % for differential quotient calc no=getd(gu,palc(i,0)) if (no.le.0) palc(i,0)=0.1d0 C palc(i,-1): factor to scale the new parameters in fit no=getd(gu,palc(i,-1)) if (no.le.0) palc(i,-1)=1.0d0 if ((dfit(i).gt.0)) $ write(*,'(A,2D8.1,3X,$)') ' fit ',palc(i,0),palc(i,-1) if ((dfit(i).eq.-1)) $ write(*,'(A,2D8.1,3X,$)') ' dqu ',palc(i,0),palc(i,-1) if ((dfit(i).eq.-2)) $ write(*,'(A,2D8.1,3X,$)') ' dqx ',palc(i,0),palc(i,-1) call getxln(gu,parstr,afit,padone,DIMPAR,DIMVB) sum=0.0d0 oldix=0 ix=0 do is=1, DIMPAR oldix=ix do ib=1, DIMVB if (padone(is,ib).eq.1) then ifit(is,ib)=1 if (afit(is,ib).eq.0.0d0) afit(is,ib)=1.0d0 ix=ix+1 if (ix.gt.DIMPLC) stop ' Dimension Error: DIMPLC' pali(i,ix,1)=is pali(i,ix,2)=ib palc(i,ix)=afit(is,ib) sum=sum+dabs(a(is,ib)) end if end do if ((ix-oldix).eq.DIMVB) then write(*,'(3X,1A,3X,1F6.2,$)') $ parstr(is),palc(i,ix) else do j=oldix+1, ix write(*,'(3X,2A,I1,2A,1F5.2,$)') $ parstr(is)(1:len_c(parstr(is))) $ ,'(',pali(i,j,2),')' $ ,spaz(1:(len(parstr(is))-len_c(parstr(is))+1)) $ ,palc(i,j) end do end if end do write(*,*) pali(i,0,1)=ix do j=1, pali(i,0,1) if ((parfit(pali(i,j,1)).ne.0).and.(dfit(i).eq.1)) then c write(*,'(3A)')' Warning: fit changed to dqu!', c $ ' No analytic derivatives for ',parstr(j) dfit(i)=-1 end if end do if ((dfit(i).eq.-1).and.(sum.eq.0.0d0)) $ stop 'ERROR: dqu/x parameter can not be zero !' end do 8 continue nfit=i-1 write(*,*) do ib=1, DIMVB adj=ctlnb(CB_ADJ,ib) if (myand(adj,2).gt.0) then if (ifit(P_FF,ib).ne.0) $ stop ' Fit ERROR: can not fit F12: adjf = 2' end if do itop=1, ctlint(C_NTOP) ift=(itop-1)*DIMPIR if (myand(adj,1).gt.0) then if (ifit(P1_F +ift,ib).ne.0) $ stop ' Fit ERROR: can not fit F: adjf = 1' else if (ifit(P1_F0+ift,ib).ne.0) $ stop ' Fit ERROR: can not fit F0: adjf <> 1' end if if (myand(adj,8).gt.0) then if (ifit(P1_RHO+ift,ib).ne.0) $ stop ' Fit ERROR: can not fit rho: adjf = 8' else if (ifit(P1_F0+ift,ib).ne.0) $ stop ' Fit ERROR: can not fit F0: adjf <> 8' end if if (myand(adj,16).gt.0) then if ((ifit(P1_GAMA+ift,ib).ne.0) $ .or.(ifit(P1_BETA+ift,ib).ne.0)) $ stop ' Fit ERROR: can not fit beta/gamma: adjf = 16' else if ((ifit(P1_ANGZ+ift,ib).ne.0) $ .or.(ifit(P1_ANGX+ift,ib).ne.0)) $ stop ' Fit ERROR: can not fit delta/epsil: adjf <> 16' end if end do ! itop end do ! ib C ------ size(S_G)=0 do i=1, DIMGAM do itop=1, DIMTOP gamma(i,itop)=NaQN end do gamma(i,0)=0 end do do i=1, 2*DIMTOP dgam(i)=0 end do if (ctlint(C_NTOP).ne.0) then do i=1, DIMGAM+1 do itop=1, 2*DIMTOP gdone(itop)=0 end do if (getbuf(gu,ui).lt.0) stop ' Error: reading gamma' if (getend(gu)) goto 7 if (i.gt.DIMGAM) stop ' to many lines reading S! ' C symmetry-species-name beginning with '/' gm=s_mark(gu) gl=getc(gu,symstr) call fillsp(qnostr(MAXQC+i)) if (symstr(1:1).eq.'/') then qnostr(MAXQC+i)=symstr(1:len(qnostr(MAXQC+i))+1) else call g_mark(gu,gm) end if call getln(gu,gamstr,dgam,gdone,2*DIMTOP) do itop=1, ctlint(C_NTOP) if ((int(dgam(2*itop-1)).eq.0).and.(int(dgam(2*itop)).eq.0)) $ gamma(i,itop)=0 if ((int(dgam(2*itop-1)).ne.0).and.(int(dgam(2*itop)).eq.0)) $ gamma(i,itop)=int(dgam(2*itop-1)) if ((int(dgam(2*itop-1)).eq.0).and.(int(dgam(2*itop)).ne.0)) $ gamma(i,itop)=int(dgam(2*itop)) if ((int(dgam(2*itop-1)).ne.0).and.(int(dgam(2*itop)).ne.0)) $ stop 'Error: use G or S as Keyword' end do size(S_G)=i end do 7 continue do is=1, size(S_G) if (qnostr(MAXQC+is)(1:1).ne.' ') $ write(*,'(3X,A,$)') qnostr(MAXQC+is) write(*,'(2X,A,4I4)') 'S ',(gamma(is,it),it=1,ctlint(C_NTOP)) do it=1,ctlint(C_NTOP) if (gamma(is,it).gt.DIMSIG) stop 'ERROR: sigma > DIMSIG' end do end do else gamma(1,1)=-999 end if C ---- do i=1, DIMVV do ib=1, DIMVB do itop=1, DIMTOP qvv(i,itop,ib)=-1 end do end do end do size(S_NB)=1 if (ctlint(C_NTOP).ne.0) then write(*,*) do ib=1, DIMVB+1 if (getbuf(gu,ui).lt.0) stop ' Error: reading qvv' if (getend(gu)) goto 20 do iv=1, DIMVV call fillsp(fitstr) gl=getc(gu,fitstr) if (fitstr(1:1).ne.'V') goto 19 do itop=1, ctlint(C_NTOP) no=geti(gu,j) if (no.le.0) stop ' Error: V no. for each top necessary!' qvv(iv,itop,ib)=j+1 end do end do 19 continue size(S_NB)=ib end do 20 continue do ib=size(S_NB)+1, DIMVB do i=1, DIMVV do itop=1, DIMTOP qvv(i,itop,ib)=qvv(i,itop,size(S_NB)) end do end do end do do ib=1, size(S_NB) do iv=1, DIMVV if (qvv(iv,1,ib).eq.-1) goto 21 write(*,'(A,$)') ' V' do itop=1,ctlint(C_NTOP) write(*,'(I3,$)') qvv(iv,itop,ib)-1 end do end do 21 continue write(*,*) end do end if C ---- write(*,*) if (ctlint(C_NDATA).le.0) ctlint(C_NDATA)=DIMLIN do iq=1, DIMQC dqno(iq)=0.0d0 end do C initial values dqno( 8)=NOFIT ! Err dqno(15)=1 ! Bup dqno(16)=1 ! Blo dqno(17)=-1 ! Fup dqno(18)=-1 ! Flo dqno(19)=0 ! Tup dqno(20)=0 ! Tlo dqno(11)=1 ! V1up dqno(12)=1 ! V1lo ndata =0 msplit =0.0d0 m2split =0.0d0 nsplit =0 efdata =0.0d0 stpflg =.false. do il=1,ctlint(C_NDATA) if (getbuf(gu,ui).lt.0) goto 10 if (getend(gu)) goto 10 dqno(23)=0 ! # dqno(24)=0 ! & dqno(27)=0 ! diff do iq=1, DIMQC qdone(iq)=0 end do call getln(gu,qnostr,dqno,qdone,DIMQC) if ((qdone(25).ne.0).and.(qdone(21).ne.0)) $ write(*,*) 'UP Tau overrides K',il if ((qdone(26).ne.0).and.(qdone(22).ne.0)) $ write(*,*) 'LO Tau overrides K',il if (((qdone(2).ne.0).or.(qdone(3).ne.0)).and.(qdone(21).ne.0)) $ write(*,*) 'UP Tau (t) overrides K- K+',il if (((qdone(5).ne.0).or.(qdone(6).ne.0)).and.(qdone(22).ne.0)) $ write(*,*) 'LO Tau (t) overrides K- K+',il if ((int(dqno(1)).gt.DIMJ).or.(int(dqno(4)).gt.DIMJ)) then write(*,'(A,I4,A)') $ ' Warning Max. J exceeded. Line',il,' error' stpflg=.true. end if if (qdone(19).ne.0) then ! Tup dqno(25)=0.0d0 ! Kup dqno(21)=0.0d0 ! tup qdone(25)=0 dqno( 2)=0.0d0 ! K- up dqno( 3)=0.0d0 ! K+ up end if if (qdone(20).ne.0) then ! Tlo dqno(26)=0.0d0 ! Klo dqno(22)=0.0d0 ! tlo qdone(26)=0 dqno( 5)=0.0d0 ! K- lo dqno( 6)=0.0d0 ! K+ lo end if if (qdone(21).ne.0) then ! tup dqno(25)=0.0d0 ! Kup dqno(19)=0.0d0 ! Tup qdone(25)=0 dqno( 2)=0.0d0 ! K- up dqno( 3)=0.0d0 ! K+ up end if if (qdone(22).ne.0) then ! tlo dqno(20)=0.0d0 ! Tlo dqno(26)=0.0d0 ! Klo qdone(26)=0 dqno( 5)=0.0d0 ! K- lo dqno( 6)=0.0d0 ! K+ lo end if if (qdone(25).ne.0) then dqno( 2)=-10.0d0 ! K- up dqno( 3)=-10.0d0 ! K+ up dqno(21)=0.0d0 ! tup,Q_TJ qdone(21)=0 end if if (qdone(26).ne.0) then dqno( 5)=-20.0d0 ! K- lo dqno( 6)=-20.0d0 ! K+ lo dqno(22)=0.0d0 ! tlo,Q_TJ qdone(22)=0 end if C copy the vector dqno to the transition list qlin do iq=1, DIMQC if ((q_q(iq).gt.0).and.(qul(iq).gt.0)) then qlin(il,q_q(iq),qul(iq))=int(dqno(iq)) end if end do if (qdone(7).ne.0) then ! = (frequency) dln(il,LN_FREQ)=dqno(7) dln(il,LN_ERR)=ctlpar(C_DEFER) if (qdone(8).ne.0) then ! Err dln(il,LN_ERR)=dqno(8) end if ndata=ndata+1 else dln(il,LN_FREQ)=0.0d0 dln(il,LN_ERR)=NOFIT end if if ((qdone(2).ne.0).or.(qdone(3).ne.0)) then qlin(il,Q_TJ,Q_UP)=0 end if if ((qdone(5).ne.0).or.(qdone(6).ne.0)) then qlin(il,Q_TJ,Q_LO)=0 end if C Check for symmetry-labels do i=1,DIMGAM if (qdone(MAXQC+i).ne.0) then if ((qdone(9).eq.0).and.(qdone(10).eq.0)) then qlin(il,Q_S,Q_UP)=i qlin(il,Q_S,Q_LO)=i else write(*,*)' Warning: S and Symmetry Label given (using S)' end if end if end do if ((qlin(il,Q_S,Q_UP).gt.size(S_G)).or. $ (qlin(il,Q_S,Q_LO).gt.size(S_G))) then write(*,*)'ERROR: Symmetry spezies not defined in line',il stpflg=.true. end if C Check for units (GHz default, MHZ and cm) if ((qdone(29).ne.0).and.(qdone(30).eq.0)) then dln(il,LN_FREQ)=dln(il,LN_FREQ)/1000.0d0 if (qdone(8).ne.0) $ dln(il,LN_ERR)=dln(il,LN_ERR)/1000.0d0 end if if ((qdone(29).eq.0).and.(qdone(30).ne.0)) then dln(il,LN_FREQ)=dln(il,LN_FREQ)*29.97925d0 if (qdone(8).ne.0) $ dln(il,LN_ERR)=dln(il,LN_ERR)*29.97925d0 end if C # references (23): ref lines ilr=int(dqno(23)) ilr=ilr+il qlin(il,Q_REF,Q_UP)=ilr qlin(il,Q_REF,Q_LO)=ilr C splitting frequency as input (27) if (qdone(27).ne.0) then ! diff ilx=int(dqno(27)) if (ilx.eq.0) then ilx=ilr else ilx=ilx+il end if if ((dln(il,LN_FREQ).ne.0.0d0).and. $ (dln(ilx,LN_FREQ).ne.0.0d0)) then dln(il,LN_FREQ)=dln(ilx,LN_FREQ)+dln(il,LN_FREQ) else write(0,'(A,2I4)') 'WARNING: diff frequency zero at',il,ilx end if end if if ((ilr.ne.il).and.(dln(il,LN_ERR).ne.NOFIT)) then msplit=msplit+abs(dln(il,LN_FREQ)-dln(ilr,LN_FREQ)) m2split=m2split+(dln(il,LN_FREQ)-dln(ilr,LN_FREQ))**2 nsplit=nsplit+1 endif efdata=efdata+ctlpar(C_DEFER)**2/dln(il,LN_ERR)**2 C Check for an average line (dqno(24)) ila=int(dqno(24)) ila=ila+il qlin(il,Q_AVG,Q_UP)=ila qlin(il,Q_AVG,Q_LO)=ila if (ila.ne.il) then if (dln(ila,LN_ERR).ne.NOFIT) then write(*,'(A,I4,A,I4,A)') $ 'Warning: average freq. in',il,': line',ila,' not used' ilr=qlin(ila,Q_REF,Q_UP) if (ilr.ne.ila) then msplit=msplit-abs(dln(ila,LN_FREQ)-dln(ilr,LN_FREQ)) m2split=m2split-(dln(ila,LN_FREQ)-dln(ilr,LN_FREQ))**2 nsplit=nsplit-1 endif efdata=efdata-ctlpar(C_DEFER)**2/dln(ila,LN_ERR)**2 dln(ila,LN_ERR)=NOFIT efdata=efdata+ctlpar(C_DEFER)**2/dln(ila,LN_ERR)**2 end if end if C calc tau (Q_TJ)(dqno(21/22) from K- dqno(2/5) and K+ dqno(3/6) if (((dqno(21).eq.0).and.(dqno(19).eq.0)).and. $ ((dqno(2).ge.0.0d0).or.(dqno(3).ge.0.0d0))) $ qlin(il,Q_TJ,Q_UP)=int(dqno(2))-int(dqno(3))+1 $ +int(dqno(1)) if (((dqno(22).eq.0).and.(dqno(20).eq.0)).and. $ ((dqno(5).ge.0.0d0).or.(dqno(6).ge.0.0d0))) $ qlin(il,Q_TJ,Q_LO)=int(dqno(5))-int(dqno(6))+1 $ +int(dqno(4)) C Q_TJ numbering of eigenvalues of one V if (qlin(il,Q_TJ,Q_UP).ne.0) then qlin(il,Q_STAT,Q_UP)=myor(qlin(il,Q_STAT,Q_UP),2) end if if (qlin(il,Q_TJ,Q_LO).ne.0) then qlin(il,Q_STAT,Q_LO)=myor(qlin(il,Q_STAT,Q_LO),2) end if C Q_T numbering of eigenvalues of the whole matrix (with several V''s) if (qlin(il,Q_T,Q_UP).ne.0) then qlin(il,Q_STAT,Q_UP)=myor(qlin(il,Q_STAT,Q_UP),4) end if if (qlin(il,Q_T,Q_LO).ne.0) then qlin(il,Q_STAT,Q_LO)=myor(qlin(il,Q_STAT,Q_LO),4) end if if (dln(il,LN_ERR).ne.NOFIT) then qlin(il,Q_STAT,Q_UP)=myor(qlin(il,Q_STAT,Q_UP),16) qlin(il,Q_STAT,Q_LO)=myor(qlin(il,Q_STAT,Q_LO),16) end if write(fmtstr,'(A,I2,A,I2,A)') $ '(',DIMQLP,'I3,3X,',DIMQLP,'I3,F18.7,D12.2)' if (myand(ctlint(C_PRI),AP_IO).ne.0) write(*,fmtstr) $ (qlin(il,iqq,Q_UP),iqq=1,DIMQLP) $ ,(qlin(il,iqq,Q_LO),iqq=1,DIMQLP) $ ,dln(il,LN_FREQ),dln(il,LN_ERR) if (myand(ctlint(C_PRI),AP_IO).ne.0) then if (qlin(il,Q_S,Q_LO).eq.1) then write(0,'(2(3I3,2X))') $ qlin(il,Q_J,Q_UP) $ ,qlin(il,Q_TJ,Q_UP)/2 $ ,(2*qlin(il,Q_J,Q_UP)-qlin(il,Q_TJ,Q_UP)+2)/2 $ ,qlin(il,Q_J,Q_LO) $ ,qlin(il,Q_TJ,Q_LO)/2 $ ,(2*qlin(il,Q_J,Q_LO)-qlin(il,Q_TJ,Q_LO)+2)/2 write(0,'(I4,F15.4)') $ qlin(il,Q_S,Q_LO),dln(il,LN_FREQ)*1000.0d0 end if if (qlin(il,Q_S,Q_LO).gt.1) then write(0,'(I4,F15.4)') $ qlin(il,Q_S,Q_LO),dln(il,LN_FREQ)*1000.0d0 end if end if if ((qlin(il,Q_TJ,Q_UP).le.0).and.(qlin(il,Q_T,Q_UP).le.0) $ .and.(qdone(25).eq.0)) then write(0,'(A,i4)') 'No tau or K (up) in line',il stpflg=.true. end if if ((qlin(il,Q_TJ,Q_LO).le.0).and.(qlin(il,Q_T,Q_LO).le.0) $ .and.(qdone(26).eq.0)) then write(0,'(A,i4)') 'No tau or K (lo) in line',il stpflg=.true. end if if ((qlin(il,Q_TJ,Q_LO).gt.(2*qlin(il,Q_J,Q_LO)+1)).or. $ (qlin(il,Q_TJ,Q_UP).gt.(2*qlin(il,Q_J,Q_UP)+1))) then write(0,'(A,i4)') 'tau > 2J+1 at line',il stpflg=.true. end if if ((qlin(il,Q_V1,Q_LO).le.0).or.(qlin(il,Q_V1,Q_UP).le.0)) then write(0,'(A,i4)') 'V < 1 at line',il stpflg=.true. end if if ((qlin(il,Q_B,Q_LO).le.0).or.(qlin(il,Q_B,Q_UP).le.0)) then write(0,'(A,i4)') 'Error: B < 1 at line',il stpflg=.true. end if if ((qlin(il,Q_F,Q_LO).lt.-1).or.(qlin(il,Q_F,Q_UP).lt.-1))then write(0,'(A,i4)') 'Error: F < -1 at transition no.',il stpflg=.true. end if if (qlin(il,Q_F,Q_LO).ge.0) then if (abs(2*qlin(il,Q_J,Q_LO)-qlin(il,Q_F,Q_LO)) $ .gt.ctlint(C_SPIN)) then write(0,'(A,i4)') 'Error: |J-F| > ! at transition no.',il stpflg=.true. end if end if if (qlin(il,Q_F,Q_UP).ge.0) then if (abs(2*qlin(il,Q_J,Q_UP)-qlin(il,Q_F,Q_UP)) $ .gt.ctlint(C_SPIN)) then write(0,'(A,i4)') 'Error: |J-F| > I at transition no.',il stpflg=.true. end if end if if ((qlin(il,Q_B,Q_LO).gt.DIMVB) $ .or.(qlin(il,Q_B,Q_UP).gt.DIMVB)) then write(0,'(A,i4)') 'B > DIM B' stpflg=.true. end if if ((qlin(il,Q_B,Q_LO).gt.size(S_NB)) $ .or.(qlin(il,Q_B,Q_UP).gt.size(S_NB))) then size(S_NB)=max(qlin(il,Q_B,Q_LO),qlin(il,Q_B,Q_UP)) end if end do 10 continue if (stpflg) then write(*,*) 'INPUT ERROR(S)' write(0,*) 'INPUT ERROR(S)' stop end if ctlint(C_NDATA)=il-1 write(*,'(3(3X,A,I4),/,3X,A,F6.1)') $ ctlstr(C_NDATA),ctlint(C_NDATA) $ ,'Data Points',ndata,'Splittings',nsplit $ ,'Effective Data Points',efdata if (nsplit.ne.0) then msplit=msplit/nsplit m2split=sqrt(m2split/nsplit) write(*,'(3X,2(A,F12.6))') 'Mean Experimental Splitting:',msplit $ ,' squared:',m2split end if C clean up pali and palc for not used ib values do i=1, nfit do j=1, pali(i,0,1) if (pali(i,j,2).gt.size(S_NB)) then pali(i,j,2)=0 pali(i,j,1)=0 palc(i,j)=0.0d0 end if end do end do do i=1, nfit do j=1, pali(i,0,1) if (pali(i,j,2).eq.0) goto 100 end do 100 continue ffree=j do j=ffree, pali(i,0,1) if (pali(i,j,2).gt.0) then pali(i,ffree,1)=pali(i,j,1) pali(i,ffree,2)=pali(i,j,2) palc(i,ffree)=palc(i,j) pali(i,j,1)=0 pali(i,j,2)=0 palc(i,j)=0.0d0 ffree=ffree+1 end if end do pali(i,0,1)=ffree-1 end do C- delete here c do ib=1, size(S_NB) cc do iv=1, DIMVV c if (qvv(iv,1,ib).eq.-1) goto 22 c write(*,'(A,$)') ' V' cc do itop=1,ctlint(C_NTOP) c write(*,'(I3,$)') qvv(iv,itop,ib)-1 c end do c end do c 22 continue c write(*,*) c end do return end C---------------------------------------------------------------------- subroutine prrrp(a,da,covar,palc,pali,nfit,ib) C print rotational constants and errors implicit none include 'iam_.for' real*8 a(DIMPAR),da(DIMPAR),covar(DIMFIT,DIMFIT) real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) integer nfit,ib integer ibj,ibk,ibd,i,j integer ixj,ixk,ixd real*8 cjk,cjd,ckd,kappa real*8 b(3),d(3),bb,dd character*3 c(3),cc logical noc C find correlation coeff between BJ BK and B- C works only if no linear comb. of BJ BK B- is fitted ibj=0 ibk=0 ibd=0 ixj=0 ixk=0 ixd=0 do i=1, nfit do j=1, pali(i,0,1) if ((pali(i,j,1).eq.P_BJ).and.(pali(i,j,2).eq.ib)) then ibj=i ixj=ixj+1 end if end do do j=1, pali(i,0,1) if ((pali(i,j,1).eq.P_BK).and.(pali(i,j,2).eq.ib)) then ibk=i ixk=ixk+1 end if end do do j=1, pali(i,0,1) if ((pali(i,j,1).eq.P_BD).and.(pali(i,j,2).eq.ib)) then ibd=i ixd=ixd+1 end if end do end do C covar(j,i) with j jup' ntop=ctlint(C_NTOP) inti=0.0 intr=0.0 dj=dble(jlo) C muz do ik=1, sizelo(S_K) do iv=1, sizelo(S_VV) i=ik+(iv-1)*sizelo(S_K) qk=qvklo(i,Q_K) dq=dble(qk) intr=intr+2.0*muz*dq*(vrlo(i)*vrup(i)+vilo(i)*viup(i)) inti=inti+2.0*muz*dq*(vrlo(i)*viup(i)-vilo(i)*vrup(i)) end do end do C mux/y do ik2=1, sizelo(S_K)-1 qk2=qvkup(ik2,Q_K) ik1=ik2+1 qk1=qvklo(ik1,Q_K) dq=sqrt((dj-dble(qk2))*(dj+dble(qk2)+1.0)) do iv1=1, sizelo(S_VV) i1=ik1+(iv1-1)*sizelo(S_K) do iv2=1, sizeup(S_VV) i2=ik2+(iv2-1)*sizeup(S_K) tt=1.0 if (gam.ne.0) then do itop=1, ntop tt=tt*tori(qk1,qk2 $ ,qvklo(i1,Q_V+itop)-size(S_MINV+itop)+1 $ ,qvkup(i2,Q_V+itop)-size(S_MINV+itop)+1 $ ,gamma(gam,itop),itop) end do else if (iv1.ne.iv2) tt=0.0 end if intr=intr $ -tt*mux*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) inti=inti $ -tt*mux*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) inti=inti $ -tt*muy*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) intr=intr $ +tt*muy*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) end do end do end do do ik2=2, sizelo(S_K) qk2=qvkup(ik2,Q_K) ik1=ik2-1 qk1=qvklo(ik1,Q_K) dq=sqrt((dj+dble(qk2))*(dj-dble(qk2)+1.0)) do iv1=1, sizelo(S_VV) i1=ik1+(iv1-1)*sizelo(S_K) do iv2=1, sizeup(S_VV) i2=ik2+(iv2-1)*sizeup(S_K) tt=1.0 if (gam.ne.0) then do itop=1, ntop tt=tt*tori(qk1,qk2 $ ,qvklo(i1,Q_V+itop)-size(S_MINV+itop)+1 $ ,qvkup(i2,Q_V+itop)-size(S_MINV+itop)+1 $ ,gamma(gam,itop),itop) end do else if (iv1.ne.iv2) tt=0.0 end if intr=intr $ -tt*mux*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) inti=inti $ -tt*mux*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) inti=inti $ +tt*muy*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) intr=intr $ -tt*muy*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) end do end do end do ints=(intr**2+inti**2)*(2.0*dj+1.0)/(2.0*dj*(2.0*dj+2.0)) return end C ---------------------------------------------------------------------- C Delta J = 1 ---------------------------------------------------------------- subroutine calir(ints,tori,jup,jlo,gam,muz, mux, muy $ ,sizeup,qvkup,vrup,viup $ ,sizelo,qvklo,vrlo,vilo) implicit none include 'iam_.for' integer jup,jlo,gam real*8 ints,muz, mux, muy real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer sizeup(DIMSIZ),sizelo(DIMSIZ) integer qvkup(DIMTOT,Q_K:Q_V+DIMTOP),qvklo(DIMTOT,Q_K:Q_V+DIMTOP) real*8 vrup(DIMTOT),vrlo(DIMTOT),viup(DIMTOT),vilo(DIMTOT) C real*8 intr,inti,dq,dj,tt integer ik,ik1,ik2,qk,qk1,qk2,iv,iv1,iv2,i,i1,i2 integer itop,ntop if ((jlo+1).ne.jup) pause 'CALIR: intens error: jlo+1 <> jup' ntop=ctlint(C_NTOP) inti=0.0 intr=0.0 dj=dble(jlo) C mu_z do ik2=2, sizelo(S_K)+1 qk2=qvkup(ik2,Q_K) ik1=ik2-1 qk1=qvklo(ik1,Q_K) do iv=1, sizelo(S_VV) i1=ik1+(iv-1)*sizelo(S_K) i2=ik2+(iv-1)*sizeup(S_K) c qk1=qvklo(i1,Q_K) c qk2=qvkup(i2,Q_K) if (qk1.ne.qk2) stop 'Error in CALIR : K numbers' dq=2.0*sqrt((dj+dble(qk1)+1.0)*(dj-dble(qk1)+1.0)) intr=intr-muz*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) inti=inti-muz*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) end do end do C mux/y do ik2=1, sizelo(S_K) qk2=qvkup(ik2,Q_K) ik1=ik2 qk1=qvklo(ik1,Q_K) dq=sqrt((dj-dble(qk2))*(dj-dble(qk2)+1.0)) do iv1=1, sizelo(S_VV) i1=ik1+(iv1-1)*sizelo(S_K) do iv2=1, sizeup(S_VV) i2=ik2+(iv2-1)*sizeup(S_K) tt=1.0 if (gam.ne.0) then do itop=1, ntop tt=tt*tori(qk1,qk2 $ ,qvklo(i1,Q_V+itop)-size(S_MINV+itop)+1 $ ,qvkup(i2,Q_V+itop)-size(S_MINV+itop)+1 $ ,gamma(gam,itop),itop) end do else if (iv1.ne.iv2) tt=0.0 end if intr=intr $ +tt*mux*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) inti=inti $ +tt*mux*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) inti=inti $ +tt*muy*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) intr=intr $ -tt*muy*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) end do end do end do do ik2=3, sizelo(S_K)+2 qk2=qvkup(ik2,Q_K) ik1=ik2-2 qk1=qvklo(ik1,Q_K) dq=sqrt((dj+dble(qk2))*(dj+dble(qk2)+1.0)) do iv1=1, sizelo(S_VV) i1=ik1+(iv1-1)*sizelo(S_K) do iv2=1, sizeup(S_VV) i2=ik2+(iv2-1)*sizeup(S_K) tt=1.0 if (gam.ne.0) then do itop=1, ntop tt=tt*tori(qk1,qk2 $ ,qvklo(i1,Q_V+itop)-size(S_MINV+itop)+1 $ ,qvkup(i2,Q_V+itop)-size(S_MINV+itop)+1 $ ,gamma(gam,itop),itop) end do else if (iv1.ne.iv2) tt=0.0 end if intr=intr $ -tt*mux*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) inti=inti $ -tt*mux*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) inti=inti $ +tt*muy*dq*(vrlo(i1)*vrup(i2)+vilo(i1)*viup(i2)) intr=intr $ -tt*muy*dq*(vrlo(i1)*viup(i2)-vilo(i1)*vrup(i2)) end do end do end do ints=(intr**2+inti**2)/(2.0*(2.0*dj+2.0)) return end C ---------------------------------------------------------------------- subroutine binnam(ij,gam,if,ib,binfname) implicit none include 'iam_.for' integer ij,if,gam,ib character*(*) binfname if (if.ge.0) then write(binfname,'(A,2I1,A,2I1,A,I1,A,2I1)') $ 'j',int(ij/10),mod(ij,10), $ 'f',int(if/10),mod(if,10), $ 'b',ib, $ '.s',int(gam/10),mod(gam,10) else write(binfname,'(A,2I1,A,I1,A,2I1)') $ 'j',int(ij/10),mod(ij,10), $ 'b',ib, $ '.s',int(gam/10),mod(gam,10) end if return end C ---------------------------------------------------------------------- subroutine wrvec(zr,zi,d,ij,gam,if,ib,qvk,qmk) implicit none include 'iam_.for' integer ij,if,gam,ib real*8 zr(DIMTOT,DIMTOT),zi(DIMTOT,DIMTOT) real*8 d(DIMTOT) integer qvk(DIMTOT,Q_K:Q_V+DIMTOP),qmk(DIMTOT,DIMQLP) integer ie,id,itop,bu,ios character*30 binfname integer myand external myand call binnam(ij,gam,if,ib,binfname) call getfu(bu) if (myand(ctlint(C_PRI),AP_ST).ne.0) $ write(*,*)' Writing ',binfname open(bu,file=binfname,status='unknown',err=99,iostat=ios $ ,form='unformatted') write(bu,err=99,iostat=ios) (size(ie),ie=1,DIMSIZ) write(bu,err=99,iostat=ios) (qvk(ie,Q_K), $ (qvk(ie,Q_V+itop),itop=1,DIMTOP) $ ,ie=1,size(S_H)) do id=1, size(S_H) c write(bu,'(F18.9,$)',err=99,iostat=ios) d(id) c write(bu,err=99,iostat=ios) d(id) write(bu,err=99,iostat=ios) d(id), (qmk(id,ie),ie=1,DIMQLP), $ (zr(ie,id),zi(ie,id),ie=1,size(S_H)) end do close (bu) return 99 continue write(*,*) 'wrvec Error iostat', ios,ij,gam,if,ib,binfname return end C---------------------------------------------------------------------- subroutine getfu(myunit) implicit none integer myunit,funit save funit data funit/10/ if (funit.gt.50) funit=10 funit=funit+1 myunit=funit c write(0,*)'funit ',myunit return end C---------------------------------------------------------------------- subroutine rdvec(ij,it,is,if,ib,mysize,qvk,vr,vi,e,qmk) implicit none include 'iam_.for' integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer mysize(DIMSIZ) integer ij,it,is,if,ib,i,ie,itop,bu integer qmk(DIMQLP) real*8 vr(DIMTOT),vi(DIMTOT),e character*30 binfname call getfu(bu) c write(0,*)'rdvec',bu call binnam(ij,is,if,ib,binfname) open(bu,file=binfname,status='unknown',form='unformatted') read(bu) (mysize(ie),ie=1,DIMSIZ) read(bu) (qvk(ie,Q_K), $ (qvk(ie,Q_V+itop),itop=1,DIMTOP) $ ,ie=1,mysize(S_H)) do i=1, mysize(S_H) read(bu) e, (qmk(ie),ie=1,DIMQLP), $ (vr(ie),vi(ie),ie=1,mysize(S_H)) if (qmk(Q_T).eq.it) goto 10 end do write(*,'(1x,a)')'RDVEC: eigenvector not found' zk write(*,'(15x,a,5i6)')'for ij,it,is,if,ib =',ij,it,is,if,ib zk 10 continue close (bu) return end C ---------------------------------------------------------------------- subroutine rdmat(ij,is,if,ib,mysize,qvk,vr,vi,e,qmk) implicit none include 'iam_.for' integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer mysize(DIMSIZ) integer ij,is,if,ib,i,ie,itop,bu integer qmk(DIMTOT,DIMQLP) real*8 vr(DIMTOT,DIMTOT),vi(DIMTOT,DIMTOT),e(DIMTOT) character*30 binfname call getfu(bu) c write(0,*)'rdmat',bu call binnam(ij,is,if,ib,binfname) open(bu,file=binfname,status='unknown',form='unformatted') read(bu) (mysize(ie),ie=1,DIMSIZ) read(bu) (qvk(ie,Q_K), $ (qvk(ie,Q_V+itop),itop=1,DIMTOP) $ ,ie=1,mysize(S_H)) do i=1, mysize(S_H) read(bu) e(i), (qmk(i,ie),ie=1,DIMQLP), $ (vr(ie,i),vi(ie,i),ie=1,mysize(S_H)) end do close (bu) return end C---------------------------------------------------------------------- subroutine wrtori(tori,ib) implicit none include 'iam_.for' integer ib real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer ie,itop,ntop,isig,sigma,ivr,ivc,ikr,ikc,bu character*30 binfname integer myand external myand call getfu(bu) ntop=ctlint(C_NTOP) write(binfname,'(A,1I1)') $ 'tori.b',ib if (myand(ctlint(C_PRI),AP_ST).ne.0) $ write(*,*)' Writing ',binfname open(bu,file=binfname,status='unknown',form='unformatted') write(bu) (size(ie),ie=1,DIMSIZ) write(bu) $ ((gamma(isig,itop),itop=1,ntop),isig=1,size(S_G)) do itop=1, ntop do isig=1, size(S_G) sigma=gamma(isig,itop) do ivr=1, size(S_V+itop) do ikr=-size(S_MAXK), size(S_MAXK) do ivc=1, size(S_V+itop) do ikc=-size(S_MAXK), size(S_MAXK) write(bu) tori(ikr,ikc,ivr,ivc,sigma,itop) $ ,ikr,ikc,ivr,ivc end do end do end do end do end do end do close (bu) return end C---------------------------------------------------------------------- subroutine rdtori(tori,ib) implicit none include 'iam_.for' integer ib real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer ie,itop,ntop,isig,sigma,ivr,ivc,ikr,ikc,bu character*30 binfname integer myand external myand call getfu(bu) ntop=ctlint(C_NTOP) write(binfname,'(A,I1)') $ 'tori.b',ib if (myand(ctlint(C_PRI),AP_ST).ne.0) $ write(*,*)' Reading Tori ',binfname open(bu,file=binfname,status='unknown',form='unformatted') read(bu) (size(ie),ie=1,DIMSIZ) read(bu) $ ((gamma(isig,itop),itop=1,ntop),isig=1,size(S_G)) do itop=1, ntop do isig=1, size(S_G) sigma=gamma(isig,itop) do ivr=1, size(S_V+itop) do ikr=-size(S_MAXK), size(S_MAXK) do ivc=1, size(S_V+itop) do ikc=-size(S_MAXK), size(S_MAXK) read(bu) tori(ikr,ikc,ivr,ivc,sigma,itop) end do end do end do end do end do end do close (bu) return end C ------------------------------------------------------------- subroutine intal2(mux,muy,muz,temp) implicit none include 'iam_.for' real*8 muz, mux, muy real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer sizeup(DIMSIZ),sizelo(DIMSIZ) integer qvkup(DIMTOT,Q_K:Q_V+DIMTOP),qvklo(DIMTOT,Q_K:Q_V+DIMTOP) C real*8 vrup(DIMTOT),vrlo(DIMTOT),viup(DIMTOT),vilo(DIMTOT) integer qup(DIMTOT,DIMQLP),qlo(DIMTOT,DIMQLP) real*8 elo(DIMTOT),eup(DIMTOT),ints,freq real*8 hrup(DIMTOT,DIMTOT),hrlo(DIMTOT,DIMTOT) real*8 hiup(DIMTOT,DIMTOT),hilo(DIMTOT,DIMTOT) integer jup,jlo integer j1,j2,km1,km2,kp1,kp2,k1,k2,t1,t2,i,t01,t02 integer fup,flo,tup,tlo,sup,slo,bup,blo,vup,vlo,isf,io integer iup(DIMVV),ilo(DIMVV) integer qsp(10,3*DIMTOT),ino,nno,iino,sp(0:DIMGAM) real*8 dsp(4,3*DIMTOT),sfrq real*8 kghz,bolt,temp,ener,statw,popl,hv parameter (kghz=20.8364) C character*6 fno fup=-1 flo=-1 isf=1 c if (ctlint(C_NTOP).eq.0) isf=0 do blo=1,size(S_NB) write(*,*) write(*,'(A,I2,28X,2A12,A9,4A9)') '-- B',blo,'Freq','Split' $ ,'Linestr.','total','stat.w.','popul.','hv-ener.' call rdtori(tori,blo) bup=blo do vlo=1,size(S_VV) vup=vlo do jlo=0, size(S_MAXK) do jup=jlo,min(jlo+1,size(S_MAXK)) ino=0 do slo=0, size(S_G) sup=slo sp(slo)=ino call rdmat(jup,sup,fup,bup,sizeup,qvkup,hrup,hiup,eup,qup) call rdmat(jlo,slo,flo,blo,sizelo,qvklo,hrlo,hilo,elo,qlo) do i=1, DIMVV ilo(i)=0 end do do tlo=1, sizelo(S_H) ilo(qlo(tlo,Q_V1))=ilo(qlo(tlo,Q_V1))+1 do i=1, DIMVV iup(i)=0 end do do tup=1, sizeup(S_H) iup(qup(tup,Q_V1))=iup(qup(tup,Q_V1))+1 freq=eup(tup)-elo(tlo) if ((dabs(freq).lt.ctlpar(C_FRQLO)) $ .or.(dabs(freq).gt.ctlpar(C_FRQUP))) goto 10 if ((tup.le.tlo).and.(jup.eq.jlo)) goto 10 if ((qup(tup,Q_V1).ne.vup).or. $ (qlo(tlo,Q_V1).ne.vlo)) goto 10 if (jup.gt.jlo) then call calir(ints,tori,jup,jlo,sup,muz, mux, muy $ ,sizeup,qvkup,hrup(1,tup),hiup(1,tup) $ ,sizelo,qvklo,hrlo(1,tlo),hilo(1,tlo)) end if if (jup.eq.jlo) then call caliq(ints,tori,jup,jlo,sup,muz, mux, muy $ ,sizeup,qvkup,hrup(1,tup),hiup(1,tup) $ ,sizelo,qvklo,hrlo(1,tlo),hilo(1,tlo)) end if statw=2*jlo+1 if (ints.ge.ctlpar(C_INTLM)) then ino=ino+1 if (ino.gt.3*DIMTOT) stop 'INTALL:error:ino' qsp(1,ino)=sup qsp(2,ino)=tlo qsp(3,ino)=qlo(tlo,Q_K) qsp(4,ino)=ilo(qlo(tlo,Q_V1))/2 qsp(5,ino)=(2*jlo+2-ilo(qlo(tlo,Q_V1)))/2 qsp(6,ino)=tup qsp(7,ino)=qup(tup,Q_K) qsp(8,ino)=iup(qup(tup,Q_V1))/2 qsp(9,ino)=(2*jup+2-iup(qup(tup,Q_V1)))/2 qsp(10,ino)=0 dsp(1,ino)=freq dsp(2,ino)=ints dsp(3,ino)=min(elo(tlo),eup(tup)) end if 10 continue end do ! tup end do ! tlo ino=ino+1 qsp(1,ino)=sup qsp(2,ino)=-1 qsp(6,ino)=-1 end do ! Sup nno=ino do iino=1, nno tlo=qsp(2,iino) tup=qsp(6,iino) C write(*,*)'tlo,tup',tlo,tup do sup=0, size(S_G) c do itry=1,2 do io=1, nno ino=sp(sup)+io C check for end of sup if ((qsp(2,ino).eq.-1) $ .and.(qsp(6,ino).eq.-1)) goto 30 if ((tlo.eq.-1).and.(tup.eq.-1) $ .and.(qsp(10,ino).eq.0)) goto 50 C check for matching tup and tlo if ((tlo.ne.qsp(2,ino)) $ .or.(tup.ne.qsp(6,ino))) goto 40 50 continue freq=dsp(1,ino) ints=dsp(2,ino) ener=dsp(3,ino) qsp(10,ino)=1 if (freq.gt.0.0) then j1 =jup t1 =qsp(6,ino) k1 =qsp(7,ino) km1=qsp(8,ino) kp1=qsp(9,ino) j2 =jlo t2 =qsp(2,ino) k2 =qsp(3,ino) km2=qsp(4,ino) kp2=qsp(5,ino) if (sup.eq.isf) then sfrq=freq t01=t1 t02=t2 end if else j2 =jup t2 =qsp(6,ino) k2 =qsp(7,ino) km2=qsp(8,ino) kp2=qsp(9,ino) j1 =jlo t1 =qsp(2,ino) k1 =qsp(3,ino) km1=qsp(4,ino) kp1=qsp(5,ino) freq=-freq if (sup.eq.isf) then sfrq=freq t01=t1 t02=t2 end if end if popl=exp(-ener/(kghz*temp)) hv =1.0d0-exp(-freq/(kghz*temp)) bolt=statw*popl*hv*ints if ((t02.eq.t2).and.(t01.eq.t1).and.(sup.gt.isf)) $ then write(*,'(20X,(A,I2),10X,F13.6,F10.4,5F9.4,2(A,2I3))') master write(*,'(20X,(A,I2),10X,F13.6,F10.4, F9.4, zk * 1PE9.2, 0P, F9.4, zk * 2F9.4,2(A,2I3))') zk $ ' S',sup $ ,freq,(freq-sfrq)*1000.0,ints,bolt,statw,popl,hv $ ,' K',k1,k2,' t',t1,t2 else if (sup.gt.0) then c write(*,'(2(3I3,1X),3(A,I2),F13.6,10X,5F9.4,2(A,2I3))') master write(*,'(2(3I3,1X),3(A,I2),F13.6,10X, F9.4, zk * 1PE9.2, 0P, F9.4, zk * 2F9.4,2(A,2I3))') zk $ j1 ,km1, kp1,j2 ,km2, kp2, $ ' S',sup,' V',vup,' B',bup $ ,freq ,ints,bolt,statw,popl,hv $ ,' K',k1,k2,' t',t1,t2 end if end if if (sup.eq.0) then c write(*,'(2(3I3,1X),A15 ,F13.6,10X,5F9.4,2(A,2I3))') master write(*,'(2(3I3,1X),A15 ,F13.6,10X, F9.4, zk * 1PE9.2, 0P, F9.4, zk * 2F9.4,2(A,2I3))') zk $ j1 ,km1, kp1,j2 ,km2, kp2, $ ' rigid ' $ ,freq ,ints,bolt,statw,popl,hv $ ,' K',k1,k2,' t',t1,t2 end if 40 continue end do ! io c end do 30 continue end do ! sup if ((tlo.eq.-1).and.(tup.eq.-1)) goto 20 end do ! ino 20 continue end do ! Jup end do ! Jlo write(*,*) end do ! Vlo end do ! Blo write(*,*) ' total is the product of Linestr., population-factor,' write(*,*) ' energy factor (hv), and the statistical weight' write(*,*) return end C fno=char(vup+64)//char(j1+64)//char(t1+64) C $ //char(j2+64)//char(t2+64)//char(sup+64) C ---------------------------------------------------------------------- C ------------------------------------------------------------- subroutine intall(mux,muy,muz,temp) implicit none include 'iam_.for' real*8 muz, mux, muy real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer sizeup(DIMSIZ),sizelo(DIMSIZ) integer qvkup(DIMTOT,Q_K:Q_V+DIMTOP),qvklo(DIMTOT,Q_K:Q_V+DIMTOP) C real*8 vrup(DIMTOT),vrlo(DIMTOT),viup(DIMTOT),vilo(DIMTOT) integer qup(DIMTOT,DIMQLP),qlo(DIMTOT,DIMQLP) real*8 elo(DIMTOT),eup(DIMTOT),ints,freq real*8 hrup(DIMTOT,DIMTOT),hrlo(DIMTOT,DIMTOT) real*8 hiup(DIMTOT,DIMTOT),hilo(DIMTOT,DIMTOT) integer jup,jlo integer j1,j2,km1,km2,kp1,kp2,k1,k2,t1,t2,i integer fup,flo,tup,tlo,sup,slo,bup,blo,vup,vlo,isf integer iup(DIMVV),ilo(DIMVV) real*8 kghz,bolt,temp,popl,statw,hv parameter (kghz=20.8364) fup=-1 flo=-1 isf=0 if (ctlint(C_NTOP).gt.0) isf=1 do blo=1,size(S_NB) write(*,'(A,I2,25X,A12,A9,4A9)') '-- B',blo,'Freq','Linestr.' $ ,'total','stat.w.','popul.','hv-ener.' bup=blo call rdtori(tori,blo) do vlo=1,size(S_VV) vup=vlo do slo=isf,size(S_G) sup=slo do jlo=0, size(S_MAXK) do jup=jlo,min(jlo+1,size(S_MAXK)) call rdmat(jup,sup,fup,bup,sizeup,qvkup,hrup,hiup,eup,qup) call rdmat(jlo,slo,flo,blo,sizelo,qvklo,hrlo,hilo,elo,qlo) do i=1, DIMVV ilo(i)=0 end do do tlo=1, sizelo(S_H) ilo(qlo(tlo,Q_V1))=ilo(qlo(tlo,Q_V1))+1 do i=1, DIMVV iup(i)=0 end do do tup=1, sizeup(S_H) iup(qup(tup,Q_V1))=iup(qup(tup,Q_V1))+1 freq=eup(tup)-elo(tlo) if ((dabs(freq).lt.ctlpar(C_FRQLO)) $ .or.(dabs(freq).gt.ctlpar(C_FRQUP))) goto 10 if ((tup.le.tlo).and.(jup.eq.jlo)) goto 10 if ((qup(tup,Q_V1).ne.vup).or. $ (qlo(tlo,Q_V1).ne.vlo)) goto 10 if (jup.gt.jlo) then call calir(ints,tori,jup,jlo,sup,muz, mux, muy $ ,sizeup,qvkup,hrup(1,tup),hiup(1,tup) $ ,sizelo,qvklo,hrlo(1,tlo),hilo(1,tlo)) end if if (jup.eq.jlo) then call caliq(ints,tori,jup,jlo,sup,muz, mux, muy $ ,sizeup,qvkup,hrup(1,tup),hiup(1,tup) $ ,sizelo,qvklo,hrlo(1,tlo),hilo(1,tlo)) end if if (ints.ge.ctlpar(C_INTLM)) then statw=2*jlo+1 if (freq.gt.0.0) then j1 =jup km1=iup(qup(tup,Q_V1))/2 kp1=(2*jup+2-iup(qup(tup,Q_V1)))/2 k1 =qup(tup,Q_K) t1 =tup j2 =jlo km2=ilo(qlo(tlo,Q_V1))/2 kp2=(2*jlo+2-ilo(qlo(tlo,Q_V1)))/2 k2 =qlo(tlo,Q_K) t2 =tlo popl=exp(-elo(tlo)/(kghz*temp)) hv =1.0d0-exp(-freq/(kghz*temp)) bolt=statw*popl*hv*ints else j2 =jup km2=iup(qup(tup,Q_V1))/2 kp2=(2*jup+2-iup(qup(tup,Q_V1)))/2 k2 =qup(tup,Q_K) t2 =tup j1 =jlo km1=ilo(qlo(tlo,Q_V1))/2 kp1=(2*jlo+2-ilo(qlo(tlo,Q_V1)))/2 k1 =qlo(tlo,Q_K) t1 =tlo freq=-freq popl=exp(-eup(tup)/(kghz*temp)) hv =1.0d0-exp(-freq/(kghz*temp)) bolt=statw*popl*hv*ints end if if (gamma(sup,0).eq.0) then write(*,'(2(I3,A3,I3,1X),2(A,I2),F13.6,5F9.4,A,I2,2(A,2I3))') $ j1 ,' K ', k1,j2 ,' K ',k2, $ ' S',sup,' V',vup $ ,freq,ints,bolt,statw,popl,hv $ ,' B',bup,' K',k1,k2,' t',t1,t2 else write(*,'(2(3I3,1X),2(A,I2),F13.6,5F9.4,A,I2,2(A,2I3))') $ j1 ,km1, kp1,j2 ,km2, kp2, $ ' S',sup,' V',vup $ ,freq,ints,bolt,statw,popl,hv $ ,' B',bup,' K',k1,k2,' t',t1,t2 end if end if 10 continue end do end do end do end do write(*,*) end do write(*,*) end do end do write(*,*) ' total is the product of Linestr., population-factor,' write(*,*) ' energy factor (hv), and the statistical weight' return end C C------------------------------------------------------------------------------ C C module IAMADJ.FOR C C------------------------------------------------------------------------------ C C---------------------------------------------------------------------- subroutine adjusta(a,npar,adj) C adjust the elements in a for consistence using adj C a is a simple vector implicit none include 'iam_.for' real*8 a(DIMPAR) integer npar,adj C local.. real*8 f(DIMTOP,DIMTOP),pi real*8 tmprho,tmpgam,tmpbet real*8 f0(DIMTOP),lx(DIMTOP),ly(DIMTOP),lz(DIMTOP) real*8 rho(DIMTOP),beta(DIMTOP),agam(DIMTOP) integer itop,ift integer myand external myand pi=dacos(-1.0d0) c write(*,*)'adjusta start',adj,a(P1_F) do itop=1, ctlint(C_NTOP) ift=(itop-1)*DIMPIR C adjust 16: obtain beta and gamma from angx and angz if (myand(adj,16).gt.0) then call reclg(a(P_BJ),a(P_BK),a(P_BD) $ ,tmpbet,tmpgam $ ,a(P1_ANGX+ift),a(P1_ANGZ+ift)) if ((myand(ctlint(C_PRI),AP_PC).ne.0).and.(xde.ge.1)) $ write(*,'(2(A,F12.6))') $ ' adjusting beta from',a(P1_BETA+ift) $ ,' to',tmpbet , $ ' adjusting gamma from',a(P1_GAMA+ift) $ ,' to',tmpgam a(P1_BETA+ift)=tmpbet a(P1_GAMA+ift)=tmpgam end if a(P1_BETA+ift)=dmod(a(P1_BETA+ift),2.0d0*PI) a(P1_GAMA+ift)=dmod(a(P1_GAMA+ift),2.0d0*PI) c write(*,*) ift,a(P1_ANGX+ift),a(P1_ANGZ+ift) c $ ,a(P1_BETA+ift),a(P1_GAMA+ift) C adjust 8 : obtain rho from F0 (= 1 / I_alpha) if (myand(adj,8).gt.0) then call recrho(a(P_BJ),a(P_BK),a(P_BD) $ ,a(P1_BETA+ift),a(P1_GAMA+ift) $ ,a(P1_F0+ift),tmprho) if ((myand(ctlint(C_PRI),AP_PC).ne.0).and.(xde.ge.1)) $ write(*,'(2(A,F12.6))') $ ' adjusting rho from',a(P1_RHO+ift) $ ,' to',tmprho a(P1_RHO+ift)=tmprho end if end do C adjust 1,2, and 4 do itop=1,ctlint(C_NTOP) ift=(itop-1)*DIMPIR rho(itop) =a(P1_RHO+ift) beta(itop) =a(P1_BETA+ift) agam(itop) =a(P1_GAMA+ift) end do call recaff(a(P_BJ),a(P_BK),a(P_BD) $ ,rho,beta,agam $ ,f,f0,lx,ly,lz,ctlint(C_NTOP),DIMTOP $ ,myand(adj,4)) c write(*,*)'adjusta a',adj,a(P1_F) do itop=1,ctlint(C_NTOP) ift=(itop-1)*DIMPIR if (myand(adj,1).gt.0) a(P1_F+ift)=f(itop,itop) if (myand(adj,8).eq.0) a(P1_F0+ift)=f0(itop) if (myand(adj,16).eq.0) then a(P1_ANGZ+ift)=acos(lz(itop)) if ((lx(itop)**2+ly(itop)**2).gt.(0.0d0)) then a(P1_ANGX+ift)=sign(1.0d0,ly(itop))*acos(lx(itop) $ /sqrt(lx(itop)**2+ly(itop)**2)) else a(P1_ANGX+ift)=0.0d0 end if end if a(P1_ANGX+ift)=dmod(a(P1_ANGX+ift),2.0d0*PI) a(P1_ANGZ+ift)=dmod(a(P1_ANGZ+ift),2.0d0*PI) end do if (myand(adj,2).gt.0) a(P_FF)=f(1,2) return end C---------------------------------------------------------------------- subroutine recalf(bj,bk,bd,rho,beta,gamma,f0,lx,ly,lz) C calc. f0 and angles (lx ly lz) from IAM-Parameters rho beta gamma implicit none real*8 bj,bk,bd,f0,rho,beta,gamma,lx,ly,lz real*8 bx,by,bz,rhox,rhoy,rhoz bx=bj+bd by=bj-bd bz=bj+bk if (rho.eq.0.0) stop 'ERROR: rho (or F0) can not be zero' rhoz=cos(beta)*rho rhox=sin(beta)*cos(gamma)*rho rhoy=sin(beta)*sin(gamma)*rho f0=1.0/sqrt((rhox/bx)**2+(rhoy/by)**2+(rhoz/bz)**2) lx=rhox*f0/bx ly=rhoy*f0/by lz=rhoz*f0/bz C r=1-bz/f0*lz**2-bx/f0*lx**2-by/f0*ly**2 C f=f0/r return end C---------------------------------------------------------------------- subroutine recrho(bj,bk,bd,beta,gamma,f0,rho) C calc rho from F0, beta and gamma implicit none real*8 bj,bk,bd,f0,rho,beta,gamma real*8 bx,by,bz,rz,ry,rx if (f0.eq.0.0) stop 'ERROR in recrho: F0 = 0' bx=bj+bd by=bj-bd bz=bj+bk rz=cos(beta)*f0/bz rx=sin(beta)*cos(gamma)*f0/bx ry=sin(beta)*sin(gamma)*f0/by rho=1.0/sqrt(rx**2+ry**2+rz**2) return end C---------------------------------------------------------------------- subroutine reclg(bj,bk,bd,beta,gamma,ax,az) C calc beta, and gamma from ax,az implicit none real*8 bj,bk,bd,beta,gamma,lx,ly,lz,ax,az real*8 bx,by,bz,rz,ry,rx,ac lz=cos(az) lx=sin(az)*cos(ax) ly=sin(az)*sin(ax) bx=bj+bd by=bj-bd bz=bj+bk rx=lx*bx ry=ly*by rz=lz*bz beta=acos(rz/sqrt(rx**2+ry**2+rz**2)) ac=rx/sqrt(rx**2+ry**2) ac=min(ac,1.0d0) ac=max(ac,-1.0d0) gamma=sign(1.0d0,ry)*acos(ac) return end C---------------------------------------------------------------------- subroutine recaff(bj,bk,bd,rho,beta,gamma, $ f,f0,lx,ly,lz,ntop,DIMTOP,singl) implicit none integer ntop,DIMTOP real*8 bj,bk,bd real*8 rho(DIMTOP),beta(DIMTOP),gamma(DIMTOP) real*8 f(DIMTOP,DIMTOP) real*8 f0(DIMTOP) real*8 lx(DIMTOP),ly(DIMTOP),lz(DIMTOP) C local .. real*8 bx,by,bz,fmat(3,3),fimat(3,3) real*8 d(3),e(3) integer itp1,itp2,singl if (DIMTOP.gt.3) stop ' Dimension Error in recaff !' bx=bj+bd by=bj-bd bz=bj+bk do itp1=1,ntop call recalf(bj,bk,bd,rho(itp1),beta(itp1),gamma(itp1) $ ,f0(itp1),lx(itp1),ly(itp1),lz(itp1)) end do do itp1=1,ntop do itp2=1,ntop fmat(itp1,itp2)=0.0 end do end do do itp1=1,ntop fmat(itp1,itp1)=(f0(itp1) $ -bx*lx(itp1)**2 $ -by*ly(itp1)**2 $ -bz*lz(itp1)**2)/(f0(itp1)**2) end do if (singl.eq.0) then do itp1=1,ntop do itp2=itp1+1,ntop fmat(itp1,itp2)= $ -(lx(itp1)*lx(itp2)*bx $ +ly(itp1)*ly(itp2)*by $ +lz(itp1)*lz(itp2)*bz)/(f0(itp1)*f0(itp2)) fmat(itp2,itp1)=fmat(itp1,itp2) end do end do end if C write(*,*)'pre-Inverse' C do itp1=1, ntop C write(*,*) (fmat(itp1,itp2),itp2=1,ntop) C end do call svdsydc(fmat,d,e,ntop,3) call svdsyinv(fmat,d,ntop,3,fimat) do itp1=1,ntop do itp2=1,ntop f(itp1,itp2)=fimat(itp1,itp2) end do end do C write(*,*)'Inverse' C do itp1=1, ntop C write(*,*) (f(itp1,itp2),itp2=1,ntop) C end do return end C C------------------------------------------------------------------------------ C C module IAMM.FOR C C------------------------------------------------------------------------------ C C---------------------------------------------------------------------- subroutine calcm(sigma,h,evalv,ovv,mvec $ ,am,qmv,ifit,k,maxm,minv,sizev) C calculation of the eigenvalues of one matrix with specified sigma C the evalues are put in the field of evalv(1..sizev) C the matrix_elements are in ovv(1..sizev,1..sizev,x) implicit none include 'iam_.for' integer sigma,k,maxm,minv,sizev real*8 h(DIMTOT,DIMTOT),evalv(DIMV),ovv(DIMV,DIMV,DIMOVV) real*8 am(DIMPM) real*8 mvec(DIMM,DIMV) integer qmv(DIMV),ifit(DIMOVV) C work real*8 e(DIMTOT),d(DIMTOT) real*8 ao(DIMOVV) integer qm(DIMTOT) integer sizem,ir,ic,i,ierr sizem=2*maxm+1 if (sizem.lt.sizev+minv) stop 'ERROR: size m < size v' if (sizev.gt.DIMV) stop 'ERROR: sizev > DIMV in calcm' if (sizem.gt.DIMM) stop 'ERROR: sizem > DIMM in calcm' if (sizem.gt.DIMTOT) stop 'ERROR: sizem > DIMTOT in calcm' do i=1, DIMPM ao(i)=am(i) end do c write(*,*) (am(ic),ic=1,DIMPM) c write(*,*) (qmv(ic),ic=1,DIMV) call buildm(sigma,h,am,ao,qm,sizem,k) c write(*,'(2I3,40F12.4)') k,sigma,(h(ic,ic),ic=1,sizem) call hdiag(DIMTOT,sizem,h,d,e,ierr) if (ierr.ne.0) then write(0,'(A,3I3)') 'Error: HDIAG in CALCM: IERR =',ierr,k,sigma end if call eigsrt(d,h,sizem,DIMTOT) call phasem(sigma,h,d,qm,sizem,sizev,minv,qmv,k) call assgnm(sigma,h,d,qm,sizem,sizev,minv,qmv,k) call calovv(ifit,am,qm,sizem,sizev,minv,h,ovv,k) do ir=1, sizev evalv(ir)=d(ir+minv-1) C ovv(ir,ir,PM_E)=d(ir+minv-1) end do do ir=1, sizem do ic=1, sizev mvec(ir,ic)=h(ir,ic+minv-1) end do end do return end C---------------------------------------------------------------------- subroutine buildm(sigma,h,am,ao,qm,sizem,k) implicit none include 'iam_.for' integer sigma, qm(DIMTOT), sizem, k real*8 h(DIMTOT,DIMTOT) real*8 am(DIMPM),ao(DIMOVV) C work integer im,iv,mm real*8 v(DIMTOT), vo(DIMTOT) if (sizem.gt.DIMTOT) stop 'Dimension Error in BUILDM' C initialize the quantum no qm mm=sizem/2 do im=1, sizem qm(im)=ctlint(C_NFOLD)*(im-mm-1)+sigma end do do im=DIMPM+1, DIMOVV ao(im)=0.0 end do ao(PM_RHO)=0.0 do im=1, sizem do iv=1, sizem v(iv)=0.0 vo(iv)=0.0 end do v(im)=1.0 call multm(v,sizem,am,ao,qm,vo,k,0) do iv=1, sizem h(im,iv)=vo(iv) end do end do return end C---------------------------------------------------------------------- subroutine multm(v,sizem,am,ao,qm,vo,k,ip) implicit none include 'iam_.for' integer sizem,k,ip integer qm(DIMTOT) real*8 v(DIMTOT), vo(DIMTOT) real*8 am(DIMPM), ao(DIMOVV) C work real*8 dm,t,dk,dm1 integer im,off if (sizem.gt.DIMTOT) stop 'Dimension Error in MULTM' C diagonal m/m dk=dble(k) do im=1, sizem dm=dble(qm(im)) t = $ + ao(PM_F ) * (dm - am(PM_RHO)*dk)**2 $ + ao(PM_VN1) * 0.5 $ + ao(PM_VN2) * 0.5 $ + ao(PM_RHO) * 2.0*am(PM_F)*dk*(am(PM_RHO)*dk-dm) c $ +4.0*am(PM_DPI4)*dk*(am(PM_RHO)*dk-dm)**3) $ + ao(PM_PI ) * (dm - am(PM_RHO)*dk) c $ + ao(PM_DPI4)* (dm - am(PM_RHO)*dk)**4 c $ + ao(PM_M) * dm c $ - ao(PM_RK) * am(PM_RHO)*dk vo(im)=vo(im)+v(im)*t end do C off diagonal m/m+1 if ((ao(PM_VN1).ne.0.0)) then off=1 do im=1, sizem-off t= - ao(PM_VN1)*0.25 vo(im) =vo(im )+v(im+off)*t vo(im+off)=vo(im+off)+v(im )*t end do end if C off diagonal m/m+2 if ((ao(PM_VN2).ne.0.0)) then off=2 do im=1, sizem-off t= - ao(PM_VN2)*0.25 vo(im) =vo(im )+v(im+off)*t vo(im+off)=vo(im+off)+v(im )*t end do end if C off diagonal m/m+1 i * (sin n alpha) if ((ao(PM_SIN).ne.0.0)) then off=1 do im=1, sizem-off t= ao(PM_SIN)*0.5 vo(im) =vo(im )-v(im+off)*t vo(im+off)=vo(im+off)+v(im )*t end do end if C off diagonal m/m+1 (cos n alpha) if ((ao(PM_COS).ne.0.0)) then off=1 do im=1, sizem-off t= ao(PM_COS)*0.5 vo(im) =vo(im )+v(im+off)*t vo(im+off)=vo(im+off)+v(im )*t end do end if c if ((ao(PM_DPIC).ne.0.0).or.(ao(PM_RHO).ne.0.0)) then c off=1 c dm=dble(qm(im)) c dm1=dble(qm(im+off)) c do im=1, sizem-off c t= ao(PM_DPIC)*((dm-am(PM_RHO)*dk)**2+(dm1-am(PM_RHO)*dk)**2) c $ -ao(PM_RHO)*2.0*am(PM_DPIC)*dk* c $ ((dm-am(PM_RHO)*dk)+(dm1-am(PM_RHO)*dk)) c vo(im) =vo(im )+v(im+off)*t c vo(im+off)=vo(im+off)+v(im )*t c end do c end if return end C---------------------------------------------------------------------- subroutine assgnm(sigma,h,eval,qm,sizem,sizev,minv,qmv,k) implicit none include 'iam_.for' real*8 h(DIMTOT,DIMTOT),eval(DIMTOT) integer sigma,qm(DIMTOT),qmv(DIMV) integer sizem, sizev,k,minv C work integer icc integer bestm(DIMV), scndm(DIMV) real*8 besth(DIMV), scndh(DIMV) real*8 difh,degn,sym if (sizem.gt.DIMTOT) stop ' ERROR: DIM 2M1 exceeded' degn=2.0d-4 call maxof(h,DIMTOT,DIMTOT,sizem,1,minv+sizev-1,bestm,scndm, $ besth,scndh) do icc=1, sizev difh=1.0 if (sizem.gt.1) then difh=(dabs(besth(icc))-dabs(scndh(icc))) end if if (difh.lt.degn) then C if ((besth(icc).lt.0.0d0).and.(scndh(icc).lt.0.0d0)) then C do im=1, sizem C h(im,icc)=-h(im,icc) C end do C end if sym=dsign(10.0d0,besth(icc)*scndh(icc)) qmv(icc)=isign(qm(bestm(icc)),int(sym)) else C if (besth(icc).lt.0.0d0) then C do im=1, sizem C h(im,icc)=-h(im,icc) C end do C end if qmv(icc)=qm(bestm(icc)) end if end do return end C---------------------------------------------------------------------- subroutine phasem(sigma,h,eval,qm,sizem,sizev,minv,qmv,k) implicit none include 'iam_.for' real*8 h(DIMTOT,DIMTOT),eval(DIMTOT) integer sigma,qm(DIMTOT),qmv(DIMV) integer sizem, sizev,k, minv C work integer iv,im,ilim real*8 sum,maxh,sigsn if (sizem.gt.DIMTOT) stop ' ERROR: DIM 2M1 exceeded' if ((k.ne.0).or.(sigma.ne.0)) then ilim=sizem else ilim=sizem/2+1 end if sigsn=1.0 if (sigma.lt.0) sigsn=-1.0 C do iv=minv, minv+sizev-1 iv=1 maxh=0.0 do im=1,ilim if (abs(maxh).lt.abs(h(im,iv))) then maxh=h(im,iv) end if end do if (maxh.lt.0.0) then do im=1,sizem h(im,iv)=-h(im,iv) end do end if C end do C calculate < v | p | (v+1) > C sigma=0,1

.gt. 0 C sigma=-1

.lt. 0 C do iv=1,sizev-1 C do iv=minv,minv+sizev-2 do iv=1,minv+sizev-2 sum=0.0 do im=1,sizem sum=sum+h(im,iv)*h(im,iv+1)*qm(im) end do sum=sum*sigsn if (sum.lt.0.0) then do im=1,sizem h(im,iv+1)=-h(im,iv+1) end do end if end do return end C---------------------------------------------------------------------- subroutine calovv(ifit,am,qm,sizem,sizev,minv,h,ovv,k) implicit none include 'iam_.for' integer sizem,sizev,k,minv integer qm(DIMTOT),ifit(DIMOVV) real*8 am(DIMPM),h(DIMTOT,DIMTOT),ovv(DIMV,DIMV,DIMOVV) C work real*8 vo(DIMTOT),da(DIMOVV),t(DIMTOT,DIMV) integer i,it,im,ir,ic if (sizem.gt.DIMTOT) stop 'Dimension Error in CALOVV' C clear ovv do ir=1, sizev do ic=1, sizev do i=1, DIMOVV ovv(ir,ic,i)=0.0 end do end do end do do it=1, DIMOVV if (it.eq.PM_PI2) goto 99 do i=1,DIMOVV da(i)=0.0 end do da(it)=1.0 do i=1, sizev do im=1, sizem vo(im)=0.0 end do call multm(h(1,i+minv-1),sizem,am,da,qm,vo,k,1) do im=1, sizem t(im,i)=vo(im) end do end do do ir=1, sizev do ic=1, sizev do im=1, sizem ovv(ir,ic,it)=ovv(ir,ic,it)+h(im,ir+minv-1)*t(im,ic) end do end do end do end do return c -------- 99 continue do ir=1, sizev do ic=1, sizev ovv(ir,ic,it)=ovv(ir,ic,PM_PI)**2 end do end do return end C C------------------------------------------------------------------------------ C C module IAMV.FOR C C------------------------------------------------------------------------------ C C---------------------------------------------------------------------- subroutine calvjk(j,gam,f,ib,h,evalv,ovv,rotm,rott,tori $ ,a,qmv,ifit,dfit,palc,pali,npar,fistat,evh) C calculation of the eigenvalues of one matrix with specified j,f,gam C the evalues are put in the field of dnv(1..ndata,Q_ENG,Q_UP/LO) C the deviations DE/DPi in dnv(1..ndata,DQ_ENG,Q_UP/LO(i)) C fistat = 0 for regular calculation of Eigenvalues C fistat > 0 Eigenvalues for differential quotient implicit none include 'iam_.for' integer j, gam, f, ib, npar, fistat real*8 h(DIMTOT,DIMTOT),evh(DIMTOT) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) real*8 a(DIMPAR) real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) integer qmv(DIMV),ifit(DIMPAR),dfit(DIMFIT) C quantum numbers integer qvk(DIMTOT,Q_K:Q_V+DIMTOP), qmk(DIMTOT,DIMQLP) integer qv(DIMTOT) C work real*8 e(DIMTOT),e2(DIMTOT),tau(2,DIMTOT) real*8 zr(DIMTOT,DIMTOT),zi(DIMTOT,DIMTOT) real*8 dedp(DIMPAR) integer id,ie,i,iv,ik,itop,ivr,ivc,ir,ic,it1,it2,ikr,ikc integer eused(DIMTOT), usert,ierr integer ruse(DIMVV,DIMVV,DIMTOP) character*30 fmtstr character*4 fnpre character*6 fnpost real*8 tt logical masave logical complex integer myand external myand integer mclock,t1,t2 external mclock masave=.false. if (ctlint(C_EVAL).gt.3) masave=.true. if ((myand(ctlint(C_PRI),AP_ST).ne.0).and.(xde.ge.1)) $ write(*,'(A,5I3)') $ 'starting with J,S,B,F Fit_stat=',J,gam,ib,f,fistat fnpre='xiam' if (gam.eq.0) ctlint(C_NTOP)=0 complex=.false. do i=1,ctlint(C_NTOP) if (a(PI_GAMA+(i-1)*DIMPIR+DIMPRR).ne.0.0) complex=.true. end do usert = 1 if ((a(P_QYZ).ne.0.0).or.(a(P_QXY).ne.0.0)) complex=.true. size(S_K)=2*j+1 C initialize the quantum no.s qvk i=0 do iv=1, size(S_VV) do ik=1, size(S_K) i=i+1 qvk(i,Q_K) =ik-j-1 qv(i)=iv do itop=1, ctlint(C_NTOP) qvk(i,Q_V+itop)=qvv(iv,itop,ib) end do end do end do size(S_H)=i do ivr=1, size(S_H) do ivc=1, size(S_H) h(ivr,ivc)=0.0 end do end do do itop=1, ctlint(C_NTOP) do ivr=1, size(S_VV) do ivc=1, size(S_VV) ruse(ivr,ivc,itop)=1 end do end do end do do it1=1, ctlint(C_NTOP) do it2=1, ctlint(C_NTOP) if (it2.ne.it1) then do ivr=1, size(S_VV) do ivc=1, size(S_VV) if (qvv(ivr,it2,ib).ne.qvv(ivc,it2,ib)) then ruse(ivr,ivc,it1)=0 end if end do end do end if end do end do if ((myand(ctlint(C_PRI),AP_ST).ne.0).and.(xde.ge.1)) then write(fmtstr,'(A,I1,A,I2,A)') '(',ctlint(C_NTOP),'I2,A,' $ ,size(S_VV),'I3)' write(*,*) fmtstr do itop=1, ctlint(C_NTOP) write(*,'(A,I3)') ' ruse array for top', itop do ivr=1, size(S_VV) write(*,fmtstr)(qvv(ivr,it2,ib),it2=1,ctlint(C_NTOP)) $ ,' | ',(ruse(ivr,ivc,itop),ivc=1, size(S_VV)) end do end do end if if (masave) then do itop=1,ctlint(C_NTOP) write(fnpost,'(I1,I1,A,I1,I1)') $ itop,gam,'.j',int(j/10),mod(j,10) open(55,file=fnpre//'t'//fnpost,status='unknown') write(55,*) size(S_V+itop)*size(S_K),0,0 do ivr=1, size(S_V+itop) do ikr=1, size(S_K) write(55,*) $ ((rotm(qvk(ikr,Q_K),qvk(ikc,Q_K),1,itop) $ *tori(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc $ ,gamma(gam,itop),itop) $ ,ikc=1,size(S_K)) $ ,ivc=1, size(S_V+itop)) end do end do close(55) end do do itop=1,ctlint(C_NTOP) write(fnpost,'(I1,I1,A,I1,I1)') $ itop,gam,'.j',int(j/10),mod(j,10) open(56,file=fnpre//'p'//fnpost,status='unknown') write(56,*) size(S_V+itop)*size(S_K),0,0 do ivr=1, size(S_V+itop) do ikr=1, size(S_K) do ivc=1, size(S_V+itop) do ikc=1, size(S_K) if (qvk(ikr,Q_K).eq.qvk(ikc,Q_K)) then write(56,'(D22.14,$)') $ ovv(ivr,ivc,PM_PI,gamma(gam,itop) $ ,qvk(ikr,Q_K),itop) else write(56,'(D22.14,$)') 0.0 end if end do end do write(56,*) end do end do close(56) end do do it1=1,ctlint(C_NTOP) write(fnpost,'(I1,I1,A,I1,I1)') $ it1,gam,'.j',int(j/10),mod(j,10) open(55,file=fnpre//'r'//fnpost,status='unknown') write(55,*) size(S_H),0,0 do ir=1, size(S_H) do ic=1, size(S_H) tt=1.0d0 do it2=1,ctlint(C_NTOP) tt=tt*tori(qvk(ir,Q_K), qvk(ic,Q_K), $ qvk(ir,Q_V+it2),qvk(ic,Q_V+it2), $ gamma(gam,it2),it2) end do write(55,'(D22.14,$)') $ rotm(qvk(ikr,Q_K),qvk(ikc,Q_K),1,it1) $ *tt end do write(55,*) end do close(55) end do end if if (gam.ne.0) then C t1=mclock() C build the rotated D^{T} E_{K v \sigma} D C if (usert.eq.0) then C call bld1vjk(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori) C else call bld2vjk(j,gam,f $ ,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori,complex) C end if c write(*,*) 'bld2vjk',mclock()-t1 else if (size(S_VV).gt.1) stop ' size vv > 1 for rigid rotor!' end if C t1=mclock() call addrig(j,gam,f $ ,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori,complex) c write(*,*) 'addrig',mclock()-t1 if (myand(ctlint(C_PRI),AP_MH).ne.0) then write(*,*) ' H_tot ' do ir=1, size(S_H) do ic=1, size(S_H) if (abs(h(ir,ic)).lt.1000.0) then write(*,'(F10.5,$)') h(ir,ic) else write(*,'(F10.2,$)') h(ir,ic) end if end do write(*,*) end do write(*,*) end if C--- C t1=mclock() if (complex) then do ir=1, size(S_H) do ic=1, size(S_H) zr(ir,ic)=0.0 end do zr(ir,ir)=1.0 end do ierr=0 call htrid3 (DIMTOT,size(s_h),h,evh,e,e2,tau) call tql2 (DIMTOT,size(s_h),evh,e,zr,ierr) if (ierr.ne.0) then write (*,'(a,i5)') 'Error in tql2 ',ierr stop endif call htrib3 (DIMTOT,size(S_H),h,tau,size(S_H),zr,zi) C sort eigenvalues in **ascending** order call heigsrt(evh,zr,zi,size(S_H),DIMTOT) do i=1, size(S_H) do ie=1, size(S_H) h(i,ie)=sign(dsqrt(zr(i,ie)**2+zi(i,ie)**2) $ ,zr(i,ie)+zi(i,ie)) end do end do else write(fnpost,'(A,I1,A,I1,I1)') $ 's',gam,'.j',int(j/10),mod(j,10) if (masave) then open(55,file=fnpre//'h'//fnpost,status='unknown') write(55,*) size(S_H),j,gam do i=1, size(S_H) write(55,*)(h(i,ie),ie=1,size(S_H)) end do close(55) end if call hdiag(DIMTOT,size(S_H),h,evh,e,ierr) if (ierr.ne.0) then write (*,'(a,i5)') 'Error in hdiag ',ierr stop endif C sort eigenvalues in **ascending** order call eigsrt(evh,h,size(S_H),DIMTOT) C--- if (masave) then open(55,file=fnpre//'e'//fnpost,status='unknown') write(55,*) size(S_H),j,gam do i=1, size(S_H) write(55,*) evh(i) end do close(55) C--- open(55,file=fnpre//'v'//fnpost,status='unknown') write(55,*) size(S_H),j,gam do i=1, size(S_H) write(55,*)(h(i,ie),ie=1,size(S_H)) end do close(55) end if do i=1, size(S_H) do ie=1, size(S_H) zi(i,ie)=0.0 zr(i,ie)=h(i,ie) end do end do end if c write(*,*) 'diag ',mclock()-t1 if (myand(ctlint(C_PRI),AP_EH).ne.0) then write(*,*) ' Eigenvectors' do ir=1, size(S_H) do ic=1, size(S_H) if (h(ir,ic).lt.1000.0) then write(*,'(2F10.6,A,$)') zr(ir,ic),zi(ir,ic),'; ' else write(*,'(2F10.2,A,$)') zr(ir,ic),zi(ir,ic),'; ' end if end do write(*,*) end do write(*,*) write(*,*) ' Eigenvalues' do ir=1, size(S_H) write(*,'(F20.8,A,$)') evh(ir),'; ' end do write(*,*) end if call assgn(j,gam,f,ib,h,evh,qvk,qmv,qmk,qv,fistat) C save the eigenvalues call esave(j,gam,f,ib,qmk,evh,eused) C write the eigenvalues and vectors to disk if ((ctlint(C_INTS).gt.0).and.(fistat.eq.0)) then call wrvec(zr,zi,evh,j,gam,f,ib,qvk,qmk) end if C calculate the deviation dedp C if (usert.eq.0) then complex=.true. if (complex) then do id=1, size(S_H) if ((eused(id).ne.0).or.(ctlint(C_DFRQ).ne.0)) then do ie=1, size(S_H) e(ie)=zr(ie,id) e2(ie)=zi(ie,id) end do call hcaldev(e,e2,j,gam,f,ib,ifit,npar $ ,qvk,ruse,a,dedp,evalv,ovv,rotm,tori) call devsave(j,gam,f,ib,qmk(id,Q_T) $ ,ifit,dfit,dedp,palc,pali) end if end do c else c do id=1, size(S_H) c if ((eused(id).ne.0).or.(ctlint(C_DFRQ).ne.0)) then c do ie=1, size(S_H) c e(ie)=zr(ie,id) c end do c call caldev(e,j,gam,f,ifit,npar c $ ,qvk,ruse,a,dedp,evalv,ovv,rotm,tori) c call devsave(j,gam,f,qmk(id,Q_T),ifit,dfit,dedp,palc) c end if c end do end if return end C---------------------------------------------------------------------- subroutine addrig(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,complex) implicit none include 'iam_.for' integer j,gam,f integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) logical complex C work real*8 vr(DIMTOT), vi(DIMTOT), vor(DIMTOT), voi(DIMTOT) integer i,iv do i =1, size(S_H) do iv=1, size(S_H) vr(iv)=0.0 vor(iv)=0.0 vi(iv)=0.0 voi(iv)=0.0 end do vr(i )=1.0d0 call hmulthrr(j,gam,f $ ,qvk,ruse,a,vr,vi,vor,voi,evalv,ovv,rotm,tori,0,0) do iv=1, i h(i,iv)=h(i,iv)+vor(iv) end do do iv=i+1, size(S_H) h(i,iv)=h(i,iv)+voi(iv) end do end do return end C---------------------------------------------------------------------- subroutine hcaldev(vr,vi,j,gam,f,ib,ifit,npar $ ,qvk,ruse,a,dedp,evalv,ovv,rotm,tori) C (hermitian) calculation of the < J tau | Op | J tau' > implicit none include 'iam_.for' real*8 vi(DIMTOT),vr(DIMTOT) integer j,gam,f,npar,ib integer qvk(DIMTOT,Q_K:Q_V1+DIMTOP-1), ifit(DIMPAR) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 a(DIMPAR),dedp(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work real*8 da(DIMPAR) real*8 vor(DIMTOT),voi(DIMTOT) integer i,ifs do ifs=1, DIMPRR dedp(ifs)=0.0 end do do ifs=1, DIMPRR if (ifit(ifs).ne.0) then do i=1,DIMPRR da(i)=0.0 end do da(ifs)=1.0 do i=1, size(S_H) vor(i)=0.0 voi(i)=0.0 end do call hmulthrr(j,gam,f $ ,qvk,ruse,da,vr,vi,vor,voi,evalv,ovv,rotm,tori,ifs,0) do i=1, size(S_H) dedp(ifs)=dedp(ifs)+vor(i)*vr(i)+voi(i)*vi(i) end do end if end do return end C---------------------------------------------------------------------- subroutine hmulthrr(j,gam,f $ ,qvk,ruse,a,vr,vi,vor,voi,evalv,ovv,rotm,tori,ifs,it) C multiply the complex vector vr,vi by the rigid part of the C Hamilton matrix, yielding vor,voi implicit none include 'iam_.for' integer j,gam,f,ifs,it integer qvk(DIMTOT,Q_K:Q_V1+DIMTOP-1) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 a(DIMPAR) real*8 vr(DIMTOT),vor(DIMTOT),vi(DIMTOT),voi(DIMTOT) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work real*8 dk,dj,djj1,dff,t,t1,t2,djjc real*8 e1,df,dff1,di,dii1,dg real*8 adelk,adelj,ah2,ah3,ahk,ar6,ahjk,ahj integer ik,ir,ic,ivr,ivc,itop integer off,voff integer myand external myand if (size(S_H).gt.DIMTOT) stop 'Dimension Error in HMULTHRR' dj=dble(j) djj1=dj*(dj+1.0) e1=0.0 C djjc is used for spin rotation coupling to prevent a division by zero C for J=0 djjc=1.0 if ((ctlint(C_SPIN).ne.0).and.(j.gt.0).and.(f.ge.0)) then di=dble(ctlint(C_SPIN))/2.0d0 dii1=di*(di+1.0) df=dble(f)/2.0d0 dff1=df*(df+1.0) djjc=djj1 dg=dff1-dii1-djj1 if (ctlint(C_SPIN).gt.1) then e1= (0.75*dg*(dg+1.0)-dii1*djj1) $ /(2.0*di*(2.0*di-1.0)*djj1*(2.0*dj-1.0)*(2.0*dj+3.0)) else e1=0.0 end if end if C the centrifugal distortion parameters C Watson A if (ctlint(C_RED).eq.0) then adelj=a(P_DJD) adelk=a(P_DKD) ar6 =0.0d0 ahj =a(P_HJD) ahjk =a(P_HJKD) ah2 =0.0d0 ahk =a(P_HKD) ah3 =0.0d0 end if C Watson S if (ctlint(C_RED).eq.1) then adelj=-a(P_DJD) adelk=0.0d0 ar6 =a(P_DKD) ahj =a(P_HJD) ahjk =0.0d0 ah2 =a(P_HJKD) ahk =0.0d0 ah3 =a(P_HKD) end if C van Eijck / Typke if (ctlint(C_RED).eq.2) then adelj=a(P_DJD) adelk=0.0d0 ar6 =a(P_DKD) ahj =0.5d0*a(P_HJD) ahjk =0.0d0 ah2 =0.25d0*a(P_HJKD) ahk =0.0d0 ah3 =0.125d0*a(P_HKD) end if if ( (a(P_BJ) .ne.0.0).or.(a(P_BK) .ne.0.0).or. $ (a(P_DJ) .ne.0.0).or.(a(P_DJK).ne.0.0).or. $ (a(P_DK) .ne.0.0).or.(a(P_HJ ).ne.0.0).or. $ (a(P_HJK).ne.0.0).or.(a(P_HKJ).ne.0.0).or. $ (a(P_HK) .ne.0.0).or.(a(P_QZ) .ne.0.0).or. $ (a(P_CP) .ne.0.0).or.(a(P_CZ) .ne.0.0))then do ik=1, size(S_K) dk=dble(qvk(ik,Q_K)) t= a(P_BJ) *djj1 $ + a(P_BK) *dk*dk $ - a(P_DJ) *djj1**2 $ - a(P_DJK)*djj1*dk**2 $ - a(P_DK) *dk**4 $ + a(P_HJ) *djj1**3 $ + a(P_HJK)*(djj1**2)*(dk**2) $ + a(P_HKJ)*djj1*(dk**4) $ + a(P_HK) *dk**6 $ + a(P_QZ) * e1 * (3.0*(dk**2)-djj1) $ + a(P_CP) * 0.5*dg*(1.0-dk*dk/djjc) $ + a(P_CZ) * 0.5*dg*dk*dk/djjc do ivc=1, size(S_VV) ic=ik+size(S_K)*(ivc-1) vor(ic)=vor(ic)+vr(ic)*t voi(ic)=voi(ic)+vi(ic)*t end do end do end if if (a(P_PZ) .ne.0.0) then do ik=1, size(S_K) dk=dble(qvk(ik,Q_K)) t= a(P_PZ) *dk do ivc=1, size(S_VV) ic=ik+size(S_K)*(ivc-1) vor(ic)=vor(ic)+vr(ic)*t voi(ic)=voi(ic)+vi(ic)*t end do end do end if if ((ctlint(C_RED).eq.2).and. $ ((ar6.ne.0.0d0).or.(ah2.ne.0.0d0))) then do ik=1, size(S_K) dk=dble(qvk(ik,Q_K)) dff= (djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0)) $ +(djj1-dk*(dk-1.0))*(djj1-(dk-1.0)*(dk-2.0)) $ -2.0d0*(djj1-dk**2)**2 t= (ar6 + ah2*djj1)*dff do ivc=1, size(S_VV) ic=ik+size(S_K)*(ivc-1) vor(ic)=vor(ic)+vr(ic)*t voi(ic)=voi(ic)+vi(ic)*t end do end do end if C real off diagonal k/k+1 if ((a(P_QXZ).ne.0.0)) then off=1 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=(1.0+2.0*dk)*dsqrt(djj1-dk*(dk+1.0)) t= e1* a(P_QXZ) *dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,0) end do end if C real off diagonal k/k+1 if ((a(P_PX).ne.0.0)) then off=1 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=0.5d0*dsqrt(djj1-dk*(dk+1.0)) t= a(P_PX) *dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,0) end do end if C imaginaer off diagonal k/k+1 if ((a(P_QYZ).ne.0.0)) then off=1 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=(1.0+2.0*dk)*dsqrt(djj1-dk*(dk+1.0)) t= e1* a(P_QYZ) *dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,1) end do end if C imaginaer off diagonal k/k+1 if ((a(P_PY).ne.0.0)) then off=1 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=0.5d0*dsqrt(djj1-dk*(dk+1.0)) t= a(P_PY) *dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,1) end do end if C real off diagonal k/k+2 if ((a(P_BD).ne.0.0).or.(adelj.ne.0.0).or. $ (adelk.ne.0.0).or.(a(P_QD).ne.0.0).or. $ (ahj.ne.0.0).or.(a(P_CD).ne.0.0).or. $ (ahjk.ne.0.0).or.(ahk.ne.0.0)) then off=2 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=0.5d0*dsqrt((djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0))) t= a(P_BD) *dff $ - adelj *2.0d0*dff*djj1 $ - adelk *dff*((dk+2.0d0)**2+dk**2) $ + ahj*2.0d0*dff*djj1**2 $ + ahjk*dff*((dk+2.0d0)**2+dk**2)*djj1 $ + ahk*dff*((dk+2.0d0)**4+dk**4) $ + a(P_QD) *dff*e1 $ + a(P_CD) *0.5*dg*dff/djjc call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,0) end do end if if ((ctlint(C_RED).eq.2).and.(ah3.ne.0.0d0)) then off=2 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=dsqrt((djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0))) $ *((djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0)) $ +(djj1-dk*(dk-1.0))*(djj1-(dk-1.0)*(dk-2.0)) $ +(djj1-(dk+2.0)*(dk+3.0))*(djj1-(dk+3.0)*(dk+4.0))) t= ah3*dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,0) end do end if C imaginaer off diagonal k/k+2 if ((a(P_QXY).ne.0.0)) then off=2 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=0.5d0*dsqrt((djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0))) t= $ + a(P_QXY)*dff*e1*2.0 call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,1) end do end if C Watson S off diagonal k/k+4 (evtl. change dff) if ((ar6.ne.0.0d0).or.(ah2.ne.0.0d0)) then off=4 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=dsqrt((djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0)) $ *(djj1-(dk+2.0)*(dk+3.0))*(djj1-(dk+3.0)*(dk+4.0))) t= $ ar6*dff + ah2*djj1*dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,0) end do end if C Watson S off diagonal k/k+6 if (ah3.ne.0.0d0) then off=6 do ik=1, size(S_K)-off dk=dble(qvk(ik,Q_K)) dff=dsqrt((djj1-dk*(dk+1.0))*(djj1-(dk+1.0)*(dk+2.0)) $ *(djj1-(dk+2.0)*(dk+3.0))*(djj1-(dk+3.0)*(dk+4.0)) $ *(djj1-(dk+4.0)*(dk+5.0))*(djj1-(dk+5.0)*(dk+6.0))) t= $ ah3*dff call vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,0) end do end if return end C---------------------------------------------------------------------- subroutine vadd(ik,off,gam,t,tori,qvk,vr,vi,vor,voi,ri) implicit none include 'iam_.for' integer ik,off,gam,ri real*8 t integer qvk(DIMTOT,Q_K:Q_V1+DIMTOP-1) real*8 vr(DIMTOT),vor(DIMTOT),vi(DIMTOT),voi(DIMTOT) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) integer ivr,ivc,ir,ic,itop,voff real*8 t1,t2 integer myand external myand if (myand(ctlint(C_WOODS),32).ne.0) then do ivr=1, size(S_VV) do ivc=1, size(S_VV) ir=(ivr-1)*size(S_K)+ik ic=(ivc-1)*size(S_K)+ik t1=1.0d0 t2=1.0d0 do itop=1, ctlint(C_NTOP) voff=size(S_MINV+itop)-1 t1=t1*tori $ (qvk(ir,Q_K),qvk(ic+off,Q_K) $ ,qvk(ir,Q_V+itop)-voff $ ,qvk(ic+off,Q_V+itop)-voff $ ,gamma(gam,itop),itop) t2=t2*tori $ (qvk(ir+off,Q_K),qvk(ic,Q_K) $ ,qvk(ir+off,Q_V+itop)-voff $ ,qvk(ic,Q_V+itop)-voff $ ,gamma(gam,itop),itop) end do if (ri.eq.0) then vor(ir) =vor(ir )+vr(ic+off)*t*t2 vor(ir+off)=vor(ir+off)+vr(ic )*t*t1 voi(ir) =voi(ir )+vi(ic+off)*t*t2 voi(ir+off)=voi(ir+off)+vi(ic )*t*t1 else vor(ir) =vor(ir )+vi(ic+off)*t*t1 vor(ir+off)=vor(ir+off)-vi(ic )*t*t2 voi(ir) =voi(ir )-vr(ic+off)*t*t1 voi(ir+off)=voi(ir+off)+vr(ic )*t*t2 end if end do end do end if if (myand(ctlint(C_WOODS),32).eq.0) then if (ri.eq.0) then do ivc=1, size(S_VV) ic=ik+size(S_K)*(ivc-1) vor(ic) =vor(ic )+vr(ic+off)*t vor(ic+off)=vor(ic+off)+vr(ic )*t voi(ic) =voi(ic )+vi(ic+off)*t voi(ic+off)=voi(ic+off)+vi(ic )*t end do else do ivc=1, size(S_VV) ic=ik+size(S_K)*(ivc-1) vor(ic) =vor(ic )+vi(ic+off)*t vor(ic+off)=vor(ic+off)-vi(ic )*t voi(ic) =voi(ic )-vr(ic+off)*t voi(ic+off)=voi(ic+off)+vr(ic )*t end do end if end if return end C---------------------------------------------------------------------- subroutine esave(j,gam,f,ib,qmk,eval,eused) implicit none include 'iam_.for' real*8 eval(DIMTOT) integer j,gam,f,ib,qmk(DIMTOT,DIMQLP), eused(DIMTOT) integer il,ie,iq,vok integer use_t,use_tj integer myand,myor external myand,myor do ie=1, size(S_H) eused(ie)=0 end do do iq=1,2 do il=1, ctlint(C_NDATA) if ((j.eq.qlin(il,Q_J,iq)) $ .and. (f.eq.qlin(il,Q_F,iq)) $ .and. (ib.eq.qlin(il,Q_B,iq)) $ .and.(gam.eq.qlin(il,Q_S,iq))) then use_tj=myand(qlin(il,Q_STAT,iq),2) use_t =myand(qlin(il,Q_STAT,iq),4) do ie=1, size(S_H) if ( $ ((qmk(ie,Q_T).eq.qlin(il,Q_T,iq)) $ .and.(use_t.ne.0)) $ .or. $ ((qmk(ie,Q_TJ).eq.qlin(il,Q_TJ,iq)) $ .and.(use_tj.ne.0)) $ .or. $ ((qmk(ie,Q_K).eq.qlin(il,Q_K,iq)) $ .and.(use_t.eq.0).and.(use_tj.eq.0)) $ ) then vok=0 if ((qmk(ie,Q_V1).eq.qlin(il,Q_V1,iq)).or.(use_t.ne.0)) $ vok=ctlint(C_NTOP) if ((myand(qlin(il,Q_STAT,iq),1).eq.0) $ .and.(vok.eq.ctlint(C_NTOP))) then dnv(il,NV_ENG,iq)=eval(ie) qlin(il,Q_STAT,iq)=myor(qlin(il,Q_STAT,iq),1) qlin(il,Q_TJ,iq)=qmk(ie,Q_TJ) qlin(il,Q_T ,iq)=qmk(ie,Q_T ) qlin(il,Q_K, iq)=qmk(ie,Q_K ) qlin(il,Q_K2,iq)=qmk(ie,Q_K2) qlin(il,Q_GK,iq)=qmk(ie,Q_GK) qlin(il,Q_V1,iq)=qmk(ie,Q_V1) C do itop=1, ctlint(C_NTOP) C qlin(il,Q_V+itop,iq)=qmk(ie,Q_V+itop) C end do if (dln(il,LN_ERR).ne.NOFIT) $ eused(ie)=myor(eused(ie),1) end if end if end do end if end do end do return end C---------------------------------------------------------------------- subroutine devsave(j,gam,f,ib,t,ifit,dfit,dedp,palc,pali) implicit none include 'iam_.for' integer j,gam,f,t,ib,ifit(DIMPAR),dfit(DIMFIT) real*8 dedp(DIMPAR) real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) integer il,ip,iq,ifp do ifp=1, DIMFIT if (dfit(ifp).gt.0) then do il=1, ctlint(C_NDATA) do iq=1,2 if ( (j .eq.qlin(il,Q_J,iq)) $ .and.(f .eq.qlin(il,Q_F,iq)) $ .and.(gam.eq.qlin(il,Q_S,iq)) $ .and.(t .eq.qlin(il,Q_T,iq)) $ .and.(ib .eq.qlin(il,Q_B,iq))) then c do ip=1, DIMPAR c dnv(il,ifp+1,iq)=dnv(il,ifp+1,iq) c $ +palc(ifp,ip)*dedp(ip) c end do do ip=1, pali(ifp,0,1) if (pali(ifp,ip,2).eq.ib) $ dnv(il,ifp+NV_DEF,iq)=dnv(il,ifp+NV_DEF,iq) $ +palc(ifp,ip)*dedp(pali(ifp,ip,1)) end do end if end do end do end if end do return end C---------------------------------------------------------------------- subroutine assgn(j,gam,f,ib,h,eval,qvk,qmv,qmk,qv,fistat) C qv: Quantum No.s from buildvjk ( 1 1 1 1 1 2 2 2 2 2 ..) C qk: Quantum No.s from buildvjk (-2 -1 0 1 2 -2 -1 0 1 2 ..) C qmv: Qunatum No.s from buildm ( 0 3 -3 6 ...) or ( 1 -2 4 -5 ...) implicit none include 'iam_.for' integer j,gam,f,ib,fistat real*8 h(DIMTOT,DIMTOT),eval(DIMTOT) integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer qmv(DIMV),qmk(DIMTOT,DIMQLP),qv(DIMTOT) C work integer i,ik,icc,iv,goodn,itop,ofistat integer i1,i2,iv1,iv2,v1,v2,ik1,ik2 C integer bestk(DIMTOT),bestv(DIMTOT,DIMTOP),bestvv(DIMTOT) integer bestk(DIMTOT),bestvv(DIMTOT) integer bestvk(1) C integer scndk(DIMTOT),scndv(DIMTOT,DIMTOP),scndvv(DIMTOT) integer scndk(DIMTOT),scndvv(DIMTOT) integer scndvk(1) integer qtp(DIMVV),qvp(DIMVV) real*8 besth(DIMTOT),scndh(DIMTOT) real*8 besth1(1),scndh1(1) real*8 ksum(DIM2J1,DIMTOT) C real*8 vsum(DIMV,DIMTOT,DIMTOP) real*8 vsum(DIMVV,DIMTOT) real*8 vvsum(DIMVV,DIMTOT) real*8 difk,difv(DIMTOP),degn character*1 sgnchr logical kdegen data ofistat /0/ C save /xx/ofistat C C integer found(DIMTOT),fp,bestgk,bestfp,k C if (size(S_K).gt.DIM2J1) stop ' ERROR: DIM 2J1 exceeded' degn=2.0d-4 kdegen=.false. do icc=1, size(S_H) qmk(icc,Q_K)=NaQN qmk(icc,Q_T)=NaQN qmk(icc,Q_K2)=NaQN qmk(icc,Q_GK)=-200 end do do iv=1, size(S_VV) qtp(iv)=0 qvp(iv)=0 end do C init the ksum and vsum matrix do ik=1, size(S_K) do i=1, size(S_H) ksum(ik,i)=0.0 end do end do c do itop=1, ctlint(C_NTOP) c do i=1, size(S_H) c do iv=1, size(S_V+itop) c vsum(iv,i,itop)=0.0 c end do c end do c end do do i=1, size(S_H) do iv=1, size(S_VV) vvsum(iv,i)=0.0 vsum(iv,i)=0.0 end do end do if (ctlint(C_NTOP).gt.0) then do i=1, size(S_H) do iv=1, size(S_VV) do ik=1, size(S_K) i1=(iv-1)*size(S_K)+ik vvsum(iv,i)=vvsum(iv,i)+h(i1,i)**2 end do end do end do end if c write(*,'(A,2I3)') ' vvsum: j,gam',j,gam c do i=1, size(S_H) c write(*,'(F10.5,$)') (vvsum(iv,i),iv=1, size(S_VV)) c write(*,*) c end do if (ctlint(C_NTOP).eq.2) then do iv1=1, size(S_VV) v1=qvv(iv1,1,ib) v2=qvv(iv1,2,ib) if (v1.gt.v2) then c vfnd=.false. do iv2=1, size(S_VV) if ((qvv(iv2,2,ib).eq.v1).and.(qvv(iv2,1,ib).eq.v2)) then C vfnd=.true. do ik=1, size(S_K) i1=(iv1-1)*size(S_K)+ik i2=(iv2-1)*size(S_K)+ik do i=1, size(S_H) vsum(iv1,i)=vsum(iv1,i)+0.5*(h(i1,i)+h(i2,i))**2 vsum(iv2,i)=vsum(iv2,i)+0.5*(h(i1,i)-h(i2,i))**2 end do end do do i=1, size(S_H) if (abs(vsum(iv1,i)-vsum(iv2,i)) $ .gt.abs(vvsum(iv1,i)-vvsum(iv2,i))) then vvsum(iv1,i)=vsum(iv1,i) vvsum(iv2,i)=vsum(iv2,i) end if end do end if end do end if end do end if c write(*,'(A,2I3)') ' vsum: j,gam,',j,gam c do i=1, size(S_H) c write(*,'(I2,(F10.5,$))') i, c $ (vsum(iv,i),iv=1, size(S_VV)) c write(*,*) c end do c write(*,'(A,2I3)') ' vvsum: j,gam,',j,gam c do i=1, size(S_H) c write(*,'(I2,F15.5,(F10.5,$))') i, c $ eval(i),(vvsum(iv,i),iv=1, size(S_VV)) c write(*,*) c end do c if ((v1.eq.v2).or.(not.vfnd)) then c do ik=1, size(S_K) c i1=(iv1-1)*size(S_K)+ik c vvsum(iv1,i)=vvsum(iv1,i)+(h(i1,i))**2 c end do c end if c end do c kof=j+1 c do iv=1, size(S_H) c do i=1, size(S_H) c do itop=1, ctlint(C_NTOP) c vsum(qvk(iv,Q_V+itop),i,itop) c $ = vsum(qvk(iv,Q_V+itop),i,itop)+h(iv,i)**2 c end do c ksum(qvk(iv,Q_K)+kof,i)=ksum(qvk(iv,Q_K)+kof,i)+h(iv,i)**2 c vvsum(qv(iv),i) =vvsum(qv(iv),i)+h(iv,i)**2 c end do c end do c kof=j+1 c if (gam.eq.0) then c do i=1, size(S_H) c do ik1=1, size(S_K)/2 c ik2=size(S_K)-ik1+1 c do iv=1, size(S_VV) c i1=(iv-1)*size(S_K)+ik1 c i2=(iv-1)*size(S_K)+ik2 c ksum(ik1,i)=ksum(ik1,i)+0.5d0*(h(i1,i)+h(i2,i))**2 c ksum(ik2,i)=ksum(ik2,i)+0.5d0*(h(i1,i)-h(i2,i))**2 c end do c end do c ik=size(S_K)/2+1 c do iv=1, size(S_VV) c i1=(iv-1)*size(S_K)+ik c ksum(ik,i)=ksum(ik,i)+h(i1,i)**2 c end do c end do c else do i=1, size(S_H) do ik=1, size(S_K) do iv=1, size(S_VV) i1=(iv-1)*size(S_K)+ik ksum(ik,i)=ksum(ik,i)+h(i1,i)**2 end do end do end do c end if call maxof(ksum,DIM2J1,DIMTOT,size(S_K),1,size(S_H),bestk,scndk $ ,besth,scndh) call maxof(vvsum,DIMVV,DIMTOT,size(S_VV) $ ,1,size(S_H),bestvv,scndvv,besth,scndh) c do itop=1, ctlint(C_NTOP) c call maxof(vsum(1,1,itop),DIMV,DIMTOT,size(S_V+itop) c $ ,1,size(S_H),bestv(1,itop),scndv(1,itop),besth,scndh) c end do qvp(bestvv(1))=1 do icc=1, size(S_H)-1 if ((bestvv(icc+1).ne.bestvv(icc)).and. $ (qvp(bestvv(icc+1)).eq.0)) then qvp(bestvv(icc+1))=qvp(bestvv(icc))+1 end if end do if (((ctlint(C_EVAL).gt.0).and.(fistat.eq.0)) $ .or.(ctlint(C_EVAL).gt.1)) then if (ofistat.ne.fistat) then write(20,'(A,I3)') ' *********** FISTAT =',fistat ofistat=fistat end if write(20,'(/,4A3,2X,4A3,A15,4A)') $ 'J','S','B','F','T','t','K','V',' Energy/GHz ' $ ,' best K(s) vec ',' V vec' $ ,' 2nd.K vec',' 2nd.V vec' endif do icc=1, size(S_H) difk=1.0 if (size(S_K).gt.1) then difk=(dabs(ksum(bestk(icc),icc)-ksum(scndk(icc),icc))) end if do itop=1, ctlint(C_NTOP) difv(itop)=1.0 end do c do itop=1, ctlint(C_NTOP) c if (size(S_V+itop).gt.1) then c difv(itop)=(dabs(vsum(bestv(icc,itop),icc,itop) c $ - vsum(scndv(icc,itop),icc,itop))) c end if c end do qmk(icc,Q_J)=j qmk(icc,Q_S)=gam qmk(icc,Q_F)=f qmk(icc,Q_B)=ib if (difk.lt.degn) then kdegen=.true. call maxof(h,DIMTOT,DIMTOT,size(S_H),icc,1,bestvk,scndvk, $ besth1,scndh1) if (abs(qvk(bestvk(1),Q_K)).ne.abs(qvk(bestk(icc),Q_K))) $ write(*,*) 'ERROR in assgn: K trouble',j,gam,icc qmk(icc,Q_K)=sign(qvk(bestvk(1),Q_K), $ int(besth1(1)*scndh1(1)*10000.0)) qmk(icc,Q_K2)=qmk(icc,Q_K) qmk(icc,Q_GK)=1000 qtp(bestvv(icc))=qtp(bestvv(icc))+1 qmk(icc,Q_TJ)=qtp(bestvv(icc)) qmk(icc,Q_V1)=qvp(bestvv(icc)) qmk(icc,Q_T )=icc sgnchr=' ' if (qmk(icc,Q_K).gt.0) sgnchr='+' if (qmk(icc,Q_K).lt.0) sgnchr='-' if (((ctlint(C_EVAL).gt.0).and.(fistat.eq.0)) $ .or.(ctlint(C_EVAL).gt.1)) then write(20, $ '(4i3,2X,2i3,i2,A,i3,F15.8,1X,2I3,2F7.3,I4,F6.3,10X,I4, $ F6.3)') $ j,gam,ib,f,qmk(icc,Q_T),qmk(icc,Q_TJ),abs(qmk(icc,Q_K)) $ ,sgnchr,qmk(icc,Q_V1),eval(icc) $ ,qvk(bestvk(1),Q_K) ,qvk(scndvk(1),Q_K) $ ,besth1(1),scndh1(1) $ ,bestvv(icc),sqrt(vvsum(bestvv(icc),icc)) $ ,scndvv(icc),sqrt(vvsum(scndvv(icc),icc)) C $ ,(bestv(icc,itop),itop=1,ctlint(C_NTOP)) end if else goodn=int(dabs(1.0-ksum(scndk(icc),icc)/ksum(bestk(icc),icc)) $ *100.0) if (qmk(icc,Q_GK).ne.-200) write(0,'(A,5I3)') $ ' Assignment Warning',j,gam,ib,f,icc qmk(icc,Q_GK)=goodn qmk(icc,Q_K) =qvk(bestk(icc),Q_K) ! this is not correct, but it will qmk(icc,Q_K2)=qvk(scndk(icc),Q_K) ! work. qtp(bestvv(icc))=qtp(bestvv(icc))+1 qmk(icc,Q_TJ)=qtp(bestvv(icc)) qmk(icc,Q_V1)=qvp(bestvv(icc)) qmk(icc,Q_T )=icc if (((ctlint(C_EVAL).gt.0).and.(fistat.eq.0)) $ .or.(ctlint(C_EVAL).gt.1)) then write(20, $ '(4i3,2X,4i3,F15.8,1X,I6,F14.3,I4,F6.3,I4,F6.3,I4,F6.3)') $ j,gam,ib,f,qmk(icc,Q_T),qmk(icc,Q_TJ),qmk(icc,Q_K) $ ,qmk(icc,Q_V1),eval(icc) $ ,qvk(bestk(icc),Q_K),sqrt(ksum(bestk(icc),icc)) $ ,bestvv(icc),sqrt(vvsum(bestvv(icc),icc)) $ ,qvk(scndk(icc),Q_K),sqrt(ksum(scndk(icc),icc)) $ ,scndvv(icc),sqrt(vvsum(scndvv(icc),icc)) C $ ,(bestv(icc,itop),vsum(bestv(icc,itop),icc,itop) C $ ,itop=1,ctlint(C_NTOP)) end if end if end do if (gam.gt.0) then if (kdegen) gamma(gam,0)=1 end if return end C---------------------------------------------------------------------- subroutine rotate(d,beta,j,oldj) implicit none include 'iam_.for' real*8 d(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2) real*8 beta integer j,oldj,ij if ((j.eq.0).or.(j.eq.1)) then call rotat1(d,beta,j) oldj=j end if if (oldj.eq.j) return if (oldj.gt.j) then do ij=1, j call rotat1(d,beta,ij) end do end if if (oldj.lt.j) then do ij=oldj+1, j call rotat1(d,beta,ij) end do end if oldj=j return end C --------------------------------------------------------------------- subroutine rotat1(d,beta,j) implicit none include 'iam_.for' real*8 d(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2) real*8 da(-DIMJ-1:DIMJ+1,-DIMJ-1:DIMJ+1,1:2) real*8 d1(-2:2,-2:2, 1:2) real*8 cg(-1:1,-DIMJ-1:DIMJ+1) real*8 beta,djj1 real*8 dnew,ddnew,cb,sb,dcb,dsb integer k,j,k1,k2,m1,m2 if (j.eq.0) then d(0,0,1)=1.0d0 d(0,0,2)=0.0d0 return endif C C D1(beta) Matrix initialisieren C if(beta.ne.0.0d0) then cb=0.5d0 * dcos(beta) sb=0.5d0 * dsqrt(2.0d0) * dsin(beta) d1(-1,-1,1)=0.5d0 + cb d1(-1, 1,1)=0.5d0 - cb d1(-1, 0,1)=sb d1( 0, 0,1)=2.d0 * cb d1( 1, 1,1)= d1(-1,-1,1) d1( 0,-1,1)=-d1(-1, 0,1) d1( 1,-1,1)= d1(-1, 1,1) d1( 0, 1,1)= d1(-1, 0,1) d1( 1, 0,1)= d1( 0,-1,1) else d1(-1,-1,1)=1.0d0 d1( 0, 0,1)=1.0d0 d1( 1, 1,1)=1.0d0 d1(-1, 1,1)=0.0d0 d1( 1,-1,1)=0.0d0 d1( 0,-1,1)=0.0d0 d1(-1, 0,1)=0.0d0 d1( 0, 1,1)=0.0d0 d1( 1, 0,1)=0.0d0 end if dcb=-0.5d0 * dsin(beta) dsb=0.5d0 * dsqrt(2.0d0) * dcos(beta) d1(-1,-1,2)=dcb d1(-1, 1,2)=-dcb d1(-1, 0,2)=dsb d1( 0, 0,2)=2.d0 * dcb d1( 1, 1,2)= d1(-1,-1,2) d1( 0,-1,2)=-d1(-1, 0,2) d1( 1,-1,2)= d1(-1, 1,2) d1( 0, 1,2)= d1(-1, 0,2) d1( 1, 0,2)= d1( 0,-1,2) C if ((j.eq.1)) then do k1=-1,1 do k2=-1,1 d(k1,k2,1)=d1(k1,k2,1) d(k1,k2,2)=d1(k1,k2,2) end do end do end if if (j.eq.1) return do k1=-j,j do k2=-j,j da(k1,k2,1)=d(k1,k2,1) da(k1,k2,2)=d(k1,k2,2) end do end do do k1=1,2 do k2=-j-1,j+1 da( j+1,k2,k1)=0.0d0 da(-j-1,k2,k1)=0.0d0 da(k2, j+1,k1)=0.0d0 da(k2,-j-1,k1)=0.0d0 end do end do C C Clebsch Gordan Koeffizienten C do k=-j,j djj1=dble(J*(2*J-1)) C cg(0,k)=dsqrt(dble((j-k) * (j+k))/djj1) C cg(-1,k)=dsqrt(dble((j-k-1)*(j-k))/(2.0d0*djj1)) C cg( 1,k)=dsqrt(dble((j+k-1)*(j+k))/(2.0d0*djj1)) C write(*,1003) j,k,cg(-1,k), cg(0,k), cg(1,k), djj1 1003 format(' J K ',2I4,' m+1 m m-1',4F10.4) end do C C do k1=0,j C do k2=k1,j do k1=-j,j do k2=-j,j dnew=0.0d0 ddnew=0.0d0 do m1=-1,1 do m2=-1,1 dnew=dnew $ + cg(m1,k1)*d1(m1,m2,1)*da(k1-m1,k2-m2,1)*cg(m2,k2) ddnew=ddnew $ + cg(m1,k1)*d1(m1,m2,1)*da(k1-m1,k2-m2,2)*cg(m2,k2) $ + cg(m1,k1)*d1(m1,m2,2)*da(k1-m1,k2-m2,1)*cg(m2,k2) end do end do d(k1,k2,1)=dnew C da(-k2,-k1)=dnew d(k1,k2,2)=ddnew C dda(-k2,-k1)=ddnew C if (myand((k2-k1),1).eq.1) then C da(k2,k1)= dnew C dda(k2,k1)= ddnew C else C da(k2,k1)=-dnew C dda(k2,k1)=-ddnew C endif C da(-k1,-k2) = da(k2,k1) C dda(-k1,-k2) = dda(k2,k1) end do end do C return end C C------------------------------------------------------------------------------ C C module IAMV2.FOR C C------------------------------------------------------------------------------ C C---------------------------------------------------------------------- subroutine bld2vjk(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,complex) C this subroutine builds the rotation + internal rotation matrix C h(DIMTOT,DIMTOT). C The energie E_{k,v,sigma} (given in the array evalv(v,sigma,k,top)) C for each top and the operators, which will be needed for the top-top C coupling terms, C (given in the array ovv(v,v',op_no,sigma,k,top)) are transformed into C the principal axes system with the rotation matrix rotm(k,k',1,top) C and written in the array rott(k,k',v,v',top). C this is provided by the subroutines are rotovv (for the operators) C and roteval (for the eigenenergies). C the second step is to write the arrays rott (where each top in independent) C into the matrix h using the subroutines addo1 and addovv. implicit none include 'iam_.for' integer j,gam,f logical complex integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C real*8 erk(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) integer itop,ift logical rrir1,rrir2,rrir3 external myand integer myand if (ctlint(C_NTOP).ge.2) then if (a(P_FF).ne.0.0) then call rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,PM_PI,PM_PI $ ,.false.) if (complex) then call haddovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,a(P_FF)) else call addovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,a(P_FF)) end if end if if (a(P_VSS).ne.0.0) then if (myand(ctlint(C_WOODS),1024).eq.0) then call rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,PM_SIN,PM_SIN $ ,.false.) if (complex) then call haddovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,-5.d-1*a(P_VSS)) else call addovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,-5.d-1*a(P_VSS)) end if else call addiop(j,gam,f,qvk,ruse,h,a,ovv,rotm,rott,tori $ ,-1.0*a(P_VSS),PM_SIN,.true.) end if end if if (a(P_VCC).ne.0.0) then if (myand(ctlint(C_WOODS),1024).eq.0) then call rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,PM_COS,PM_COS $ ,.false.) if (complex) then call haddovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,+5.d-1*a(P_VCC)) else call addovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,+5.d-1*a(P_VCC)) end if else call addiop(j,gam,f,qvk,ruse,h,a,ovv,rotm,rott,tori $ ,a(P_VCC),PM_COS,.true.) end if end if end if rrir1=.false. rrir2=.false. rrir3=.false. do itop=1, ctlint(C_NTOP) ift=(itop-1)*DIMPIR if (a(P1_DPIJ+ift).ne.0.0) rrir1=.true. if (a(P1_DPIK+ift).ne.0.0) rrir2=.true. if (a(P1_DPID+ift).ne.0.0) rrir3=.true. c write(*,'(50F10.4)') c $ (ovv(1,1,PM_PI2,gamma(gam,itop),ift,itop),ift=-j,j) end do if (rrir1.or.rrir2.or.rrir3) $ call rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,PM_F,PM_F $ ,.true.) if (rrir1) then call haddjp(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori $ ,PI_DPIJ) end if if (rrir2) then call haddkp(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori $ ,PI_DPIK) end if if (rrir3) then call hadddp(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori $ ,PI_DPID) end if rrir1=.false. rrir2=.false. rrir3=.false. do itop=1, ctlint(C_NTOP) ift=(itop-1)*DIMPIR if (a(P1_DC3J+ift).ne.0.0) rrir1=.true. C ... C ... end do if (rrir1) $ call rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,PM_COS,PM_COS $ ,.true.) if (rrir1) then call haddjp(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori $ ,PI_DC3J) end if call rotevl(j,gam,f,qvk,a,evalv,rotm,rott,tori) if (complex) then call haddo1(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori,1.0d0) else call addo1(j,gam,f,qvk,ruse,h,a,evalv,ovv,rotm,rott,tori,1.0d0) end if return end C --------------------------------------------------------------------- subroutine rotevl(j,gam,f,qvk,a,evalv,rotm,rott,tori) implicit none include 'iam_.for' integer j,gam,f integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) real*8 a(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work integer itop,ikr,ikc,ivr,ivc,ik,iv,itest,off external myand integer myand real*8 tt do itop=1, ctlint(C_NTOP) do ikr=1, size(S_K) do ikc=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop)=0.0 end do end do end do end do end do itest=0 C rotate evalv into rho system for each top with torsional integrals C if ((myand(ctlint(C_WOODS),1).ne.0).and. ! torsional integrals C $ (myand(ctlint(C_WOODS),4).ne.0).and. ! use tors int. in rot. matrix C $ (myand(ctlint(C_WOODS),64).eq.0)) then ! don't use Demaisons method if (myand(ctlint(C_WOODS),4).ne.0) then ! torsional integrals itest=itest+1 do itop=1, ctlint(C_NTOP) off=size(S_MINV+itop)-size(S_FIRV+itop) do ikr=1, size(S_K) do ikc=1, size(S_K) do ik=1, size(S_K) tt=rotm(qvk(ik,Q_K),qvk(ikr,Q_K),1,itop) $ *rotm(qvk(ik,Q_K),qvk(ikc,Q_K),1,itop) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) do iv=1, size(S_MAXV+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ = rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ + tt $ * tori(qvk(ik,Q_K),qvk(ikr,Q_K),iv,ivr+off $ ,gamma(gam,itop),itop) $ * evalv(iv,gamma(gam,itop) $ ,qvk(ik,Q_K),itop) $ * tori(qvk(ik,Q_K),qvk(ikc,Q_K),iv,ivc+off $ ,gamma(gam,itop),itop) end do end do end do end do end do end do end do end if C rotate evalv into rho system for each top without torsional integrals C if ((myand(ctlint(C_WOODS),1).eq.0).or. C $ (myand(ctlint(C_WOODS),4).eq.0).or. ! don't use tors int. in rot. matrix C $ (myand(ctlint(C_WOODS),64).ne.0)) then ! use Demaisons method if (myand(ctlint(C_WOODS),4).eq.0) then itest=itest+1 do itop=1, ctlint(C_NTOP) off=size(S_MINV+itop)-size(S_FIRV+itop) do ikr=1, size(S_K) do ikc=1, size(S_K) do ik=1, size(S_K) tt=rotm(qvk(ik,Q_K),qvk(ikr,Q_K),1,itop) $ *rotm(qvk(ik,Q_K),qvk(ikc,Q_K),1,itop) do iv=1, size(S_V+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),iv,iv,itop) $ = rott(qvk(ikr,Q_K),qvk(ikc,Q_K),iv,iv,itop) $ + tt $ * evalv(iv+off,gamma(gam,itop),qvk(ik,Q_K),itop) end do end do end do end do end do end if if (itest.ne.1) stop 'Error: rotating in rotevl' itest=0 C multiply torsional integrals of one top like Demaison if (myand(ctlint(C_WOODS),64).ne.0) then itest=itest+1 do itop=1, ctlint(C_NTOP) off=size(S_MINV+itop)-size(S_FIRV+itop) do ikr=1, size(S_K) do ikc=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ = rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ * tori(qvk(ikr,Q_K),qvk(ikc,Q_K) $ ,ivr+off,ivc+off $ ,gamma(gam,itop),itop) end do end do end do end do end do end if if (itest.gt.1) stop ' ERROR: tori two times multiplied ' return end C---------------------------------------------------------------------- subroutine addo1(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,ap) C add the rotated eigenvalues (in rott) to the main matrix h C real version implicit none include 'iam_.for' integer j,gam,f integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR),ap real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C integer qv(DIMTOT) C work real*8 rt,tt integer iv,itop,it,ir,ic,voff external myand integer myand if (size(S_H).gt.DIMTOT) stop 'Dimension Error in addo1' do iv=1,size(S_H) qv(iv)=int((iv-1)/size(S_K))+1 end do do itop=1, ctlint(C_NTOP) voff=size(S_MINV+itop)-1 if (myand(ctlint(C_PRI),AP_MH).ne.0) $ write(*,'(A,I2)') ' Add one-top-operator Top',itop do ir=1,size(S_H) do ic=1,ir if (myand(ctlint(C_WOODS),8).eq.0) then tt=dble(ruse(qv(ir),qv(ic),itop)) ! don't mult. with tor. int. of the other tops else ! use kronecker tt=1.0 do it=1,ctlint(C_NTOP) ! supply tor.int. of the other tops if (it.ne.itop) tt=tt*tori(qvk(ir,Q_K) $ ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+it)-size(S_MINV+it)+1 $ ,qvk(ic,Q_V+it)-size(S_MINV+it)+1 $ ,gamma(gam,it),it) end do end if rt=rott(qvk(ir,Q_K) $ ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+itop)-voff $ ,qvk(ic,Q_V+itop)-voff $ ,itop) $ *tt h(ir,ic)=h(ir,ic)+rt*ap if (myand(ctlint(C_PRI),AP_MH).ne.0) then if (abs(rt).lt.1000.0) then write(*,'(F10.5,$)') rt*ap else write(*,'(F10.2,$)') rt*ap end if end if end do if (myand(ctlint(C_PRI),AP_MH).ne.0) write(*,*) end do end do c if (myand(ctlint(C_PRI),AP_MH).ne.0) then c write(*,*) ' H_ir ' c do ir=1, size(S_H) c do ic=1, size(S_H) c if (abs(h(ir,ic)).lt.1000.0) then c write(*,'(F10.5,$)') h(ir,ic) c else c write(*,'(F10.2,$)') h(ir,ic) c end if c end do c write(*,*) c end do c write(*,*) c end if return end C---------------------------------------------------------------------- subroutine haddjp(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,ipm) implicit none include 'iam_.for' integer j,gam,f,ipm integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C integer qv(DIMTOT) C work real*8 rt,tt real*8 dcgam, dsgam integer iv,itop,ir,ic,voff external myand integer myand if (size(S_H).gt.DIMTOT) stop 'Dimension Error in ADDJP' do iv=1,size(S_H) qv(iv)=int((iv-1)/size(S_K))+1 end do do itop=1, ctlint(C_NTOP) voff=size(S_MINV+itop)-1 C if (ctlint(C_PRI).gt.11) write(*,'(/,A,I2)') 'H_Djp',itop do ir=1,size(S_H) do ic=1,ir tt=dble(ruse(qv(ir),qv(ic),itop)) ! don't mult. with tor. int. of the other tops rt=rott(qvk(ir,Q_K) $ ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+itop)!-voff $ ,qvk(ic,Q_V+itop)!-voff $ ,itop) $ *tt $ *2.0*(a(DIMPRR+(itop-1)*DIMPIR+ipm) $ *dble(j*(j+1))) dcgam=cos(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K)))*rt h(ir,ic)=h(ir,ic)+dcgam if (qvk(ir,Q_K).ne.qvk(ic,Q_K)) then dsgam=sin(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K)))*rt h(ic,ir)=h(ic,ir)+dsgam end if end do end do end do if (myand(ctlint(C_PRI),AP_MH).ne.0) then write(*,*) ' H_DJPM ' do ir=1, size(S_H) do ic=1, size(S_H) if (abs(h(ir,ic)).lt.1000.0) then write(*,'(F10.5,$)') h(ir,ic) else write(*,'(F10.2,$)') h(ir,ic) end if end do write(*,*) end do write(*,*) end if return end C---------------------------------------------------------------------- subroutine haddkp(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,ipm) implicit none include 'iam_.for' integer j,gam,f,ipm integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C integer qv(DIMTOT) C work real*8 rt,tt real*8 dcgam, dsgam integer iv,itop,ir,ic,voff external myand integer myand if (size(S_H).gt.DIMTOT) stop 'Dimension Error in HaddKP' do iv=1,size(S_H) qv(iv)=int((iv-1)/size(S_K))+1 end do do itop=1, ctlint(C_NTOP) voff=size(S_MINV+itop)-1 C if (ctlint(C_PRI).gt.11) write(*,'(/,A,I2)') 'H_DKp',itop do ir=1,size(S_H) do ic=1,ir tt=dble(ruse(qv(ir),qv(ic),itop)) ! don't mult. with tor. int. of the other tops rt=rott(qvk(ir,Q_K) $ ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+itop)!-voff $ ,qvk(ic,Q_V+itop)!-voff $ ,itop) $ *tt $ *(a(DIMPRR+(itop-1)*DIMPIR+ipm) $ *(dble(qvk(ir,Q_K))**2+dble(qvk(ic,Q_K))**2)) C h(ir,ic)=h(ir,ic)+rt dcgam=cos(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K)))*rt h(ir,ic)=h(ir,ic)+dcgam if (qvk(ir,Q_K).ne.qvk(ic,Q_K)) then dsgam=sin(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K)))*rt h(ic,ir)=h(ic,ir)+dsgam end if end do end do end do if (myand(ctlint(C_PRI),AP_MH).ne.0) then write(*,*) ' H_DKP ' do ir=1, size(S_H) do ic=1, size(S_H) if (abs(h(ir,ic)).lt.1000.0) then write(*,'(F10.5,$)') h(ir,ic) else write(*,'(F10.2,$)') h(ir,ic) end if end do write(*,*) end do write(*,*) end if return end C---------------------------------------------------------------------- subroutine hadddp(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,ipm) implicit none include 'iam_.for' integer j,gam,f,ipm integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR) real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C integer qv(DIMTOT) C work real*8 tmp(DIM2J1,DIM2J1),djj1,dk,dff integer itop,ir,ic,voff,ivr,ivc,ikr,ikc external myand integer myand if (size(S_H).gt.DIMTOT) stop 'Dimension Error in HAddDP' do ivr=1,size(S_H) qv(ivr)=int((ivr-1)/size(S_K))+1 end do djj1=dble(j*(j+1)) do itop=1, ctlint(C_NTOP) voff=size(S_MINV+itop)-1 do ivr=1, size(S_VV) do ivc=1, ivr if (ruse(ivr,ivc,itop).ne.0) then do ikr=1, size(S_K) do ikc=1, size(S_K) tmp(ikr,ikc)=0.0 end do end do do ikc=1, size(S_K)-2 ic=ikc+(ivc-1)*size(S_K) dk=dble(qvk(ic,Q_K)) dff=0.5d0*dsqrt((djj1-dk*(dk+1.0)) $ *(djj1-(dk+1.0)*(dk+2.0))) do ikr=1, size(S_K) ir=ikr+(ivr-1)*size(S_K) tmp(ikr,ikc)=tmp(ikr,ikc)+ $ rott(qvk(ir,Q_K) ,qvk(ic+2,Q_K) $ ,qvk(ir,Q_V+itop),qvk(ic+2,Q_V+itop) $ ,itop) $ *dff tmp(ikr,ikc+2)=tmp(ikr,ikc+2)+ $ rott(qvk(ir,Q_K) ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+itop),qvk(ic,Q_V+itop) $ ,itop) $ *dff end do end do do ikr=1, size(S_K)-2 ir=ikr+(ivr-1)*size(S_K) dk=dble(qvk(ir,Q_K)) dff=0.5d0*dsqrt((djj1-dk*(dk+1.0)) $ *(djj1-(dk+1.0)*(dk+2.0))) do ikc=1, size(S_K) ic=ikc+(ivc-1)*size(S_K) tmp(ikr,ikc)=tmp(ikr,ikc)+ $ rott(qvk(ir+2,Q_K) ,qvk(ic,Q_K) $ ,qvk(ir+2,Q_V+itop),qvk(ic,Q_V+itop) $ ,itop) $ *dff tmp(ikr+2,ikc)=tmp(ikr+2,ikc)+ $ rott(qvk(ir,Q_K) ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+itop),qvk(ic,Q_V+itop) $ ,itop) $ *dff end do end do if (ivr.eq.ivc) then do ikr=1, size(S_K) ir=ikr+(ivr-1)*size(S_K) do ikc=1, ikr ic=ikc+(ivc-1)*size(S_K) h(ir,ic)=h(ir,ic) $ +a(DIMPRR+(itop-1)*DIMPIR+ipm) $ *cos(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K))) $ *tmp(ikr,ikc) h(ic,ir)=h(ic,ir) $ +a(DIMPRR+(itop-1)*DIMPIR+ipm) $ *sin(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K))) $ *tmp(ikr,ikc) end do enddo else do ikr=1, size(S_K) ir=ikr+(ivr-1)*size(S_K) do ikc=1, size(S_K) ic=ikc+(ivc-1)*size(S_K) h(ir,ic)=h(ir,ic) $ +a(DIMPRR+(itop-1)*DIMPIR+ipm) $ *cos(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K))) $ *tmp(ikr,ikc) h(ic,ir)=h(ic,ir) $ +a(DIMPRR+(itop-1)*DIMPIR+ipm) $ *sin(a(P1_GAMA+(itop-1)*DIMPIR) $ *dble(qvk(ir,Q_K)-qvk(ic,Q_K))) $ *tmp(ikr,ikc) end do end do end if end if end do end do if (myand(ctlint(C_PRI),AP_MH).ne.0) then write(*,'(A,I3)') ' H_DKD top',itop do ir=1, size(S_H) do ic=1, size(S_H) if (abs(h(ir,ic)).lt.1000.0) then write(*,'(F10.5,$)') h(ir,ic) else write(*,'(F10.2,$)') h(ir,ic) end if end do write(*,*) end do write(*,*) end if end do return end C---------------------------------------------------------------------- subroutine haddo1(j,gam,f,qvk,ruse $ ,h,a,evalv,ovv,rotm,rott,tori,ap) C add the rotated matrixelements (in rott) to the main matrix h C hermitian version, uses gamma implicit none include 'iam_.for' integer j,gam,f integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT),a(DIMPAR),ap real*8 evalv(DIMV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C integer qv(DIMTOT) C work real*8 rt, dcgam, dsgam, tt, gam1 integer iv,itop,it,ir,ic,qkr,qkc,vr1,vc1 external myand integer myand if (size(S_H).gt.DIMTOT) stop 'Dimension Error in haddo1' do iv=1,size(S_H) qv(iv)=int((iv-1)/size(S_K))+1 end do do itop=1, ctlint(C_NTOP) gam1=a(P1_GAMA+(itop-1)*DIMPIR) do ir=1,size(S_H) do ic=1,ir qkr=qvk(ir,Q_K) qkc=qvk(ic,Q_K) vr1=qvk(ir,Q_V+itop)-size(S_MINV+itop)+1 vc1=qvk(ic,Q_V+itop)-size(S_MINV+itop)+1 if (myand(ctlint(C_WOODS),8).eq.0) then tt=dble(ruse(qv(ir),qv(ic),itop)) ! don't mult. with tor. int. of the other tops else ! use kronecker tt=1.0 do it=1,ctlint(C_NTOP) ! supply tor.int. of the other tops if (it.ne.itop) tt=tt*tori(qkr,qkc $ ,qvk(ir,Q_V+it)-size(S_MINV+it)+1 $ ,qvk(ic,Q_V+it)-size(S_MINV+it)+1 $ ,gamma(gam,it),it) end do end if rt=rott(qkr,qkc,vr1,vc1,itop)*tt*ap dcgam=cos(gam1*dble(qkr-qkc)) dsgam=sin(gam1*dble(qkr-qkc)) h(ir,ic)=h(ir,ic)+dcgam*rt ! real part of H h(ic,ir)=h(ic,ir)+dsgam*rt ! imag. part if (myand(ctlint(C_PRI),AP_MH).ne.0) then if (abs(dcgam*ap).lt.1000.0) then write(*,'(F10.5,$)') dcgam*ap else write(*,'(F10.2,$)') dcgam*ap end if if (abs(dsgam*ap).lt.1000.0) then write(*,'(F10.5,A,$)') dsgam*ap,'i' else write(*,'(F10.2,A,$)') dsgam*ap,'i' end if end if end do if (myand(ctlint(C_PRI),AP_MH).ne.0) write(*,*) end do end do return end C --------------------------------------------------------------------- subroutine addiop(j,gam,f,qvk,ruse,h,a,ovv,rotm,rott,tori,ap,iop, $ offv) implicit none include 'iam_.for' integer j,gam,f,iop integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) logical offv real*8 h(DIMTOT,DIMTOT),ap real*8 a(DIMPAR) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work integer it1,it2,ivr,ivc,ik,ir,ic do it1=1, ctlint(C_NTOP)-1 do it2=it1+1, ctlint(C_NTOP) do ivr=1, size(S_VV) do ivc=1, ivr if ((ivr.ne.ivc).or.offv) then do ik=1, size(S_K) ir=(ivr-1)*size(S_K)+ik ic=(ivc-1)*size(S_K)+ik h(ir,ic)=h(ir,ic) $ +ap $ *ovv(qvk(ir,Q_V+it1) $ ,qvk(ic,Q_V+it1) $ ,iop,gamma(gam,it1) $ ,qvk(ir,Q_K),it1) $ *ovv(qvk(ir,Q_V+it2) $ ,qvk(ic,Q_V+it2) $ ,iop,gamma(gam,it2) $ ,qvk(ir,Q_K),it2) end do end if end do end do end do end do return end C --------------------------------------------------------------------- subroutine addovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,ap) implicit none include 'iam_.for' integer j,gam,f integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT) real*8 a(DIMPAR),ap real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work integer it1,it2,ii,ir,ic,qkr,qkc,qki,vr1,vc1,vr2,vc2 real*8 rt1,rt2 external myand integer myand if (myand(ctlint(C_PRI),AP_MH).ne.0) $ write(*,'(/,A)') ' Add Ovv' do it1=1, ctlint(C_NTOP)-1 do it2=it1+1, ctlint(C_NTOP) do ir=1, size(S_H) do ic=1, ir rt1=0.0 rt2=0.0 qkr=qvk(ir,Q_K) qkc=qvk(ic,Q_K) vr1=qvk(ir,Q_V+it1)-size(S_MINV+it1)+1 vc1=qvk(ic,Q_V+it1)-size(S_MINV+it1)+1 vr2=qvk(ir,Q_V+it2)-size(S_MINV+it2)+1 vc2=qvk(ic,Q_V+it2)-size(S_MINV+it2)+1 do ii=1, size(S_K) qki=qvk(ii,Q_K) rt1=rt1 $ + rott(qkr,qki,vr1,vc1,it1) $ * rott(qki,qkc,vr2,vc2,it2) rt2=rt2 $ + rott(qkr,qki,vr2,vc2,it2) $ * rott(qki,qkc,vr1,vc1,it1) end do h(ir,ic)=h(ir,ic)+ap*(rt1+rt2) if (myand(ctlint(C_PRI),AP_MH).ne.0) then if (abs(ap*(rt1+rt2)).lt.1000.0) then write(*,'(F10.5,$)') ap*(rt1+rt2) else write(*,'(F10.2,$)') ap*(rt1+rt2) end if end if end do if (myand(ctlint(C_PRI),AP_MH).ne.0) write(*,*) end do end do end do return end C --------------------------------------------------------------------- subroutine haddovv(j,gam,f $ ,qvk,ruse,h,a,ovv,rotm,rott,tori,ap) implicit none include 'iam_.for' integer j,gam,f integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) integer ruse(DIMVV,DIMVV,DIMTOP) real*8 h(DIMTOT,DIMTOT) real*8 a(DIMPAR),ap real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work integer it1,it2,ii,ir,ic,qkr,qkc,qki,vr1,vc1,vr2,vc2 real*8 tr1,tr2,ti1,ti2,gam1,gam2,t1,t2 external myand integer myand if (myand(ctlint(C_PRI),AP_MH).ne.0) $ write(*,'(A)') ' H AddOvv' do it1=1, ctlint(C_NTOP)-1 do it2=it1+1, ctlint(C_NTOP) gam1=a(P1_GAMA+(it1-1)*DIMPIR) gam2=a(P1_GAMA+(it2-1)*DIMPIR) do ir=1, size(S_H) do ic=1, ir tr1=0.0 tr2=0.0 ti1=0.0 ti2=0.0 qkr=qvk(ir,Q_K) qkc=qvk(ic,Q_K) vr1=qvk(ir,Q_V+it1)-size(S_MINV+it1)+1 vc1=qvk(ic,Q_V+it1)-size(S_MINV+it1)+1 vr2=qvk(ir,Q_V+it2)-size(S_MINV+it2)+1 vc2=qvk(ic,Q_V+it2)-size(S_MINV+it2)+1 do ii=1, size(S_K) qki=qvk(ii,Q_K) t1= $ rott(qkr,qki,vr1,vc1,it1) $ * rott(qki,qkc,vr2,vc2,it2) tr1=tr1+t1 $ * cos(gam1*dble(qkr-qki) $ +gam2*dble(qki-qkc)) ti1=ti1+t1 $ * sin(gam1*dble(qkr-qki) $ +gam2*dble(qki-qkc)) t2= $ rott(qkr,qki,vr2,vc2,it2) $ * rott(qki,qkc,vr1,vc1,it1) tr2=tr2+t2 $ * cos(gam2*dble(qkr-qki) $ +gam1*dble(qki-qkc)) ti2=ti2+t2 $ * sin(gam2*dble(qkr-qki) $ +gam1*dble(qki-qkc)) end do h(ir,ic)=h(ir,ic)+ap*(tr1+tr2) h(ic,ir)=h(ic,ir)+ap*(ti1+ti2) if (myand(ctlint(C_PRI),AP_MH).ne.0) $ write(*,'(2F11.5,A,$)') $ ap*(tr1+tr2),ap*(ti1+ti2),'i' end do if (myand(ctlint(C_PRI),AP_MH).ne.0) write(*,*) end do end do end do return end C --------------------------------------------------------------------- subroutine rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,ifs1,ifs2,sc) implicit none include 'iam_.for' integer j,gam,f,ifs1,ifs2,ifs integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) logical sc real*8 a(DIMPAR) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work integer itop,ikr,ikc,ivr,ivc,ik,iv,off real*8 tt real*8 rtmp(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV) real*8 ovt(DIMV,DIMV,DIM2J1) external myand integer myand do itop=1, ctlint(C_NTOP) do ikr=1, size(S_K) do ikc=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop)=0.0 end do end do end do end do end do if (myand(ctlint(C_WOODS),16).ne.0) then do itop=1, ctlint(C_NTOP) if (itop.eq.1) then ifs=ifs1 else ifs=ifs2 endif off=size(S_MINV+itop)-size(S_FIRV+itop) if (sc) then do ik=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) ovt(ivr,ivc,ik)= $ ovv(ivr+off,ivc+off,ifs,gamma(gam,itop) $ ,qvk(ik,Q_K),itop) $ -ovv(ivr+off,ivc+off,ifs,gamma(1,itop) $ ,qvk(ik,Q_K),itop) end do end do end do else do ik=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) ovt(ivr,ivc,ik)= $ ovv(ivr+off,ivc+off,ifs,gamma(gam,itop) $ ,qvk(ik,Q_K),itop) end do end do end do end if do ikr=1, size(S_K) do ikc=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) rtmp(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc)=0.0 end do end do end do end do do ikr=1, size(S_K) do ikc=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) do iv =1, size(S_MAXV+itop) rtmp(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc)= $ rtmp(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc) $ + ovt(ivr,iv,ikr) $ * tori(qvk(ikr,Q_K),qvk(ikc,Q_K),iv,ivc+off $ ,gamma(gam,itop),itop) $ * rotm(qvk(ikr,Q_K),qvk(ikc,Q_K),1,itop) end do end do end do end do end do do ikr=1, size(S_K) do ikc=1, size(S_K) do ik=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) do iv =1, size(S_MAXV+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop)= $ rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ + tori(qvk(ik ,Q_K),qvk(ikr,Q_K),iv ,ivr+off $ ,gamma(gam,itop),itop) $ * rotm(qvk(ik ,Q_K),qvk(ikr,Q_K),1,itop) $ * rtmp(qvk(ik ,Q_K),qvk(ikc,Q_K),iv ,ivc) end do end do end do end do end do end do end do end if C rotate ifs into rho system for each top without torsional integrals if (myand(ctlint(C_WOODS),16).eq.0) then do itop=1, ctlint(C_NTOP) if (itop.eq.1) then ifs=ifs1 else ifs=ifs2 endif off=size(S_MINV+itop)-size(S_FIRV+itop) if (sc) then do ik=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) ovt(ivr,ivc,ik)= $ ovv(ivr+off,ivc+off,ifs,gamma(gam,itop) $ ,qvk(ik,Q_K),itop) $ -ovv(ivr+off,ivc+off,ifs,gamma(1,itop) $ ,qvk(ik,Q_K),itop) end do end do end do else do ik=1, size(S_K) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) ovt(ivr,ivc,ik)= $ ovv(ivr+off,ivc+off,ifs,gamma(gam,itop) $ ,qvk(ik,Q_K),itop) end do end do end do end if do ikr=1, size(S_K) do ikc=1, size(S_K) do ik=1, size(S_K) tt=rotm(qvk(ik,Q_K),qvk(ikr,Q_K),1,itop) $ *rotm(qvk(ik,Q_K),qvk(ikc,Q_K),1,itop) do ivr=1, size(S_V+itop) do ivc=1, size(S_V+itop) rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ = rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) $ + tt $ * ovt(ivr,ivc,ik) end do end do end do end do end do end do end if if (myand(ctlint(C_PRI),AP_MH).ne.0) then do itop=1, ctlint(C_NTOP) write(*,'(/,A)') $ 'Matrixelements after rotation into principal axes system' write(*,'(2(A,I2))') $ ' K V | Operator No.',ifs,' Top No.',itop do ivr=1, size(S_V+itop) do ikr=1, size(S_K) write(*,'(2I3,$)') qvk(ikr,Q_K),ivr do ivc=1, size(S_V+itop) do ikc=1, size(S_K) write(*,'(F10.4,$)') $ rott(qvk(ikr,Q_K),qvk(ikc,Q_K),ivr,ivc,itop) end do end do write(*,*) end do end do end do end if return end C ========================================= C --------------------------------------------------------------------- subroutine prrott(j,gam,f,qvk,a,ovv,rotm,rott,tori,ifs1,ifs2,sc) implicit none include 'iam_.for' integer j,gam,f,ifs1,ifs2 integer it,ir,ic,it1 integer qvk(DIMTOT,Q_K:Q_V+DIMTOP) logical sc real*8 a(DIMPAR) real*8 ovv(DIMV,DIMV,DIMOVV,-DIMSIG:DIMSIG,-DIMJ:DIMJ,DIMTOP) real*8 rotm(-DIMJ:DIMJ,-DIMJ:DIMJ,1:2,DIMTOP) real*8 rott(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV,DIMTOP) real*8 tori(-DIMJ:DIMJ,-DIMJ:DIMJ,DIMV,DIMV, $ -DIMSIG:DIMSIG,DIMTOP) C work real*8 tt,hh call rotovv(j,gam,f,qvk,a,ovv,rotm,rott,tori,ifs1,ifs2,.false.) write(*,*) ' rott ' do it=1,ctlint(C_NTOP) do ir=1, size(S_H) do ic=1, size(S_H) tt=1.0 do it1=1,ctlint(C_NTOP) if (it.ne.it1) $ tt=tt $ * tori(qvk(ir,Q_K) $ ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+it1) $ ,qvk(ic,Q_V+it1) $ ,gamma(gam,it),it1) end do hh=rott(qvk(ir,Q_K) $ ,qvk(ic,Q_K) $ ,qvk(ir,Q_V+it) $ ,qvk(ic,Q_V+it) $ ,it) $ * tt if (abs(hh).lt.1000.0) then write(*,'(F10.5,$)') hh else write(*,'(F10.2,$)') hh end if end do write(*,*) end do write(*,*) end do return end C C------------------------------------------------------------------------------ C C module IAMFIT.FOR C C------------------------------------------------------------------------------ C subroutine lmfit(ndata,npar,nb,DIMFIT,DIMPAR,DIMVB,DIMPLC $ ,iprint,nsvfit,nfit,ifit,dfit $ ,alpha,covar,evec,beta,w,a,anew,da,freed,palc,pali $ ,rofit,sigsq,sigsqold,tol,stepw,fstat,usex,const,alamda $ ,fitscl,svderr) C fit routine Levenberg Marquardt Method C Parameters: C ndata: number of data points (transitions) C npar: total number of parameters (fitted and constrained) C nb: number of b's C DIMPAR: physical dimension of a,da, ... C DIMVB : physical dimension of a,da, ... C DIMFIT: physical dimension of alpha,beta, ... C DIMPLC: physical dimension of pali, palc C iprint: output level 0-5 C nsvfit: number of indepentent variables C nfit: number of parameters to fit C ifit: array(1:DIMPAR) 1=fit 0=fixed C dfit: array(1:DIMPAR) 1=fit 0=fixed for each linear comb. C alpha: matrix C covar: freedom \ covariance matrix C evec: eigenvectors of alpha C beta: vector C w: eigenvalues of alpha C a: parameters (old, but good) C anew: parameters (new, just a try) C da: error of paramaters C freed: freedom of parameter C palc: array of linear combinations (no.of.lin.comb, coefficient) C pali: array of linear combinations (no.of.lin.comb, no.of.parameter or B) C rofit: robust fitting parameter C sigsq: sum_i (dy_i^2 * weight_i) C sigsqold: C tol: tolerance value to neglect eigenvalues C stepw: stepw: C fstat: = 0: calc. only chisq C > 0: calc. new parameters (using derivatives dyda) C < 0: calc. errors C usex: use experimental sigma C const: no. of additional datapoints C alamda: lambda parameter C fitscl: = 0: normalize alpha-Matrix = 1: don't change alpha C svderr: treatment of error-caclulation of nsvfit < nfit implicit none C .. C .. Scalar Arguments .. real*8 rofit,sigsq,sigsqold,tol,stepw,alamda integer ndata,npar,dimfit,nb,dimpar,dimvb,dimplc integer iprint,nsvfit,nfit,fstat,usex,const integer svderr,fitscl C .. C .. Array Arguments .. integer ifit(DIMPAR,DIMVB), dfit(DIMFIT) real*8 alpha(DIMFIT,DIMFIT),covar(DIMFIT,DIMFIT), $ evec(DIMFIT,DIMFIT) real*8 w(DIMFIT),beta(DIMFIT),freed(DIMFIT) real*8 a(DIMPAR,DIMVB),anew(DIMPAR,DIMVB),da(DIMPAR,DIMVB) real*8 palc(DIMFIT,-1:DIMPLC) integer pali(DIMFIT, 0:DIMPLC,2) C .. local Scalars real*8 chisqex,sig2isum,dy,wt,wmax,wmin,sig2i,thresh,sigex real*8 dy2av,psi,psisum,psiav,EPS integer i,j,k,l,imin,imax,DIMLMF,b,ic,ir parameter (DIMLMF=60,EPS=1.0d-12) C .. local Arrays real*8 dyda(DIMLMF),tmp(DIMLMF),dpar(DIMLMF) save dy2av if (DIMFIT.gt.DIMLMF) stop 'DIMENSION ERROR in iamfit' if (nfit.gt.DIMLMF) stop 'DIMENSION ERROR in iamfit' if (const.ne.0) stop 'FITNEW: const .ne. 0' if (fstat.eq.0) then C calc sigma**2 chisqex=0.0d0 psisum=0.0 sig2isum=0.0d0 do j= 1, ndata+const if (j.le.ndata) $ call funcs(j,dy,dyda,anew,sigex,nfit,ifit,dfit,1) C if (j.gt.ndata) C $ call fconst(j-ndata,dy,dyda,anew,sigex,DIMPAR,1,ifit,dfit) psi=1.0/(1.0+0.5*((rofit*dy)/sigex)**2) call savepsi(j,psi) psisum =psisum +psi chisqex =chisqex +(dy**2/sigex**2)*psi sig2isum=sig2isum +1.0d0/sigex**2 end do if ((ndata-nfit-1).le.0) then write(0,*)' FIT: Warning: ndata-nfit = 0: no fit possible!' sigsq=100000.0 dy2av=100000.0 return end if psiav=psisum/dble(ndata) sigsq=(chisqex/(sig2isum*psiav)) $ *(dble(ndata)/(dble(ndata-nfit-1))) dy2av=chisqex/(dble(ndata-nfit-1)) return end if C ---------------------------------------------------------------------- if (fstat.gt.0) then C Check if new sigma square is better than old sigma square if (sigsq.lt.sigsqold) then C succsess: calc. new alpha matrix and beta vector alamda=alamda*0.4 do b = 1, nb do j = 1, npar a(j,b) = anew(j,b) end do end do do j = 1,nfit do k = 1,j alpha(j,k) = 0.d0 end do beta(j) = 0.d0 end do do i = 1,ndata+const do j = 1, nfit dyda(j)=0.0d0 end do if (i.le.ndata) $ call funcs(i,dy,dyda,anew,sigex,nfit,ifit,dfit,2) C if (i.gt.ndata) C $ call fconst(i-ndata,dy,dyda,anew,sigex,npar,2,ifit,dfit) if (usex.eq.1) then sig2i=1.0d0/(sigex**2) else sig2i=1.0d0/(sigex**2*dy2av) end if psi=1.0/(1.0+0.5*((rofit*dy)/sigex)**2) sig2i=sig2i*psi C build alpha and beta do j = 1,nfit wt = dyda(j)*sig2i do k = 1,j alpha(j,k) = alpha(j,k) + wt*dyda(k) end do beta(j) = beta(j) + dy*wt end do end do C scale beta if (fitscl.eq.0) then do j = 1,nfit beta(j)=beta(j)/dsqrt(alpha(j,j)) end do end if else alamda=alamda*10.0 end if C put scaled alpha in evec with lambda do j = 1,nfit if (fitscl.eq.0) then do k = 1,j evec(j,k) = alpha(j,k)/dsqrt(alpha(j,j)*alpha(k,k)) end do else do k = 1,j evec(j,k) = alpha(j,k) end do end if end do do j = 1,nfit evec(j,j) = evec(j,j)*(1.0+alamda) !+alamda end do call SVDSYDC(evec,w,tmp,nfit,DIMFIT) call minmax(w,nfit,wmin,wmax,imin,imax,nsvfit) ! get wmax thresh = tol*wmax do j= 1,nfit if (w(j).lt.thresh) w(j) = 0.D0 end do call minmax(w,nfit,wmin,wmax,imin,imax,nsvfit) ! get nsvfit call svdsybk(evec,w,nfit,DIMFIT,beta,dpar,tmp) C rescale if (fitscl.eq.0) then do j = 1, nfit dpar(j)=dpar(j)/dsqrt(alpha(j,j)) end do end if C multiply the scale factor palc(i,-1) do j = 1, nfit if (palc(j,-1).ne.0.0) dpar(j)=dpar(j)*palc(j,-1) end do C put the variations of a into da do b= 1, nb do j = 1, npar da(j,b)=0.0d0 end do end do do j = 1, nfit do i = 1, pali(j,0,1) k=pali(j,i,1) b=pali(j,i,2) da(k,b)=da(k,b)+dpar(j)*palc(j,i) end do end do do b= 1, nb do j= 1, npar anew(j,b)=a(j,b)+da(j,b)*stepw end do end do end if C ----------------------------- calc. of errors ---------------- C don't use lambda in last cylce if (fstat.lt.0) then do j = 1,nfit if (fitscl.eq.0) then do k = 1,j evec(j,k) = alpha(j,k)/dsqrt(alpha(j,j)*alpha(k,k)) end do else do k = 1,j evec(j,k) = alpha(j,k) end do end if end do C calculate the covar = inverse of alpha call SVDSYDC(evec,w,tmp,nfit,DIMFIT) call minmax(w,nfit,wmin,wmax,imin,imax,nsvfit) ! get wmax if (svderr.eq.0 ) then thresh = EPS*wmax else thresh = tol*wmax end if do j= 1,nfit if (w(j).lt.thresh) w(j) = 0.D0 end do call minmax(w,nfit,wmin,wmax,imin,imax,nsvfit) ! get nsvfit if (svderr.le.0 ) then do j= 1,nfit if (w(j).eq.0.0d0) w(j) = thresh end do end if call svdsyinv(evec,w,nfit,DIMFIT,covar) C rescale covar if (fitscl.eq.0) then do j = 1, nfit do k = 1, nfit covar(j,k)=covar(j,k)/dsqrt(alpha(j,j)*alpha(k,k)) end do end do end if C da contains the errors of the input parameters C dyda is used as a temporary vector do b = 1, nb do k = 1, npar if (ifit(k,b).le.0) goto 10 do i = 1, nfit dyda(i) = 0.0d0 end do do i = 1, nfit do j = 1, pali(i,0,1) if ((pali(i,j,1).eq.k).and.(pali(i,j,2).eq.b)) then dyda(i)=palc(i,j) end if end do end do do ir = 1, nfit tmp(ir) = 0.0d0 end do do ir = 1, nfit do ic = 1, nfit tmp(ir)=tmp(ir)+covar(ir,ic)*dyda(ic) end do end do da(k,b)=0.0d0 do ir = 1, nfit da(k,b)=da(k,b)+dyda(ir)*tmp(ir) end do da(k,b)=dsqrt(da(k,b)) 10 continue end do end do C anew contains now the errors of the fitted linear comb. do j = 1, nfit ir=mod(j-1,DIMPAR)+1 ic=int((j-1)/DIMPAR)+1 anew(ir,ic)=dsqrt(covar(j,j)) end do do j=1, nfit freed(j) = -99.0 end do do i = 1,nfit C calc cofreedom matrix on lower left side of covar do j = 1,i - 1 covar(i,j) = $ dsqrt(dsqrt((1.0d0-alpha(i,j)**2 $ / (alpha(i,i)*alpha(j,j)))* $ (1.0d0-covar(i,j)**2 $ / (covar(i,i)*covar(j,j))))) end do C calc correlation matrix on upper right side of covar do j = i + 1, nfit covar(i,j) = covar(i,j)/dsqrt(covar(i,i)*covar(j,j)) end do end do C calc freedom parameters on diagonal of covar do j = 1, nfit covar(j,j) = 1.0d0/dsqrt(alpha(j,j)*covar(j,j)) end do end if return end C --------------------------------------------------------------------- subroutine minmax(w,n,min,max,imin,imax,nw) implicit none integer n,imin,imax,nw real*8 w(n),min,max integer i min= 1.0d100 max=-1.0d100 imin=0 imax=0 nw=0 do i=1, n if (w(i).gt.max) then max=w(i) imax=i end if if (w(i).ne.0.0d0) then nw=nw+1 if (w(i).lt.min) then min=w(i) imin=i end if end if end do return end C --------------------------------------------------------------------- subroutine SVDSYDC(A,W,TMP,N,DIMA) C SVD decomposition of a reell symmetric matrix integer dima,n,ierr real*8 a(DIMA,DIMA),w(DIMA),tmp(DIMA) if (n.gt.dima) stop 'Dimension Error in SCDSYDC' call hdiag(dima,n,a,w,tmp,ierr) if (ierr.ne.0) then write (*,'(a,i5)') 'SVDSYDC: Error in hdiag (sydsycd)',ierr write (*,'(60F10.4)') (a(i,i),i=1,n) stop endif call eigsrt(w,a,n,dima) return end C --------------------------------------------------------------------- subroutine svdsybk(a,w,n,dima,b,x,tmp) implicit none integer n, dima real*8 a(dima,dima), w(n), b(n), x(n), tmp(n) integer i,j C tmp=A*b do i=1, n tmp(i)=0.0 if (w(i).ne.0.0d0) then do j=1, n tmp(i)=tmp(i)+a(j,i)*b(j) end do tmp(i)=tmp(i)/w(i) end if end do C do i=1,n x(i)=0.0d0 do j=1,n x(i)=x(i)+a(i,j)*tmp(j) end do end do return end C --------------------------------------------------------------------- subroutine svdsyinv(evec,w,n,dima,ai) implicit none integer n,dima real*8 evec(dima,dima), w(n), ai(dima,dima) integer i,j,k do i=1,n do j=1,n ai(i,j)=0.0d0 end do do k=1,n if (w(k).ne.0.0d0) then do j=1,n ai(i,j)=ai(i,j)+evec(i,k)*evec(j,k)/w(k) end do end if end do end do return end C C------------------------------------------------------------------------------ C C module MGETX.FOR C C------------------------------------------------------------------------------ C C ------------------------------------------------------- C getbuf(gu,unit) C nx_ss(gu) C pr_ss(gu) C rd_ss(gu,ss) C len_ss(gu) C end_ss(gu) C C -------------------------------------------------------------------- integer function getbuf(gu,ui) C read from unit ui, eleminates comments, and copies into buf C sets bi (buf index) to 1 C sets pointer bp(bi) (buf poiter) to 1 (beginnig of buf) C sets pointer bl (buf length) to end of buf C readln returns the iostat of the last read statement implicit none include 'mgetx_.for' integer gu,ierr,i,ui,endp,maxl logical next,nocom,noquo character*500 instr c character*1 CMT1a,CMT1b,CMT2,CMT3,QUOT integer nx_ss external nx_ss maxl=len(buf) next =.true. ! next line is to be read nocom=.true. ! no comment mode noquo=.true. ! no quote mode bl=0 call fillsp(buf) do while (next.or.(.not.nocom)) call fillsp(instr) next=.false. read(unit=ui,fmt='(A)',iostat=ierr,err=10) instr C get the pointer endp to the end of instr i=len(instr) do while ((i.ge.1).and.(instr(i:i).le.' ')) i=i-1 end do endp=i i=1 do while (i .le. min(len(instr),maxl,endp)) if (nocom) then if (instr(i:i) .eq. QUOT) then if (noquo) then noquo=.false. else noquo=.true. end if end if if (noquo) then next=.false. else next=.true. end if end if C if in quot modus, skip all comments if (.not.noquo) goto 30 C eliminates TAB if (instr(i:i).eq.char(9)) instr(i:i)=' ' C ignore all other nonprintable characters if (instr(i:i).lt.' ') goto 20 if (nocom) then if (instr(i:i) .eq. CMT1a) then nocom=.false. end if end if if (nocom) then if (instr(i:i) .eq. CMT2) then i=len(instr) ! abbruch goto 20 end if end if if (nocom) then if (instr(i:i) .eq. CMT3) then if ((i.lt.min(len(instr),maxl,endp)).and. $ ((instr(i+1:i+1).eq.CMT1a) $ .or.(instr(i+1:i+1).eq.CMT2) $ .or.(instr(i+1:i+1).eq.CMT3))) then i=i+1 else next = .true. i=len(instr) ! abbruch goto 20 end if end if end if 30 continue if (nocom) then bl=bl+1 buf(bl:bl)=instr(i:i) end if if (.not.nocom) then if (instr(i:i) .eq. CMT1b) then nocom=.true. end if end if 20 continue i=i+1 end do ! i end do ! read instr bp=1 C get the first non blank character do while ((buf(bp:bp).eq.' ').and.(bp.le.bl)) bp=bp+1 end do bpf=bp bpl=0 bpsp=0 getbuf = bl-bp+1 if (rdldbg.gt.0) call writebuf(0) return 10 getbuf = ierr call writebuf(0) return end C -------------------------------------------------------------------- integer function nx_ss(gu) C delete leading spaces, commas and semicolons C set bpf (buf pointer first) to first character C set bpl (buf pointer last) to last character C returns -1 if end of line reached implicit none include 'mgetx_.for' integer gu,p logical noquo p=bp C get the first non blank character do while ((buf(p:p).eq.' ').and.(p.le.bl)) p=p+1 end do bpf=p bp=p C scan over the string and stop when a blank of delimiter is reached C if a quote character is found, scan to the next quote ignoring all C delimiters and spaces noquo=.false. do while (((buf(p:p).ne.' ') & .and.(buf(p:p).ne.',') & .and.(buf(p:p).ne.';') & .and.(p.le.bl)) $ .or.noquo) if (buf(p:p).eq.QUOT) then if (noquo) then noquo=.false. else noquo=.true. end if end if p=p+1 end do bpl=p-1 C eliminate the following spaces do while ((buf(p:p).eq.' ').and.(p.le.bl)) p=p+1 end do del_ss=0 C and a following delimiter if ((buf(p:p).eq.',').or.(buf(p:p).eq.';')) then p=p+1 del_ss=1 end if bp=p nx_ss=bpl-bpf+1 if (bpf.gt.bl) nx_ss=-1 if (rdldbg.gt.2) then if (bpf.le.bpl) $ write(0,'(3I4,3A)') p,bpf,bpl,'>>',buf(bpf:bpl),'<<' if ((bpf.gt.bpl).and.(bpf.le.bl)) $ write(0,'(3I4,1A)') p,bpf,bpl,'>><<' if (bpf.gt.bl) $ write(0,'(3I4,1A)') p,bpf,bpl,'>>EOF<<' end if return end C -------------------------------------------------------------------- subroutine setdbg(i) implicit none integer i include 'mgetx_.for' rdldbg=i return end C -------------------------------------------------------------------- integer function rd_ss(gu,ss) C ReaD one SubString of the input buffer taking quotes into account C and interprets a double quote '' as a single ' (fortran like) C returns the length of ss implicit none integer gu,i,j,p character*(*) ss include 'mgetx_.for' call fillsp(ss) j=0 p=bpf-1 do i=bpf, bpl p=p+1 if (buf(p:p).ne.QUOT) then j=j+1 if (len(ss).ge.j) ss(j:j)=buf(p:p) else if (p.lt.bpl) then if (buf(p+1:p+1).eq.QUOT) then j=j+1 p=p+1 if (len(ss).ge.j) ss(j:j)=buf(p:p) end if end if end if end do rd_ss=j return end C -------------------------------------------------------------------- integer function len_ss(gu) C returns the length of the next substring in the input buffer C analog rd_ss implicit none integer gu,i,j,p include 'mgetx_.for' j=0 p=bpf-1 do i=bpf, bpl p=p+1 if (buf(p:p).ne.QUOT) then j=j+1 else if (p.lt.bpl) then if (buf(p+1:p+1).eq.QUOT) then j=j+1 p=p+1 end if end if end if end do len_ss=j return end C -------------------------------------------------------------------- logical function end_ss(gu) implicit none integer gu include 'mgetx_.for' end_ss=.false. if (del_ss.ge.1) end_ss=.true. return end C -------------------------------------------------------------------- logical function nx_end(gu) implicit none integer gu include 'mgetx_.for' if (bp.lt.bl) then nx_end=.false. else nx_end=.true. end if return end C -------------------------------------------------------------------- logical function is_end(gu) implicit none integer gu include 'mgetx_.for' if (bpf.le.bl) then is_end=.false. else is_end=.true. end if return end C -------------------------------------------------------------------- logical function getend(gu) implicit none integer gu include 'mgetx_.for' if (bpf.le.bl) then getend=.false. else getend=.true. end if return end C --------------------------------------------------------------- subroutine fillsp(var) implicit none character*(*) var integer i do i=1, len(var) var(i:i)=' ' end do return end C --------------------------------------------------------------------- subroutine writebuf(UI) implicit none include 'mgetx_.for' integer ui if (bp.le.bl) write(UI,'(A)') buf(bp:bl) return end C -------------------------------------------------------------------- block data getxdb implicit none include 'mgetx_.for' data rdldbg /0/ end C --------------------------------------------------------------------- logical function isdecno(c) implicit none character*(*) c if (((c(1:1).ge.'0').and.(c(1:1).le.'9')).or. $ ((c(2:2).ge.'0').and.(c(2:2).le.'9').and. $ ((c(1:1).eq.'-').or.(c(1:1).eq.'+').or.(c(1:1).eq.'.'))).or. $ ((c(3:3).ge.'0').and.(c(3:3).le.'9').and.(c(2:2).eq.'.').and. $ ((c(1:1).eq.'-').or.(c(1:1).eq.'+')))) then isdecno=.true. else isdecno=.false. end if return end C --------------------------------------------------------------------- logical function isdualno(c) implicit none character*(*) c if (len(c).lt.2) then isdualno=.false. return end if if (((c(1:1).eq.'%').and.(c(2:2).eq.'0')).or. $ ((c(1:1).eq.'%').and.(c(2:2).eq.'1'))) then isdualno=.true. else isdualno=.false. end if return end C --------------------------------------------------------------------- logical function ishexno(c) implicit none character*(*) c if (len(c).lt.2) then ishexno=.false. return end if if (((c(1:1).eq.'0').and.(c(2:2).eq.'X')).or. $ ((c(1:1).eq.'0').and.(c(2:2).eq.'x'))) then ishexno=.true. else ishexno=.false. end if return end C --------------------------------------------------------------------- integer function isnumber(c) implicit none character*(*) c logical isdualno, isdecno, ishexno, isvar external isdualno, isdecno, ishexno, isvar isnumber=0 if (isdecno(c)) isnumber=1 if (isdualno(c)) isnumber=2 if (ishexno(c)) isnumber=3 if (isvar(c)) isnumber=4 return end C --------------------------------------------------------------------- integer function isoper(c) implicit none character*(*) c if (len(c).lt.1) then isoper=0 return end if isoper=0 if ((c(1:1).eq.'+').and.(c(2:2).eq.' ')) isoper=1 if ((c(1:1).eq.'-').and.(c(2:2).eq.' ')) isoper=2 return end C --------------------------------------------------------------------- logical function isvar(c) implicit none character*(*) c isvar=.false. if (c(1:1).eq.'$') isvar=.true. return end C --------------------------------------------------------------------- integer function dualread(var) implicit none character*(*) var integer i,z,j i=0 z=1 do j=len(var),2,-1 if (var(j:j).eq.'1') i=i+z if ((var(j:j).eq.'1').or.(var(j:j).eq.'0')) then z=z*2 else if (var(j:j).ne.' ') then write(0,'(A,A)') 'supposed binary: ',var stop 'ERROR: binary constant must be of 0 and 1' end if end do dualread=i return end C --------------------------------------------------------------------- integer function hexread(var) implicit none character*(*) var integer i,z,j logical hexfnd integer asc external asc i=0 z=1 C do loop down to 3 to ignore leading '0x' do j=len(var),3,-1 if (var(j:j).ne.' ') then hexfnd=.false. if ((var(j:j).ge.'0').and.(var(j:j).le.'9')) then i=i+z*(asc(var(j:j))-asc('0')) hexfnd=.true. end if if ((var(j:j).ge.'a').and.(var(j:j).le.'f')) then i=i+z*(asc(var(j:j))-asc('a')+10) hexfnd=.true. end if if ((var(j:j).ge.'A').and.(var(j:j).le.'F')) then i=i+z*(asc(var(j:j))-asc('A')+10) hexfnd=.true. end if z=z*16 if (.not.hexfnd) then write(0,'(A,A)') 'supposed hexadecimal: ',var stop 'ERROR: hex digit out of range !' end if end if end do hexread=i return end C --------------------------------------------------------------------- integer function asc(var) implicit none character*(*) var character*1 c integer i c=var(1:1) asc=ichar(c) return end C --------------------------------------------------------------------- integer function ss2iv(c,i,vard,varc,ivar) implicit none character*(*) c integer ivar character*(*) varc(ivar) real*8 vard(ivar) integer isno,i integer isnumber,dualread,hexread real*8 varread external isnumber,dualread,hexread external varread i=0 isno=isnumber(c) if (isno.eq.1) read(c,'(I40)') i if (isno.eq.2) i=dualread(c) if (isno.eq.3) i=hexread(c) if (isno.eq.4) i=varread(c,vard,varc,ivar) ss2iv=isno return end C --------------------------------------------------------------------- integer function ss2dv(c,d,vard,varc,ivar) implicit none character*(*) c real*8 d integer ivar character*(*) varc(ivar) real*8 vard(ivar) integer isno integer isnumber,dualread,hexread real*8 varread external isnumber,dualread,hexread external varread d=0.0 isno=isnumber(c) if (isno.eq.1) read(c,'(F40.0)') d if (isno.eq.2) d=dualread(c) if (isno.eq.3) d=hexread(c) if (isno.eq.4) d=varread(c,vard,varc,ivar) ss2dv=isno return end C --------------------------------------------------------------------- integer function ss2i(c,i) implicit none character*(*) c integer isno,i integer isnumber,dualread,hexread external isnumber,dualread,hexread i=0 isno=isnumber(c) if (isno.eq.1) read(c,'(I40)') i if (isno.eq.2) i=dualread(c) if (isno.eq.3) i=hexread(c) ss2i=isno return end C --------------------------------------------------------------------- integer function ss2d(c,d) C converts a substring into a real number C returns the typ of number (isnumber) C returns zero if no valid number was found implicit none character*(*) c real*8 d integer isno integer isnumber,dualread,hexread external isnumber,dualread,hexread d=0.0 isno=isnumber(c) if (isno.eq.1) read(c,'(F40.0)') d if (isno.eq.2) d=dualread(c) if (isno.eq.3) d=hexread(c) ss2d=isno return end C --------------------------------------------------------------------- real*8 function varread(c,vard,varc,ivar) implicit none character*(*) c integer ivar character*(*) varc(ivar) real*8 vard(ivar) integer i,l integer len_c external len_c l=len_c(c) do i=1, ivar if (varc(i)(1:l-1).eq.c(2:l)) then varread=vard(i) goto 10 end if end do write(0,'(3A)') ' ERROR: Variable ',c(1:l),' not defined !' stop 10 continue return end C- -------------------------------------------------------------------- integer function len_c(c) implicit none character*(*) c integer i do i=len(c),1,-1 if (c(i:i).gt.' ') goto 10 end do 10 continue len_c=i return end C --------------------------------------------------------------------- integer function getc(gu,c) implicit none integer gu character*(*) c integer l integer nx_ss,rd_ss external nx_ss,rd_ss l=nx_ss(gu) if (l.lt.0) goto 10 l=rd_ss(gu,c) 10 continue getc=l return end C --------------------------------------------------------------------- integer function getcd(gu,c,d) implicit none integer gu character*(*) c real*8 d,dd integer no,l logical end_ss external end_ss integer nx_ss,rd_ss,getd external nx_ss,rd_ss,getd l=0 dd=d no=getd(gu,dd) C write(0,'(A,I3,$)') ' no-a',no if (no.le.0) then l=nx_ss(gu) l=rd_ss(gu,c) no=getd(gu,d) C write(0,'(A,I3,$)') ' no-b',no else d=dd end if getcd=no+10*l C write(0,'(A,I3)') ' getcd',no+10*l,no return end C --------------------------------------------------------------------- integer function getd(gu,d) C gets a number (with calculations) out of buffer C if no number was found : returns a zero C does not advance buffer poiter C sets d to zero C returns a value .gt. zero if a number d was read. implicit none integer gu real*8 d,dd include 'mgetx_.for' integer no,op integer xgetop,xgetd logical end_ss external xgetop,xgetd,end_ss no=0 op=xgetop(gu) if (end_ss(gu).and.(op.gt.0)) goto 30 10 continue no=xgetd(gu,dd) if ((no.le.0).and.(op.gt.0)) goto 30 if (op.eq.0) d=dd if (op.eq.1) d=d+dd if (op.eq.2) d=d-dd if (end_ss(gu)) goto 20 op=xgetop(gu) if (op.gt.0) goto 10 20 continue getd=no goto 40 30 continue getd=5 if (op.eq.2) d=-d 40 continue return end C --------------------------------------------------------------------- integer function geti(gu,i) C gets a number (with calculations) out of buffer C if no number was found : returns a zero C does not advance buffer poiter C sets d to zero C returns a value .gt. zero if a number d was read. implicit none integer gu integer i,ii include 'mgetx_.for' integer no,op integer xgetop,xgeti logical end_ss external xgetop,xgeti,end_ss no=0 op=xgetop(gu) if (end_ss(gu).and.(op.gt.0)) goto 30 10 continue no=xgeti(gu,ii) if ((no.le.0).and.(op.gt.0)) goto 30 if (op.eq.0) i=ii if (op.eq.1) i=i+ii if (op.eq.2) i=i-ii if (end_ss(gu)) goto 20 op=xgetop(gu) if (op.gt.0) goto 10 20 continue geti=no goto 40 30 continue geti=5 if (op.eq.2) i=-i 40 continue return end C --------------------------------------------------------------------- integer function xgetop(gu) implicit none integer gu,l,op character*(40) ss integer m integer nx_ss,s_mark,rd_ss,isoper external nx_ss,s_mark,rd_ss,isoper op=0 m=s_mark(gu) l=nx_ss(gu) l=rd_ss(gu,ss) c write(0,'(2A)') 'xgetop:',ss(1:5) if (l.le.0) then call g_mark(gu,m) else op=isoper(ss) if (op.le.0) call g_mark(gu,m) end if xgetop=op return end C --------------------------------------------------------------------- integer function xgetd(gu,d) implicit none integer gu,l,no,m real*8 d character*(40) ss integer nx_ss,s_mark,rd_ss,ss2d external nx_ss,s_mark,rd_ss,ss2d d=0.0 no=0 m=s_mark(gu) l=nx_ss(gu) l=rd_ss(gu,ss) if (l.le.0) then call g_mark(gu,m) else no=ss2d(ss,d) c write(0,'(2A)') 'xgetd: ',ss(1:5) if (no.le.0) call g_mark(gu,m) end if xgetd=no return end C --------------------------------------------------------------------- integer function xgeti(gu,i) implicit none integer gu,l,no,m,i character*(40) ss integer nx_ss,s_mark,rd_ss,ss2i external nx_ss,s_mark,rd_ss,ss2i i=0 no=0 m=s_mark(gu) l=nx_ss(gu) l=rd_ss(gu,ss) if (l.le.0) then call g_mark(gu,m) else no=ss2i(ss,i) if (no.le.0) call g_mark(gu,m) end if xgeti=no return end C --------------------------------------------------------------- subroutine pop_mark(gu) implicit none include 'mgetx_.for' integer gu if (bpsp.gt.1) then bpsp=bpsp-1 bp=bp_stack(bpsp) end if return end C --------------------------------------------------------------- subroutine push_mark(gu) implicit none include 'mgetx_.for' integer gu if (bpsp.ge.dimbpst) stop 'Buffer Pointer Stack exceeded !' bpsp=bpsp+1 bp_stack(bpsp)=bp return end C --------------------------------------------------------------- integer function s_mark(gu) implicit none include 'mgetx_.for' integer gu s_mark=bp return end C --------------------------------------------------------------- subroutine g_mark(gu,m) implicit none include 'mgetx_.for' integer gu,m bp=m return end C --------------------------------------------------------------------- subroutine getln(gu,varc,vard,varx,DIMVAR) implicit none integer gu,DIMVAR character*(*) varc(DIMVAR) real*8 vard(DIMVAR) integer varx(DIMVAR) C ..local integer lasthit,ilen,iq,ihit,qdef,no,l,strt,ovrwr real*8 dqn,oldv character*40 chrqn,ochrqn C ..externals logical is_end integer getd,nx_ss,pr_ss,rd_ss,s_mark external is_end external getd,nx_ss,pr_ss,rd_ss,s_mark call fillsp(ochrqn) call fillsp(chrqn) qdef=0 C write(0,*) 'start getln' do while (.not.is_end(gu)) C write(0,*) 'start getln loop' strt = s_mark(gu) no=getd(gu,dqn) if (no.le.0) then l=nx_ss(gu) l=rd_ss(gu,chrqn) ochrqn=chrqn strt = s_mark(gu) else chrqn=ochrqn end if if (chrqn(1:1).eq.' ') then qdef=qdef+1 if (qdef.gt.DIMVAR) return chrqn=varc(qdef) end if ilen=1 do while (chrqn(ilen:ilen).ne.' ') ilen=ilen+1 end do ilen=ilen-1 C write(0,*) 'getln:',chrqn(1:ilen),no,ilen ihit=0 ovrwr=0 33 continue do iq=1,DIMVAR if (chrqn(1:ilen).eq.varc(iq)(1:ilen)) then C write(0,*) 'getln:>>',varc(iq),'<<' if (varx(iq).eq.ovrwr) then ihit=ihit+1 lasthit=iq call g_mark(gu,strt) oldv=vard(iq) no=getd(gu,vard(iq)) C write(0,*) no,ihit,vard(iq) if (ovrwr.eq.1) write(0,*) $ ' GETLN: overwriting ',chrqn(1:ilen) $ ,' from ',oldv,' to ',vard(iq) varx(iq)=ihit else if (varx(iq).gt.1) then ihit=ihit+1 lasthit=iq call g_mark(gu,strt) no=getd(gu,vard(iq)) C write(0,*) no,ihit,vard(iq) varx(iq)=varx(iq)-1 end if end if end if end do if (ihit.eq.1) varx(lasthit)=1 if ((ovrwr.eq.0).and.(ihit.eq.0)) then ovrwr=1 goto 33 end if if ((ovrwr.eq.1).and.(ihit.eq.0)) then write(0,'(2A)') $ 'Input Error: undef character ',chrqn(1:ilen) end if if (ihit.eq.1) then call fillsp(ochrqn) end if end do return end C ------------------------------------------------------- subroutine ind_ss(c,maxi,i1,i2,j2) implicit none C i1,i2 : index of array C j2 : len of substring of c without array information C maxi : maximal arrayelement number integer maxi,i1,i2,j2 character*(*) c character*(40) cc integer i,l,h1,h2,x1,x2 l=len(c) h1=0 h2=0 x1=0 x2=0 do i=1, l if (c(i:i).eq.'(') then x1=i h1=h1+1 end if if (c(i:i).eq.')') then x2=i h2=h2+1 endif if (h2.gt.h1) stop ' index error 2' if (c(i:i).eq.' ') goto 10 end do 10 continue i1=1 i2=maxi j2=i-1 if (h1.ne.h2) stop ' index error 1' if ((h1.eq.0).and.(h2.eq.0)) return j2=x1-1 if (x1.ge.(x2-1)) return do i=x1+1,x2-1 if ((c(i:i).lt.'0').or.(c(i:i).gt.'9')) then if ((c(i:i).ne.'-').and.(c(i:i).ne.':')) $ stop 'index range - or :' goto 20 end if end do 20 continue if (i.gt.(x1+1)) then call fillsp(cc) cc=c(x1+1:i-1) read(cc,'(I40)') i1 end if i2=i1 if (i.eq.x2) goto 30 i2=maxi if ((i+1).eq.x2) goto 30 call fillsp(cc) cc=c(i+1:x2-1) read(cc,'(I40)') i2 30 continue if ((i1.lt.1).or.(i2.lt.1)) stop ' index .lt. 1' if ((i1.gt.maxi).or.(i2.gt.maxi)) stop ' index gt maxi' return end C --------------------------------------------------------------------- subroutine getxln(gu,varc,vard,varx,DIMVAR,DIMP) implicit none integer gu,DIMVAR,DIMP character*(*) varc(DIMVAR) real*8 vard(DIMVAR,DIMP) integer varx(DIMVAR,DIMP) C ..local integer lasthit,ilen,iq,ihit,qdef,no,l,strt integer id,i1,i2,ovrwr real*8 dqn,oldv character*40 chrqn,ochrqn C ..externals logical is_end integer getd,nx_ss,pr_ss,rd_ss,s_mark external is_end external getd,nx_ss,pr_ss,rd_ss,s_mark call fillsp(ochrqn) call fillsp(chrqn) qdef=0 C write(0,*) 'start getln' do while (.not.is_end(gu)) C write(0,*) 'start getln loop' strt = s_mark(gu) no=getd(gu,dqn) if (no.le.0) then l=nx_ss(gu) l=rd_ss(gu,chrqn) ochrqn=chrqn strt = s_mark(gu) else chrqn=ochrqn end if if (chrqn(1:1).eq.' ') then qdef=qdef+1 if (qdef.gt.DIMVAR) return chrqn=varc(qdef) end if call ind_ss(chrqn,DIMP,i1,i2,ilen) C write(0,*) 'getln:',chrqn(1:ilen),no,ilen,i1,i2 do id=i1,i2 ihit=0 ovrwr=0 33 continue do iq=1,DIMVAR if (chrqn(1:ilen).eq.varc(iq)(1:ilen)) then C write(0,*) 'getln:>>',varc(iq),'<<' if (varx(iq,id).eq.ovrwr) then ihit=ihit+1 lasthit=iq call g_mark(gu,strt) oldv=vard(iq,id) no=getd(gu,vard(iq,id)) C write(0,*) no,ihit,vard(iq,id) varx(iq,id)=ihit if (ovrwr.eq.1) write(0,*) $ 'GETXLN: overwriting ',chrqn(1:ilen) $ ,' from ',oldv,' to ',vard(iq,id) else if (varx(iq,id).gt.1) then ihit=ihit+1 lasthit=iq call g_mark(gu,strt) no=getd(gu,vard(iq,id)) C write(0,*) no,ihit,vard(iq,id) varx(iq,id)=varx(iq,id)-1 end if end if end if end do if (ihit.eq.1) varx(lasthit,id)=1 if ((ovrwr.eq.0).and.(ihit.eq.0)) then ovrwr=1 goto 33 end if if ((ovrwr.eq.1).and.(ihit.eq.0)) then write(0,'(2A)') $ 'Input Error: undef character ',chrqn(1:ilen) end if if (ihit.eq.1) then call fillsp(ochrqn) end if end do end do return end C C------------------------------------------------------------------------------ C C module IAMSYS.FOR C C------------------------------------------------------------------------------ C C C This file contains system dependend subroutines and functions. C Modify it for your system/compiler! C the "myand" and "myor" functions are demanded by xiam, C "mysignal" and "mydate" are optional. C integer function myand(i1,i2) C some compiler don't know the generic "and", C use "iand" instead. C if neiher "and" nor "iand" is available you're in trouble here. implicit none integer i1,i2 c myand=and(i1,i2) myand=iand(i1,i2) ZK return end integer function myor(i1,i2) C some compiler don't know the generic "or", C use "ior" instead. implicit none integer i1,i2 c myor=or(i1,i2) myor=ior(i1,i2) ZK return end subroutine mysignal() implicit none integer sig_stat common/sig_com/sig_stat external sig_func C for most unix systems signal(2) means SIGINT=control C (see e.g. /usr/include/signal.h) C if signal is not known to your (unix) f77 compiler, C try _signal or signal_ C on other machines (DOS, VMS), comment the next line out. C C signal works with: C AIX xlf C C signal does not work with: C linux g77 c call c_signal() return end subroutine mydate() C this subroutine writes the date and time to stdout C other compiler may use other functions. C VMS use SYS$... functions. implicit none C If you find no corresponding commands for your compiler simple C comment it out. c call dateput() return end C C------------------------------------------------------------------------------ C C module IAMLIB.FOR C C------------------------------------------------------------------------------ C C C Herbert M. Pickett, 24 Feb 1989 C Adapted from subset of BLAS routines in LINPAK C FUNCTION IDAMAX(N,SX,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C REAL*8 SX(0:*),SMAX INTEGER IDAMAX,N,INCX,I,M INTEGER*4 IX C EMA SX C IDAMAX = 0 M=N-1 IF(M.LE.0) THEN IF(M.LT.0) IDAMAX=-1 ELSE IF(INCX.NE.1) THEN C C CODE FOR INCREMENT NOT EQUAL TO 1 C SMAX = ABS(SX(0)) IX = INCX DO 10 I = 1,M IF(ABS(SX(IX)).GT.SMAX) THEN IDAMAX = I SMAX = ABS(SX(IX)) ENDIF IX = IX + INCX 10 CONTINUE ELSE C C CODE FOR INCREMENT EQUAL TO 1 C SMAX = ABS(SX(0)) DO 30 I = 1,M IF(ABS(SX(I)).GT.SMAX) THEN IDAMAX = I SMAX = ABS(SX(I)) ENDIF 30 CONTINUE ENDIF IDAMAX=IDAMAX+1 RETURN END FUNCTION DASUM(N,SX,INCX) C C TAKES THE SUM OF THE ABSOLUTE VALUES. C REAL*8 DASUM,SX(0:*) INTEGER I,INCX,N,M INTEGER*4 IX C EMA SX C DASUM = 0 M=N-1 IF(M.GE.0) THEN IF(INCX.NE.1) THEN C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX=0 DO 10 I = 1,N DASUM = DASUM + ABS(SX(IX)) IX = IX + INCX 10 CONTINUE ELSE C C CODE FOR INCREMENT EQUAL TO 1 C C DO 30 I = 0,M DASUM = DASUM + ABS(SX(I)) 30 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE DAXPY(N,SA,SX,INCX,SY,INCY) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C REAL*8 SX(0:*),SY(0:*),SA INTEGER I,INCX,INCY,N,M INTEGER*4 IX,IY C EMA SX,SY C M=N-1 IF(M.LT.0)RETURN IF(SA.EQ.0) RETURN IF(INCX.NE.1)GO TO 20 IF(INCY.NE.1)GO TO 20 C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C DO 30 I = 0,M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE RETURN C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C 20 IX = 0 IF(INCX.LT.0) IX = -M*INCX IY = 0 IF(INCY.LT.0) IY = -M*INCY DO 10 I = 1,N SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN END SUBROUTINE DCOPY(N,SX,INCX,SY,INCY) C C COPIES A VECTOR, X, TO A VECTOR, Y. C REAL*8 SX(0:*),SY(0:*),SA INTEGER I,INCX,INCY,N,M INTEGER*4 IX,IY C EMA SX,SY C M=N-1 IF(M.LT.0)RETURN IF(INCX.EQ.0) THEN SA=SX(0) IF(INCY.NE.1) THEN C C CODE FOR FILL AND INCREMENT NOT EQUAL TO 1 C IY = 0 IF(INCY.LT.0) IY = -M*INCY DO 10 I = 1,N SY(IY) = SA IY = IY + INCY 10 CONTINUE ELSE C C CODE FOR FILL AND INCREMENT EQUAL TO 1 C C DO 20 I = 0,M SY(I) = SA 20 CONTINUE ENDIF ELSE IF(INCX.NE.1.OR.INCY.NE.1) THEN C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 0 IF(INCX.LT.0)IX = -M*INCX IY = 0 IF(INCY.LT.0)IY = -M*INCY DO 30 I = 1,N SY(IY) = SX(IX) IX = IX + INCX IY = IY + INCY 30 CONTINUE ELSE C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C DO 40 I = 0,M SY(I) = SX(I) 40 CONTINUE ENDIF RETURN END FUNCTION DDOT(N,SX,INCX,SY,INCY) C C FORMS THE DOT PRODUCT OF TWO VECTORS. C REAL*8 DDOT,SX(0:*),SY(0:*) INTEGER I,INCX,INCY,N,M INTEGER*4 IX,IY C EMA SX,SY C DDOT = 0 M=N-1 IF(M.LT.0)RETURN IF(INCX.NE.1)GO TO 20 IF(INCY.NE.1)GO TO 20 C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C DO 30 I = 0,M DDOT = DDOT + SX(I)*SY(I) 30 CONTINUE RETURN C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C 20 IX = 0 IF(INCX.LT.0)IX = -M*INCX IY = 0 IF(INCY.LT.0)IY = -M*INCY DO 10 I = 1,N DDOT = DDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN END SUBROUTINE DSCAL(N,SA,SX,INCX) C C SCALES A VECTOR BY A CONSTANT. C REAL*8 SA,SX(0:*) INTEGER I,INCX,N,M INTEGER*4 IX C EMA SX C M=N-1 IF(M.LT.0) RETURN IF(SA.EQ.1) RETURN IF(INCX.EQ.1) GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX=0 DO 10 I = 1,N SX(IX) = SA*SX(IX) IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DO 30 I = 0,M SX(I) = SA*SX(I) 30 CONTINUE RETURN END SUBROUTINE DSWAP (N,SX,INCX,SY,INCY) C C INTERCHANGES TWO VECTORS. C REAL*8 SX(0:*),SY(0:*),STEMP INTEGER I,INCX,INCY,N,M INTEGER*4 IX,IY C EMA SX,SY C M=N-1 IF(M.LT.0) RETURN IF(INCX.NE.1) GO TO 20 C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C DO 30 I = 0,M STEMP = SX(I) SX(I) = SY(I) SY(I) = STEMP 30 CONTINUE RETURN C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL C TO 1 C 20 IX = 0 IF(INCX.LT.0)IX = -M*INCX IY = 0 IF(INCY.LT.0)IY = -M*INCY DO 10 I = 1,N STEMP = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN END SUBROUTINE DROT (N,SX,INCX,SY,INCY,C,S) C C APPLIES A PLANE ROTATION. C REAL*8 SX(0:*),SY(0:*),C,S,STEMP INTEGER INCX,INCY,N,I,M INTEGER*4 IX,IY C EMA SX,SY C M=N-1 IF(M.LT.0)RETURN IF(INCX.NE.1) GO TO 20 IF(INCY.NE.1) GO TO 20 C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C DO 30 I = 0,M STEMP = SX(I)*C + SY(I)*S SY(I) = SY(I)*C - SX(I)*S SX(I) = STEMP 30 CONTINUE C RETURN C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL C TO 1 C 20 IX = 0 IF(INCX.LT.0)IX = -M*INCX IY = 0 IF(INCY.LT.0)IY = -M*INCY DO 10 I = 1,N STEMP = SX(IX)*C + SY(IY)*S SY(IY) = SY(IY)*C - SX(IX)*S SX(IX) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN END SUBROUTINE EIGSRT(D,V,N,NP) C sort eigenvectors in ascending order implicit none INTEGER N,NP,I,J,K REAL*8 D(NP),V(NP,NP),P DO 13 I=1,N-1 K=I P=D(I) DO 11 J=I+1,N IF(D(J).LE.P)THEN K=J P=D(J) ENDIF 11 CONTINUE IF(K.NE.I)THEN D(K)=D(I) D(I)=P DO 12 J=1,N P=V(J,I) V(J,I)=V(J,K) V(J,K)=P 12 CONTINUE ENDIF 13 CONTINUE RETURN END SUBROUTINE HDIAG(NM,NX,Z,D,E,IERR) C C INTEGER NM,NX,IERR REAL*8 Z(NM,*),D(*),E(*) C EMA Z,D,E C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C MODIFIED TO SPEED UP FOR SPARCE MATRICIES C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C THE SUBROUTINE THEN CALLS TRIAG WHICH DIAGONALIZES C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C NX IS THE ORDER OF THE MATRIX, C C Z CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON CALL TO TRIAG - C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS FIRST N-1 POSITIONS. E(N) IS ARBITRARY, C C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX C PRODUCED IN THE REDUCTION. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ARBITRARY ORDER C C Z CONTAINS THE EIGENVECTORS C C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C ------------------------------------------------------------------ C INTEGER I0,I1 PARAMETER (I0=0,I1=1) REAL*8 MACHEP,F,G,H,T,BB,DDOT,ONE,ZERO PARAMETER (ONE=1.,ZERO=0.) INTEGER I,J,K,L,IZ,LZ,NT1,NT2,NDM,N MACHEP=1.E-30 N=NX NDM=NM C ********** FOR I=N STEP -1 UNTIL 3 DO -- ********** DO 300 I = N,3,-1 L = I - 1 J = L - 1 CALL DCOPY(L,Z(I,1),NDM,D,I1) F=D(L) IZ=0 H=0 C GET SUM OF SQUARES OF ELEMENTS AND FIND FIRST NON-ZERO ELEMENT DO 220 K=J,1,-1 G=D(K)*D(K) IF(G.GT.MACHEP) THEN IZ=K H=H+G ELSE D(K)=0 ENDIF 220 CONTINUE E(I)=F IF(IZ.NE.0) THEN T=F*F IF(H.LT.MACHEP*T) IZ=0 ENDIF IF(IZ.EQ.0) THEN D(L)=0 ELSE G= SIGN( SQRT( H +T ), F) E(I)= -G F= F + G D(L)=F BB=SIGN( ONE, F ) / SQRT( F*G ) LZ=I-IZ CALL DSCAL(LZ,BB,D(IZ),I1) CALL DCOPY(L,D,I1,Z(1,I),I1) C DO 230 J= 1, IZ 230 E(J)= DDOT(LZ,Z(IZ,J),I1,D(IZ),I1) F=-E(IZ)*D(IZ) DO 240 J = IZ+1, L NT1=J-IZ NT2=I-J T= DDOT(NT1,Z(J,IZ),NDM,D(IZ),I1) + +DDOT(NT2,Z(J, J), I1,D( J),I1) E(J)=T 240 F=F-T*D(J) C C ********** FORM REDUCED A ********** DO 260 J = IZ, L H = -D(J) G = F * H - E(J) K = I-J IF(ABS(H).GT.MACHEP) CALL DAXPY(K,H,E(J),I1,Z(J,J),I1) CALL DAXPY(K,G,D(J),I1,Z(J,J),I1) 260 CONTINUE DO 265 J = 1,IZ-1 G = -E(J) CALL DAXPY(LZ,G,D(IZ),I1,Z(IZ,J),I1) 265 CONTINUE ENDIF 300 CONTINUE C D(1)=Z(1,1) Z(1,1)=ONE IF(N.LE.1) THEN IERR=0 RETURN ENDIF D(N)=0 E(2)=Z(2,1) C ********** ACCUMULATION OF TRANSFORMATION MATRICES ********** DO 500 L = 2, N I = L + 1 J = L - 1 E(J)=E(L) F=D(L) D(L)=Z(L,L) IF(F.GT.MACHEP) THEN DO 360 K=1,J G= -DDOT(J,Z(1,I),I1,Z(1,K),I1) IF(ABS(G).GT.MACHEP) CALL DAXPY(J,G,Z(1,I),I1 + ,Z(1,K),I1) Z(L,K)= F * G Z(K,L)= - F * Z(K,I) 360 CONTINUE Z(L,L) = ONE -F*F ELSE Z(L,L) = ONE CALL DCOPY(J,ZERO,I0,Z(1,L),I1) CALL DCOPY(J,ZERO,I0,Z(L,1),NDM) ENDIF 500 CONTINUE C CALL TRIAG(NM,N,Z,D,E,IERR) RETURN END SUBROUTINE TRIAG(NM,NX,Z,D,E,IERR) C INTEGER NM,NX,IERR REAL*8 Z(0:*),D(*),E(*) C EMA Z,D,E C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE imtql2, C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON. C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C NX IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS FIRST N-1 POSITIONS. E(N) IS ARBITRARY, C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ARBITRARY ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1, C C E HAS BEEN DESTROYED, C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C ------------------------------------------------------------------ C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C C ********** INTEGER I1 PARAMETER (I1=1) REAL*8 MACHEP,F,B,P,G,R,C,S INTEGER*4 INDX1,INDX2 INTEGER N,NN,ITR,M,I,NDM,L,MM MACHEP=1.E-15 N=NX C IERR = 0 IF (N .LE. 1) RETURN NN=N-1 NDM=NM E(N) = 0 F = 0 B = 0 C DO 240 L = 1, NN ITR = 31 C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** DO WHILE(ITR.NE.0) M=N DO 110 I = L, NN IF (ABS(E(I)).LE.MACHEP*(ABS(D(I))+ABS(D(I+1)))) THEN M=I GO TO 120 ENDIF 110 CONTINUE C 120 P=D(L) IF (M .EQ. L) GO TO 240 ITR = ITR - 1 IF (ITR .EQ. 0) THEN C ** SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER 30 ITERATIONS ** IERR = L RETURN ENDIF C ********** FORM SHIFT ********** G = E(L) G = ( D(L+1)-P )/( G + G ) R = SQRT(1+G*G) G = D(M) - P + E(L) / ( G +SIGN(R,G) ) C ********** QL TRANSFORMATION ********** P = D(M) C = 1 S = C C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** MM=M-1 INDX2=NDM*MM DO 200 I = MM,L,-1 B=E(I)*C F=E(I)*S IF(ABS(F).GE.ABS(G)) THEN C=G/F R=SQRT(1+C*C) E(I+1)=F*R S=1/R C=C*S ELSE S=F/G R=SQRT(1+S*S) E(I+1)=G*R C=1/R S=S*C ENDIF F=C*D(I)-S*B G=C*B-S*P R=D(I)+P P=C*F-S*G G=S*F+C*G D(I+1)=R-P C ********** FORM VECTOR ********** INDX1=INDX2 INDX2=INDX2-NDM CALL DROT(N,Z(INDX1),I1,Z(INDX2),I1,C,S) C 200 CONTINUE C D(L) = P E(L) = G E(M) = 0 ENDDO 240 CONTINUE RETURN END SUBROUTINE HEIGSRT(D,VR,VI,N,NP) C sort hermitian eigenvectors in ascending order implicit real*8 (a-h,o-z) DIMENSION D(NP),VR(NP,NP),VI(NP,NP) DO 13 I=1,N-1 K=I P=D(I) DO 11 J=I+1,N IF(D(J).LE.P)THEN K=J P=D(J) ENDIF 11 CONTINUE IF(K.NE.I)THEN D(K)=D(I) D(I)=P DO 12 J=1,N P=VR(J,I) VR(J,I)=VR(J,K) VR(J,K)=P P=VI(J,I) VI(J,I)=VI(J,K) VI(J,K)=P 12 CONTINUE ENDIF 13 CONTINUE RETURN END SUBROUTINE HTRIB3(NM,N,A,TAU,M,ZR,ZI) C INTEGER I,J,K,L,M,N,NM DOUBLE PRECISION A(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M) DOUBLE PRECISION H,S,SI C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968) C BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRID3. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS C USED IN THE REDUCTION BY HTRID3. C C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. C C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED C IN ITS FIRST M COLUMNS. C C ON OUTPUT C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (M .EQ. 0) GO TO 200 C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN C TRIDIAGONAL MATRIX. .......... DO 50 K = 1, N C DO 50 J = 1, M ZI(K,J) = -ZR(K,J) * TAU(2,K) ZR(K,J) = ZR(K,J) * TAU(1,K) 50 CONTINUE C IF (N .EQ. 1) GO TO 200 C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... DO 140 I = 2, N L = I - 1 H = A(I,I) IF (H .EQ. 0.0D0) GO TO 140 C DO 130 J = 1, M S = 0.0D0 SI = 0.0D0 C DO 110 K = 1, L S = S + A(I,K) * ZR(K,J) - A(K,I) * ZI(K,J) SI = SI + A(I,K) * ZI(K,J) + A(K,I) * ZR(K,J) 110 CONTINUE C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... S = (S / H) / H SI = (SI / H) / H C DO 120 K = 1, L ZR(K,J) = ZR(K,J) - S * A(I,K) - SI * A(K,I) ZI(K,J) = ZI(K,J) - SI * A(I,K) + S * A(K,I) 120 CONTINUE C 130 CONTINUE C 140 CONTINUE C 200 RETURN END C C C SUBROUTINE HTRID3(NM,N,A,D,E,E2,TAU) C INTEGER I,J,K,L,N,II,NM,JM1,JP1 DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N),TAU(2,N) DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG C C DIAGONALISIERUNG MIT EISPACK- ROUTINEN C C IERR=0 C CALL HTRID3 (NARZ,N,ZM1,D,E,E2,TAU) C CALL TQL2 (NARZ,N,D,E,ZM2,IERR) C IF (IERR.NE.0) THEN C WRITE (0,513) IERR C 513 FORMAT ('FEHLER BEI EIGENWERT:',I5) C STOP C ENDIF C CALL HTRIB3 (NARZ,N,ZM1,TAU,NARZ,ZM2,ZM3) C C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE TRED3, NUM. MATH. 11, 181-195(1968) C BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX, STORED AS C A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX C USING UNITARY SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT C MATRIX. THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED C IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS C ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER C TRIANGLE OF A. NO STORAGE IS REQUIRED FOR THE ZERO C IMAGINARY PARTS OF THE DIAGONAL ELEMENTS. C C ON OUTPUT C C A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS C USED IN THE REDUCTION. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. C C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C TAU(1,N) = 1.0D0 TAU(2,N) = 0.0D0 C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0D0 SCALE = 0.0D0 IF (L .LT. 1) GO TO 130 C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + DABS(A(I,K)) + DABS(A(K,I)) C IF (SCALE .NE. 0.0D0) GO TO 140 TAU(1,L) = 1.0D0 TAU(2,L) = 0.0D0 130 E(I) = 0.0D0 E2(I) = 0.0D0 GO TO 290 C 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE A(K,I) = A(K,I) / SCALE H = H + A(I,K) * A(I,K) + A(K,I) * A(K,I) 150 CONTINUE C E2(I) = SCALE * SCALE * H G = DSQRT(H) E(I) = SCALE * G F = PYTHAG(A(I,L),A(L,I)) C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... IF (F .EQ. 0.0D0) GO TO 160 TAU(1,L) = (A(L,I) * TAU(2,I) - A(I,L) * TAU(1,I)) / F SI = (A(I,L) * TAU(2,I) + A(L,I) * TAU(1,I)) / F H = H + F * G G = 1.0D0 + G / F A(I,L) = G * A(I,L) A(L,I) = G * A(L,I) IF (L .EQ. 1) GO TO 270 GO TO 170 160 TAU(1,L) = -TAU(1,I) SI = TAU(2,I) A(I,L) = G 170 F = 0.0D0 C DO 240 J = 1, L G = 0.0D0 GI = 0.0D0 IF (J .EQ. 1) GO TO 190 JM1 = J - 1 C .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, JM1 G = G + A(J,K) * A(I,K) + A(K,J) * A(K,I) GI = GI - A(J,K) * A(K,I) + A(K,J) * A(I,K) 180 CONTINUE C 190 G = G + A(J,J) * A(I,J) GI = GI - A(J,J) * A(J,I) JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L G = G + A(K,J) * A(I,K) - A(J,K) * A(K,I) GI = GI - A(K,J) * A(K,I) - A(J,K) * A(I,K) 200 CONTINUE C .......... FORM ELEMENT OF P .......... 220 E(J) = G / H TAU(2,J) = GI / H F = F + E(J) * A(I,J) - TAU(2,J) * A(J,I) 240 CONTINUE C HH = F / (H + H) C .......... FORM REDUCED A .......... DO 260 J = 1, L F = A(I,J) G = E(J) - HH * F E(J) = G FI = -A(J,I) GI = TAU(2,J) - HH * FI TAU(2,J) = -GI A(J,J) = A(J,J) - 2.0D0 * (F * G + FI * GI) IF (J .EQ. 1) GO TO 260 JM1 = J - 1 C DO 250 K = 1, JM1 A(J,K) = A(J,K) - F * E(K) - G * A(I,K) X + FI * TAU(2,K) + GI * A(K,I) A(K,J) = A(K,J) - F * TAU(2,K) - G * A(K,I) X - FI * E(K) - GI * A(I,K) 250 CONTINUE C 260 CONTINUE C 270 DO 280 K = 1, L A(I,K) = SCALE * A(I,K) A(K,I) = SCALE * A(K,I) 280 CONTINUE C TAU(2,L) = -SI 290 D(I) = A(I,I) A(I,I) = SCALE * DSQRT(H) 300 CONTINUE C RETURN END C C SUBROUTINE TQL2(NM,N,D,E,Z,IERR) C INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR DOUBLE PRECISION D(N),E(N),Z(NM,N) DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND C WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1. C C E HAS BEEN DESTROYED. C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C F = 0.0D0 TST1 = 0.0D0 E(N) = 0.0D0 C DO 240 L = 1, N J = 0 H = DABS(D(L)) + DABS(E(L)) IF (TST1 .LT. H) TST1 = H C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... DO 110 M = L, N TST2 = TST1 + DABS(E(M)) IF (TST2 .EQ. TST1) GO TO 120 C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE C 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... L1 = L + 1 L2 = L1 + 1 G = D(L) P = (D(L1) - G) / (2.0D0 * E(L)) R = PYTHAG(P,1.0D0) D(L) = E(L) / (P + DSIGN(R,P)) D(L1) = E(L) * (P + DSIGN(R,P)) DL1 = D(L1) H = G - D(L) IF (L2 .GT. N) GO TO 145 C DO 140 I = L2, N 140 D(I) = D(I) - H C 145 F = F + H C .......... QL TRANSFORMATION .......... P = D(M) C = 1.0D0 C2 = C EL1 = E(L1) S = 0.0D0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML C3 = C2 C2 = C S2 = S I = M - II G = C * E(I) H = C * P R = PYTHAG(P,E(I)) E(I+1) = S * R S = E(I) / R C = P / R P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) C .......... FORM VECTOR .......... DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE C 200 CONTINUE C P = -S * S2 * C3 * EL1 * E(L) / DL1 E(L) = S * P D(L) = C * P TST2 = TST1 + DABS(E(L)) IF (TST2 .GT. TST1) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END C C C DOUBLE PRECISION FUNCTION PYTHAG(A,B) DOUBLE PRECISION A,B C C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW C DOUBLE PRECISION P,R,S,T,U P = DMAX1(DABS(A),DABS(B)) IF (P .EQ. 0.0D0) GO TO 20 R = (DMIN1(DABS(A),DABS(B))/P)**2 10 CONTINUE T = 4.0D0 + R IF (T .EQ. 4.0D0) GO TO 20 S = R/T U = 1.0D0 + 2.0D0*S P = U*P R = (S/U)**2 * R GO TO 10 20 PYTHAG = P RETURN END C C------------------------------------------------------------------------------ C-----end-of-XIAMALL-listing--------------------------------------------------