From 277be48350eb036c76a41e176dfa940a26e545ab Mon Sep 17 00:00:00 2001 From: "Veronica K. B. Olsen" Date: Thu, 8 Aug 2019 18:40:52 +0200 Subject: [PATCH 1/6] Moved linear optics routines to a separate file, and merged the three solenoid includes --- CMakeLists.txt | 1 + source/include/phas1so1.f90 | 12 - source/include/phas2so1.f90 | 10 - source/include/phas3so1.f90 | 11 - source/include/phassolenoid.f90 | 29 + source/linear_optics.f90 | 1173 ++++++++++++++++++++++++++++++ source/sixtrack.f90 | 1198 +------------------------------ 7 files changed, 1211 insertions(+), 1223 deletions(-) delete mode 100644 source/include/phas1so1.f90 delete mode 100644 source/include/phas2so1.f90 delete mode 100644 source/include/phas3so1.f90 create mode 100644 source/include/phassolenoid.f90 create mode 100644 source/linear_optics.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index d53891479..c20ebce10 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -300,6 +300,7 @@ list(APPEND FORT90_LIB end_sixtrack fma lielib + linear_optics mainarrays matrix_inv mod_alloc diff --git a/source/include/phas1so1.f90 b/source/include/phas1so1.f90 deleted file mode 100644 index ea0f5a6ca..000000000 --- a/source/include/phas1so1.f90 +++ /dev/null @@ -1,12 +0,0 @@ -! start include/phas1so1.f90 -!--solenoid -elseif(kzz.eq.25) then - do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)).gt.pieni) then - phibf(l)=atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l)=pi2 - end if - end do -! end include/phas1so1.f90 diff --git a/source/include/phas2so1.f90 b/source/include/phas2so1.f90 deleted file mode 100644 index 623644287..000000000 --- a/source/include/phas2so1.f90 +++ /dev/null @@ -1,10 +0,0 @@ -! start include/phas2so1.f90 -crkve=t(i,2)-(t(i,1)*qu)*qv !hr02 -cikve=t(i,4)-(t(i,3)*qu)*qv !hr02 -t(i,2)=crkve*cos_mb(qv)+cikve*sin_mb(qv) !hr02 -t(i,4)=cikve*cos_mb(qv)-crkve*sin_mb(qv) !hr02 -crkve=t(i,1)*cos_mb(qv)+t(i,3)*sin_mb(qv) !hr02 -cikve=t(i,3)*cos_mb(qv)-t(i,1)*sin_mb(qv) !hr02 -t(i,1)=crkve -t(i,3)=cikve -! end include/phas2so1.f90 diff --git a/source/include/phas3so1.f90 b/source/include/phas3so1.f90 deleted file mode 100644 index c8b1f03ce..000000000 --- a/source/include/phas3so1.f90 +++ /dev/null @@ -1,11 +0,0 @@ -! start include/phas3so1.f90 -do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)).gt.pieni) then - dphi=atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi=pi2-phibf(l) - end if - phi(l)=phi(l)+dphi/pie -end do -! end include/phas3so1.f90 diff --git a/source/include/phassolenoid.f90 b/source/include/phassolenoid.f90 new file mode 100644 index 000000000..eee98881a --- /dev/null +++ b/source/include/phassolenoid.f90 @@ -0,0 +1,29 @@ +! start include/phassolenoid.f90 +do l=1,2 + ll = 2*l + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = pi2 + end if +end do + +crkve = t(i,2) - (t(i,1)*qu)*qv +cikve = t(i,4) - (t(i,3)*qu)*qv +t(i,2) = crkve*cos_mb(qv) + cikve*sin_mb(qv) +t(i,4) = cikve*cos_mb(qv) - crkve*sin_mb(qv) +crkve = t(i,1)*cos_mb(qv) + t(i,3)*sin_mb(qv) +cikve = t(i,3)*cos_mb(qv) - t(i,1)*sin_mb(qv) +t(i,1) = crkve +t(i,3) = cikve + +do l=1,2 + ll = 2*l + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = pi2-phibf(l) + end if + phi(l) = phi(l)+dphi/twopi +end do +! end include/phassolenoid.f90 diff --git a/source/linear_optics.f90 b/source/linear_optics.f90 new file mode 100644 index 000000000..ba74e08df --- /dev/null +++ b/source/linear_optics.f90 @@ -0,0 +1,1173 @@ +!----------------------------------------------------------------------- +! LINEAR PARAMETERS AT THE POSITION OF EVERY ELEMENT OR BLOCK +!----------------------------------------------------------------------- +subroutine linopt(dpp) + + use parpro + use crcoall + use mod_units + use mod_common + use mod_commons + use mod_common_track + use mod_settings + use floatPrecision + use mathlib_bouncer + use numerical_constants + +#ifdef ROOT + use root_output +#endif + +#ifdef HDF5 + use hdf5_output + use hdf5_linopt +#endif + + use collimation + + implicit none + + integer i,iiii,im,ium,ix,izu,j,jj,jk,jm,k,kpz,kzz,l,l1,ll,nmz,nr,dj + real(kind=fPrec) aa,aeg,alfa,bb,benkr,beta,bexi,bezii,bl1eg,bl2eg,ci,cikve,clo0,clop0,cr,crkve, & + crkveuk,di00,dip00,dphi,dpp,dpp1,dppi,dpr,dyy1,dyy2,ekk,etl,phi,phibf,puf,qu,qv,qw,qwc,r0,& + r0a,t,xl,xs,zl,zs,quz,qvz +#ifdef TILT + real(kind=fPrec) dyy11,qu1,tiltck,tiltsk +#endif + character(len=mNameLen) idum + + dimension t(6,4) + dimension beta(2),alfa(2),phibf(2),phi(2) + dimension clo0(2),clop0(2),di00(2),dip00(2),qw(2),qwc(3) + dimension aa(mmul),bb(mmul),dpr(6) + dimension cr(mmul),ci(mmul) + dimension aeg(nele,2,6),bl1eg(nblo,2,6),bl2eg(nblo,2,6) + data dpr/6*zero/ + + nhmoni = 0 + nvmoni = 0 + nhcorr = 0 + nvcorr = 0 + ium = 6 + + if(ncorru == 0) then + write(lout,10010) + write(lout,10000) + endif + + dpr(:) = zero + t(:,:) = zero + + beta(:) = zero + alfa(:) = zero + phibf(:) = zero + phi(:) = zero + clo0(:) = zero + clop0(:) = zero + di00(:) = zero + dip00(:) = zero + qw(:) = zero + qwc(:) = zero + + aa(:) = zero + bb(:) = zero + cr(:) = zero + ci(:) = zero + + etl = zero + dpr(1) = dpp*c1e3 + dpr(6) = one + dpp1 = dpp+ded + + call clorb(dpp1) + + clo0(1:2) = clo(1:2) + clop0(1:2) = clop(1:2) + + call clorb(dpp) + + do l=1,2 + ll = 2*l + di0(l) = (clo0(l)-clo(l))/ded + dip0(l) = (clop0(l)-clop(l))/ded + t(6,ll-1) = di0(l) + t(6,ll) = dip0(l) + end do + + if(ncorru == 0) then + call f_open(unit=34,file="fort.34",formatted=.true.,mode="w") + write(lout,10010) + write(lout,10050) (di0(l),dip0(l),l=1,2) + endif + + call betalf(dpp,qw) + call phasad(dpp,qwc) + + if(ierro /= 0) then + write(lerr,"(a)") "LINOPT> ERROR No optical solution." + call prror + end if + if(ncorru == 0) then + write(lout,10040) dpp,qwc(1),qwc(2) + end if + + call envar(dpp) + + if(ithick == 1) then + call envardis(dpp1,aeg,bl1eg,bl2eg) + end if + +!--STARTVALUES OF THE TRAJECTORIES + do l=1,2 + ll = 2*l + t(1,ll-1) = clo(l) + t(1,ll) = clop(l) + end do + + do i=1,4 + do j=1,4 + t(i+1,j) = ta(j,i) + t(i+1,j) = ta(j,i) + end do + end do + + if(ncorru == 0 .and. st_quiet == 0) then + write(lout,10010) + write(lout,10030) + write(lout,10020) + write(lout,10010) + end if + +!--START OF THE MACHINE + idum = "START" + nr = 0 + call writelin(nr,idum,etl,phi,t,1,.false.,0) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(idum,t,etl,phi) + end if + end if + +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + +!--STRUCTURE ELEMENT LOOP + if(nt <= 0 .or. nt > iu) then + nt = iu + end if + izu=0 + +#ifdef HDF5 + if(h5_writeOptics) then + call h5lin_init + end if +#endif + + STRUCTLOOP: do k=1,nt + ix = ic(k) + if(ix > nblo) goto 220 !Not a BLOCK + if(ithick == 1 .and. iprint == 1) goto 160 + + jj=0 !initial idx + dj=1 !step + + if(ix <= 0) then + ix = -1*ix + jj = mel(ix)+1 !initial idx + dj = -1 !step + endif + jm = mel(ix) + +!-- Loop over elements inside the block + do 150 j=1,jm + jj = jj+dj ! Subelement index of current sub=element + jk = mtyp(ix,jj) ! Single-element index of the current sub-element + if(ithick == 1 .and. kz(jk) /= 0) goto 120 + if(ithick == 0 .and. kz(jk) /= 0) then + etl=etl+el(jk) + write(lerr,"(a)") "LINOPT> ERROR In block '"//trim(bezb(ix))//"': found a thick non-drift element '"//& + trim(bez(jk))//"' while ithick=1. This should not be possible!" + call prror + cycle STRUCTLOOP + end if + +!--IN BLOCK: PURE DRIFTLENGTH (above: If ITHICK=1 and kz!=0, goto 120->MAGNETELEMENT) + etl = etl+el(jk) + + do l=1,2 + ll = 2*l + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = pi2 + end if + do i=1,ium + t(i,ll-1) = t(i,ll-1)+t(i,ll)*(el(jk)) + end do + end do + + do l=1,2 + ll=2*l + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = pi2-phibf(l) + end if + if((-one*dphi) > pieni) then + dphi = dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + + nr = nr+1 + call writelin(nr,bez(jk),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(jk),t,etl, phi) + end if + end if + +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + goto 150 + +!--IN BLOCK: MAGNETELEMENT +120 continue + if(kz(jk) /= 8) then + etl = etl+el(jk) + end if + do l=1,2 + ll = 2*l + + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = zero + end if + + puf = t(6,ll-1) + t(6,ll-1) = (((((aeg(jk,l,1)*(t(1,ll-1)+puf*ded) + aeg(jk,l,2)*(t(1,ll) + t(6,ll)*ded)) & + + aeg(jk,l,5)*dpp1*c1e3)- a(jk,l,1)*t(1,ll-1))-a(jk,l,2)*t(1,ll))- a(jk,l,5)*dpr(1))/ded + t(6,ll) = (((((aeg(jk,l,3)*(t(1,ll-1)+puf*ded) + aeg(jk,l,4)*(t(1,ll) + t(6,ll)*ded)) & + + aeg(jk,l,6)*dpp1*c1e3)- a(jk,l,3)*t(1,ll-1))-a(jk,l,4)*t(1,ll))- a(jk,l,6)*dpr(1))/ded + + do i=1,ium-1 + puf=t(i,ll-1) + t(i,ll-1) = (puf*a(jk,l,1)+t(i,ll)*a(jk,l,2))+dpr(i)*a(jk,l,5) + t(i,ll) = (puf*a(jk,l,3)+t(i,ll)*a(jk,l,4))+dpr(i)*a(jk,l,6) + end do + end do + + do l=1,2 + ll=2*l + + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = -one*phibf(l) + end if + + if(kz(jk) /= 8 .and. -one*dphi > pieni) then + dphi=dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + + nr = nr+1 + call writelin(nr,bez(jk),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(jk),t,etl, phi) + end if + end if + +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + +150 continue !End of loop over elements inside block + + nr = nr+1 + call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bezb(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + cycle STRUCTLOOP + +!--BETACALCULATION FOR SERIES OF BLOCKS (ix >= nblo.and.ithick == 1.and.iprint == 1) +160 continue !if ithick=1 and iprint=1: + if(ix <= 0) goto 190 +!--REGULAR RUN THROUGH BLOCKS + etl = etl+elbe(ix) + + do l=1,2 + ll=2*l + + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = zero + end if + + puf = t(6,ll-1) + t(6,ll-1) = (((((bl1eg(ix,l,1)*(t(1,ll-1)+puf*ded) + bl1eg(ix,l,2)*(t(1,ll)+t(6,ll)*ded)) & + + bl1eg(ix,l,5)*dpp1*c1e3)- bl1(ix,l,1)*t(1,ll-1))-bl1(ix,l,2)*t(1,ll))- bl1(ix,l,5)*dpr(1))/ded + t(6,ll) = (((((bl1eg(ix,l,3)*(t(1,ll-1)+puf*ded) + bl1eg(ix,l,4)*(t(1,ll)+t(6,ll)*ded)) & + + bl1eg(ix,l,6)*dpp1*c1e3)- bl1(ix,l,3)*t(1,ll-1))-bl1(ix,l,4)*t(1,ll))- bl1(ix,l,6)*dpr(1))/ded + + do i=1,ium-1 + puf = t(i,ll-1) + t(i,ll-1) = (bl1(ix,l,1)*puf+bl1(ix,l,2)*t(i,ll))+dpr(i)*bl1(ix,l,5) + t(i,ll) = (bl1(ix,l,3)*puf+bl1(ix,l,4)*t(i,ll))+dpr(i)*bl1(ix,l,6) + end do + end do + + do l=1,2 + ll=2*l + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = -one*phibf(l) + endif + if(-one*dphi > pieni) then + dphi = dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + + nr = nr+1 + call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bezb(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + cycle STRUCTLOOP + +!--REVERSE RUN THROUGH BLOCKS (ix <= 0) +190 ix = -ix + etl = etl+elbe(ix) + do l=1,2 + ll=2*l + + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = zero + end if + + puf = t(6,ll-1) + t(6,ll-1) = (((((bl2eg(ix,l,1)*(t(1,ll-1)+puf*ded) + bl2eg(ix,l,2)*(t(1,ll)+t(6,ll)*ded)) & + + bl2eg(ix,l,5)*dpp1*c1e3)- bl2(ix,l,1)*t(1,ll-1))-bl2(ix,l,2)*t(1,ll))- bl2(ix,l,5)*dpr(1))/ded + t(6,ll) = (((((bl2eg(ix,l,3)*(t(1,ll-1)+puf*ded) + bl2eg(ix,l,4)*(t(1,ll)+t(6,ll)*ded)) & + + bl2eg(ix,l,6)*dpp1*c1e3)- bl2(ix,l,3)*t(1,ll-1))-bl2(ix,l,4)*t(1,ll))- bl2(ix,l,6)*dpr(1))/ded + + do i=1,ium-1 + puf = t(i,ll-1) + t(i,ll-1) = (bl2(ix,l,1)*puf+bl2(ix,l,2)*t(i,ll))+dpr(i)*bl2(ix,l,5) + t(i,ll) = (bl2(ix,l,3)*puf+bl2(ix,l,4)*t(i,ll))+dpr(i)*bl2(ix,l,6) + end do + end do + + do l=1,2 + ll = 2*l + + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = -phibf(l) + end if + + if(-one*dphi > pieni) then + dphi = dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + + nr = nr+1 + call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bezb(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + cycle STRUCTLOOP + + ! NOT A BLOCK / Nonlinear insertion +220 ix = ix-nblo + qu = zero + qv = zero + dyy1 = zero + dyy2 = zero + kpz = kp(ix) + kzz = kz(ix) + + ! Cavity + if(kpz == 6 .or. abs(kzz) == 12) then + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + cycle STRUCTLOOP + end if + + ! Beam Beam element .and. fort.3 has BB block + if(kzz == 20 .and. nbeam >= 1) then + nbeam = k + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) call cpltwis(bez(ix),t,etl,phi) + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + cycle STRUCTLOOP + end if + + ! if kzz==22, starts a do over l; Update t matrix + if(kzz == 22) then + do l=1,2 + ll = 2*l + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = zero + end if + do i=1,ium + puf = t(i,ll-1) + t(i,ll-1) = (puf*rrtr(imtr(ix),ll-1,ll-1)+t(i,ll)*rrtr(imtr(ix),ll-1,ll))+dpr(i)*rrtr(imtr(ix),ll-1,6) + t(i,ll) = (puf*rrtr(imtr(ix),ll,ll-1)+t(i,ll)*rrtr(imtr(ix),ll,ll))+dpr(i)*rrtr(imtr(ix),ll,6) + end do + t(1,ll-1) = t(1,ll-1)+cotr(imtr(ix),ll-1) + t(1,ll) = t(1,ll)+cotr(imtr(ix),ll) + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = -one*phibf(l) + end if + if(-one*dphi > pieni) then + dphi = dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + end if + +!+if collimat.or.bnlelens + ! Marker, beam-beam, phase-trombone, crab cavity (incl. multipole), or wire + if(kzz == 0 .or. kzz == 20 .or. kzz == 22 .or. abs(kzz) == 23 .or. abs(kzz) == 26 .or. & + abs(kzz) == 27 .or. abs(kzz) == 28 .or. abs(kzz) == 15) then + + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + cycle STRUCTLOOP + end if + + ! Update the matrix etc. for supported blocks + dyy1 = zero + dyy2 = zero + if(iorg < 0) then + mzu(k) = izu + end if + izu = mzu(k)+1 + ekk = (sm(ix)+zfz(izu)*ek(ix))/(one+dpp) + izu = izu+1 + xs = xpl(ix)+zfz(izu)*xrms(ix) + izu = izu+1 + zs = zpl(ix)+zfz(izu)*zrms(ix) +#include "include/alignl.f90" + + if(kzz >= 0) then + select case(kzz) + + case (1) +!--HORIZONTAL DIPOLE + ekk=ekk*c1e3 +#include "include/kickl01h.f90" +#include "include/kickq01h.f90" +!--NORMAL QUADRUPOLE + case(2) +#include "include/kicklxxh.f90" +#include "include/kickq02h.f90" +!-- NORMAL SEXTUPOLE + case(3) + ekk=ekk*c1m3 +#include "include/kickq03h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL OCTUPOLE + case(4) + ekk=ekk*c1m6 +#include "include/kicksho.f90" +#include "include/kickq04h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL DECAPOLE + case(5) + ekk=ekk*c1m9 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq05h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL DODECAPOLE + case(6) + ekk=ekk*c1m12 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq06h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL 14-POLE + case(7) + ekk=ekk*c1m15 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq07h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL 16-POLE + case(8) + ekk=ekk*c1m18 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq08h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL 18-POLE + case(9) + ekk=ekk*c1m21 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq09h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--NORMAL 20-POLE + case(10) + ekk=ekk*c1m24 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq10h.f90" +#include "include/kicksho.f90" +#include "include/kicklxxh.f90" +!--Multipole block + case(11) + r0=ek(ix) + if(abs(dki(ix,1)) > pieni) then + if(abs(dki(ix,3)) > pieni) then +#include "include/multl01.f90" +#include "include/multl08.f90" + do i=2,ium +#include "include/multl02.f90" + end do + else +#include "include/multl03.f90" +#include "include/multl09.f90" + end if + end if + if(abs(dki(ix,2)) > pieni) then + if(abs(dki(ix,3)) > pieni) then +#include "include/multl04.f90" +#include "include/multl10.f90" + do i=2,ium +#include "include/multl05.f90" + end do + else +#include "include/multl06.f90" +#include "include/multl11.f90" + end if + end if + if(abs(r0) <= pieni) then + cycle STRUCTLOOP + end if + nmz=nmu(ix) + if(nmz == 0) then + izu=izu+2*mmul + + nr=nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + cycle STRUCTLOOP + end if + im = irm(ix) + r0a = one + benkr = ed(ix)/(one+dpp) + do l=1,nmz +#include "include/multl07a.f90" + end do + if(nmz >= 2) then +#include "include/multl07b.f90" + do l=3,nmz +#include "include/multl07c.f90" + end do + else +#include "include/multl07d.f90" + endif +#ifdef TILT +#include "include/multl07e.f90" +#endif + izu = izu+2*mmul-2*nmz + +!--Skipped elements + case(12,13,14,15,16,17,18,19,20,21,22,23) + cycle STRUCTLOOP + +!--DIPEDGE ELEMENT + case(24) +#include "include/kickldpe.f90" +#include "include/kickqdpe.f90" +!--solenoid + case(25) +#include "include/kicklso1.f90" +#include "include/kickqso1.f90" + +!--Skipped elements + case(26,27,28) + cycle STRUCTLOOP + +!--Unrecognized element (incl. cav with kp /= 6 for non-collimat/bnlelens) + case default + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + cycle STRUCTLOOP + end select + + +!--SKEW ELEMENTS + else if(kzz < 0) then + kzz = -kzz !Make it positive + select case(kzz) + case(1) +!--VERTICAL DIPOLE + ekk=ekk*c1e3 +#include "include/kickl01v.f90" +#include "include/kickq01v.f90" +!--SKEW QUADRUPOLE + case(2) +#include "include/kicklxxv.f90" +#include "include/kickq02v.f90" +!--SKEW SEXTUPOLE + case(3) + ekk=ekk*c1m3 +#include "include/kickq03v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW OCTUPOLE + case(4) + ekk=ekk*c1m6 +#include "include/kicksho.f90" +#include "include/kickq04v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW DECAPOLE + case(5) + ekk=ekk*c1m9 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq05v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW DODECAPOLE + case(6) + ekk=ekk*c1m12 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq06v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW 14-POLE + case(7) + ekk=ekk*c1m15 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq07v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW 16-POLE + case(8) + ekk=ekk*c1m18 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq08v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW 18-POLE + case(9) + ekk=ekk*c1m21 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq09v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" +!--SKEW 20-POLE + case(10) + ekk=ekk*c1m24 +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kicksho.f90" +#include "include/kickq10v.f90" +#include "include/kicksho.f90" +#include "include/kicklxxv.f90" + +! Unrecognized skew element (including kzz=-12,kp /= 6 for non-collimat/bnlelens) + case default + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + cycle STRUCTLOOP + end select + end if + + ! Done processing an element: go here! + t(6,2) = t(6,2)-dyy1/(one+dpp) + t(6,4) = t(6,4)-dyy2/(one+dpp) + t(1,2) = t(1,2)+dyy1 + t(1,4) = t(1,4)+dyy2 + do i=2,ium + if(kzz == 24) then + t(i,2) = (t(i,2)+t(i,1)*qu)-qv*t(i,3) + t(i,4) = (t(i,4)-t(i,3)*quz)-qvz*t(i,1) + elseif(kzz.eq.25) then !--solenoid +#include "include/phassolenoid.f90" + else + t(i,4) = (t(i,4)-t(i,3)*qu)-qv*t(i,1) + t(i,2) = (t(i,2)+t(i,1)*qu)-qv*t(i,3) + end if + end do + bexi = t(2,1)**2+t(3,1)**2 + bezii = t(4,3)**2+t(5,3)**2 + if(ncorru == 0) then + if(kz(ix) == 11) then + if(abs(aa(2)) > pieni.and.nmz > 1) then + write(34,10070) etl,bez(ix),-2,aa(2),bexi,bezii,phi + end if + do iiii=3,nmz + if(abs(bb(iiii)) > pieni) then + write(34,10070) etl,bez(ix),iiii,bb(iiii),bexi,bezii,phi + end if + if(abs(aa(iiii)) > pieni) then + write(34,10070) etl,bez(ix),-iiii,aa(iiii),bexi,bezii,phi + end if + end do + else if(abs(ekk) > pieni.and.abs(kz(ix)) >= 3) then + write(34,10070) etl,bez(ix),kz(ix),ekk,bexi,bezii,phi + else if(abs(ekk) > pieni.and.kz(ix) == -2) then + write(34,10070) etl,bez(ix),kz(ix),ekk,bexi,bezii,phi + end if + end if + + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + end do STRUCTLOOP ! END LOOP OVER ELEMENTS + +#ifdef HDF5 + if(h5_writeOptics) call h5lin_saveData +#endif + + call clorb(ded) + clo0(1:2) = clo(1:2) + clop0(1:2) = clop(1:2) + call clorb(zero) + do l=1,2 + ll = 2*l + di0(l) = (clo0(l)-clo(l))/ded + dip0(l) = (clop0(l)-clop(l))/ded + end do + iiii = 100 + idum = "END" + bexi = t(2,1)**2+t(3,1)**2 + bezii = t(4,3)**2+t(5,3)**2 + if(ncorru == 0) then + write(34,10070) etl,idum,iiii,zero,bexi,bezii,phi + end if + if(ncorru == 0) then + write(lout,10060) + end if + return + +!----------------------------------------------------------------------- + +10000 format(t5 ,'---- ENTRY LINOPT ----') +10010 format(132('-')) +10020 format(' NR TYP L-TOTAL P PHI ', & + &'BETA ALFA GAMMA DIS DISP ',& + &'CLO CLOP'/ 1x, & + &' (M) (2*PI) ', & + &'(M) (RAD) (M) (M) (RAD) ',& + &'(MM) (MRAD)') +10030 format(' LINEAR OPTICS CALCULATION WITH PRINTOUT ', & + &'AFTER EACH BLOCK'/ & + &' A T T E N T I O N : BETATRON PHASE CALCULATION MIGHT BE WRONG'& + &,' BY A MULTIPLE OF 0.5 FOR EACH LARGE BLOCK'/) +10040 format(/10x,'RELATIVE ENERGY DEVIATION ',t40,f23.16/ 10x, & + &'TUNES -HORIZONTAL',t40,f23.16/ 10x,' -VERTICAL ',t40,f23.16/) +10050 format(t8,' PLANE DISP(MM) DISP(MRAD)'/ & + &t6,' X ',2(f20.12,6x)/t10,' Y ',2(f20.12,6x)/) +10060 format(//131('-')//) +10070 format(1x,1pg21.14,1x,a,1x,i4,5(1x,1pg21.14)) + +end subroutine linopt + +! ============================================================================ ! +! Write out linear optics parameters and send to modules that needs it +! Updated: 2019-07-22 +! ============================================================================ ! +subroutine writelin(nr,typ,tl,p1,t,ixwl,isBLOC,ielem) + + use parpro + use crcoall + use mod_settings + use mod_common + use mod_commons + use mod_common_track + use collimation + use floatPrecision + use mathlib_bouncer + use numerical_constants + +#ifdef ROOT + use iso_c_binding, only: C_NULL_CHAR + use root_output +#endif + +#ifdef HDF5 + use hdf5_output + use hdf5_linopt +#endif + + implicit none + + integer i,iwrite,ixwl,l,ll,nr + real(kind=fPrec) al1(2),al2(2),b1(2),b2(2),c(2),cp(2),d(2),dp(2),g1(2),g2(2),p1(2),t(6,4),tl + character(len=mNameLen) typ + ! isBLOC == TRUE if ixwl currently refers to a BLOC index, FALSE if it is a SINGLE ELEMENT index + logical isBLOC + integer ielem + +#ifdef HDF5 + real(kind=fPrec) hdf5Data(17) +#endif + + iwrite = 0 + if(nlin == 0) then + iwrite = 1 + else + do i=1,nlin + if(typ == bezl(i)) iwrite = 1 + end do + end if + if(iwrite == 1) then + do l=1,2 + ll = 2*l + b1(l) = t(ll,ll-1)**2+t(ll+1,ll-1)**2 + b2(l) = t(6-ll,ll-1)**2+t(7-ll,ll-1)**2 + al1(l) = -one*(t(ll,ll-1)*t(ll,ll)+t(ll+1,ll-1)*t(ll+1,ll)) + al2(l) = -one*(t(6-ll,ll-1)*t(6-ll,ll)+t(7-ll,ll-1)*t(7-ll,ll)) + g1(l) = t(ll,ll)**2+t(ll+1,ll)**2 + g2(l) = t(6-ll,ll)**2+t(7-ll,ll)**2 + d(l) = t(6,ll-1)*c1m3 + dp(l) = t(6,ll)*c1m3 + c(l) = t(1,ll-1) + cp(l) = t(1,ll) + end do + +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWriteLin(nr, typ // C_NULL_CHAR,len(typ),tl,c(1),cp(1),c(2),cp(2),& + b1(1),b1(2),al1(1),al1(2),d(1),d(2),dp(1),dp(2)) + end if +#endif +#ifdef HDF5 + if(h5_writeOptics) then + hdf5Data(:) = (/tl,& + p1(1),b1(1),al1(1),g1(1),d(1),dp(1),c(1),cp(1),& + p1(2),b1(2),al1(2),g1(2),d(2),dp(2),c(2),cp(2)/) + call h5lin_writeLine(nr, typ, hdf5Data) + end if +#endif + + if(do_coll) then + tbetax(max(ielem,1)) = b1(1) + tbetay(max(ielem,1)) = b1(2) + talphax(max(ielem,1)) = al1(1) + talphay(max(ielem,1)) = al1(2) + torbx(max(ielem,1)) = c(1) + torbxp(max(ielem,1)) = cp(1) + torby(max(ielem,1)) = c(2) + torbyp(max(ielem,1)) = cp(2) + tdispx(max(ielem,1)) = d(1) + tdispy(max(ielem,1)) = d(2) + end if + + if(ncorru == 0) then + if(st_quiet == 0) then + write(lout,10000) nr,typ(:8),tl,p1(1),b1(1),al1(1),g1(1),d(1),dp(1),c(1),cp(1) + write(lout,10010) b2(1),al2(1),g2(1) + write(lout,10030) typ(9:16) + write(lout,10020) p1(2),b1(2),al1(2),g1(2),d(2),dp(2),c(2),cp(2) + write(lout,10010) b2(2),al2(2),g2(2) + write(lout,10040) + end if + else + if(.not.isBLOC) then + if(kp(ixwl) == 3) then + nhmoni = nhmoni + 1 + betam(nhmoni,1) = b1(1) + pam(nhmoni,1) = p1(1)*twopi + bclorb(nhmoni,1) = c(1) + else if(kp(ixwl) == 4) then + nhcorr = nhcorr + 1 + betac(nhcorr,1) = b1(1) + pac(nhcorr,1) = p1(1)*twopi + else if(kp(ixwl) == -3) then + nvmoni = nvmoni + 1 + betam(nvmoni,2) = b1(2) + pam(nvmoni,2) = p1(2)*twopi + bclorb(nvmoni,2) = c(2) + else if(kp(ixwl) == -4) then + nvcorr = nvcorr + 1 + betac(nvcorr,2) = b1(2) + pac(nvcorr,2) = p1(2)*twopi + end if + end if + end if + end if + + return +10000 format('|',i6,'|',a8,'|',f12.5,'|','X','|',f12.7,'|',f12.6,'|',f13.7,'|',f11.6,'|',f11.7,'|',f11.7,'|',f11.7,'|',f11.7,'|') +10010 format('|',6x,'|',8x,'|',12x,'|',1x,'|',12x,'|',f12.6,'|', f13.7,'|',f11.6,'|',11x,'|',11x,'|',11x,'|',11x,'|') +10020 format('|',6x,'|',8x,'|',12x,'|','Y','|',f12.7,'|',f12.6,'|', f13.7,'|',f11.6,'|',f11.7,'|',f11.7,'|',f11.7,'|',f11.7,'|') +10030 format('|',6x,'|',a8,'|',12x,'|',102('-')) +10040 format(132('-')) +end subroutine writelin + +!----------------------------------------------------------------------- +! CALCULATES COUPLED TWISS PARAMETERS AROUND THE RING AND ALSO THE +! ANGLE OF THE MAJOR AXIS OF A ELLIPSE IN THE X-Y PROJECTION WITH +! THE X-AXIS. THE 4-D ELLIPSOID IS GIVEN BY THE BOUNDARY OF A +! DISTRIBUTION OF PARTICLES WITH MAXIMUM EMITANCE OF MODE I AND II, +! EUI AND EUII RESPECTIVELY. +! BINARY PRINT ON FILE 11 OF 22 VALUES : +! POSITION [M], +! BET(1-4), ALF(1-4), GAM(1-4), COOR-PHI(1-4), COOR-PRIME-PHI(1-4), +! COUUANGL +!----------------------------------------------------------------------- +subroutine cpltwis(typ,t,etl,phi) + + use parpro + use mod_units + use mod_common + use mod_commons + use mod_common_track + use floatPrecision + use mathlib_bouncer + use numerical_constants +#ifdef ROOT + use root_output +#endif + + implicit none + + integer i,iwrite + logical :: open11 = .false. + real(kind=fPrec) alxi,alxii,alzi,alzii,bexi,bexii,bezi,bezii,couuang,etl,gaxi,gaxii,gazi,gazii, & + phi(2),phxi,phxii,phxpi,phxpii,phzi,phzii,phzpi,phzpii,t(6,4) + character(len=mNameLen) typ + + iwrite = 0 + if(nlin == 0) then + iwrite = 1 + else + do i=1,nlin + if(typ == bezl(i)) iwrite = 1 + end do + end if + if(iwrite == 1) then + bexi = t(2,1)**2+t(3,1)**2 + bexii = t(4,1)**2+t(5,1)**2 + bezi = t(2,3)**2+t(3,3)**2 + bezii = t(4,3)**2+t(5,3)**2 + alxi = -one*(t(2,1)*t(2,2)+t(3,1)*t(3,2)) + alxii = -one*(t(4,1)*t(4,2)+t(5,1)*t(5,2)) + alzi = -one*(t(2,3)*t(2,4)+t(3,3)*t(3,4)) + alzii = -one*(t(4,3)*t(4,4)+t(5,3)*t(5,4)) + gaxi = t(2,2)**2+t(3,2)**2 + gaxii = t(4,2)**2+t(5,2)**2 + gazi = t(2,4)**2+t(3,4)**2 + gazii = t(4,4)**2+t(5,4)**2 + if(abs(t(2,1)) > pieni) phxi = atan2_mb(t(3,1),t(2,1)) + if(abs(t(4,1)) > pieni) phxii = atan2_mb(t(5,1),t(4,1)) + if(abs(t(4,1)) > pieni) phxii = atan2_mb(t(5,1),t(4,1)) + if(abs(t(2,3)) > pieni) phzi = atan2_mb(t(3,3),t(2,3)) + if(abs(t(4,3)) > pieni) phzii = atan2_mb(t(5,3),t(4,3)) + if(abs(t(2,2)) > pieni) phxpi = atan2_mb(t(3,2),t(2,2)) + if(abs(t(4,2)) > pieni) phxpii = atan2_mb(t(5,2),t(4,2)) + if(abs(t(2,4)) > pieni) phzpi = atan2_mb(t(3,4),t(2,4)) + if(abs(t(4,4)) > pieni) phzpii = atan2_mb(t(5,4),t(4,4)) + if(abs(t(2,1)) <= pieni) phxi = pi2 + if(abs(t(4,1)) <= pieni) then + if(bexii > pieni) phxii = pi2 + if(bexii <= pieni) phxii = zero + end if + if(abs(t(2,3)) <= pieni) then + if(bezi > pieni) phzi = pi2 + if(bezi <= pieni) phzi = zero + end if + if(abs(t(4,3)) <= pieni) phzii = pi2 + if(abs(t(2,2)) <= pieni) phxpi = pi2 + if(abs(t(4,2)) <= pieni) then + if(gaxii > pieni) phxpii = pi2 + if(gaxii <= pieni) phxpii = zero + end if + if(abs(t(2,4)) <= pieni) then + if(gazi > pieni) phzpi = pi2 + if(gazi <= pieni) phzpi = zero + end if + if(abs(t(4,4)) <= pieni) phzpii = pi2 + if(abs(eui*(bexi-bezi)+euii*(bexii-bezii)) > pieni) then + couuang = half*atan_mb((two*((eui*sqrt(bexi*bezi))*cos_mb(phxi-phzi)+(euii*sqrt(bexii*bezii)) & + *cos_mb(phxii-phzii)))/ (eui*(bexi-bezi)+euii*(bexii-bezii))) + else + couuang = zero + end if + if(open11 .eqv. .false.) then + ! Note: Description above says binary file, but the file has been opened as ascii since at least 4.x + call f_open(unit=11,file="fort.11",formatted=.true.,mode="w") + open11 = .true. + end if + write(11,*) typ,etl,phi,bexi,bexii,bezi,bezii, alxi,alxii,alzi, & + alzii, gaxi,gaxii,gazi,gazii,phxi,phxii,phzi,phzii, phxpi, & + phxpii,phzpi,phzpii,couuang,t(6,1),t(6,2),t(6,3),t(6,4),t(1,1), & + t(1,2),t(1,3),t(1,4) + +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWriteCpl(phi(1), phi(2),bexi,bexii,bezi,bezii, & + alxi,alxii,alzi,alzii,gaxi,gaxii,gazi,gazii, & + phxi,phxii,phzi,phzii,phxpi,phxpii,phzpi,phzpii,couuang, & + t(6,1),t(6,2),t(6,3),t(6,4),t(1,1),t(1,2),t(1,3),t(1,4)) + end if +#endif + + end if + +end subroutine cpltwis diff --git a/source/sixtrack.f90 b/source/sixtrack.f90 index 2f3fe7ea8..798b86dee 100644 --- a/source/sixtrack.f90 +++ b/source/sixtrack.f90 @@ -3942,1184 +3942,6 @@ subroutine envardis(dpp,aeg,bl1eg,bl2eg) end subroutine envardis -!----------------------------------------------------------------------- -! LINEAR PARAMETERS AT THE POSITION OF EVERY ELEMENT OR BLOCK -!----------------------------------------------------------------------- -subroutine linopt(dpp) - - use floatPrecision - use numerical_constants - use mathlib_bouncer - use crcoall - use parpro - use mod_units - use mod_common - use mod_commons - use mod_common_track - -#ifdef ROOT - use root_output -#endif - -#ifdef HDF5 - use hdf5_output - use hdf5_linopt -#endif - - use collimation - - implicit none - - integer i,iiii,im,ium,ix,izu,j,jj,jk,jm,k,kpz,kzz,l,l1,ll,nmz,nr,dj - real(kind=fPrec) aa,aeg,alfa,bb,benkr,beta,bexi,bezii,bl1eg,bl2eg,ci,cikve,clo0,clop0,cr,crkve, & - crkveuk,di00,dip00,dphi,dpp,dpp1,dppi,dpr,dyy1,dyy2,ekk,etl,phi,phibf,pie,puf,qu,qv,qw,qwc,r0,& - r0a,t,xl,xs,zl,zs,quz,qvz -#ifdef TILT - real(kind=fPrec) dyy11,qu1,tiltck,tiltsk -#endif - character(len=mNameLen) idum - - dimension t(6,4) - dimension beta(2),alfa(2),phibf(2),phi(2) - dimension clo0(2),clop0(2),di00(2),dip00(2),qw(2),qwc(3) - dimension aa(mmul),bb(mmul),dpr(6) - dimension cr(mmul),ci(mmul) - dimension aeg(nele,2,6),bl1eg(nblo,2,6),bl2eg(nblo,2,6) - data dpr/6*zero/ - save -!----------------------------------------------------------------------- - - nhmoni=0 - nvmoni=0 - nhcorr=0 - nvcorr=0 - ium=6 - pie=two*pi - - if(ncorru.eq.0) then - write(lout,10010) - write(lout,10000) - endif - - do i=1,ium - dpr(i)=zero - end do - - do i=1,ium - do j=1,4 - t(i,j)=zero - end do - end do - - do i=1,2 - beta(i)=zero - alfa(i)=zero - phibf(i)=zero - phi(i)=zero - clo0(i)=zero - clop0(i)=zero - di00(i)=zero - dip00(i)=zero - qw(i)=zero - qwc(i)=zero - end do - - qwc(3)=zero - - do i=1,mmul - aa(i)=zero - bb(i)=zero - cr(i)=zero - ci(i)=zero - end do - - etl=zero - dpr(1)=dpp*c1e3 - dpr(6)=one - dpp1=dpp+ded - call clorb(dpp1) - - do l=1,2 - clo0(l)=clo(l) - clop0(l)=clop(l) - end do - - call clorb(dpp) - - do l=1,2 - ll=2*l - di0(l)=(clo0(l)-clo(l))/ded - dip0(l)=(clop0(l)-clop(l))/ded - t(6,ll-1)=di0(l) - t(6,ll)=dip0(l) - end do - - if(ncorru.eq.0) then - call f_open(unit=34,file="fort.34",formatted=.true.,mode="w") - write(lout,10010) - write(lout,10050) (di0(l),dip0(l),l=1,2) - endif - - call betalf(dpp,qw) - call phasad(dpp,qwc) - - if(ierro /= 0) then - write(lerr,"(a)") "LINOPT> ERROR No optical solution." - call prror - end if - if(ncorru.eq.0) write(lout,10040) dpp,qwc(1),qwc(2) - - call envar(dpp) - - if(ithick.eq.1) call envardis(dpp1,aeg,bl1eg,bl2eg) - -!--STARTVALUES OF THE TRAJECTORIES - do l=1,2 - ll=2*l - t(1,ll-1)=clo(l) - t(1,ll)=clop(l) - end do - - do i=1,4 - do j=1,4 - t(i+1,j)=ta(j,i) - t(i+1,j)=ta(j,i) - end do - end do - - if(ncorru.eq.0 .and. iprint.eq.1) then - write(lout,10010) - write(lout,10030) - write(lout,10020) - write(lout,10010) - endif - -!--START OF THE MACHINE - idum='START' - nr=0 - call writelin(nr,idum,etl,phi,t,1,.false.,0) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(idum,t,etl,phi) - endif - -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - -!--STRUCTURE ELEMENT LOOP - if(nt.le.0.or.nt.gt.iu) nt=iu - izu=0 -#ifdef HDF5 - if(h5_writeOptics) call h5lin_init -#endif - - STRUCTLOOP: do k=1,nt - ix=ic(k) - if(ix.gt.nblo) goto 220 !Not a BLOCK - if(ithick.eq.1.and.iprint.eq.1) goto 160 - - jj=0 !initial idx - dj=1 !step - - if (ix.le.0) then - ix=-1*ix !hr13 - jj=mel(ix)+1 !initial idx - dj=-1 !step - endif - jm=mel(ix) -!-- Loop over elements inside the block - do 150 j=1,jm - jj=jj+dj ! Subelement index of current sub=element - jk=mtyp(ix,jj) ! Single-element index of the current sub-element - if(ithick.eq.1.and.kz(jk).ne.0) goto 120 - if(ithick.eq.0.and.kz(jk).ne.0) then - etl=etl+el(jk) - -!c$$$ nr=nr+1 -!c$$$ call writelin(nr,bez(jk),etl,phi,t,ix,.true.,k) -!c$$$ if(ntco.ne.0) then -!c$$$ if(mod(nr,ntco).eq.0) call cpltwis(bez(jk),t,etl,phi) -!c$$$ endif - - write(lerr,"(a)") "LINOPT> ERROR In block '"//trim(bezb(ix))//"': found a thick non-drift element '"//& - trim(bez(jk))//"' while ithick=1. This should not be possible!" - call prror - cycle STRUCTLOOP - endif - -!--IN BLOCK: PURE DRIFTLENGTH (above: If ITHICK=1 and kz!=0, goto 120->MAGNETELEMENT) - etl=etl+el(jk) - - do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)).gt.pieni) then - phibf(l)=atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l)=pi2 - endif - do i=1,ium - t(i,ll-1)=t(i,ll-1)+t(i,ll)*(el(jk)) - end do - end do - - do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)).gt.pieni) then - dphi=atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi=pi2-phibf(l) - endif - if((-one*dphi).gt.pieni) dphi=dphi+pi !hr06 - phi(l)=phi(l)+dphi/pie - end do - - nr=nr+1 - call writelin(nr,bez(jk),etl,phi,t,ix,.true.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(jk),t,etl, phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - goto 150 - -!--IN BLOCK: MAGNETELEMENT - 120 continue - if(kz(jk).ne.8) etl=etl+el(jk) - do l=1,2 - ll=2*l - - if(abs(t(ll,ll-1)).gt.pieni) then - phibf(l)=atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l)=zero - endif - - puf=t(6,ll-1) - t(6,ll-1)=(((((aeg(jk,l,1)*(t(1,ll-1)+puf*ded)+ aeg(jk,l,2)*(t &!hr06 - &(1,ll)+t(6,ll)*ded))+aeg(jk,l,5)*dpp1*c1e3)- a(jk,l,1)*t &!hr06 - &(1,ll-1))-a(jk,l,2)*t(1,ll))- a(jk,l,5)*dpr(1))/ded !hr06 - t(6,ll)=(((((aeg(jk,l,3)*(t(1,ll-1)+puf*ded)+ aeg(jk,l,4)*(t &!hr06 - &(1,ll)+t(6,ll)*ded))+aeg(jk,l,6)*dpp1*c1e3)- a(jk,l,3)*t &!hr06 - &(1,ll-1))-a(jk,l,4)*t(1,ll))- a(jk,l,6)*dpr(1))/ded !hr06 - - do i=1,ium-1 - puf=t(i,ll-1) - t(i,ll-1)=(puf*a(jk,l,1)+t(i,ll)*a(jk,l,2))+dpr(i)*a(jk,l,5) !hr06 - t(i,ll)=(puf*a(jk,l,3)+t(i,ll)*a(jk,l,4))+dpr(i)*a(jk,l,6) !hr06 - enddo - enddo - - do l=1,2 - ll=2*l - - if(abs(t(ll,ll-1)).gt.pieni) then - dphi=atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi=-one*phibf(l) !hr06 - endif - - if(kz(jk).ne.8.and.-one*dphi.gt.pieni) dphi=dphi+pi !hr06 - phi(l)=phi(l)+dphi/pie - enddo - - nr=nr+1 - call writelin(nr,bez(jk),etl,phi,t,ix,.true.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(jk),t,etl, phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - 150 continue !End of loop over elements inside block - - nr=nr+1 - call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bezb(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - cycle STRUCTLOOP - -!--BETACALCULATION FOR SERIES OF BLOCKS (ix.ge.nblo.and.ithick.eq.1.and.iprint.eq.1) - 160 continue !if ithick=1 and iprint=1: - if(ix.le.0) goto 190 -!--REGULAR RUN THROUGH BLOCKS - etl=etl+elbe(ix) - - do l=1,2 - ll=2*l - - if(abs(t(ll,ll-1)).gt.pieni) then - phibf(l)=atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l)=zero - endif - - puf=t(6,ll-1) - t(6,ll-1)=(((((bl1eg(ix,l,1)*(t(1,ll-1)+puf*ded)+ bl1eg(ix,l,2)*(t&!hr06 - &(1,ll)+t(6,ll)*ded))+ bl1eg(ix,l,5)*dpp1*c1e3)- bl1(ix,l,1)*t &!hr06 - &(1,ll-1))-bl1(ix,l,2)*t(1,ll))- bl1(ix,l,5)*dpr(1))/ded !hr06 - t(6,ll)=(((((bl1eg(ix,l,3)*(t(1,ll-1)+puf*ded)+ bl1eg(ix,l,4)*(t &!hr06 - &(1,ll)+t(6,ll)*ded))+ bl1eg(ix,l,6)*dpp1*c1e3)- bl1(ix,l,3)*t &!hr06 - &(1,ll-1))-bl1(ix,l,4)*t(1,ll))- bl1(ix,l,6)*dpr(1))/ded !hr06 - - do i=1,ium-1 - puf=t(i,ll-1) - t(i,ll-1)=(bl1(ix,l,1)*puf+bl1(ix,l,2)*t(i,ll))+dpr(i)*bl1 &!hr06 - &(ix,l,5) !hr06 - t(i,ll)=(bl1(ix,l,3)*puf+bl1(ix,l,4)*t(i,ll))+dpr(i)*bl1(ix,l,6) !hr06 - end do - end do - - do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)).gt.pieni) then - dphi=atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi=-one*phibf(l) !hr06 - endif - if(-one*dphi.gt.pieni) dphi=dphi+pi !hr06 - phi(l)=phi(l)+dphi/pie - end do - - nr=nr+1 - call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bezb(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - cycle STRUCTLOOP - -!--REVERSE RUN THROUGH BLOCKS (ix.le.0) - 190 ix=-ix - etl=etl+elbe(ix) - do l=1,2 - ll=2*l - - if(abs(t(ll,ll-1)).gt.pieni) then - phibf(l)=atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l)=zero - endif - - puf=t(6,ll-1) - t(6,ll-1)=(((((bl2eg(ix,l,1)*(t(1,ll-1)+puf*ded)+ bl2eg(ix,l,2)*(t&!hr06 - &(1,ll)+t(6,ll)*ded))+ bl2eg(ix,l,5)*dpp1*c1e3)- bl2(ix,l,1)*t &!hr06 - &(1,ll-1))-bl2(ix,l,2)*t(1,ll))- bl2(ix,l,5)*dpr(1))/ded !hr06 - t(6,ll)=(((((bl2eg(ix,l,3)*(t(1,ll-1)+puf*ded)+ bl2eg(ix,l,4)*(t &!hr06 - &(1,ll)+t(6,ll)*ded))+ bl2eg(ix,l,6)*dpp1*c1e3)- bl2(ix,l,3)*t &!hr06 - &(1,ll-1))-bl2(ix,l,4)*t(1,ll))- bl2(ix,l,6)*dpr(1))/ded !hr06 - - do i=1,ium-1 - puf=t(i,ll-1) - t(i,ll-1)=(bl2(ix,l,1)*puf+bl2(ix,l,2)*t(i,ll))+dpr(i)*bl2 &!hr06 - &(ix,l,5) !hr06 - t(i,ll)=(bl2(ix,l,3)*puf+bl2(ix,l,4)*t(i,ll))+dpr(i)*bl2(ix,l,6) !hr06 - end do - end do - - do l=1,2 - ll=2*l - - if(abs(t(ll,ll-1)).gt.pieni) then - dphi=atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi=-phibf(l) - endif - - if(-one*dphi.gt.pieni) dphi=dphi+pi !hr06 - phi(l)=phi(l)+dphi/pie - end do - - nr=nr+1 - call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bezb(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - cycle STRUCTLOOP - -!--NOT A BLOCK / Nonlinear insertion - 220 ix=ix-nblo - qu=zero - qv=zero - dyy1=zero - dyy2=zero - kpz=kp(ix) - kzz=kz(ix) - - ! Cavity - if( kpz.eq.6 .or. abs(kzz).eq.12 ) then - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - cycle STRUCTLOOP - endif - - !Beam Beam element .and. fort.3 has BB block - if(kzz.eq.20.and.nbeam.ge.1) then - nbeam=k - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - cycle STRUCTLOOP - endif - ! if kzz==22, starts a do over l; Update t matrix - if(kzz == 22) then - do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)).gt.pieni) then - phibf(l)=atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l)=zero - end if - do i=1,ium - puf=t(i,ll-1) - t(i,ll-1)=(puf*rrtr(imtr(ix),ll-1,ll-1)+t(i,ll)*rrtr(imtr(ix),ll-1,ll))+dpr(i)*rrtr(imtr(ix),ll-1,6) - t(i,ll)=(puf*rrtr(imtr(ix),ll,ll-1)+t(i,ll)*rrtr(imtr(ix),ll,ll))+dpr(i)*rrtr(imtr(ix),ll,6) - end do - t(1,ll-1)=t(1,ll-1)+cotr(imtr(ix),ll-1) - t(1,ll)=t(1,ll)+cotr(imtr(ix),ll) - if(abs(t(ll,ll-1)) > pieni) then - dphi=atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi=-one*phibf(l) - end if - if(-one*dphi.gt.pieni) dphi=dphi+pi - phi(l)=phi(l)+dphi/pie - enddo - endif - -!+if collimat.or.bnlelens - ! Marker, beam-beam, phase-trombone, crab cavity (incl. multipole), or wire - if(kzz.eq.0.or.kzz.eq.20.or.kzz.eq.22 & - & .or.abs(kzz).eq.23.or.abs(kzz).eq.26 & - & .or.abs(kzz).eq.27.or.abs(kzz).eq.28 & - & .or.abs(kzz).eq.15) then - - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - cycle STRUCTLOOP - endif -!+ei -!+if .not.collimat.and..not.bnlelens -! ! Marker, beam-beam or phase-trombone -> next element -! if(kzz.eq.0.or.kzz.eq.20.or.kzz.eq.22) then -! cycle STRUCTLOOP -! endif -! ! Wire -> next element -! if(abs(kzz).eq.15) then -! cycle STRUCTLOOP -! endif -! ! RF CC Multipoles -> next element -! if (abs(kzz).eq.23.or.abs(kzz).eq.26.or. & -! & abs(kzz).eq.27.or.abs(kzz).eq.28) then -! cycle STRUCTLOOP -! endif -!+ei - - ! Update the matrix etc. for supported blocks - dyy1=zero - dyy2=zero - if(iorg.lt.0) mzu(k)=izu - izu=mzu(k)+1 - ekk=(sm(ix)+zfz(izu)*ek(ix))/(one+dpp) - izu=izu+1 - xs=xpl(ix)+zfz(izu)*xrms(ix) - izu=izu+1 - zs=zpl(ix)+zfz(izu)*zrms(ix) -#include "include/alignl.f90" - - if (kzz .ge. 0) then - select case(kzz) - - case (1) -!--HORIZONTAL DIPOLE - ekk=ekk*c1e3 -#include "include/kickl01h.f90" -#include "include/kickq01h.f90" -!--NORMAL QUADRUPOLE - case(2) -#include "include/kicklxxh.f90" -#include "include/kickq02h.f90" -!-- NORMAL SEXTUPOLE - case(3) - ekk=ekk*c1m3 -#include "include/kickq03h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL OCTUPOLE - case(4) - ekk=ekk*c1m6 -#include "include/kicksho.f90" -#include "include/kickq04h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL DECAPOLE - case(5) - ekk=ekk*c1m9 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq05h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL DODECAPOLE - case(6) - ekk=ekk*c1m12 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq06h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL 14-POLE - case(7) - ekk=ekk*c1m15 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq07h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL 16-POLE - case(8) - ekk=ekk*c1m18 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq08h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL 18-POLE - case(9) - ekk=ekk*c1m21 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq09h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--NORMAL 20-POLE - case(10) - ekk=ekk*c1m24 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq10h.f90" -#include "include/kicksho.f90" -#include "include/kicklxxh.f90" -!--Multipole block - case(11) - r0=ek(ix) - if(abs(dki(ix,1)).gt.pieni) then - if(abs(dki(ix,3)).gt.pieni) then -#include "include/multl01.f90" -#include "include/multl08.f90" - do 340 i=2,ium -#include "include/multl02.f90" - 340 continue - else -#include "include/multl03.f90" -#include "include/multl09.f90" - endif - endif - if(abs(dki(ix,2)).gt.pieni) then - if(abs(dki(ix,3)).gt.pieni) then -#include "include/multl04.f90" -#include "include/multl10.f90" - do 350 i=2,ium -#include "include/multl05.f90" - 350 continue - else -#include "include/multl06.f90" -#include "include/multl11.f90" - endif - endif - if(abs(r0).le.pieni) then - cycle STRUCTLOOP - endif - nmz=nmu(ix) - if(nmz.eq.0) then - izu=izu+2*mmul - - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - cycle STRUCTLOOP - endif - im=irm(ix) - r0a=one - benkr=ed(ix)/(one+dpp) - do 360 l=1,nmz -#include "include/multl07a.f90" - 360 continue - if(nmz.ge.2) then -#include "include/multl07b.f90" - do 365 l=3,nmz -#include "include/multl07c.f90" - 365 continue - else -#include "include/multl07d.f90" - endif -#ifdef TILT -#include "include/multl07e.f90" -#endif - izu=izu+2*mmul-2*nmz - -!--Skipped elements - case(12,13,14,15,16,17,18,19,20,21,22,23) - cycle STRUCTLOOP - -!--DIPEDGE ELEMENT - case(24) -#include "include/kickldpe.f90" -#include "include/kickqdpe.f90" -!--solenoid - case(25) -#include "include/kicklso1.f90" -#include "include/kickqso1.f90" - -!--Skipped elements - case(26,27,28) - cycle STRUCTLOOP - -!--Unrecognized element (incl. cav with kp.ne.6 for non-collimat/bnlelens) - case default - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - cycle STRUCTLOOP - end select - - -!--SKEW ELEMENTS - else if(kzz .lt. 0) then - kzz=-kzz !Make it positive - select case(kzz) - case(1) -!--VERTICAL DIPOLE - ekk=ekk*c1e3 -#include "include/kickl01v.f90" -#include "include/kickq01v.f90" -!--SKEW QUADRUPOLE - case(2) -#include "include/kicklxxv.f90" -#include "include/kickq02v.f90" -!--SKEW SEXTUPOLE - case(3) - ekk=ekk*c1m3 -#include "include/kickq03v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW OCTUPOLE - case(4) - ekk=ekk*c1m6 -#include "include/kicksho.f90" -#include "include/kickq04v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW DECAPOLE - case(5) - ekk=ekk*c1m9 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq05v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW DODECAPOLE - case(6) - ekk=ekk*c1m12 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq06v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW 14-POLE - case(7) - ekk=ekk*c1m15 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq07v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW 16-POLE - case(8) - ekk=ekk*c1m18 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq08v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW 18-POLE - case(9) - ekk=ekk*c1m21 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq09v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" -!--SKEW 20-POLE - case(10) - ekk=ekk*c1m24 -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kicksho.f90" -#include "include/kickq10v.f90" -#include "include/kicksho.f90" -#include "include/kicklxxv.f90" - -! Unrecognized skew element (including kzz=-12,kp.ne.6 for non-collimat/bnlelens) - case default - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - cycle STRUCTLOOP - end select - endif - - !Done processing an element: go here! - t(6,2)=t(6,2)-dyy1/(one+dpp) - t(6,4)=t(6,4)-dyy2/(one+dpp) - t(1,2)=t(1,2)+dyy1 - t(1,4)=t(1,4)+dyy2 - do i=2,ium - if(kzz.eq.24) then - t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 - t(i,4)=(t(i,4)-t(i,3)*quz)-qvz*t(i,1) !hr06 -!Contains elseif statements -#include "include/phas1so1.f90" -#include "include/phas2so1.f90" -#include "include/phas3so1.f90" - else - t(i,4)=(t(i,4)-t(i,3)*qu)-qv*t(i,1) !hr06 - t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 - endif - end do - bexi=t(2,1)**2+t(3,1)**2 !hr06 - bezii=t(4,3)**2+t(5,3)**2 !hr06 - if(ncorru.eq.0) then - if(kz(ix).eq.11) then - if(abs(aa(2)).gt.pieni.and.nmz.gt.1) then - write(34,10070) etl,bez(ix),-2,aa(2),bexi,bezii,phi - endif - do iiii=3,nmz - if(abs(bb(iiii)).gt.pieni) then - write(34,10070) etl,bez(ix),iiii,bb(iiii),bexi,bezii,phi - endif - if(abs(aa(iiii)).gt.pieni) then - write(34,10070) etl,bez(ix),-iiii,aa(iiii),bexi,bezii,phi - endif - enddo - elseif(abs(ekk).gt.pieni.and.abs(kz(ix)).ge.3) then - write(34,10070) etl,bez(ix),kz(ix),ekk,bexi,bezii,phi - elseif(abs(ekk).gt.pieni.and.kz(ix).eq.-2) then - write(34,10070) etl,bez(ix),kz(ix),ekk,bexi,bezii,phi - endif - endif - - nr=nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco.ne.0) then - if(mod(nr,ntco).eq.0) call cpltwis(bez(ix),t,etl,phi) - endif -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWrite() - end if -#endif - - end do STRUCTLOOP ! END LOOP OVER ELEMENTS - -#ifdef HDF5 - if(h5_writeOptics) call h5lin_saveData -#endif - - call clorb(ded) - do 510 l=1,2 - clo0(l)=clo(l) - clop0(l)=clop(l) - 510 continue - call clorb(zero) - do 520 l=1,2 - ll=2*l - di0(l)=(clo0(l)-clo(l))/ded - dip0(l)=(clop0(l)-clop(l))/ded - 520 continue - iiii=100 - idum='END' - bexi=t(2,1)**2+t(3,1)**2 !hr06 - bezii=t(4,3)**2+t(5,3)**2 !hr06 - if(ncorru.eq.0) write(34,10070) etl,idum,iiii,zero,bexi,bezii,phi - if(ncorru.eq.0) write(lout,10060) -!----------------------------------------------------------------------- - return -10000 format(t5 ,'---- ENTRY LINOPT ----') -10010 format(132('-')) -10020 format(' NR TYP L-TOTAL P PHI ', & - &'BETA ALFA GAMMA DIS DISP ',& - &'CLO CLOP'/ 1x, & - &' (M) (2*PI) ', & - &'(M) (RAD) (M) (M) (RAD) ',& - &'(MM) (MRAD)') -10030 format(' LINEAR OPTICS CALCULATION WITH PRINTOUT ', & - &'AFTER EACH BLOCK'/ & - &' A T T E N T I O N : BETATRON PHASE CALCULATION MIGHT BE WRONG'& - &,' BY A MULTIPLE OF 0.5 FOR EACH LARGE BLOCK'/) -10040 format(/10x,'RELATIVE ENERGY DEVIATION ',t40,f23.16/ 10x, & - &'TUNES -HORIZONTAL',t40,f23.16/ 10x,' -VERTICAL ',t40,f23.16/) -10050 format(t8,' PLANE DISP(MM) DISP(MRAD)'/ & - &t6,' X ',2(f20.12,6x)/t10,' Y ',2(f20.12,6x)/) -10060 format(//131('-')//) -10070 format(1x,1pg21.14,1x,a,1x,i4,5(1x,1pg21.14)) -end subroutine linopt - -!----------------------------------------------------------------------- -! WRITE OUT LINEAR OPTICS PARAMETERS AND IF COLLIMATION, SAVE STUFF. -!----------------------------------------------------------------------- -subroutine writelin(nr,typ,tl,p1,t,ixwl,isBLOC,ielem) - use floatPrecision - use numerical_constants - use mathlib_bouncer - use crcoall - use parpro - use mod_settings - use mod_common - use mod_commons - use mod_common_track - -#ifdef ROOT - use iso_c_binding, only: C_NULL_CHAR - use root_output -#endif - -#ifdef HDF5 - use hdf5_output - use hdf5_linopt -#endif - - use collimation - - implicit none - - integer i,iwrite,ixwl,l,ll,nr - real(kind=fPrec) al1,al2,b1,b2,c,cp,d,dp,g1,g2,p1,t,tl - character(len=mNameLen) typ - ! isBLOC.eq.TRUE if ixwl currently refers to a BLOC index, FALSE if it is a SINGLE ELEMENT index - logical isBLOC - dimension p1(2),t(6,4),b1(2),b2(2),al1(2),al2(2),g1(2),g2(2) - dimension d(2),dp(2),c(2),cp(2) - integer ielem - -#ifdef HDF5 - real(kind=fPrec) hdf5Data(17) -#endif - - save -!----------------------------------------------------------------------- - iwrite=0 - if(nlin.eq.0) then - iwrite=1 - else - do i=1,nlin - if(typ.eq.bezl(i)) iwrite=1 - end do - end if - if(iwrite.eq.1) then - do l=1,2 - ll=2*l - b1(l)=t(ll,ll-1)**2+t(ll+1,ll-1)**2 !hr06 - b2(l)=t(6-ll,ll-1)**2+t(7-ll,ll-1)**2 !hr06 - al1(l)=-one*(t(ll,ll-1)*t(ll,ll)+t(ll+1,ll-1)*t(ll+1,ll)) !hr06 - al2(l)=-one*(t(6-ll,ll-1)*t(6-ll,ll)+t(7-ll,ll-1)*t(7-ll,ll)) !hr06 - g1(l)=t(ll,ll)**2+t(ll+1,ll)**2 !hr06 - g2(l)=t(6-ll,ll)**2+t(7-ll,ll)**2 !hr06 - d(l)=t(6,ll-1)*c1m3 - dp(l)=t(6,ll)*c1m3 - c(l)=t(1,ll-1) - cp(l)=t(1,ll) - end do - -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWriteLin(nr, typ // C_NULL_CHAR,len(typ),tl,c(1),cp(1),c(2),cp(2),& - b1(1),b1(2),al1(1),al1(2),d(1),d(2),dp(1),dp(2)) - end if -#endif -#ifdef HDF5 - if(h5_writeOptics) then - hdf5Data(:) = (/tl,& - p1(1),b1(1),al1(1),g1(1),d(1),dp(1),c(1),cp(1),& - p1(2),b1(2),al1(2),g1(2),d(2),dp(2),c(2),cp(2)/) - call h5lin_writeLine(nr, typ, hdf5Data) - end if -#endif - - if (do_coll) then - tbetax(max(ielem,1)) = b1(1) - tbetay(max(ielem,1)) = b1(2) - talphax(max(ielem,1)) = al1(1) - talphay(max(ielem,1)) = al1(2) - torbx(max(ielem,1)) = c(1) - torbxp(max(ielem,1)) = cp(1) - torby(max(ielem,1)) = c(2) - torbyp(max(ielem,1)) = cp(2) - tdispx(max(ielem,1)) = d(1) - tdispy(max(ielem,1)) = d(2) - endif - - if(ncorru == 0) then - if(st_quiet == 0) then - write(lout,10000) nr,typ(:8),tl,p1(1),b1(1),al1(1),g1(1),d(1),dp(1),c(1),cp(1) - write(lout,10010) b2(1),al2(1),g2(1) - write(lout,10030) typ(9:16) - write(lout,10020) p1(2),b1(2),al1(2),g1(2),d(2),dp(2),c(2),cp(2) - write(lout,10010) b2(2),al2(2),g2(2) - write(lout,10040) - end if - else - if(.not.isBLOC) then - if(kp(ixwl).eq.3) then - nhmoni=nhmoni+1 - betam(nhmoni,1)=b1(1) - pam(nhmoni,1)=(p1(1)*two)*pi - bclorb(nhmoni,1)=c(1) - else if(kp(ixwl).eq.4) then - nhcorr=nhcorr+1 - betac(nhcorr,1)=b1(1) - pac(nhcorr,1)=(p1(1)*two)*pi - else if(kp(ixwl).eq.-3) then - nvmoni=nvmoni+1 - betam(nvmoni,2)=b1(2) - pam(nvmoni,2)=(p1(2)*two)*pi - bclorb(nvmoni,2)=c(2) - else if(kp(ixwl).eq.-4) then - nvcorr=nvcorr+1 - betac(nvcorr,2)=b1(2) - pac(nvcorr,2)=(p1(2)*two)*pi - end if - end if - end if - end if -!----------------------------------------------------------------------- - return -10010 format('|',6x,'|',8x,'|',12x,'|',1x,'|',12x,'|',f12.6,'|', f13.7,'|',f11.6,'|',11x,'|',11x,'|',11x,'|',11x,'|') -10020 format('|',6x,'|',8x,'|',12x,'|','Y','|',f12.7,'|',f12.6,'|', f13.7,'|',f11.6,'|',f11.7,'|',f11.7,'|',f11.7,'|',f11.7,'|') -10040 format(132('-')) -10000 format('|',i6,'|',a8,'|',f12.5,'|','X','|',f12.7,'|',f12.6,'|',f13.7,'|',f11.6,'|',f11.7,'|',f11.7,'|',f11.7,'|',f11.7,'|') -10030 format('|',6x,'|',a8,'|',12x,'|',102('-')) -end subroutine writelin - -subroutine cpltwis(typ,t,etl,phi) -!----------------------------------------------------------------------- -! CALCULATES COUPLED TWISS PARAMETERS AROUND THE RING AND ALSO THE -! ANGLE OF THE MAJOR AXIS OF A ELLIPSE IN THE X-Y PROJECTION WITH -! THE X-AXIS. THE 4-D ELLIPSOID IS GIVEN BY THE BOUNDARY OF A -! DISTRIBUTION OF PARTICLES WITH MAXIMUM EMITANCE OF MODE I AND II, -! EUI AND EUII RESPECTIVELY. -! BINARY PRINT ON FILE 11 OF 22 VALUES : -! POSITION [M], -! BET(1-4), ALF(1-4), GAM(1-4), COOR-PHI(1-4), COOR-PRIME-PHI(1-4), -! COUUANGL -!----------------------------------------------------------------------- - use floatPrecision -#ifdef ROOT - use root_output -#endif - use numerical_constants - use mathlib_bouncer - use parpro - use mod_common - use mod_commons - use mod_common_track - use mod_units - implicit none - integer i,iwrite - logical :: open11 = .false. - real(kind=fPrec) alxi,alxii,alzi,alzii,bexi,bexii,bezi,bezii, & - &couuang,etl,gaxi,gaxii,gazi,gazii,phi,phxi,phxii,phxpi,phxpii, & - &phzi,phzii,phzpi,phzpii,t - character(len=mNameLen) typ - dimension t(6,4),phi(2) - save -!----------------------------------------------------------------------- - iwrite=0 - if(nlin.eq.0) then - iwrite=1 - else - do 10 i=1,nlin - if(typ.eq.bezl(i)) iwrite=1 - 10 continue - endif - if(iwrite.eq.1) then - bexi=t(2,1)**2+t(3,1)**2 !hr06 - bexii=t(4,1)**2+t(5,1)**2 !hr06 - bezi=t(2,3)**2+t(3,3)**2 !hr06 - bezii=t(4,3)**2+t(5,3)**2 !hr06 - alxi=-one*(t(2,1)*t(2,2)+t(3,1)*t(3,2)) !hr06 - alxii=-one*(t(4,1)*t(4,2)+t(5,1)*t(5,2)) !hr06 - alzi=-one*(t(2,3)*t(2,4)+t(3,3)*t(3,4)) !hr06 - alzii=-one*(t(4,3)*t(4,4)+t(5,3)*t(5,4)) !hr06 - gaxi=t(2,2)**2+t(3,2)**2 !hr06 - gaxii=t(4,2)**2+t(5,2)**2 !hr06 - gazi=t(2,4)**2+t(3,4)**2 !hr06 - gazii=t(4,4)**2+t(5,4)**2 !hr06 - if(abs(t(2,1)).gt.pieni) phxi=atan2_mb(t(3,1),t(2,1)) - if(abs(t(4,1)).gt.pieni) phxii=atan2_mb(t(5,1),t(4,1)) - if(abs(t(4,1)).gt.pieni) phxii=atan2_mb(t(5,1),t(4,1)) - if(abs(t(2,3)).gt.pieni) phzi=atan2_mb(t(3,3),t(2,3)) - if(abs(t(4,3)).gt.pieni) phzii=atan2_mb(t(5,3),t(4,3)) - if(abs(t(2,2)).gt.pieni) phxpi=atan2_mb(t(3,2),t(2,2)) - if(abs(t(4,2)).gt.pieni) phxpii=atan2_mb(t(5,2),t(4,2)) - if(abs(t(2,4)).gt.pieni) phzpi=atan2_mb(t(3,4),t(2,4)) - if(abs(t(4,4)).gt.pieni) phzpii=atan2_mb(t(5,4),t(4,4)) - if(abs(t(2,1)).le.pieni) phxi=pi*half - if(abs(t(4,1)).le.pieni) then - if(bexii.gt.pieni) phxii=pi*half - if(bexii.le.pieni) phxii=zero - endif - if(abs(t(2,3)).le.pieni) then - if(bezi.gt.pieni) phzi=pi*half - if(bezi.le.pieni) phzi=zero - endif - if(abs(t(4,3)).le.pieni) phzii=pi*half - if(abs(t(2,2)).le.pieni) phxpi=pi*half - if(abs(t(4,2)).le.pieni) then - if(gaxii.gt.pieni) phxpii=pi*half - if(gaxii.le.pieni) phxpii=zero - endif - if(abs(t(2,4)).le.pieni) then - if(gazi.gt.pieni) phzpi=pi*half - if(gazi.le.pieni) phzpi=zero - endif - if(abs(t(4,4)).le.pieni) phzpii=pi*half - if(abs(eui*(bexi-bezi)+euii*(bexii-bezii)).gt.pieni) then - couuang=half*atan_mb((two*((eui*sqrt(bexi*bezi))* &!hr06 - &cos_mb(phxi-phzi)+ &!hr06 - &(euii*sqrt(bexii*bezii))*cos_mb(phxii-phzii)))/ (eui*(bexi-bezi) &!hr06 - &+euii*(bexii-bezii))) !hr06 - else - couuang=zero - endif - if(open11 .eqv. .false.) then - ! Note: Description above says binary file, but the file has been opened as ascii since at least 4.x - call f_open(unit=11,file="fort.11",formatted=.true.,mode="w") - open11 = .true. - end if - write(11,*) typ,etl,phi,bexi,bexii,bezi,bezii, alxi,alxii,alzi, & - &alzii, gaxi,gaxii,gazi,gazii,phxi,phxii,phzi,phzii, phxpi, & - &phxpii,phzpi,phzpii,couuang,t(6,1),t(6,2),t(6,3),t(6,4),t(1,1), & - &t(1,2),t(1,3),t(1,4) - -#ifdef ROOT - if(root_flag .and. root_Optics.eq.1) then - call OpticsRootWriteCpl(phi(1), phi(2),bexi,bexii,bezi,bezii, & - & alxi,alxii,alzi,alzii, & - & gaxi,gaxii,gazi,gazii, & - & phxi,phxii,phzi,phzii, & - & phxpi,phxpii,phzpi,phzpii, & - & couuang, & - & t(6,1),t(6,2),t(6,3),t(6,4), & - & t(1,1),t(1,2),t(1,3),t(1,4)) - end if -#endif - - endif - return -end subroutine cpltwis - subroutine loesd (rmat, vec,dimakt,dimtot,kod) !----------------------------------------------------------------------- ! SOLUTION OF A SYSTEM OF LINEAR EQUATIONS @@ -6772,9 +5594,8 @@ subroutine phasad(dpp,qwc) if(kzz.eq.24) then t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*quz)-qvz*t(i,1) !hr06 -#include "include/phas1so1.f90" -#include "include/phas2so1.f90" -#include "include/phas3so1.f90" + elseif(kzz.eq.25) then !--solenoid +#include "include/phassolenoid.f90" else t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*qu)-qv*t(i,1) !hr06 @@ -8102,9 +6923,8 @@ subroutine resex(dpp) if(kzz.eq.24) then t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*quz)-qvz*t(i,1) !hr06 -#include "include/phas1so1.f90" -#include "include/phas2so1.f90" -#include "include/phas3so1.f90" + elseif(kzz.eq.25) then !--solenoid +#include "include/phassolenoid.f90" else t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*qu)-qv*t(i,1) !hr06 @@ -9395,9 +8215,8 @@ subroutine subre(dpp) if(kzz.eq.24) then t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*quz)-qvz*t(i,1) !hr06 -#include "include/phas1so1.f90" -#include "include/phas2so1.f90" -#include "include/phas3so1.f90" + elseif(kzz.eq.25) then !--solenoid +#include "include/phassolenoid.f90" else t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*qu)-qv*t(i,1) !hr06 @@ -10322,9 +9141,8 @@ subroutine subsea(dpp) if(kzz.eq.24) then t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*quz)-qvz*t(i,1) !hr06 -#include "include/phas1so1.f90" -#include "include/phas2so1.f90" -#include "include/phas3so1.f90" + elseif(kzz.eq.25) then !--solenoid +#include "include/phassolenoid.f90" else t(i,2)=(t(i,2)+t(i,1)*qu)-qv*t(i,3) !hr06 t(i,4)=(t(i,4)-t(i,3)*qu)-qv*t(i,1) !hr06 From 27febbc07f91a28f68b1b3fb93a17ada87b0c514 Mon Sep 17 00:00:00 2001 From: "Veronica K. B. Olsen" Date: Thu, 8 Aug 2019 18:54:21 +0200 Subject: [PATCH 2/6] Created the mod_linopt module --- source/linear_optics.f90 | 13 ++++++++++++ source/main_cr.f90 | 4 +++- source/main_da.f90 | 1 + source/sixtrack.f90 | 44 ++++++++++++++++++++++------------------ 4 files changed, 41 insertions(+), 21 deletions(-) diff --git a/source/linear_optics.f90 b/source/linear_optics.f90 index ba74e08df..65b77a319 100644 --- a/source/linear_optics.f90 +++ b/source/linear_optics.f90 @@ -1,3 +1,14 @@ +! ================================================================================================ ! +! Linear Optics Calculations Module +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Updated: 2019-08-08 +! ================================================================================================ ! +module mod_linopt + + implicit none + +contains + !----------------------------------------------------------------------- ! LINEAR PARAMETERS AT THE POSITION OF EVERY ELEMENT OR BLOCK !----------------------------------------------------------------------- @@ -1171,3 +1182,5 @@ subroutine cpltwis(typ,t,etl,phi) end if end subroutine cpltwis + +end module mod_linopt diff --git a/source/main_cr.f90 b/source/main_cr.f90 index 74cc694ff..e1421c08a 100644 --- a/source/main_cr.f90 +++ b/source/main_cr.f90 @@ -15,6 +15,7 @@ program maincr use floatPrecision use mod_units + use mod_linopt use string_tools use sixtrack_input use mathlib_bouncer @@ -83,7 +84,8 @@ program maincr real(kind=fPrec) alf0s1,alf0s2,alf0s3,alf0x2,alf0x3,alf0z2,alf0z3,amp00,bet0s1,bet0s2,bet0s3, & bet0x2,bet0x3,bet0z2,bet0z3,chi,coc,dam1,dchi,dp0,dp00,dp10,dpsic,dps0,dsign,gam0s1,gam0s2, & gam0s3,gam0x1,gam0x2,gam0x3,gam0z1,gam0z2,gam0z3,phag,r0,r0a,rat0,sic,tasia56,tasiar16,tasiar26,& - tasiar36,tasiar46,tasiar56,tasiar61,tasiar62,tasiar63,tasiar64,tasiar65,taus,x11,x13,damp,eps(2),epsa(2) + tasiar36,tasiar46,tasiar56,tasiar61,tasiar62,tasiar63,tasiar64,tasiar65,taus,x11,x13,damp, & + eps(2),epsa(2) integer idummy(6) character(len=4) cpto character(len=1024) arecord diff --git a/source/main_da.f90 b/source/main_da.f90 index b17f02a14..8c3f17886 100644 --- a/source/main_da.f90 +++ b/source/main_da.f90 @@ -21,6 +21,7 @@ program mainda use mathlib_bouncer use crcoall use parpro + use mod_linopt use mod_common use mod_commons use mod_common_track diff --git a/source/sixtrack.f90 b/source/sixtrack.f90 index 798b86dee..52599d704 100644 --- a/source/sixtrack.f90 +++ b/source/sixtrack.f90 @@ -4053,31 +4053,35 @@ subroutine matrix(dpp,am) return end subroutine matrix -subroutine corrorb !----------------------------------------------------------------------- ! CORRECTION OF CLOSED ORBIT FIRST (MOST EFFECTIV CORRECTOR STRATEGY ! USING MICADO), THEN ! SCALING OF DIPOLE-ERRORS FOR RMS-VALUES OF THE CLOSED ORBIT !----------------------------------------------------------------------- - use floatPrecision - use numerical_constants - use mathlib_bouncer - use crcoall - use parpro - use mod_units - use mod_common - use mod_commons - use mod_common_track - implicit none - integer i,icflag,ihflag,ii,ij,im,iprinto,ivflag,j,k,kpz,kzz,l,nlino,ntcoo,nto,nx - real(kind=fPrec) ar(nmon1,ncor1) - real(kind=fPrec) b(nmon1),orbr(nmon1),xinc(ncor1) - real(kind=fPrec) rmsx,ptpx,rmsz,ptpz,rzero,rzero1 - real(kind=fPrec) clo0,clop0,hfac,qwc1,vfac - character(len=mNameLen) bezlo(nele) - dimension clo0(2),clop0(2) - dimension qwc1(3),nx(ncor1) - save +subroutine corrorb + + use floatPrecision + use numerical_constants + use mathlib_bouncer + use crcoall + use parpro + use mod_units + use mod_linopt + use mod_common + use mod_commons + use mod_common_track + + implicit none + + integer i,icflag,ihflag,ii,ij,im,iprinto,ivflag,j,k,kpz,kzz,l,nlino,ntcoo,nto,nx + real(kind=fPrec) ar(nmon1,ncor1) + real(kind=fPrec) b(nmon1),orbr(nmon1),xinc(ncor1) + real(kind=fPrec) rmsx,ptpx,rmsz,ptpz,rzero,rzero1 + real(kind=fPrec) clo0,clop0,hfac,qwc1,vfac + character(len=mNameLen) bezlo(nele) + dimension clo0(2),clop0(2) + dimension qwc1(3),nx(ncor1) + save !----------------------------------------------------------------------- rzero=zero rzero1=zero From 826a8840a2f8aad69970b08f31170fa949d544d5 Mon Sep 17 00:00:00 2001 From: "Veronica K. B. Olsen" Date: Thu, 8 Aug 2019 19:07:40 +0200 Subject: [PATCH 3/6] Moved input parsing of LINE block to mod_linopt --- source/linear_optics.f90 | 96 ++++++++++++++++++++++++++++++++++----- source/sixtrack.f90 | 3 +- source/sixtrack_input.f90 | 86 ----------------------------------- 3 files changed, 87 insertions(+), 98 deletions(-) diff --git a/source/linear_optics.f90 b/source/linear_optics.f90 index 65b77a319..707d57edc 100644 --- a/source/linear_optics.f90 +++ b/source/linear_optics.f90 @@ -9,6 +9,88 @@ module mod_linopt contains +! ================================================================================================ ! +! Parse Linear Optics Calculation Line +! Rewritten from code from DATEN by VKBO +! Updated: 2019-08-08 +! ================================================================================================ ! +subroutine linopt_parseInputLine(inLine, iLine, iErr) + + use crcoall + use string_tools + use mod_settings + use mod_common + use sixtrack_input + + character(len=*), intent(in) :: inLine + integer, intent(in) :: iLine + logical, intent(inout) :: iErr + + character(len=:), allocatable :: lnSplit(:) + character(len=mNameLen) mode + integer nSplit,i,ilin0 + logical spErr + + call chr_split(inLine, lnSplit, nSplit, spErr) + if(spErr) then + write(lerr,"(a)") "LINE> ERROR Failed to parse input line." + iErr = .true. + return + end if + + if(iLine == 1) then + + nlin = 0 + ilin = 1 + + if(nSplit > 0) mode = lnSplit(1) + if(nSplit > 1) call chr_cast(lnSplit(2),nt, iErr) + if(nSplit > 2) call chr_cast(lnSplit(3),ilin,iErr) + if(nSplit > 3) call chr_cast(lnSplit(4),ntco,iErr) + if(nSplit > 4) call chr_cast(lnSplit(5),eui, iErr) + if(nSplit > 5) call chr_cast(lnSplit(6),euii,iErr) + + select case(mode) + case("ELEMENT") + iprint = 0 + case("BLOCK") + iprint = 1 + case default + write(lerr,"(a)") "LINE> ERROR Valid modes are 'BLOCK' or 'ELEMENT'" + iErr = .true. + end select + + if(ilin /= 1 .and. ilin /= 2) then + write(lerr,"(a)") "LINE> ERROR Only 1 (4D) and 2 (6D) are valid options for ilin." + iErr = .true. + end if + + if(st_debug) then + call sixin_echoVal("mode",mode,"LINE",iLine) + call sixin_echoVal("nt", nt, "LINE",iLine) + call sixin_echoVal("ilin",ilin,"LINE",iLine) + call sixin_echoVal("ntco",ntco,"LINE",iLine) + call sixin_echoVal("eui", eui, "LINE",iLine) + call sixin_echoVal("euii",euii,"LINE",iLine) + end if + if(iErr) return + + else + + do i=1,nSplit + nlin = nlin + 1 + if(nlin > nele) then + write(lerr,"(2(a,i0))") "LINE> ERROR Too many elements for linear optics write out. Max is ",nele," got ",nlin + iErr = .true. + return + end if + bezl(nlin) = trim(lnSplit(i)) + end do + + end if + +end subroutine linopt_parseInputLine + !----------------------------------------------------------------------- ! LINEAR PARAMETERS AT THE POSITION OF EVERY ELEMENT OR BLOCK !----------------------------------------------------------------------- @@ -24,6 +106,7 @@ subroutine linopt(dpp) use floatPrecision use mathlib_bouncer use numerical_constants + use collimation #ifdef ROOT use root_output @@ -34,10 +117,6 @@ subroutine linopt(dpp) use hdf5_linopt #endif - use collimation - - implicit none - integer i,iiii,im,ium,ix,izu,j,jj,jk,jm,k,kpz,kzz,l,l1,ll,nmz,nr,dj real(kind=fPrec) aa,aeg,alfa,bb,benkr,beta,bexi,bezii,bl1eg,bl2eg,ci,cikve,clo0,clop0,cr,crkve, & crkveuk,di00,dip00,dphi,dpp,dpp1,dppi,dpr,dyy1,dyy2,ekk,etl,phi,phibf,puf,qu,qv,qw,qwc,r0,& @@ -504,7 +583,6 @@ subroutine linopt(dpp) end do end if -!+if collimat.or.bnlelens ! Marker, beam-beam, phase-trombone, crab cavity (incl. multipole), or wire if(kzz == 0 .or. kzz == 20 .or. kzz == 22 .or. abs(kzz) == 23 .or. abs(kzz) == 26 .or. & abs(kzz) == 27 .or. abs(kzz) == 28 .or. abs(kzz) == 15) then @@ -731,7 +809,7 @@ subroutine linopt(dpp) !--SKEW ELEMENTS else if(kzz < 0) then - kzz = -kzz !Make it positive + kzz = -kzz ! Make it positive select case(kzz) case(1) !--VERTICAL DIPOLE @@ -819,8 +897,8 @@ subroutine linopt(dpp) #include "include/kicksho.f90" #include "include/kicklxxv.f90" -! Unrecognized skew element (including kzz=-12,kp /= 6 for non-collimat/bnlelens) case default + ! Unrecognized skew element (including kzz=-12,kp /= 6 for non-collimat/bnlelens) nr = nr+1 call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) if(ntco /= 0) then @@ -965,8 +1043,6 @@ subroutine writelin(nr,typ,tl,p1,t,ixwl,isBLOC,ielem) use hdf5_linopt #endif - implicit none - integer i,iwrite,ixwl,l,ll,nr real(kind=fPrec) al1(2),al2(2),b1(2),b2(2),c(2),cp(2),d(2),dp(2),g1(2),g2(2),p1(2),t(6,4),tl character(len=mNameLen) typ @@ -1096,8 +1172,6 @@ subroutine cpltwis(typ,t,etl,phi) use root_output #endif - implicit none - integer i,iwrite logical :: open11 = .false. real(kind=fPrec) alxi,alxii,alzi,alzii,bexi,bexii,bezi,bezii,couuang,etl,gaxi,gaxii,gazi,gazii, & diff --git a/source/sixtrack.f90 b/source/sixtrack.f90 index 52599d704..033a4683f 100644 --- a/source/sixtrack.f90 +++ b/source/sixtrack.f90 @@ -23,6 +23,7 @@ subroutine daten use string_tools use mod_alloc use mod_units + use mod_linopt use mod_dist, only : dist_enable, dist_parseInputLine use scatter, only : scatter_active,scatter_debug,scatter_parseInputLine @@ -405,7 +406,7 @@ subroutine daten elseif(closeBlock) then continue else - call sixin_parseInputLineLINE(inLine,blockLine,inErr) + call linopt_parseInputLine(inLine,blockLine,inErr) if(inErr) goto 9999 end if diff --git a/source/sixtrack_input.f90 b/source/sixtrack_input.f90 index fb3d661f6..5fd0a2f12 100644 --- a/source/sixtrack_input.f90 +++ b/source/sixtrack_input.f90 @@ -29,9 +29,6 @@ module sixtrack_input logical, allocatable, private, save :: sixin_lBlock(:) ! Block closed integer, private, save :: sixin_nBlock ! Number of blocks - ! Linear Optics Variables - integer, private, save :: sixin_ilin0 = 1 - ! Synchrotron Oscillations real(kind=fPrec), public, save :: sixin_alc = c1m3 real(kind=fPrec), public, save :: sixin_harm = one @@ -1814,89 +1811,6 @@ subroutine sixin_parseInputLineTUNE(inLine, iLine, iErr) end subroutine sixin_parseInputLineTUNE -! ================================================================================================ ! -! Parse Linear Optics Calculation Line -! Rewritten from code from DATEN by VKBO -! Last modified: 2018-06-xx -! ================================================================================================ ! -subroutine sixin_parseInputLineLINE(inLine, iLine, iErr) - - use crcoall - use string_tools - use mod_settings - use mod_common - - character(len=*), intent(in) :: inLine - integer, intent(in) :: iLine - logical, intent(inout) :: iErr - - character(len=:), allocatable :: lnSplit(:) - character(len=mNameLen) mode - integer nSplit,i - logical spErr - - call chr_split(inLine, lnSplit, nSplit, spErr) - if(spErr) then - write(lerr,"(a)") "LINE> ERROR Failed to parse input line." - iErr = .true. - return - end if - - if(iLine == 1) then - - nlin = 0 - ilin = 1 - - if(nSplit > 0) mode = lnSplit(1) - if(nSplit > 1) call chr_cast(lnSplit(2),nt, iErr) - if(nSplit > 2) call chr_cast(lnSplit(3),sixin_ilin0,iErr) - if(nSplit > 3) call chr_cast(lnSplit(4),ntco, iErr) - if(nSplit > 4) call chr_cast(lnSplit(5),eui, iErr) - if(nSplit > 5) call chr_cast(lnSplit(6),euii, iErr) - - select case(mode) - case("ELEMENT") - iprint = 0 - case("BLOCK") - iprint = 1 - case default - write(lerr,"(a)") "LINE> ERROR Valid modes are 'BLOCK' or 'ELEMENT'" - iErr = .true. - end select - - if(sixin_ilin0 == 1 .or. sixin_ilin0 == 2) then - ilin = sixin_ilin0 - else - write(lerr,"(a)") "LINE> ERROR Only 1 (4D) and 2 (6D) are valid options for ilin." - iErr = .true. - end if - - if(st_debug) then - call sixin_echoVal("mode",mode,"LINE",iLine) - call sixin_echoVal("nt", nt, "LINE",iLine) - call sixin_echoVal("ilin",ilin,"LINE",iLine) - call sixin_echoVal("ntco",ntco,"LINE",iLine) - call sixin_echoVal("eui", eui, "LINE",iLine) - call sixin_echoVal("euii",euii,"LINE",iLine) - end if - if(iErr) return - - else - - do i=1,nSplit - nlin = nlin + 1 - if(nlin > nele) then - write(lerr,"(2(a,i0))") "LINE> ERROR Too many elements for linear optics write out. Max is ",nele," got ",nlin - iErr = .true. - return - end if - bezl(nlin) = trim(lnSplit(i)) - end do - - end if - -end subroutine sixin_parseInputLineLINE - ! ================================================================================================ ! ! Parse Synchrotron Oscillations Line ! Rewritten from code from DATEN by VKBO From 8d74b1bbd0aaafc61753c161be72915cae245c0d Mon Sep 17 00:00:00 2001 From: "Veronica K. B. Olsen" Date: Thu, 8 Aug 2019 19:18:51 +0200 Subject: [PATCH 4/6] Renamed fort.11 to linopt_dump.dat --- source/linear_optics.f90 | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/source/linear_optics.f90 b/source/linear_optics.f90 index 707d57edc..7c6731f38 100644 --- a/source/linear_optics.f90 +++ b/source/linear_optics.f90 @@ -7,6 +7,10 @@ module mod_linopt implicit none + ! Linear optics dump file, formerly fort.11 + character(len=15), private, parameter :: linopt_fileName = "linopt_dump.dat" + integer, private, save :: linopt_fileUnit = -1 + contains ! ================================================================================================ ! @@ -1173,7 +1177,6 @@ subroutine cpltwis(typ,t,etl,phi) #endif integer i,iwrite - logical :: open11 = .false. real(kind=fPrec) alxi,alxii,alzi,alzii,bexi,bexii,bezi,bezii,couuang,etl,gaxi,gaxii,gazi,gazii, & phi(2),phxi,phxii,phxpi,phxpii,phzi,phzii,phzpi,phzpii,t(6,4) character(len=mNameLen) typ @@ -1234,19 +1237,18 @@ subroutine cpltwis(typ,t,etl,phi) else couuang = zero end if - if(open11 .eqv. .false.) then - ! Note: Description above says binary file, but the file has been opened as ascii since at least 4.x - call f_open(unit=11,file="fort.11",formatted=.true.,mode="w") - open11 = .true. + if(linopt_fileUnit == -1) then + call f_requestUnit(linopt_fileName, linopt_fileUnit) + call f_open(unit=linopt_fileUnit,file=linopt_fileName,formatted=.true.,mode="w") end if - write(11,*) typ,etl,phi,bexi,bexii,bezi,bezii, alxi,alxii,alzi, & - alzii, gaxi,gaxii,gazi,gazii,phxi,phxii,phzi,phzii, phxpi, & - phxpii,phzpi,phzpii,couuang,t(6,1),t(6,2),t(6,3),t(6,4),t(1,1), & - t(1,2),t(1,3),t(1,4) + write(linopt_fileUnit,*) typ,etl,phi,bexi,bexii,bezi,bezii, & + alxi,alxii,alzi,alzii,gaxi,gaxii,gazi,gazii, & + phxi,phxii,phzi,phzii,phxpi,phxpii,phzpi,phzpii,couuang, & + t(6,1),t(6,2),t(6,3),t(6,4),t(1,1),t(1,2),t(1,3),t(1,4) #ifdef ROOT if(root_flag .and. root_Optics == 1) then - call OpticsRootWriteCpl(phi(1), phi(2),bexi,bexii,bezi,bezii, & + call OpticsRootWriteCpl(phi(1),phi(2),bexi,bexii,bezi,bezii, & alxi,alxii,alzi,alzii,gaxi,gaxii,gazi,gazii, & phxi,phxii,phzi,phzii,phxpi,phxpii,phzpi,phzpii,couuang, & t(6,1),t(6,2),t(6,3),t(6,4),t(1,1),t(1,2),t(1,3),t(1,4)) From 8d527e4f226c32d0e80525f78f6bb45b9cab394a Mon Sep 17 00:00:00 2001 From: "Veronica K. B. Olsen" Date: Wed, 14 Aug 2019 13:59:35 +0200 Subject: [PATCH 5/6] Fixed some broken indent, updated printout, and renamed fort.34 --- source/linear_optics.f90 | 584 ++++++++++++++++++++------------------- 1 file changed, 296 insertions(+), 288 deletions(-) diff --git a/source/linear_optics.f90 b/source/linear_optics.f90 index 7c6731f38..d5e53c78f 100644 --- a/source/linear_optics.f90 +++ b/source/linear_optics.f90 @@ -7,9 +7,11 @@ module mod_linopt implicit none - ! Linear optics dump file, formerly fort.11 - character(len=15), private, parameter :: linopt_fileName = "linopt_dump.dat" - integer, private, save :: linopt_fileUnit = -1 + ! Linear optics files, formerly fort.34 and fort.11 + character(len=15), private, parameter :: linopt_dumpFile = "linopt_dump.dat" + character(len=18), private, parameter :: linopt_coupleFile = "linopt_coupled.dat" + integer, private, save :: linopt_dumpUnit = -1 + integer, private, save :: linopt_coupleUnit = -1 contains @@ -32,7 +34,7 @@ subroutine linopt_parseInputLine(inLine, iLine, iErr) character(len=:), allocatable :: lnSplit(:) character(len=mNameLen) mode - integer nSplit,i,ilin0 + integer nSplit,i logical spErr call chr_split(inLine, lnSplit, nSplit, spErr) @@ -107,6 +109,7 @@ subroutine linopt(dpp) use mod_commons use mod_common_track use mod_settings + use string_tools use floatPrecision use mathlib_bouncer use numerical_constants @@ -145,9 +148,15 @@ subroutine linopt(dpp) ium = 6 if(ncorru == 0) then - write(lout,10010) - write(lout,10000) - endif + write(lout,"(a)") str_divLine + write(lout,"(a)") "" + write(lout,"(a)") " OOOOOOOOOOOOOOOOOOOOO" + write(lout,"(a)") " OO OO" + write(lout,"(a)") " OO Linear Optics OO" + write(lout,"(a)") " OO OO" + write(lout,"(a)") " OOOOOOOOOOOOOOOOOOOOO" + write(lout,"(a)") "" + end if dpr(:) = zero t(:,:) = zero @@ -174,11 +183,10 @@ subroutine linopt(dpp) dpp1 = dpp+ded call clorb(dpp1) - clo0(1:2) = clo(1:2) clop0(1:2) = clop(1:2) - call clorb(dpp) + write(lout,"(a)") "" do l=1,2 ll = 2*l @@ -189,20 +197,32 @@ subroutine linopt(dpp) end do if(ncorru == 0) then - call f_open(unit=34,file="fort.34",formatted=.true.,mode="w") - write(lout,10010) - write(lout,10050) (di0(l),dip0(l),l=1,2) - endif + call f_requestUnit(linopt_dumpFile, linopt_dumpUnit) + call f_open(unit=linopt_dumpUnit,file=linopt_dumpFile,formatted=.true.,mode="w",status="replace") + write(linopt_dumpUnit,"(a1,1x,a15,1x,a,1x,a4,5(1x,a16))") "#","len_tot",chr_rPad("element",mNameLen),& + "kz","ekk","bexi","bezii","phi(1)","phi(2)" + write(lout,"(a)") repeat("-",132) + write(lout,"(a)") "" + write(lout,"(a)") " PLANE | DISP(MM) | DISP(MRAD)" + write(lout,"(a)") " -----------------------------------------------------" + write(lout,"(a,f20.12,a3,f20.12)") " X | ",di0(1)," | ",dip0(1) + write(lout,"(a,f20.12,a3,f20.12)") " Y | ",di0(2)," | ",dip0(2) + write(lout,"(a)") "" + end if call betalf(dpp,qw) call phasad(dpp,qwc) if(ierro /= 0) then - write(lerr,"(a)") "LINOPT> ERROR No optical solution." + write(lerr,"(a)") "LINOPT> ERROR No optical solution" call prror end if if(ncorru == 0) then - write(lout,10040) dpp,qwc(1),qwc(2) + write(lout,"(a)") "" + write(lout,"(a,f23.16)") " Relative energy deviation : ",dpp + write(lout,"(a,f23.16)") " Horizontal tune : ",qwc(1) + write(lout,"(a,f23.16)") " Vertical tune : ",qwc(2) + write(lout,"(a)") "" end if call envar(dpp) @@ -226,10 +246,15 @@ subroutine linopt(dpp) end do if(ncorru == 0 .and. st_quiet == 0) then - write(lout,10010) - write(lout,10030) - write(lout,10020) - write(lout,10010) + write(lout,"(a)") repeat("-",132) + write(lout,"(a)") "" + write(lout,"(a)") " LINEAR OPTICS CALCULATION WITH PRINTOUT AFTER EACH BLOCK" + write(lout,"(a)") " Note: Betatron phase calculation might be wrong by a multiple of 0.5 for each large block" + write(lout,"(a)") "" + write(lout,"(a)") repeat("-",132) + write(lout,"(a)") "| NR | ELEM. | L-TOTAL(M) |P| PHI(2*PI) | BETA(M) | ALFA(RAD) |"//& + " GAMMA(M) | DIS(M) | DISP(RAD) | CLO(MM) | CLOP(MRAD)|" + write(lout,"(a)") repeat("-",132) end if !--START OF THE MACHINE @@ -262,7 +287,7 @@ subroutine linopt(dpp) STRUCTLOOP: do k=1,nt ix = ic(k) - if(ix > nblo) goto 220 !Not a BLOCK + if(ix > nblo) goto 220 ! Not a BLOCK if(ithick == 1 .and. iprint == 1) goto 160 jj=0 !initial idx @@ -270,13 +295,13 @@ subroutine linopt(dpp) if(ix <= 0) then ix = -1*ix - jj = mel(ix)+1 !initial idx - dj = -1 !step - endif + jj = mel(ix)+1 ! initial idx + dj = -1 ! step + end if jm = mel(ix) !-- Loop over elements inside the block - do 150 j=1,jm + do j=1,jm jj = jj+dj ! Subelement index of current sub=element jk = mtyp(ix,jj) ! Single-element index of the current sub-element if(ithick == 1 .and. kz(jk) /= 0) goto 120 @@ -330,7 +355,7 @@ subroutine linopt(dpp) end if #endif - goto 150 + cycle !--IN BLOCK: MAGNETELEMENT 120 continue @@ -388,69 +413,150 @@ subroutine linopt(dpp) end if #endif -150 continue !End of loop over elements inside block + end do ! End of loop over elements inside block - nr = nr+1 - call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) - if(ntco /= 0) then - if(mod(nr,ntco) == 0) then - call cpltwis(bezb(ix),t,etl,phi) - end if + nr = nr+1 + call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bezb(ix),t,etl,phi) end if + end if #ifdef ROOT - if(root_flag .and. root_Optics == 1) then - call OpticsRootWrite() - end if + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if #endif - cycle STRUCTLOOP + cycle STRUCTLOOP !--BETACALCULATION FOR SERIES OF BLOCKS (ix >= nblo.and.ithick == 1.and.iprint == 1) -160 continue !if ithick=1 and iprint=1: - if(ix <= 0) goto 190 +160 continue !if ithick=1 and iprint=1: + if(ix <= 0) goto 190 !--REGULAR RUN THROUGH BLOCKS - etl = etl+elbe(ix) + etl = etl+elbe(ix) - do l=1,2 - ll=2*l + do l=1,2 + ll=2*l - if(abs(t(ll,ll-1)) > pieni) then - phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l) = zero - end if + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = zero + end if - puf = t(6,ll-1) - t(6,ll-1) = (((((bl1eg(ix,l,1)*(t(1,ll-1)+puf*ded) + bl1eg(ix,l,2)*(t(1,ll)+t(6,ll)*ded)) & - + bl1eg(ix,l,5)*dpp1*c1e3)- bl1(ix,l,1)*t(1,ll-1))-bl1(ix,l,2)*t(1,ll))- bl1(ix,l,5)*dpr(1))/ded - t(6,ll) = (((((bl1eg(ix,l,3)*(t(1,ll-1)+puf*ded) + bl1eg(ix,l,4)*(t(1,ll)+t(6,ll)*ded)) & - + bl1eg(ix,l,6)*dpp1*c1e3)- bl1(ix,l,3)*t(1,ll-1))-bl1(ix,l,4)*t(1,ll))- bl1(ix,l,6)*dpr(1))/ded + puf = t(6,ll-1) + t(6,ll-1) = (((((bl1eg(ix,l,1)*(t(1,ll-1)+puf*ded) + bl1eg(ix,l,2)*(t(1,ll)+t(6,ll)*ded)) & + + bl1eg(ix,l,5)*dpp1*c1e3)- bl1(ix,l,1)*t(1,ll-1))-bl1(ix,l,2)*t(1,ll))- bl1(ix,l,5)*dpr(1))/ded + t(6,ll) = (((((bl1eg(ix,l,3)*(t(1,ll-1)+puf*ded) + bl1eg(ix,l,4)*(t(1,ll)+t(6,ll)*ded)) & + + bl1eg(ix,l,6)*dpp1*c1e3)- bl1(ix,l,3)*t(1,ll-1))-bl1(ix,l,4)*t(1,ll))- bl1(ix,l,6)*dpr(1))/ded - do i=1,ium-1 - puf = t(i,ll-1) - t(i,ll-1) = (bl1(ix,l,1)*puf+bl1(ix,l,2)*t(i,ll))+dpr(i)*bl1(ix,l,5) - t(i,ll) = (bl1(ix,l,3)*puf+bl1(ix,l,4)*t(i,ll))+dpr(i)*bl1(ix,l,6) - end do + do i=1,ium-1 + puf = t(i,ll-1) + t(i,ll-1) = (bl1(ix,l,1)*puf+bl1(ix,l,2)*t(i,ll))+dpr(i)*bl1(ix,l,5) + t(i,ll) = (bl1(ix,l,3)*puf+bl1(ix,l,4)*t(i,ll))+dpr(i)*bl1(ix,l,6) end do + end do - do l=1,2 - ll=2*l - if(abs(t(ll,ll-1)) > pieni) then - dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi = -one*phibf(l) - endif - if(-one*dphi > pieni) then - dphi = dphi+pi - end if - phi(l) = phi(l)+dphi/twopi + do l=1,2 + ll=2*l + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = -one*phibf(l) + end if + if(-one*dphi > pieni) then + dphi = dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + + nr = nr+1 + call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bezb(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + + cycle STRUCTLOOP + +!--REVERSE RUN THROUGH BLOCKS (ix <= 0) +190 ix = -ix + etl = etl+elbe(ix) + do l=1,2 + ll=2*l + + if(abs(t(ll,ll-1)) > pieni) then + phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) + else + phibf(l) = zero + end if + + puf = t(6,ll-1) + t(6,ll-1) = (((((bl2eg(ix,l,1)*(t(1,ll-1)+puf*ded) + bl2eg(ix,l,2)*(t(1,ll)+t(6,ll)*ded)) & + + bl2eg(ix,l,5)*dpp1*c1e3)- bl2(ix,l,1)*t(1,ll-1))-bl2(ix,l,2)*t(1,ll))- bl2(ix,l,5)*dpr(1))/ded + t(6,ll) = (((((bl2eg(ix,l,3)*(t(1,ll-1)+puf*ded) + bl2eg(ix,l,4)*(t(1,ll)+t(6,ll)*ded)) & + + bl2eg(ix,l,6)*dpp1*c1e3)- bl2(ix,l,3)*t(1,ll-1))-bl2(ix,l,4)*t(1,ll))- bl2(ix,l,6)*dpr(1))/ded + + do i=1,ium-1 + puf = t(i,ll-1) + t(i,ll-1) = (bl2(ix,l,1)*puf+bl2(ix,l,2)*t(i,ll))+dpr(i)*bl2(ix,l,5) + t(i,ll) = (bl2(ix,l,3)*puf+bl2(ix,l,4)*t(i,ll))+dpr(i)*bl2(ix,l,6) end do + end do + + do l=1,2 + ll = 2*l + + if(abs(t(ll,ll-1)) > pieni) then + dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) + else + dphi = -phibf(l) + end if + + if(-one*dphi > pieni) then + dphi = dphi+pi + end if + phi(l) = phi(l)+dphi/twopi + end do + + nr = nr+1 + call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bezb(ix),t,etl,phi) + end if + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + cycle STRUCTLOOP + + ! NOT A BLOCK / Nonlinear insertion +220 ix = ix-nblo + qu = zero + qv = zero + dyy1 = zero + dyy2 = zero + kpz = kp(ix) + kzz = kz(ix) + + ! Cavity + if(kpz == 6 .or. abs(kzz) == 12) then nr = nr+1 - call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) if(ntco /= 0) then if(mod(nr,ntco) == 0) then - call cpltwis(bezb(ix),t,etl,phi) + call cpltwis(bez(ix),t,etl,phi) end if end if #ifdef ROOT @@ -460,52 +566,61 @@ subroutine linopt(dpp) #endif cycle STRUCTLOOP + end if -!--REVERSE RUN THROUGH BLOCKS (ix <= 0) -190 ix = -ix - etl = etl+elbe(ix) - do l=1,2 - ll=2*l + ! Beam Beam element .and. fort.3 has BB block + if(kzz == 20 .and. nbeam >= 1) then + nbeam = k + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) call cpltwis(bez(ix),t,etl,phi) + end if +#ifdef ROOT + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if +#endif + cycle STRUCTLOOP + end if + ! if kzz==22, starts a do over l; Update t matrix + if(kzz == 22) then + do l=1,2 + ll = 2*l if(abs(t(ll,ll-1)) > pieni) then phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) else phibf(l) = zero end if - - puf = t(6,ll-1) - t(6,ll-1) = (((((bl2eg(ix,l,1)*(t(1,ll-1)+puf*ded) + bl2eg(ix,l,2)*(t(1,ll)+t(6,ll)*ded)) & - + bl2eg(ix,l,5)*dpp1*c1e3)- bl2(ix,l,1)*t(1,ll-1))-bl2(ix,l,2)*t(1,ll))- bl2(ix,l,5)*dpr(1))/ded - t(6,ll) = (((((bl2eg(ix,l,3)*(t(1,ll-1)+puf*ded) + bl2eg(ix,l,4)*(t(1,ll)+t(6,ll)*ded)) & - + bl2eg(ix,l,6)*dpp1*c1e3)- bl2(ix,l,3)*t(1,ll-1))-bl2(ix,l,4)*t(1,ll))- bl2(ix,l,6)*dpr(1))/ded - - do i=1,ium-1 + do i=1,ium puf = t(i,ll-1) - t(i,ll-1) = (bl2(ix,l,1)*puf+bl2(ix,l,2)*t(i,ll))+dpr(i)*bl2(ix,l,5) - t(i,ll) = (bl2(ix,l,3)*puf+bl2(ix,l,4)*t(i,ll))+dpr(i)*bl2(ix,l,6) + t(i,ll-1) = (puf*rrtr(imtr(ix),ll-1,ll-1)+t(i,ll)*rrtr(imtr(ix),ll-1,ll))+dpr(i)*rrtr(imtr(ix),ll-1,6) + t(i,ll) = (puf*rrtr(imtr(ix),ll,ll-1)+t(i,ll)*rrtr(imtr(ix),ll,ll))+dpr(i)*rrtr(imtr(ix),ll,6) end do - end do - - do l=1,2 - ll = 2*l - + t(1,ll-1) = t(1,ll-1)+cotr(imtr(ix),ll-1) + t(1,ll) = t(1,ll)+cotr(imtr(ix),ll) if(abs(t(ll,ll-1)) > pieni) then dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) else - dphi = -phibf(l) + dphi = -one*phibf(l) end if - if(-one*dphi > pieni) then dphi = dphi+pi end if phi(l) = phi(l)+dphi/twopi end do + end if + + ! Marker, beam-beam, phase-trombone, crab cavity (incl. multipole), or wire + if(kzz == 0 .or. kzz == 20 .or. kzz == 22 .or. abs(kzz) == 23 .or. abs(kzz) == 26 .or. & + abs(kzz) == 27 .or. abs(kzz) == 28 .or. abs(kzz) == 15) then nr = nr+1 - call writelin(nr,bezb(ix),etl,phi,t,ix,.true.,k) + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) if(ntco /= 0) then if(mod(nr,ntco) == 0) then - call cpltwis(bezb(ix),t,etl,phi) + call cpltwis(bez(ix),t,etl,phi) end if end if #ifdef ROOT @@ -513,149 +628,59 @@ subroutine linopt(dpp) call OpticsRootWrite() end if #endif - cycle STRUCTLOOP + end if - ! NOT A BLOCK / Nonlinear insertion -220 ix = ix-nblo - qu = zero - qv = zero - dyy1 = zero - dyy2 = zero - kpz = kp(ix) - kzz = kz(ix) - - ! Cavity - if(kpz == 6 .or. abs(kzz) == 12) then - nr = nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco /= 0) then - if(mod(nr,ntco) == 0) then - call cpltwis(bez(ix),t,etl,phi) - end if - end if -#ifdef ROOT - if(root_flag .and. root_Optics == 1) then - call OpticsRootWrite() - end if -#endif - - cycle STRUCTLOOP - end if - - ! Beam Beam element .and. fort.3 has BB block - if(kzz == 20 .and. nbeam >= 1) then - nbeam = k - nr = nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco /= 0) then - if(mod(nr,ntco) == 0) call cpltwis(bez(ix),t,etl,phi) - end if -#ifdef ROOT - if(root_flag .and. root_Optics == 1) then - call OpticsRootWrite() - end if -#endif - cycle STRUCTLOOP - end if - - ! if kzz==22, starts a do over l; Update t matrix - if(kzz == 22) then - do l=1,2 - ll = 2*l - if(abs(t(ll,ll-1)) > pieni) then - phibf(l) = atan_mb(t(ll+1,ll-1)/t(ll,ll-1)) - else - phibf(l) = zero - end if - do i=1,ium - puf = t(i,ll-1) - t(i,ll-1) = (puf*rrtr(imtr(ix),ll-1,ll-1)+t(i,ll)*rrtr(imtr(ix),ll-1,ll))+dpr(i)*rrtr(imtr(ix),ll-1,6) - t(i,ll) = (puf*rrtr(imtr(ix),ll,ll-1)+t(i,ll)*rrtr(imtr(ix),ll,ll))+dpr(i)*rrtr(imtr(ix),ll,6) - end do - t(1,ll-1) = t(1,ll-1)+cotr(imtr(ix),ll-1) - t(1,ll) = t(1,ll)+cotr(imtr(ix),ll) - if(abs(t(ll,ll-1)) > pieni) then - dphi = atan_mb(t(ll+1,ll-1)/t(ll,ll-1))-phibf(l) - else - dphi = -one*phibf(l) - end if - if(-one*dphi > pieni) then - dphi = dphi+pi - end if - phi(l) = phi(l)+dphi/twopi - end do - end if - - ! Marker, beam-beam, phase-trombone, crab cavity (incl. multipole), or wire - if(kzz == 0 .or. kzz == 20 .or. kzz == 22 .or. abs(kzz) == 23 .or. abs(kzz) == 26 .or. & - abs(kzz) == 27 .or. abs(kzz) == 28 .or. abs(kzz) == 15) then - - nr = nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco /= 0) then - if(mod(nr,ntco) == 0) then - call cpltwis(bez(ix),t,etl,phi) - end if - end if -#ifdef ROOT - if(root_flag .and. root_Optics == 1) then - call OpticsRootWrite() - end if -#endif - cycle STRUCTLOOP - end if - - ! Update the matrix etc. for supported blocks - dyy1 = zero - dyy2 = zero - if(iorg < 0) then - mzu(k) = izu - end if - izu = mzu(k)+1 - ekk = (sm(ix)+zfz(izu)*ek(ix))/(one+dpp) - izu = izu+1 - xs = xpl(ix)+zfz(izu)*xrms(ix) - izu = izu+1 - zs = zpl(ix)+zfz(izu)*zrms(ix) + ! Update the matrix etc. for supported blocks + dyy1 = zero + dyy2 = zero + if(iorg < 0) then + mzu(k) = izu + end if + izu = mzu(k)+1 + ekk = (sm(ix)+zfz(izu)*ek(ix))/(one+dpp) + izu = izu+1 + xs = xpl(ix)+zfz(izu)*xrms(ix) + izu = izu+1 + zs = zpl(ix)+zfz(izu)*zrms(ix) #include "include/alignl.f90" - if(kzz >= 0) then - select case(kzz) + if(kzz >= 0) then + select case(kzz) - case (1) + case (1) !--HORIZONTAL DIPOLE - ekk=ekk*c1e3 + ekk = ekk*c1e3 #include "include/kickl01h.f90" #include "include/kickq01h.f90" !--NORMAL QUADRUPOLE - case(2) + case(2) #include "include/kicklxxh.f90" #include "include/kickq02h.f90" !-- NORMAL SEXTUPOLE - case(3) - ekk=ekk*c1m3 + case(3) + ekk = ekk*c1m3 #include "include/kickq03h.f90" #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL OCTUPOLE - case(4) - ekk=ekk*c1m6 + case(4) + ekk = ekk*c1m6 #include "include/kicksho.f90" #include "include/kickq04h.f90" #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL DECAPOLE - case(5) - ekk=ekk*c1m9 + case(5) + ekk = ekk*c1m9 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kickq05h.f90" #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL DODECAPOLE - case(6) - ekk=ekk*c1m12 + case(6) + ekk = ekk*c1m12 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -663,8 +688,8 @@ subroutine linopt(dpp) #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL 14-POLE - case(7) - ekk=ekk*c1m15 + case(7) + ekk = ekk*c1m15 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -673,8 +698,8 @@ subroutine linopt(dpp) #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL 16-POLE - case(8) - ekk=ekk*c1m18 + case(8) + ekk = ekk*c1m18 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -684,8 +709,8 @@ subroutine linopt(dpp) #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL 18-POLE - case(9) - ekk=ekk*c1m21 + case(9) + ekk = ekk*c1m21 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -696,8 +721,8 @@ subroutine linopt(dpp) #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--NORMAL 20-POLE - case(10) - ekk=ekk*c1m24 + case(10) + ekk = ekk*c1m24 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -709,8 +734,8 @@ subroutine linopt(dpp) #include "include/kicksho.f90" #include "include/kicklxxh.f90" !--Multipole block - case(11) - r0=ek(ix) + case(11) + r0 = ek(ix) if(abs(dki(ix,1)) > pieni) then if(abs(dki(ix,3)) > pieni) then #include "include/multl01.f90" @@ -736,12 +761,11 @@ subroutine linopt(dpp) end if end if if(abs(r0) <= pieni) then - cycle STRUCTLOOP + cycle STRUCTLOOP end if - nmz=nmu(ix) + nmz = nmu(ix) if(nmz == 0) then izu=izu+2*mmul - nr=nr+1 call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) if(ntco /= 0) then @@ -770,54 +794,53 @@ subroutine linopt(dpp) end do else #include "include/multl07d.f90" - endif + end if #ifdef TILT #include "include/multl07e.f90" #endif izu = izu+2*mmul-2*nmz !--Skipped elements - case(12,13,14,15,16,17,18,19,20,21,22,23) - cycle STRUCTLOOP + case(12,13,14,15,16,17,18,19,20,21,22,23) + cycle STRUCTLOOP !--DIPEDGE ELEMENT - case(24) + case(24) #include "include/kickldpe.f90" #include "include/kickqdpe.f90" !--solenoid - case(25) + case(25) #include "include/kicklso1.f90" #include "include/kickqso1.f90" !--Skipped elements - case(26,27,28) - cycle STRUCTLOOP + case(26,27,28) + cycle STRUCTLOOP !--Unrecognized element (incl. cav with kp /= 6 for non-collimat/bnlelens) - case default - nr = nr+1 - call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) - if(ntco /= 0) then - if(mod(nr,ntco) == 0) then - call cpltwis(bez(ix),t,etl,phi) - end if + case default + nr = nr+1 + call writelin(nr,bez(ix),etl,phi,t,ix,.false.,k) + if(ntco /= 0) then + if(mod(nr,ntco) == 0) then + call cpltwis(bez(ix),t,etl,phi) end if + end if #ifdef ROOT - if(root_flag .and. root_Optics == 1) then - call OpticsRootWrite() - end if + if(root_flag .and. root_Optics == 1) then + call OpticsRootWrite() + end if #endif - cycle STRUCTLOOP + cycle STRUCTLOOP end select - !--SKEW ELEMENTS else if(kzz < 0) then kzz = -kzz ! Make it positive select case(kzz) case(1) !--VERTICAL DIPOLE - ekk=ekk*c1e3 + ekk = ekk*c1e3 #include "include/kickl01v.f90" #include "include/kickq01v.f90" !--SKEW QUADRUPOLE @@ -826,20 +849,20 @@ subroutine linopt(dpp) #include "include/kickq02v.f90" !--SKEW SEXTUPOLE case(3) - ekk=ekk*c1m3 + ekk = ekk*c1m3 #include "include/kickq03v.f90" #include "include/kicksho.f90" #include "include/kicklxxv.f90" !--SKEW OCTUPOLE case(4) - ekk=ekk*c1m6 + ekk = ekk*c1m6 #include "include/kicksho.f90" #include "include/kickq04v.f90" #include "include/kicksho.f90" #include "include/kicklxxv.f90" !--SKEW DECAPOLE case(5) - ekk=ekk*c1m9 + ekk = ekk*c1m9 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kickq05v.f90" @@ -847,7 +870,7 @@ subroutine linopt(dpp) #include "include/kicklxxv.f90" !--SKEW DODECAPOLE case(6) - ekk=ekk*c1m12 + ekk = ekk*c1m12 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -856,7 +879,7 @@ subroutine linopt(dpp) #include "include/kicklxxv.f90" !--SKEW 14-POLE case(7) - ekk=ekk*c1m15 + ekk = ekk*c1m15 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -866,7 +889,7 @@ subroutine linopt(dpp) #include "include/kicklxxv.f90" !--SKEW 16-POLE case(8) - ekk=ekk*c1m18 + ekk = ekk*c1m18 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -889,7 +912,7 @@ subroutine linopt(dpp) #include "include/kicklxxv.f90" !--SKEW 20-POLE case(10) - ekk=ekk*c1m24 + ekk = ekk*c1m24 #include "include/kicksho.f90" #include "include/kicksho.f90" #include "include/kicksho.f90" @@ -928,32 +951,32 @@ subroutine linopt(dpp) if(kzz == 24) then t(i,2) = (t(i,2)+t(i,1)*qu)-qv*t(i,3) t(i,4) = (t(i,4)-t(i,3)*quz)-qvz*t(i,1) - elseif(kzz.eq.25) then !--solenoid + elseif(kzz == 25) then !--solenoid #include "include/phassolenoid.f90" else t(i,4) = (t(i,4)-t(i,3)*qu)-qv*t(i,1) t(i,2) = (t(i,2)+t(i,1)*qu)-qv*t(i,3) end if end do - bexi = t(2,1)**2+t(3,1)**2 + bexi = t(2,1)**2+t(3,1)**2 bezii = t(4,3)**2+t(5,3)**2 if(ncorru == 0) then if(kz(ix) == 11) then - if(abs(aa(2)) > pieni.and.nmz > 1) then - write(34,10070) etl,bez(ix),-2,aa(2),bexi,bezii,phi + if(abs(aa(2)) > pieni .and. nmz > 1) then + write(linopt_dumpUnit,"(f17.9,1x,a,1x,i4,5(1x,1pe16.9))") etl,bez(ix),-2,aa(2),bexi,bezii,phi end if do iiii=3,nmz if(abs(bb(iiii)) > pieni) then - write(34,10070) etl,bez(ix),iiii,bb(iiii),bexi,bezii,phi + write(linopt_dumpUnit,"(f17.9,1x,a,1x,i4,5(1x,1pe16.9))") etl,bez(ix),iiii,bb(iiii),bexi,bezii,phi end if if(abs(aa(iiii)) > pieni) then - write(34,10070) etl,bez(ix),-iiii,aa(iiii),bexi,bezii,phi + write(linopt_dumpUnit,"(f17.9,1x,a,1x,i4,5(1x,1pe16.9))") etl,bez(ix),-iiii,aa(iiii),bexi,bezii,phi end if end do - else if(abs(ekk) > pieni.and.abs(kz(ix)) >= 3) then - write(34,10070) etl,bez(ix),kz(ix),ekk,bexi,bezii,phi - else if(abs(ekk) > pieni.and.kz(ix) == -2) then - write(34,10070) etl,bez(ix),kz(ix),ekk,bexi,bezii,phi + else if(abs(ekk) > pieni .and. abs(kz(ix)) >= 3) then + write(linopt_dumpUnit,"(f17.9,1x,a,1x,i4,5(1x,1pe16.9))") etl,bez(ix),kz(ix),ekk,bexi,bezii,phi + else if(abs(ekk) > pieni .and. kz(ix) == -2) then + write(linopt_dumpUnit,"(f17.9,1x,a,1x,i4,5(1x,1pe16.9))") etl,bez(ix),kz(ix),ekk,bexi,bezii,phi end if end if @@ -990,33 +1013,19 @@ subroutine linopt(dpp) bexi = t(2,1)**2+t(3,1)**2 bezii = t(4,3)**2+t(5,3)**2 if(ncorru == 0) then - write(34,10070) etl,idum,iiii,zero,bexi,bezii,phi + write(linopt_dumpUnit,"(f17.9,1x,a,1x,i4,5(1x,1pe16.9))") etl,idum,iiii,zero,bexi,bezii,phi end if if(ncorru == 0) then - write(lout,10060) + write(lout,"(a)") repeat("-",131) end if - return - -!----------------------------------------------------------------------- -10000 format(t5 ,'---- ENTRY LINOPT ----') -10010 format(132('-')) -10020 format(' NR TYP L-TOTAL P PHI ', & - &'BETA ALFA GAMMA DIS DISP ',& - &'CLO CLOP'/ 1x, & - &' (M) (2*PI) ', & - &'(M) (RAD) (M) (M) (RAD) ',& - &'(MM) (MRAD)') -10030 format(' LINEAR OPTICS CALCULATION WITH PRINTOUT ', & - &'AFTER EACH BLOCK'/ & - &' A T T E N T I O N : BETATRON PHASE CALCULATION MIGHT BE WRONG'& - &,' BY A MULTIPLE OF 0.5 FOR EACH LARGE BLOCK'/) -10040 format(/10x,'RELATIVE ENERGY DEVIATION ',t40,f23.16/ 10x, & - &'TUNES -HORIZONTAL',t40,f23.16/ 10x,' -VERTICAL ',t40,f23.16/) -10050 format(t8,' PLANE DISP(MM) DISP(MRAD)'/ & - &t6,' X ',2(f20.12,6x)/t10,' Y ',2(f20.12,6x)/) -10060 format(//131('-')//) -10070 format(1x,1pg21.14,1x,a,1x,i4,5(1x,1pg21.14)) + ! Close files + if(linopt_coupleUnit /= -1) then + call f_close(linopt_coupleUnit) + end if + if(ncorru == 0) then + call f_close(linopt_dumpUnit) + end if end subroutine linopt @@ -1116,7 +1125,7 @@ subroutine writelin(nr,typ,tl,p1,t,ixwl,isBLOC,ielem) write(lout,10030) typ(9:16) write(lout,10020) p1(2),b1(2),al1(2),g1(2),d(2),dp(2),c(2),cp(2) write(lout,10010) b2(2),al2(2),g2(2) - write(lout,10040) + write(lout,"(a)") repeat("-",132) end if else if(.not.isBLOC) then @@ -1148,7 +1157,6 @@ subroutine writelin(nr,typ,tl,p1,t,ixwl,isBLOC,ielem) 10010 format('|',6x,'|',8x,'|',12x,'|',1x,'|',12x,'|',f12.6,'|', f13.7,'|',f11.6,'|',11x,'|',11x,'|',11x,'|',11x,'|') 10020 format('|',6x,'|',8x,'|',12x,'|','Y','|',f12.7,'|',f12.6,'|', f13.7,'|',f11.6,'|',f11.7,'|',f11.7,'|',f11.7,'|',f11.7,'|') 10030 format('|',6x,'|',a8,'|',12x,'|',102('-')) -10040 format(132('-')) end subroutine writelin !----------------------------------------------------------------------- @@ -1237,11 +1245,11 @@ subroutine cpltwis(typ,t,etl,phi) else couuang = zero end if - if(linopt_fileUnit == -1) then - call f_requestUnit(linopt_fileName, linopt_fileUnit) - call f_open(unit=linopt_fileUnit,file=linopt_fileName,formatted=.true.,mode="w") + if(linopt_coupleUnit == -1) then + call f_requestUnit(linopt_coupleFile, linopt_coupleUnit) + call f_open(unit=linopt_coupleUnit,file=linopt_coupleFile,formatted=.true.,mode="w") end if - write(linopt_fileUnit,*) typ,etl,phi,bexi,bexii,bezi,bezii, & + write(linopt_coupleUnit,*) typ,etl,phi,bexi,bexii,bezi,bezii, & alxi,alxii,alzi,alzii,gaxi,gaxii,gazi,gazii, & phxi,phxii,phzi,phzii,phxpi,phxpii,phzpi,phzpii,couuang, & t(6,1),t(6,2),t(6,3),t(6,4),t(1,1),t(1,2),t(1,3),t(1,4) From 9f6ad1ac1ef6c7a829bf5894aa5a11876c593710 Mon Sep 17 00:00:00 2001 From: "Veronica K. B. Olsen" Date: Wed, 14 Aug 2019 14:12:50 +0200 Subject: [PATCH 6/6] Updated manual entry on files fort.11 and fort.34 --- doc/user_manual/apxInputOutput.tex | 8 ++++---- doc/user_manual/chProcessing.tex | 4 ++-- source/linear_optics.f90 | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/doc/user_manual/apxInputOutput.tex b/doc/user_manual/apxInputOutput.tex index ad56da085..459368933 100644 --- a/doc/user_manual/apxInputOutput.tex +++ b/doc/user_manual/apxInputOutput.tex @@ -33,8 +33,8 @@ \chapter{Input and Output Files} \label{Files} \hline 10 & \checkmark & \checkmark & Ascii & Summary of Post-processing (auxiliary) \\ \hline - 11 & & \checkmark & Ascii & This file is used to dump linear coupling parameters at locations of choice \\ - \hline + % 11 & & \checkmark & Ascii & This file is used to dump linear coupling parameters at locations of choice \\ + % \hline 12 & & \checkmark & Ascii & End coordinates of all particles. Format: ($15 \times F10.6$) \\ \hline 13 & \checkmark & & Ascii & Start coordinates for a prolongation \\ @@ -79,8 +79,8 @@ \chapter{Input and Output Files} \label{Files} \hline 33 & \checkmark & & Ascii & Guess values for 6D closed orbit search \\ \hline - 34 & & \checkmark & Ascii & Multipole strength and linear lattice parameters~\cite{SODD} \\ - \hline + % 34 & & \checkmark & Ascii & Multipole strength and linear lattice parameters~\cite{SODD} \\ + % \hline 90--k & & \checkmark & Binary & Tracking Data (not singletrackfile) $0 \leq k \leq 31$ \\ \hline 90 & & \checkmark & Binary & Tracking Data (singletrackfile) \texttt{singletrackfile.dat} \\ diff --git a/doc/user_manual/chProcessing.tex b/doc/user_manual/chProcessing.tex index 251d2956d..dcf67c306 100644 --- a/doc/user_manual/chProcessing.tex +++ b/doc/user_manual/chProcessing.tex @@ -27,7 +27,7 @@ \section{Linear Optics Calculation} \label{LinOpt} \texttt{ilin} & integer & Logical switch to calculate the traditional linear optics calculation in 4D (\texttt{1 = ilin}) and with the DA approach 6D (\texttt{2 = ilin}). \\ \texttt{ntco} & integer & A switch to write out linear coupling parameters. \\ & & \texttt{ntco = 0}: no write-out. \\ - & & \texttt{ntco $\neq$ 0}: write-out of all linear coupled (4D) parameters including the coupling angle. These parameters (name, longitudinal position, the phase advances at that location, 4 $\beta$-, $\alpha$- and $\gamma$-functions, 4 angles for coordinates and momenta respectively, plus the coupling angle [rad]) are written in ascii format on file \texttt{fort.11}. This write-out happens every \texttt{ntco} turns. \\ + & & \texttt{ntco $\neq$ 0}: write-out of all linear coupled (4D) parameters including the coupling angle. These parameters (name, longitudinal position, the phase advances at that location, 4 $\beta$-, $\alpha$- and $\gamma$-functions, 4 angles for coordinates and momenta respectively, plus the coupling angle [rad]) are written in ascii format on file \texttt{linopt\_coupled.dat}. This write-out happens every \texttt{ntco} turns. \\ \texttt{E\_I, E\_II} & floats & The two eigen-emittances to be chosen to determine the coupling angle. They are typically set to be equal. \\ \texttt{names} & char & For \texttt{nlin $\leq$ nele} element and block names the linear parameters are printed whenever they appear in the accelerator structure. \end{longtabu} @@ -35,7 +35,7 @@ \section{Linear Optics Calculation} \label{LinOpt} \paragraph{Remarks} \begin{itemize} \item To make this block work the Tracking Parameter block (\ref{TraPar}) has to used as well. - \item When the \texttt{ELEMENT 0} option is used, a file \texttt{fort.34} is written with the longitudinal position, name, element type, multipole strength, $\beta$ functions and phase advances in the horizontal and vertical phase space respectively. This file is used as input for the \texttt{SODD} program~\cite{SODD} to calculate de-tuning and distortion terms in first and second order. A full program suite can be found at: /afs/cern.ch/group/si/slap/share/sodd + \item When the \texttt{ELEMENT 0} option is used, a file \texttt{linopt\_dump.dat} is written with the longitudinal position, name, element type, multipole strength, $\beta$ functions and phase advances in the horizontal and vertical phase space respectively. This file is used as input for the \texttt{SODD} program~\cite{SODD} to calculate de-tuning and distortion terms in first and second order. A full program suite can be found at: /afs/cern.ch/group/si/slap/share/sodd \item If the \texttt{BLOCK} option has been used, the tunes may be wrong by a multiple of 1/2. This option is not active in the DA part (\texttt{2 = ilin}), which also ignores the (\texttt{NTCO}) option. \end{itemize} diff --git a/source/linear_optics.f90 b/source/linear_optics.f90 index d5e53c78f..0a3ba4be0 100644 --- a/source/linear_optics.f90 +++ b/source/linear_optics.f90 @@ -200,7 +200,7 @@ subroutine linopt(dpp) call f_requestUnit(linopt_dumpFile, linopt_dumpUnit) call f_open(unit=linopt_dumpUnit,file=linopt_dumpFile,formatted=.true.,mode="w",status="replace") write(linopt_dumpUnit,"(a1,1x,a15,1x,a,1x,a4,5(1x,a16))") "#","len_tot",chr_rPad("element",mNameLen),& - "kz","ekk","bexi","bezii","phi(1)","phi(2)" + "type","strength","beta(1)","beta(2)","phi(1)","phi(2)" write(lout,"(a)") repeat("-",132) write(lout,"(a)") "" write(lout,"(a)") " PLANE | DISP(MM) | DISP(MRAD)"