program main *----------------------------------------------------------------------* * * * CERN * * * * European Organization for Nuclear Research * * * * Program name: ECLOUD Version 1.0 * * * * Authors and contact: O. BRUNING, G. RUMOLO, * * X. ZHANG, F. ZIMMERMANN * * AB (formerly) SL Division * * CERN * * CH-1211 GENEVA 23 * * SWITZERLAND * * Tel. [041] (022) 767 9054 * * frank.zimmermann@cern.ch * * * * Copyright CERN, Geneva 2003 - Copyright and any other * * appropriate legal protection of this computer program and * * associated documentation reserved in all countries of the * * world. * * * * Organizations collaborating with CERN may receive this program * * and documentation freely and without charge. * * * * CERN undertakes no obligation for the maintenance of this * * program, nor responsibility for its correctness, and accepts * * no liability whatsoever resulting from its use. * * * * Program and documentation are provided solely for the use of * * the organization to which they are distributed. * * * * This program may not be copied or otherwise distributed * * without permission. This message must be retained on this and * * any other authorized copies. * * * * The material cannot be sold. CERN should be given credit in * * all references. * * * *----------------------------------------------------------------------* c c purpose: calculations for ohmi effect c c Modification with respect to 'ohmilhc.eric': c introduction of a new module for the particle motion in the c presence of a magnetic field. c c Oct. 1998. Add a common block for six-wire waveguide geometry c and an input parameter rbound6 for wire radius. Add also two c output files of electron numbers and energy distribution for c electrons that hit the wall. c c Nov. 1998. Add Parameters of ppb1, sb1, ppb2, sb2 for simulating c the effect of the satellite bunches. c c Jul. 1999. Add electrons from collisional ionization c c Aug. 1999. Remove obscure offset problem (xoff,yoff) in c this version of the code. c c 2000-2001 lots of undocumented changes (e.g., new parametrization c of secondary emission including elastic reflection, debugged formulae c for image charges, eliminated problems related to longitudinal c profile and bunch length, inconsistencies in time accounting,...) c c Giovanni (July 2001): c c 'clean' routine modified and activated. c c As the new switch 'iirefl' for the distribution of the reflected c light has been introduced, in the input file for this version of c the code one has to put 3 numbers after the line c 'Primary photoelectron emission yield (peeff):' c of the input file. The first is the photoelectric yield, the c second is the percent of reflected radiation, and the third is c an integer that sets the angular distribution of the reflected c light -> c [1] uniform [2] cos [3] cos^2 [4] smooth parabolic [5] cos^3 c c An "on line" Runge-Kutta integration for a dipole and a finite c length solenoid field is introduced. To activate it, use as switch c 'ibend': 40 [dipole], or 41 [solenoid] c Please, when you set 'ibend' to be 40 or 41, let 'ibeam' be 1 and c 'ispace' be 2. c c August 30, add idistr=2: flat charge distribution with edges c and new input c c November 4, 2001, add iseldis=5 (Noel's distribution) implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: parameter (npelm=600000,iybin=500,ngrid=500,ngrid2=10) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) integer iycount(0:iybin) integer index(npelm), ik, iabort real*8 ayield(0:iybin), avcos(0:iybin) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), * pz(npelm), py(npelm), px(npelm) real*8 ptime(npelm), esign(npelm), test(npelm) c charge of lost electrons in fine time steps real*8 qlosswh, qlosstot, qlosstot2 c oliver 6.6.197:cccccccccccccccccc real*8 eloss, elossq, ephoto, adele, qadele, alimit real*8 dele(npelm), qele(npelm) real*8 bweight(50000) real*8 peeff, yim, yemax real*8 xwto, ywto real*8 epesig, epemax, ecut real*8 wgl, wk, vtem, vtem0 real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 factor, dt real*8 xt, yt real*8 one, etemp real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) c real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) ccccccccccccccccccccccccccccccccccccccc c frank nov 99, index field for empty buckets integer indexb (1:nbmax), iazi, iwake real*8 dntr(1:nbmax) real*8 denscenter ccccccccccccccccccccccccccccccccccccccc common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def6 / peeff, yim, yemax common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def8 / alimit common / def9 / wgl, wk, vtem, vtem0 c 01.08.1999 Frank: adding transverse offsets in input file common / def10 / x1, y1, x2, y2, x3, y3 common / def11 / icoll common / bunch / bweight ccccccccccccccccccccccccccccccccccccccccccccccc common / help / factor, dt common / rann / iseed, idumy common / loss2 / qlosswh, qlosstot, qlosstot2 c oliver 6.6.197:cccccccccccccccccc common / loss / eloss, elossq, ephoto, adele, qadele common / egain / dele, qele common / eini / epemax,ecut common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig cccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax,wen1,wen2,wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c frank 13/11/1999 common / indb / indexb common / indb2 / dntr common / indb3 / iabort common / azi / iazi common / wake / iwake common / wake2 / xwto, ywto c cccccccccccccccccccccccccccccccccccccccccccc common / def1 / rbound, xbound, ybound, zbound, energy, belen common / test1 / itest common / test2 / test common / space2 / efxa, efya, qgrid common / center / denscenter one = 1.0d0 etemp = 0.0d0 yksum = 0.0d0 yk2 = 0.0d0 xksum = 0.0d0 xk2 = 0.0d0 isemax = 1 open(23,file="kick.dat",status='unknown') open(9,file="tr.dat",status='unknown') open(42,file="cdbunch.data",status='unknown') open(43,file="centerdensity.data",status='unknown') open(44,file="edistr.data",status='unknown') open(4444,file="edistrp.data",status='unknown') open(49,file="qgrid.data",status='unknown') open(45,file="edistr.movie.data",status='unknown') open(46,file="movie.gnuplot",status='unknown') open(21,file="main.data",status='unknown') open(24,file="time.outer.data",status='unknown') open(27,file="time.outer.sp.data",status='unknown') open(28,file="time.outer.dp.data",status='unknown') open(25,file="time.inner.data",status='unknown') open(26,file="eloss.data",status='unknown') open(88,file="eloss.charge.data",status='unknown') open(56,file="av.yield.data",status='unknown') open(66,file="photoel.energy.distr.data",status='unknown') open(67,file="secel.energy.distr.data",status='unknown') open(74,file="onwall.energy.distr.data",status='unknown') open(1174,file="onwall.energyn.distr.data",status='unknown') open(174,file="onwall.azimuth.distr.data",status='unknown') c 176 - energy flux on wall open(176,file="onwall.x.distr.data",status='unknown') open(1741,file="onwall.azimuth1.distr.data",status='unknown') c 1761 - charge flux on wall open(1761,file="onwall.x1.distr.data",status='unknown') c 1762 - charge flux on wall from e- with energy > 30 eV open(1762,file="onwall.x2.distr.data",status='unknown') open(87,file="photo.elect.angle.distr.data",status='unknown') open(89,file="maxenergy.data",status='unknown') open(29,file="volt.data",status='unknown') open(188,file="qlosswh.data",status='unknown') open(144,file="traj.test.data",status='unknown') open(145,file="trapping.data",status='unknown') call init isignmax = 1 c frank, nov 99 if (iwake.eq.1) then c isemax = 3 isignmax = 2 iinitf = 0 endif do 10 ise = 1, isemax do 11 isign = 1, isignmax if (isign.eq.1) sign = 1.0d0 if (isign.eq.2) sign = -1.0d0 if (iwake.eq.1.and.iinitf.eq.1) then call init endif iinitf = 1 iseed = ise + 1234567 c Oliver 03.09.1997 c call init c loop over bunch passages do 12 j = 1, nbunch eloss = 0.0d0 ephoto = 0.0d0 adele = 0.0d0 qadele = 0.0d0 iadele = 0 elossq = 0.0d0 sbtot = sb+bl if(ppb1.gt.1.0d0) then sbtot = sb+sb1+bl+bl endif if(ppb2.gt.1.0d0) then sbtot = sb+sb2+bl+bl endif if(ppb1.gt.1.0d0.and.ppb2.gt.1.0d0) then sbtot = sb+sb1+sb2+bl+bl+bl endif write(*,*) ' sb1 is distance between 1st satellite and 2nd s.' write(*,*) ' sb2 is distance between second satellite and m.b.' write(*,*) ' sb is distance after main bunch ' write(*,*) ' sbtot = ',sbtot write(*,*) ' sb1, sb2, sb = ',sb1, sb2, sb yt = y1 xt = x1 c yt = 5.0d-3 c xt = 5.0d-3 iflagg=0 if (indexb(j).eq.1) then write(*,*) ' call generate ' call generate(j,iseed,yt,xt,iflagg) else if (indexb(j).eq.0) then iflagi=4 call interbunch(iflagi) endif qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter if (indexb(j).eq.1) then write(42,'(e25.5,e25.5)') t, denscenter endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=0 write(*,*) ' call interbunch ' if (iwave.eq.0) call interbunch(iflagi) c X. Zhang Nov. 1998 c For satellite bunch if(ppb1.gt.1.0d0) then yt = y2 xt = x2 c yt = -5.0d-3 c xt = -5.0d-3 iflagg=1 c frank, 13/11/99, new branch to simulate fill patterns if (indexb(j).eq.1) then call generate(j,iseed,yt,xt,iflagg) else if (indexb(j).eq.0) then iflagi=4 call interbunch(iflagi) endif c --------------------------------------------- c write(21,'(i3,1x,i3,e25.5,i8,1e25.5)') j,0,t,icount,qacc qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter if (indexb(j).eq.1) then write(42,'(e25.5,e25.5)') t, denscenter endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=1 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif if(ppb2.gt.1.0d0) then yt = y3 xt = x3 iflagg=2 call generate(j,iseed,yt,xt,iflagg) qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter if (indexb(j).eq.1) then write(42,'(e25.5,e25.5)') t, denscenter endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=2 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif c---End of X. Zhang c oliver 6.6.197:cccccccccccccccccc c output is given as: 'energy[eV]*total charge of macroparticle/ c bunch spacing/magnet length' if(mod(j,10).eq.0.or.iwave.eq.0) then write(*,*) write(*,*) "Bunch Passage: ",j if (iwave.eq.1) then call tem(xbound/2.0,xbound/2.0,wk,t,wgl,pre,pim) write(*,*) "Kick polarity: ",vtem*pim/abs(vtem) endif if (iwave.eq.2) then call tem6(xbound/2.0,xbound/2.0,wk,t,wgl,xbound,pre,pim,0d0) write(*,*) "Kick polarity: ",vtem*pim/abs(vtem) endif c frankz 05/08/99 normalize with the actual bunch spacing deltatime = sbtot/vl write(*,*) "Electron loss",j, eloss*el/deltatime/belen, * "Watts/meter" write(*,*) "Photon loss",j, ephoto*el/deltatime/belen, * "Watts/meter" if(qadele.ne.0.0) * write(*,*) "Average energy: ",adele/el/qadele, "eV" if(qadele.eq.0.0.and.adele.eq.0.0) * write(*,*) "Average energy: ",0.0, "eV" if(qadele.eq.0.0.and.adele.ne.0.0) * write(*,*) "Average energy: ",Inf, "eV" c * adele, el, qadele write(*,*) "Number of electrons per bend: ",qacc endif write(26,*) j, eloss*el/deltatime/belen write(88,*) j, elossq ccccccccccccccccccccccccccccccccccccccc call clean 12 continue c end loop over bunch passages c start if over qacc if (qacc.gt.1.e-8) then c write(*,*) ' koko ' c write(*,*) qgrid call spacecharge3 c write(*,*) ' after spacecharge 3' c write(*,*) qgrid c ------------------------------------------ c print out charge distribution on grid ymbound = min(ybound,zbound) write(*,*) ' qgrid output - ngrid2 =',ngrid2 do ig1 = -ngrid2,ngrid2 do ig2 = -ngrid2,ngrid2 xga = ig1*xbound/ngrid2 yga = ig2*ymbound/ngrid2 write(49,9441) xga,yga,qgrid(ig1,ig2) 9441 format(3(1x,e14.6)) end do end do close(49) c ------------------------------------------ write(*,*) ' binning e distribution ' c open(44,file="edistr.data",status='unknown') c 4.08.1997 Oliver: Bining the electron distribution: call binx c 4.08.1997 Oliver: Bining the yield: do 210 iy=0,iybin if(iycount(iy).ne.0) * write(56,*) (2.0d0*iy/iybin-1.0d0)*xbound, * ayield(iy)/iycount(iy),avcos(iy)/iycount(iy) c if(iycount(iy).eq.0) c * write(56,*) (2.0d0*iy/iybin-1.0d0)*xbound, c * 0.0,0.0 210 continue close(56) c write(*,*) ' call spacecharge ' ix = 1 if (ispace.eq.1) then call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c frank, 26 april 2000. c add abort gap c temporarily set space charge and image force to zero c frank, 23 March 2002 c ispace=0 c iimage=0 do j = 1, iabort qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter c write(42,'(e25.5,e25.5)') t, denscenter if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=0 if (iwave.eq.0) call interbunch(iflagi) end do c compute trapping condition c for quadrupole fields c if (ibend.eq.2) then do j =1, icount vtot2 = xp(j)**2+yp(j)**2+zp(j)**2 vtrans2 = (x(j)*xp(j)-y(j)*yp(j))**2/(x(j)**2+y(j)**2) trap = vtot2*Sqrt(x(j)**2+y(j)**2)/vtrans2/xbound-1. write(145,'(i4,3(1x,e12.4))') j, trap, x(j), y(j), q(j) end do endif c frank, nov 99 if (iwake.eq.0) then yt = 0.00d0 * sign xt = 0.00d0 * sign else if (iwake.eq.1) then yt = ywto * sign xt = xwto * sign endif ytoffs = yt xtoffs = xt if (iwake.eq.0) goto 444 c goto 444 c do not go through the following loop iflagg=0 call generate(nbunch+1,iseed,yt,xt,iflagg) if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c if (iwave.ne.1) call interbunch iflagi=0 if (iwave.eq.0) call interbunch(iflagi) c call interbunch c X. Zhang Nov. 1998 c For satellite bunch if(ppb1.gt.1.0d0) then yt = y2 c 0.00d0 * sign xt = x2 c 0.00d0 * sign c yt = -5.00d-3 * sign c xt = -5.00d-3 * sign ytoff = yt xtoff = xt iflagg=1 call generate(nbunch+1,iseed,yt,xt,iflagg) if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c if (iwave.ne.1) call interbunch iflagi=1 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif if(ppb2.gt.1.0d0) then yt = y3 xt = x3 ytoff = yt xtoff = xt iflagg=2 call generate(nbunch+1,iseed,yt,xt,iflagg) if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c if (iwave.ne.1) call interbunch iflagi=2 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif 444 continue iseed = 201 yto = 0.0 xto = 0.0 if (iwake.eq.1) then c 10.07.1997 Oliver c call bin dkickyn = 0. dkickxn = 0. call offsetkick(iseed,dkickx,dkicky,yto,xto) if (abs(ytoffs).gt.1.e-20) then dkickyn = dkicky/ytoffs endif if (abs(xtoffs).gt.1.e-20) then dkickxn = dkickx/xtoffs endif if (isign.eq.1) then ykick1 = dkickyn xkick1 = dkickxn else if (isign.eq.2) then ykick2 = dkickyn xkick2 = dkickxn endif endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c end if over qacc 11 continue if (iwake.eq.1) then ykickav = (ykick1+ykick2)/2. xkickav = (xkick1+xkick2)/2. write(23,*) ise, ykick1, ykick2, ykickav, xkick1, & xkick2, xkickav yksum = yksum + ykickav xksum = xksum + xkickav yk2 = yk2 + ykickav*ykickav xk2 = xk2 + xkickav*xkickav endif 10 continue if (iwake.eq.1) then write(23,*) ' ' c write(23,*) ' 1. attempt ' c write(23,*) yksum, yrms, xksum, xrms, isemax yksum = yksum / real(isemax) yk2 = yk2 / real(isemax) yrms = dsqrt(dmax1(yk2-yksum*yksum,0.)) xksum = xksum / real(isemax) xk2 = xk2 / real(isemax) xrms = dsqrt(dmax1(xk2-xksum*xksum,0.)) write(23,*) ' ' write(23,*) yksum, yrms, xksum, xrms close(23) write(*,*) dkickx, dkicky, dkickn write(*,*) dkickx, dkicky, dkickn endif write(*,*) ' write e distribution ' c----Write the energy distribution of the electrons that c----hit the wall etemp = 0.0d0 etemp2 = 0.0d0 do 121 ik=0,500 c etemp = max(etemp, webin(ik)) etemp = etemp + webin(ik) etemp2 = etemp2 + webinn(ik) 121 continue if (etemp.eq.0) then write(*,*) ' WARNING - etemp=0 ' goto 323 endif if (etemp2.eq.0) then write(*,*) ' WARNING - etemp2=0 ' goto 322 endif do 322 ik=0,500 dik=ik*2. write(1174,*) dik, webinn(ik)/etemp2 322 continue do 323 ik=0,500 dik=ik*2. write(74,*) dik, webin(ik)/etemp 323 continue close(74) ccccccc frank 22.07.99 ccccccccccccccccccccccccccccccccccccccccc write(89,*) ' ' write(89,*) ' maximum electron energy a la Scott Berg:' write(89,*) ' ' write(89,*) ' rms bunch length = ',sigmal,' (m)' write(89,*) ' critical radius = ',rcrit,' (m)' write(89,*) ' maximum energy gain = ',deltaemax,' (eV)' write(89,*) ' ' if (j.gt.1) then jx = j-1 else jx = 1 endif xstep = xbound/500. ymbound=min(ybound,zbound) c write(*,*) ' deltatime = ',deltatime, belen do 329 ik=0,500 if (ik.eq.0) then c and.ibend.eq.38) then webinx(ik)=webinx(ik)*2. webinx2(ik)=webinx2(ik)*2. webinx3(ik)=webinx3(ik)*2. endif c write(*,*) ' ik = ',ik, webinphi(ik) write(174,*) real(ik)*pi/250.,webinphi(ik)/deltatime/ & belen/real(jx)*el*500./(pi*(xbound+ymbound)),j write(1741,*) real(ik)*pi/250.,webinph2(ik)/deltatime/ & belen/real(jx)*el*500./(pi*(xbound+ymbound)),j c heat load write(176,*) (xstep*real(ik)),webinx(ik)/ & deltatime/belen/real(jx)*el*500./(2*xbound),j c charge write(1761,*) (xstep*real(ik)),webinx2(ik)/ & deltatime/belen/real(jx)*el*500./(2*xbound),j c charge with e energies above 30 eV write(1762,*) (xstep*real(ik)),webinx3(ik)/ & deltatime/belen/real(jx)*el*500./(2*xbound),j 329 continue close(174) close(1741) wen2loss = wen2/deltatime/belen/real(nbunch)*el wen1loss = wen1/deltatime/belen/real(nbunch)*el+wen2loss if (qne1.gt.0) then en1av = wen1/qne1 else en1av = 0 . endif if (qne2.gt.0) then en2av = wen2/qne2 else en2av = 0. endif qfrac1 = qne1/qlosstot qfrac2 = qne2/qlosstot write(89,*) ' wen1 = ',wen1 write(89,*) ' wen2 = ',wen2 write(89,*) ' nbunch = ',nbunch write(89,*) ' heat load at E > 500 eV = ',wen1loss,' (W/m)' write(89,*) ' heat load at E > Emax = ',wen2loss,' (W/m)' write(89,*) ' av. el. energy at E > 250 eV = ',en1av,' (eV)' write(89,*) ' av. el. energy at E > Emax = ',en2av,' (eV)' write(89,*) ' fraction of e- at E > 250 eV = ',qfrac1 write(89,*) ' fraction of e- at E > Emax = ',qfrac2 write(89,*) ' maximum electron energy = ',wenmax,' (eV)' close(89) c------------------------------------------------------ close(9) close(21) close(88) close(45) close(26) close(87) close(24) close(43) close(144) end subroutine init c purpose: initialization and definition routine implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: parameter (npelm=600000) ccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,iybin=500,ngrid2=10) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) integer iycount(0:iybin) integer index(npelm), i, ik, iabort real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), py(npelm) real*8 px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 mec2 real*8 peeff, yim, yemax real*8 boundix(40), boundiy(40), boundox(80), boundoy(80) real*8 bweight(50000) c 30.06.1997 Oliver real*8 alimit ccccccccccccccccccccccccccccccccccccccccccccccccccc c 24.07.1997 Oliver real*8 semax, emax0 real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) real*8 rg, rm1 ccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 epesig, epemax, ecut real*8 epesig2, epemax2, ratio real*8 wgl, wk, vtem, vtem0 real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient, f0, efieldrf real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 rmax, rmin, circum c frank nov 99, index field for empty buckets integer indexb (1:nbmax), iazi, iwake real*8 dntr(1:nbmax) character*64 dummy c oliver 27.10.1997: variables for miguel: integer intn, iirefl, iscatter parameter (intn=1000) real*8 limit(intn), lcount(intn) real*8 avq, isectot, ltest real*8 xwto, ywto real*8 qlosstot, qlosswh, qlosstot2 common / miguel1 / isectot, ltest, avq common / miguel2 / lcount, limit ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / def4 / circum common / def10 / x1, y1, x2, y2, x3, y3 common / def11 / icoll common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / rann / iseed, idumy common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def6 / peeff, yim, yemax common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def8 / alimit common / def9 / wgl, wk, vtem, vtem0 common / def20 / inel common / bunch / bweight common / eini / epemax,ecut common / epe / epemax2, epesig2, ratio common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig common / movie / boundix, boundiy, boundox, boundoy common / beam / rg, rm1 common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c oliver 24.7.197:cccccccccccccccccc common / emax / semax, emax0 common / image / iimage, iimageb, interspace, igeom ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax, sigmal, rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc c frank 13/11/1999 common / indb / indexb common / indb2 / dntr common / indb3 / iabort common / refl / refl common / swrefl / iirefl common / azi / iazi common / wake / iwake common / wake2 / xwto, ywto common / byield1 / iycount common / loss2 / qlosswh, qlosstot, qlosstot2 common / delay / iscatter c write(*,*) ' in init ' icount = 0 icountact = 0 itest = 0 qacc = 0.0d0 idumy = 1 iscatter = 0 mcount = 0 qouter = 0.0d0 qinner = 0.0d0 c pi = 4.*atan(1.) pi = acos(-1.0d0) c photo electron emission efficiency c (number of emitted electrons/photon): peeff = 0.02d0 c IBEND - switch to 0 for drift / 1 for bend ibend = 0 xbound = 0.022d0 ybound = 0.018d0 belen = 14.2d0 circum = 27000.0d0 el = 1.6d-19 vl = 3.0d8 re = 2.8d-15 elmass = 9.0d-31 ppb = 1.05d11 ppb1 = 0d0 ppb2 = 0d0 c bunch spacing sb = 7.48d0 sb1 = 0d0 sb2 = 0d0 mec2 = 511000.0d0 c FINAL ENERGY energy = 7.0d12 if (ibend.eq.0) then bfield = 0.0d0 else bfield = 8.39d0 endif sx = 0.000303d0 sy = 0.000303d0 c bunch length c CORRECT: bl = 0.077d0 * 4.0d0 * dsqrt(3.0d0) c bl = 0.077d0 * 4.0d0 c OLD WRONG RELATION c bl = 0.077d0 * 2.0d0 * dsqrt(6.0d0) c OLD WRONG RELATION c bl = 0.077d0 * 2.0d0 * dsqrt(2.0d0) c INJECTION ENERGY cc energy = 4.5d11 cc bfield = 0.539d0 cc sx = 0.0012d0 cc sy = 0.0012d0 c bunch length cc bl = 0.13d0 * 2.d0 * dsqrt(2.0d0) cc cc ALSO NEED TO CHANGE NUMBER OF PHOTOELECTRONS! c 20.06.1997 Oliver: Read input from file: open(11,file="ecloud.input",status='unknown') read(11,'(a64)') dummy read(11,*) isemax write(*,*) dummy write(*,*) isemax read(11,'(a64)') dummy read(11,*) npepb c write(*,*) dummy c write(*,*) npepb read(11,'(a64)') dummy read(11,*) nbunch c write(*,*) dummy c write(*,*) nbunch read(11,'(a64)') dummy read(11,*) nbstep c write(*,*) dummy c write(*,*) nbstep read(11,'(a64)') dummy read(11,*) nistep c write(*,*) dummy c write(*,*) nistep read(11,'(a64)') dummy read(11,*) nostep c write(*,*) dummy c write(*,*) nostep read(11,'(a64)') dummy read(11,*) jebin c write(*,*) dummy c write(*,*) jebin read(11,'(a64)') dummy read(11,*) iebin if(iebin.gt.nbstep) iebin = nbstep c write(*,*) dummy c write(*,*) iebin read(11,'(a64)') dummy read(11,*) imovie c write(*,*) dummy c write(*,*) imovie read(11,'(a64)') dummy read(11,*) iseq c write(*,*) dummy c write(*,*) iseq read(11,'(a64)') dummy read(11,*) ppb c write(*,*) dummy c write(*,*) ppb read(11,'(a64)') dummy read(11,*) sb c write(*,*) dummy c write(*,*) sb read(11,'(a64)') dummy read(11,*) bl c write(*,*) dummy c write(*,*) bl read(11,'(a64)') dummy read(11,*) belen c write(*,*) dummy c write(*,*) belen read(11,'(a64)') dummy read(11,*) energy c write(*,*) dummy c write(*,*) energy read(11,'(a64)') dummy read(11,*) circum c write(*,*) dummy c write(*,*) circum read(11,'(a64)') dummy read(11,*) peeff, refl, iirefl c write(*,*) dummy c write(*,*) peeff, refl read(11,'(a64)') dummy read(11,*) nbini c write(*,*) dummy c write(*,*) nbini read(11,'(a64)') dummy read(11,*) nsini c write(*,*) dummy c write(*,*) nsini if (nbini.lt.0.or.nsini.lt.0) then nbini = nbunch nsini = nbstep endif read(11,'(a64)') dummy read(11,*) imodo c write(*,*) dummy c write(*,*) imodo read(11,'(a64)') dummy read(11,*) alimit c write(*,*) dummy c write(*,*) alimit read(11,'(a64)') dummy read(11,*) epemax, epemax2, ratio write(*,*) dummy write(*,*) epemax, epemax2, ratio read(11,'(a64)') dummy read(11,*) epesig, epesig2 write(*,*) dummy write(*,*) epesig, epesig2 read(11,'(a64)') dummy read(11,*) semax c write(*,*) dummy c write(*,*) semax read(11,'(a64)') dummy read(11,*) iseldis c write(*,*) dummy c write(*,*) iseldis read(11,'(a64)') dummy read(11,*) ecut c write(*,*) dummy c write(*,*) ecut read(11,'(a64)') dummy read(11,*) yim c write(*,*) dummy c write(*,*) yim read(11,'(a64)') dummy read(11,*) yemax c write(*,*) dummy c write(*,*) yemax read(11,'(a64)') dummy read(11,*) interspace c write(*,*) dummy c write(*,*) interspace read(11,'(a64)') dummy read(11,*) iimage c write(*,*) dummy c write(*,*) iimage read(11,'(a64)') dummy read(11,*) iimageb c write(*,*) dummy c write(*,*) iimageb read(11,'(a64)') dummy read(11,*) sx c write(*,*) dummy c write(*,*) sx read(11,'(a64)') dummy read(11,*) sy c write(*,*) dummy c write(*,*) sy read(11,'(a64)') dummy read(11,*) xbound c write(*,*) dummy c write(*,*) xbound read(11,'(a64)') dummy read(11,*) ybound c write(*,*) dummy c write(*,*) ybound read(11,'(a64)') dummy read(11,*) zbound c write(*,*) dummy c write(*,*) zbound read(11,'(a64)') dummy read(11,*) bfield c write(*,*) dummy c write(*,*) bfield read(11,'(a64)') dummy read(11,*) volt c write(*,*) dummy c write(*,*) volt c if (zbound.ne.0.0) volt = volt /2.0d0/zbound read(11,'(a64)') dummy read(11,*) ibend c write(*,*) dummy c write(*,*) ibend if (ibend.eq.24.or.ibend.eq.50) then read(11,*) bgradient endif if (ibend.eq.25) then read(11,*) f0,efieldrf endif read(11,'(a64)') dummy read(11,*) iloss c write(*,*) dummy c write(*,*) iloss read(11,'(a64)') dummy read(11,*) ispace write(*,*) dummy write(*,*) ispace read(11,'(a64)') dummy read(11,*) idistr write(*,*) dummy write(*,*) idistr if (idistr.eq.2) then read(11,*) edgefraction write(*,*) edgefraction endif c write(*,*) dummy read(11,'(a64)') dummy read(11,*) ibeam if (ibeam.eq.2) then write(*,*) ' ibeam set to 1, iscatter activated ' write(*,*) ' (iscatter=1 represents e- beam) ' iscatter=1 ibeam=1 endif write(*,*) dummy write(*,*) ibeam, iscatter read(11,'(a64)') dummy read(11,*) iwave write(*,*) dummy write(*,*) iwave if (iwave.ne.0) idistr = 0 read(11,'(a64)') dummy read(11,*) rbound c write(*,*) dummy c write(*,*) rbound read(11,'(a64)') dummy read(11,*) wgl c write(*,*) dummy c write(*,*) wgl read(11,'(a64)') dummy read(11,*) wk c write(*,*) dummy c write(*,*) wk read(11,'(a64)') dummy read(11,*) vtem c write(*,*) dummy c write(*,*) vtem read(11,'(a64)') dummy read(11,*) vtem0 c write(*,*) dummy c write(*,*) vtem0 c vtem0 = vtem0 * log(sqrt(xbound**2+ybound**2)/rbound) read(11,'(a64)') dummy read(11,*) rbound6 read(11,'(a64)') dummy read(11,*) ppb1 c write(*,*) dummy c write(*,*) ppb1 read(11,'(a64)') dummy read(11,*) sb1 c write(*,*) dummy c write(*,*) sb1 read(11,'(a64)') dummy read(11,*) ppb2 c write(*,*) dummy c write(*,*) ppb2 read(11,'(a64)') dummy read(11,*) sb2 c write(*,*) dummy c write(*,*) sb2 read(11,'(a64)') dummy read(11,*) x1,y1 write(*,*) dummy write(*,*) x1,y1 read(11,'(a64)') dummy read(11,*) x2,y2 write(*,*) dummy write(*,*) x2,y2 read(11,'(a64)') dummy read(11,*) x3,y3 write(*,*) dummy write(*,*) x3,y3 read(11,'(a64)') dummy read(11,*) icoll write(*,*) dummy write(*,*) icoll c frank, november 99, flag for inelastic scattering read(11,'(a64)') dummy read(11,*) inel write(*,*) dummy write(*,*) inel c c frank, november 99, for bunch fill pattern read(11,'(a64)') dummy read(11,*) irep, iabort read(11,*) ito1, ito2, ito3, ito4 read(11,*) ditn1, ditn2, ditn3, ditn4 write(*,*) dummy write(*,*) irep, iabort write(*,*) ito1, ito2, ito3, ito4 write(*,*) ditn1, ditn2, ditn3, ditn4 c frank, november 99, switch for azimuthal heat load read(11,'(a64)') dummy read(11,*) iazi write(*,*) dummy write(*,*) iazi c frank, november 99, switch for wake read(11,'(a64)') dummy read(11,*) iwake read(11,*) xwto, ywto write(*,*) dummy write(*,*) iwake write(*,*) xwto, ywto close(11) write(*,*) ' input complete ' indbx = 0 do i = 1, irep do j = 1, ito1 indbx = indbx+1 indexb (indbx) = 1 dntr (indbx) = ditn1 end do do j = 1, ito2 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = ditn2 end do do j = 1, ito3 indbx = indbx+1 indexb (indbx) = 1 dntr (indbx) = ditn3 end do do j = 1, ito4 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = ditn4 end do end do c frank, summer 99 c note sign reversal for offset c of first satellite! x10 = x1/1000. x1=x10 x20 = -x2/1000. x2=x20 x30 = x3/1000. x3=x30 y10 = y1/1000. y1=y10 y20 = -y2/1000. y2=y20 y30 = y3/1000. y3=y30 if (idistr.eq.1) then c CORRECT bl = bl * 4. * sqrt(3.) c bl = bl * 4. c NEW c bl = bl * 2. * sqrt(4.) c OLD AND POSSIBLY WRONG c bl = bl * 2. * sqrt(2.0d0) endif sb = sb-bl if(ppb1.gt.1.0d0.and.ppb2.lt.1.d0) then sb0 = sb sb = sb1-bl sb1 = sb0-sb-1.*bl endif c if(ppb2.gt.1.0d0.and.ppb1.le.0) then if(ppb2.gt.1.0d0.and.ppb1.gt.1.d0) then sb0 = sb+bl sb10 = sb1 sb20 = sb2 sb1 = sb20-sb10-bl sb2 = sb0-sb20-bl sb = sb10-bl else if(ppb2.gt.1.0d0) then sb0 = sb sb = sb2-bl sb2 = sb0-sb-1.*bl endif c Round vacuum chamber: if(xbound.eq.ybound.and.zbound.eq.ybound) igeom = 1 c Elliptical vacuum chamber: if(xbound.ne.ybound.or.zbound.lt.ybound) igeom = 2 c Rectangular vacuum chamber: if(xbound.eq.ybound.and.zbound.gt.ybound) igeom = 4 c Circular coaxial structure: if(iwave.ne.0) write(*,*) "Wave Guide Mode!", iwave if(iwave.eq.1) igeom = 3 if(iwave.eq.2) then igeom = 1 c----X.Zhang, Oct. 1998 c---- add geometry for waveguide with 6 wire do 666 i=1,6 x0r(i) = rbound*dcos(2.0d0*pi*dble(i-1)/6.0d0) y0r(i) = rbound*dsin(2.0d0*pi*dble(i-1)/6.0d0) c print*, x0r(i),y0r(i) 666 continue endif c--------------- if (igeom.eq.1) then iimageb = 0 write(*,*) "Assuming Circular Geometry" write(*,*) " -> Variable IIMAGEB = 0" endif if (igeom.eq.2.and.zbound.ge.ybound) * write(*,*) "Assuming Elliptical Geometry" if (igeom.eq.2.and.zbound.lt.ybound) * write(*,*) "Assuming LHC Geometry" if (igeom.eq.3) write(*,*) "Assuming Wave Guide Geometry" if (igeom.eq.4) write(*,*) "Assuming Rectangular Geometry" if(igeom.eq.3.and.ybound.ne.xbound) then ybound = xbound write(*,*) "Variable YBOUND changed to :",ybound endif if(igeom.eq.3.and.zbound.ne.xbound) then zbound = xbound write(*,*) "Variable ZBOUND changed to :",zbound endif if(rbound.eq.0.0) then rbound = min(xbound,ybound) rbound = min(rbound,zbound)/10.0d0 write(*,*) "Variable RBOUND changed to :",rbound endif if(ispace.eq.1) write(*,*) * "Using a 1-dimensional mesh for space charge calculations:", * ngrid if(ispace.eq.2) write(*,*) * "Using a 2-dimensional mesh for space charge calculations:", * ngrid2,"*",ngrid2 if (igeom.eq.4) then zbound = ybound write(*,*) "Variable ZBOUND changed to :",zbound endif c print*,'vl=',vl,'bl=',bl if(iwave.eq.1) * write(*,*) "Time step per bunch = ",bl/vl,"sec" if(iwave.eq.1) * write(*,*) "Time step per slice = ",bl/vl/nbstep,"sec" if(iwave.eq.1) * write(*,*) "TEM period = ",wgl/(wk*vl),"sec" if(iwave.eq.2) * write(*,*) "Time step per bunch = ",bl/vl,"sec" if(iwave.eq.2) * write(*,*) "Time step per slice = ",bl/vl/nbstep,"sec" if(iwave.eq.2) * write(*,*) "TEM period = ",wgl/vl,"sec" do 10 i=1,40 boundix(i) = rbound*cos(2*pi*i/40.0d0) boundiy(i) = rbound*sin(2*pi*i/40.0d0) 10 continue do 11 i=1,80 boundox(i) = xbound*cos(2*pi*i/80) boundoy(i) = ybound*sin(2*pi*i/80) if (boundoy(i).gt.zbound) boundoy(i) = zbound if (boundoy(i).lt.-zbound) boundoy(i) = -zbound 11 continue if(ispace.eq.2) then c initializing the charge on the mesh: do 101 i=-ngrid2,ngrid2 do 102 j=-ngrid2,ngrid2 qgrid(i,j) = 0.0d0 102 continue 101 continue endif ymbound = min(ybound,zbound) rmax = max(xbound,ymbound) rmin = min(xbound,ymbound) rg = 0.0d0 rm1 = 0.0d0 if(igeom.eq.2) then rg = sqrt(rmax**2 - rmin**2) rm1 = log((rmax+rmin)/(rmax-rmin))/2.0d0 endif if(nbini.gt.nbunch) then nbini = nbunch write(*,*) "Variable NBINI changed to :", nbini endif if(nsini.gt.nbstep) then nsini = nbstep write(*,*) "Variable NSINI changed to :", nsini endif if(jebin.gt.nbunch) then jebin = nbunch write(*,*) "Variable JEBIN changed to :", jebin endif if(iebin.gt.nbstep) then iebin = nbstep write(*,*) "Variable IEBIN changed to :", iebin endif ccccccccccccccccccccccccccccccccccccccccccccccccccccc fom = bfield*vl*vl/mec2 t = 0.0d0 c write(*,*) ' in init:',fom c c number of photo-electrons / bunch / bend c number of photo-electrons / RF-period do 12 i = 1, npelm if (icoll.ne.1) then q(i) = ppb*peeff/real(npepb) index(i) = 0 else if (icoll.eq.1) then cc previously: gas ionization - 1 Torr, e- over 65 mm length cc now the same as for photoemission q(i) = ppb*peeff/real(npepb) c ppb*belen*6.d-9*peeff/real(npepb) index(i) = 0 endif 12 continue bnorm = 0.0 if (idistr.eq.2) * write(*,*) "Using a flat charge distribution with edges" if (idistr.eq.1) * write(*,*) "Using a Gaussian charge distribution" if (idistr.eq.0) * write(*,*) "Using a Uniform charge distribution" c frank 07/22/99 c check using S. Berg's formulae if (idistr.eq.1) then dlambdamax = 1./sqrt(2.*pi) else if (idistr.eq.0) then dlambdamax = 1./2./sqrt(3.) else if (idistr.eq.2) then dlambdamax = 1. endif sigmal = bl/(2.*sqrt(4.d0)) rcrit = 2.*sqrt(ppb*re*sigmal/pi/dlambdamax) deltaemax = mec2*2.*ppb*re/sigmal*dlambdamax*dlog(rcrit/ & (1.06*sqrt(sx*sy))) write(*,*) ' calculated parameters a la Scott Berg ' write(*,*) ' ' write(*,*) ' maximum electron energy a la Scott Berg:' write(*,*) ' ' write(*,*) ' rms bunch length = ',sigmal,' (m)' write(*,*) ' critical radius = ',rcrit,' (m)' write(*,*) ' maximum energy gain = ',deltaemax,' (eV)' write(*,*) ' ' c ----------------------------------------------------- if (idistr.eq.2) then ibmin = nbstep*edgefraction*0.5 ibmax = nbstep*(1.-edgefraction*0.5) endif do 13 i = 1,nbstep c flat charge distribution with edges: if (idistr.eq.2) then bweight(i) = 1.0d0 if (ibmin.gt.0) then if (i.lt.ibmin) then bweight(i) = real(i)/real(ibmin) else if (i.gt.ibmax) then bweight(i) = (real(i)-real(ibmax))/real(ibmin) endif endif endif c uniform charge distribution: if (idistr.eq.0) then bweight(i) = 1.0d0 endif c Gaussian charge distribution: if (idistr.eq.1) then cc CORRECT with bunch length = sqrt(3)*4*sz: bweight(i) = exp(-6*real(2*(i-1)-(nbstep-1))* cc bweight(i) = exp(-2*real(2*(i-1)-(nbstep-1))* c bweight(i) = exp(-5*real(2*(i-1)-(nbstep-1))* c bweight(i) = exp(-2*real(2*(i-1)-(nbstep-1))* * real(2*(i-1)-(nbstep-1))/ real(nbstep)/real(nbstep)) endif bnorm = bnorm + bweight(i) 13 continue do 14 i = 1,nbstep bweight(i) = bweight(i)/bnorm c write(9119,*) "DISTRIBUTION:",i, bnorm, bweight(i) 14 continue c grid parameters do 35 i = 0,iybin iycount(i) = 0 35 continue c grid parameters do 15 i = 1, ngrid efield(i) = 0.0d0 15 continue radstep = xbound/real(ngrid) rad(0) = 0.0d0 do 16 j = 1, ngrid crg(j) = 0.0d0 rad(j) = real(j) * radstep 16 continue c Oliver 27.10.1997: c Gaussian energy distribution: c initialize variables: if (iseldis.eq.1) then c define number of intervals and width of distribution: esigma = semax emax0 = 5.0d0*semax c count total number of produced secondary electrons: isectot = 0 c divide total energy range in 'intn' intervalls and create array of c counter which limits the number of particles in a given intervall: ltest = 0.0 do 17 im=1,intn elocal = dble(im)*emax0/ dble(intn) limit(im) = exp(-elocal**2/2.0d0/esigma**2)* * emax0/dble(intn) ltest = ltest + limit(im) 17 continue do 18 im=1,intn lcount(im) = 0 limit(im) = limit(im)/ ltest 18 continue endif c Oliver 27.10.1997: c Miguels energy distribution: c initialize variables: if (iseldis.eq.2) then c define number of intervals and width of distribution: esigma = semax emax0 = 5.0d0*semax c count total number of produced secondary electrons: isectot = 0 c devide total energy range in 'intn' intervalls and create array of c counter which limits the number of particles in a given intervall: ltest = 0.0 do 19 im=1,intn elocal = dble(im)*emax0/ dble(intn) limit(im) = emax0*elocal*exp(-elocal/esigma)/ dble(intn) if (elocal.gt.5.0d0*esigma) limit(im) = 0.0d0 ltest = ltest + limit(im) 19 continue do 20 im=1,intn lcount(im) = 0 limit(im) = limit(im)/ ltest 20 continue endif c Oliver 27.10.1997: c Exponential Distribution: c initialize variables: if (iseldis.eq.3) then c define number of intervals and width of distribution: esigma = semax emax0 = 5.0d0*semax c count total number of produced secondary electrons: isectot = 0 c divide total energy range in 'intn' intervalls and create array of c counter which limits the number of particles in a given intervall: ltest = 0.0 do 21 im=1,intn elocal = dble(im)*emax0/ dble(intn) limit(im) = emax0*exp(-elocal/esigma)/ dble(intn) ltest = ltest + limit(im) 21 continue do 22 im=1,intn lcount(im) = 0 limit(im) = limit(im)/ ltest 22 continue endif c Oliver 27.10.1997: c Ians Lorentian energy distribution: c initialize variables: if (iseldis.eq.4) then c define number of intervals and width of distribution: esigma = semax emax0 = 10.0d0*semax c count total number of produced secondary electrons: isectot = 0 c divide total energy range in 'intn' intervalls and create array of c counter which limits the number of particles in a given intervall: ltest = 0.0 do 23 im=1,intn elocal = dble(im)*emax0/ dble(intn) limit(im) = emax0/ dble(intn)/ (elocal**2 + esigma**2) c if (elocal.gt.10.0d0*esigma) limit(im) = 0.0d0 ltest = ltest + limit(im) 23 continue do 24 im=1,intn lcount(im) = 0 limit(im) = limit(im)/ ltest 24 continue endif c Oliver 27.10.1997: c Noel Hilleret's fit according to Philips Res. 50, 375 (1996) c initialize variables: if (iseldis.eq.5) then c define number of intervals and width of distribution: esigma = semax emax0 = 12.0d0*semax c count total number of produced secondary electrons: isectot = 0 c devide total energy range in 'intn' intervalls and create array of c counter which limits the number of particles in a given intervall: ltest = 0.0 do 25 im=1,intn elocal = dble(im)*emax0/ dble(intn) limit(im) = exp (-dLog(elocal/esigma)**2/2.) c if (elocal.gt.10.0d0*esigma) limit(im) = 0.0d0 ltest = ltest + limit(im) 25 continue do 26 im=1,intn lcount(im) = 0 limit(im) = limit(im)/ ltest 26 continue endif c---Initialize energy bin of the electrons that hit the wall. do 777 ik=0,500 webin(ik) = 0.0d0 777 continue c---Initialize azimuth bin of the electrons that hit the wall. do 778 ik=0,500 webinphi(ik) = 0.0d0 webinph2(ik) = 0.0d0 778 continue do 779 ik=0,500 webinx(ik) = 0.0d0 webinx2(ik) = 0.0d0 webinx3(ik) = 0.0d0 779 continue wen1 = 0. wen2 = 0. wenmax = 0. qne1 = 0 qne2 = 0 qlosstot = 0. qlosstot2 = 0. end subroutine generate(jb,is,yoff,xoff,iflag) c purpose: generates photoelectrons and propagates them c during bunch passage implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,iybin=500) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) c parameter (nbstep = 5) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,ngrid2=10) parameter (np=8000,np1=8000) integer iycount(0:iybin) integer index(npelm) integer kw, nw, iflag integer iazi, IFAIL, iirefl, iscatter real*8 ayield(0:iybin), avcos(0:iybin) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm),zp(npelm),py(npelm),pz(npelm) real*8 px(npelm), dele(npelm), qele(npelm), test(npelm) real*8 xpt, ypt, zpt, pxt, pyt, pzt real*8 ptime(npelm), esign(npelm) real*8 arrayr2(npelm) c real*8 rn(np), rn1(np1) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 uni, XX, CDF c oliver 17.6.1997:cccccccccccccccccc real*8 eloss, elossq, ephoto, adele, qadele, alimit real*8 bweight(50000) real*8 boundix(40), boundiy(40), boundox(80), boundoy(80) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccc real*8 rg, rm1 real*8 epesig, epemax, ecut real*8 wgl, wk, vtem, vtem0 real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppbt, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 factor, dt real*8 radi real*8 xt, yt, zt real*8 volt, qouter, qinner real*8 ran2 real*8 r2, r3, rnorm, rnx, rny, avar, sigmr, avar1, avar2 real*8 enhelp, voltx, volty real*8 one real*8 dpx, dpy, dpz, dpxm, dpym, dpzm real*8 epemax2, epesig2, ratio real*8 dntr(1:nbmax) real*8 qlosswh, qlosstot, qlosstot2 real*8 eespacex, eespacey, eebeamx, eebeamy, gamman real*8 xtn,ytn,xta,yta,frasol real*8 c11,c12,c13,c14,c15,c16,c21,c22,c23,c24,c25,c26 real*8 c31,c32,c33,c34,c35,c36,c41,c42,c43,c44,c45,c46 real*8 bgradient c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / def10 / x1, y1, x2, y2, x3, y3 common / def11 / icoll common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / help / factor, dt common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid common / rann / iseed, idumy c oliver 17.6.1997:cccccccccccccccccc common / loss / eloss, elossq, ephoto, adele, qadele common / egain / dele, qele common / bunch / bweight common / loss2 / qlosswh, qlosstot, qlosstot2 cccccccccccccccccccccccccccccccccccccc c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def8 / alimit common / def9 / wgl, wk, vtem, vtem0 common / eini / epemax,ecut common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig common / epe / epemax2, epesig2, ratio common / movie / boundix, boundiy, boundox, boundoy ccccccccccccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos ccccccccccccccccccccccccccccccccccccccc c frank, nov 99 for azimuth common / azi / iazi cccccccccccccccccccccccccccccccccccccccccccccc common / test1 / itest common / test2 / test common / beam / rg, rm1 common / image / iimage, iimageb, interspace, igeom common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 common / refl / refl common / swrefl / iirefl common / indb2 / dntr common / caso / uni common / delay / iscatter external C05ADF external CDF external solenx,soleny,solenz one = 1.0d0 write(*,*) ' in subroutine generate ' c X. Zhang Oct. 1998:cccccccccccccccc c Introduce a parameter sigmr to modify the initial electron c distribution when alimit<0 c sigmr = 1.0d0*sy/xbound if (iwave.eq.2) sigmr = 1.0d0 iseed = iseed+12349 ppbt = ppb if(iflag.eq.1) ppbt = ppb1 if(iflag.eq.2) ppbt = ppb2 factor = ppbt * re * vl & * sqrt(2.0d0*pi) if (iscatter.eq.1) then factor = - factor endif dt = bl/vl dtex = bl/vl/real(nbstep) c t = t + dt c frankz introduce intensity variation, 25/01/01 c cfac = (ran2(idumy)-0.5) * 0.4 cfac = 1.d0 c first propagate existing particles... if(interspace.ne.0) ismod = nbstep/interspace if(interspace.eq.0) ismod = nbstep + 1 do 10 ib = 1, nbstep c write(*,*) ' existing ib = ', ib qlosswh = 0. c Recalculating the electric field on the mesh 'interspace' times c for the wave guide geometry: c if(mod(ib,ismod).eq.0.and.iwave.ne.0) then if(mod(ib,ismod).eq.0) then if(ispace.eq.2) call spacecharge2 if(ispace.eq.1) call spacecharge(0) endif c elossq = 0.0d0 t = t + dtex c write(*,*) ' icount = ',icount iadele = 0 c write(*,*) ' after spacecharge2 ' if (icount.gt.0) then do 11 i = 1, icount c write(*,*) ' 11 loop', i, ib if ((index(i).eq.0).and.(q(i).gt.0.0d0)) then dpx = 0.0 dpy = 0.0 dpz = 0.0 xt = x(i) yt = y(i) zt = z(i) xpt = xp(i) ypt = yp(i) zpt = zp(i) c Oliver 12.8.1998: c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = 1.0d0*gammaf(velt)*ypt pxt = 1.0d0*gammaf(velt)*xpt pzt = 1.0d0*gammaf(velt)*zpt if (i.eq.1) then ti=1.e9*t gf=gammaf(velt) c write(144,900) ti,x(i),y(i),xp(i),yp(i),gf write(144,900) ti,x(i),y(i),z(i),x(i+1), & y(i+1),z(i+1) 900 format(7(1x,e12.5)) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccc c space charge if (ispace.eq.1) then radi = sqrt(xt*xt+yt*yt) do 12 j1 = 1, ngrid if (radi.lt.rad(j1)) then c 19.08.1997 Oliver: Changing the interpolation routine. ef = efield(j1-1)+(radi-rad(j1-1))/ & (rad(j1)-rad(j1-1))*(efield(j1)-efield(j1-1)) goto 200 endif 12 continue 200 continue dpx = dpx + xt/radi*ef dpy = dpy + yt/radi*ef eespacex = xt/radi*ef eespacey = yt/radi*ef endif c 18.8.1997 Oliver: New spacecharge routine. if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xt/xbound) indy = nint(ngrid2*yt/ymbound) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1201 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif dpx = dpx + sign(efx3,xt) dpy = dpy + sign(efy3,yt) eespacex = sign(efx3,xt) eespacey = sign(efy3,yt) endif 1201 continue c end space charge cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' before bb kick ' ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Beam-Beam Kick: yt = yt xt = xt xta = abs(xt-xoff) yta = abs(yt-yoff) c Normal beam-beam kick: if (ibeam.eq.1.and.iwave.eq.0) then if(iimageb.ne.1) * call ffrank(xt,yt,xoff,yoff,sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xt,yt,xoff,yoff,sx,sy,rg,rm1,pre,pim) c call bbkick(pre,pim,xta,yta,sx,sy) c Oliver 23.06.1997: Introducing arbitrary bunch distributions: c frankz introduce intensity variation, 25/01/01 pim = pim * bweight(ib) * nbstep/dt * dntr(jb) * cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb) * cfac dpx = dpx - pim * factor * (xt-xoff)/xta dpy = dpy - pre * factor * (yt-yoff)/yta c + el*volt/ elmass eebeamx = - pim * factor * (xt-xoff)/xta eebeamy = - pre * factor * (yt-yoff)/yta endif c Oliver 30.07.1997: Introducing the kick from a TEM wave: if (ibeam.eq.1.and.iwave.eq.1) then call tem(xt,yt,wk,t,wgl,pre,pim) dpx = dpx + el * (vtem * pim)/ elmass dpy = dpy + el * (vtem * pre)/ elmass c Voltage between inner and outer conducter. if(vtem0.ne.1.0d-5) then dpx = dpx - * el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2)/elmass dpy = dpy - * el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2)/elmass eebeamx = - el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2) * /elmass eebeamy = - el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2) * /elmass endif endif c Oliver 23.07.1998: Introducing the kick from a TEM wave: if (ibeam.eq.1.and.iwave.eq.2) then vtem06 = vtem0/vtem call tem6(xt,yt,wk,t,wgl,xbound,pre,pim,vtem06) dpx = dpx + el * (vtem * pim)/ elmass dpy = dpy + el * (vtem * pre)/ elmass eebeamx = el * (vtem * pim)/ elmass eebeamy = el * (vtem * pre)/ elmass c Voltage between inner and outer conducter. c if(vtem0.ne.1.0d-5) then c dpx = dpx - c * el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2)/elmass c dpy = dpy - c * el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2)/elmass c endif endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 11.8.1998 Oliver: New module for case without magnetic field. if(ibend.eq.0) then pz(i) = pzt px(i) = pxt + dpx*dtex py(i) = pyt + dpy*dtex c pz(i) = pzt gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + (xp(i)+xpt)/2.0d0 * dtex y(i) = yt + (yp(i)+ypt)/2.0d0 * dtex z(i) = zt + (zp(i)+zpt)/2.0d0 * dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 17.11.1998 X. Zhang: For case with field of horizontal bend magnet. if(ibend.eq.1) then px(i) = pxt py(i) = pyt + dpy*dtex pz(i) = pzt c gamma = sqrt(1.0d0+(py(i)/vl)**2) gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt c fixed bug, 12/11/99 y(i) = yt + (yp(i)+ypt)/2.0d0 * dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c May 2002 Frank: for combined function magnet with motion frozen c on field lines c if(ibend.eq.50) then bx = + bgradient*y(i) by = bfield - bgradient*x(i) bmod = sqrt(bx*bx+by*by) projx = (bx*dpx+by*dpy)*bx*dtex/bmod**2 projy = (bx*dpx+by*dpy)*by*dtex/bmod**2 px(i) = pxt + projx py(i) = pyt + projy c gamma = sqrt(1.0d0+(py(i)/vl)**2) gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + 0.5* & ((px(i)+pxt)*bx+(py(i)+pyt)*by)*bx/bmod**2*dtex y(i) = yt + 0.5* & ((px(i)+pxt)*bx+(py(i)+pyt)*by)*by/bmod**2*dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 2.6.1998: New module for particle motion in magnetic fields: if(ibend.eq.2) then c write(*,*) ' call bmap ' call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dtex) c write(*,*) ' end bmap ' gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c end bmap ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if (ibend.eq.3) then c y(i) = deltax*a1+a2*zt+a3*xpt+a4*ypt c x(i) = xoff + deltax*b1+b2*xt+b3*xpt+b4*ypt c yp(i) = deltax*c1+c2*xpt+c3*ypt c xp(i) = deltax*d1+d2*xpt+d3*ypt c px(i) = pxt + deltax*dtex c py(i) = pyt + deltay*dtex c pz(i) = pzt c gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c xp(i) = px(i)/gamma c yp(i) = py(i)/gamma c zp(i) = pz(i)/gamma call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dtex) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c -------------------------------------------------------------- c frank 06/01/2000, explicit solution for solenoid field c if(ibend.eq.4) then px(i) = pxt + dpx*dtex py(i) = pyt + dpy*dtex pxt = px(i) pyt = py(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl c gamma = 1. xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma fomc = fom/gamma argu = fomc*dtex if (argu.le.0.001) then cofomc1 = 1-argu*argu/2. sifomc1 = argu else cofomc1 = cos(fomc*dtex) sifomc1 = sin(fomc*dtex) endif x(i) = xt + yp(i)/fomc*(1.-cofomc1)+xp(i)/fomc* & sifomc1 y(i) = yt + xp(i)/fomc*(-1.+cofomc1)+yp(i)/fomc* & sifomc1 z(i) = zt xpt = yp(i)*sifomc1+xp(i)*cofomc1 ypt = -xp(i)*sifomc1+yp(i)*cofomc1 xp(i) = xpt yp(i) = ypt velt = sqrt(ypt*ypt+xpt*xpt+zp(i)*zp(i)) gfac = gammaf(velt) c gfac = 1. py(i) = 1.0d0*gfac*ypt px(i) = 1.0d0*gfac*xpt pz(i) = 1.0d0*gfac*zp(i) endif c endbmap ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if (ibend.eq.5) then c frank 06/01/2000, explicit solution for weak bending magnet c c deltax = dpx / dtex c deltay = dpy / dtex c write(*,*) ' in generate 2 ', fom pxt = px(i) + dpx*dtex pyt = py(i) + dpy*dtex pzt = pz(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl c if (i.eq.184) then c write(*,*) ' gamma = ',gamma c write(*,*) ' cofim = ',cofim,sifim c write(*,*) xpt,ypt,zpt,xt,yt,zt c endif c gamma = 1. xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma fomc = fom/gamma cofim = cos(fomc*dtex) sifim = sin(fomc*dtex) zt = z(i) + sifim/fomc*zp(i)+(1.-cofim)/fomc*xp(i) xt = x(i) + (cofim-1.)/fomc*zp(i)+sifim/fomc*xp(i) yt = y(i) + yp(i) * dtex x(i) = xt y(i) = yt z(i) = zt zpt = sifim*xp(i)+cofim*zp(i) xpt = cofim*xp(i)-sifim*zp(i) ypt = yp(i) xp(i) = xpt zp(i) = zpt c if (i.eq.184) then c write(*,*) ' fomc = ',fomc,gamma c write(*,*) ' cofim = ',cofim,sifim c write(*,*) xpt,ypt,zpt,xt,yt,zt c endif velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) c if (i.eq.184) then c write(*,*) ' velt = ',velt c endif gfac = gammaf(velt) c if (i.eq.184) then c write(*,*) ' gfac = ',gfac c endif c pyt = 1.0d0*gfac*yp(i) c pxt = 1.0d0*gfac*xp(i) c pzt = 1.0d0*gfac*zp(i) py(i) = 1.0d0*gfac*ypt px(i) = 1.0d0*gfac*xpt pz(i) = 1.0d0*gfac*zpt c gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c xp(i) = px(i)/gamma c yp(i) = py(i)/gamma c zp(i) = pz(i)/gamma c x(i) = xt + (xp(i)+xpt)/2.0d0 * dtex endif c end bmap ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if (ibend.eq.6) then c frank 18/04/2000, solution for quadrupole magnet c c deltax = dpx / dtex c deltay = dpy / dtex c write(*,*) ' in generate 2 ', fom z(i) = a2*zt+a3*xpt+a4*zpt x(i) = b2*xt+b3*xpt+b4*zpt y(i) = yt + dtex*ypt zp(i) = c2*xpt+c3*zpt xp(i) = d2*xpt+d3*zpt yp(i) = ypt velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) gfac = gammaf(velt) pyt = 1.0d0*gfac*yp(i) pxt = 1.0d0*gfac*xp(i) pzt = 1.0d0*gfac*zp(i) px(i) = pxt + dpx*dtex py(i) = pyt + dpy*dtex pz(i) = pzt gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + (xp(i)+xpt)/2.0d0 * dtex y(i) = yt + (yp(i)+ypt)/2.0d0 * dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c symmetric KEKB yokes (quadrupole and dipole) if(ibend.eq.11.or.ibend.eq.13.or.ibend.eq.16) then call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dtex) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c end bmap c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c asymmetric KEKB yokes if(ibend.eq.12.or.ibend.eq.14.or.ibend.eq.17) then c write(*,*) ' ibend 17 ' call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dtex) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c end bmap c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c solenoid with z dependence, for KEKB c c ibend = 18, strong dipole with bfield using commercial runge-kutta c c ibend = 38, strong dipole with bfield using commercial runge-kutta c and y electric field 20 kV/m (for IPM simulation) c if(ibend.eq.15.or.ibend.eq.18.or.ibend.eq.38. & or.ibend.ge.19.and.ibend.lt.40) then c write(*,*) ' in generate A ', fom call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dtex) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c end bmap c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Giovanni: an "on line" Runge-Kutta algorithm for the electron c motion in a dipole field. if(ibend.eq.40) then cc11 = pxt*dtex/gamma cc12 = (eebeamx + el/elmass*pzt*bfield/gamma)*dtex cc13 = pyt*dtex/gamma cc14 = eebeamy*dtex cc15 = pzt*dtex/gamma cc16 = - el/elmass*pxt/gamma*bfield*dtex c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1210 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1210 continue endif cc cc21 = (pxt+cc12/2)/gamman*dtex cc22 = (eebeamx + eespacex + el/elmass*(pzt+ * cc16/2)/gamman*bfield)*dtex cc23 = (pyt+cc14/2)/gamman*dtex cc24 = (eebeamy + eespacey)*dtex cc25 = (pzt+cc16/2)/gamman*dtex cc26 = - el/elmass*(pxt+cc12/2)* * bfield/gamman*dtex c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1211 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1211 continue endif cc31 = (pxt+cc22/2)/gamman*dtex cc32 = (eebeamx + eespacex + el/elmass*(pzt * +cc26/2)/gamman*bfield)*dtex cc33 = (pyt+cc24/2)/gamman*dtex cc34 = (eebeamy + eespacey)*dtex cc35 = (pzt+cc26/2)/gamman*dtex cc36 = - el/elmass*(pxt+cc22/2)* * bfield/gamman*dtex c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1212 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1212 continue endif cc41 = (pxt+cc32)/gamman*dtex cc42 = (eebeamx + eespacex + el/elmass*(pzt * +cc36)/gamman*bfield)*dtex cc43 = (pyt+cc34)/gamman*dtex cc44 = (eebeamy+eespacey)*dtex cc45 = (pzt+cc36)/gamman*dtex cc46 = - el/elmass*(pxt+cc32)* * bfield/gamman*dtex c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl endif c Giovanni: an "on line" Runge-Kutta for the solution of the electron c motion in a finite length solenoid field. if(ibend.eq.41) then frasol = 0.8 cc11 = pxt*dtex/gamma cc12 = (eebeamx + eespacex - el/elmass*pyt*solenz * (frasol,xt,yt,zt)/gamma + el/elmass* * pzt*soleny(frasol,xt,yt,zt)/gamma)*dtex cc13 = pyt*dtex/gamma cc14 = (eebeamy + eespacey - el/elmass*pzt*solenx * (frasol,xt,yt,zt)/gamma + el/elmass* * pxt*solenz(frasol,xt,yt,zt)/gamma)*dtex cc15 = pzt*dtex/gamma cc16 = (- el/elmass*pxt*soleny(frasol,xt,yt,zt) * /gamma + el/elmass*pyt*solenx(frasol,xt,yt, * zt)/gamma)*dtex c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 ztn = zt + cc15/2 pxtn = pxt + cc12/2 pytn = pyt + cc14/2 pztn = pzt + cc16/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1220 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1220 continue endif cc21 = pxtn/gamman*dtex cc22 = (eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dtex cc23 = pytn/gamman*dtex cc24 = (eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dtex cc25 = pztn/gamman*dtex cc26 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass * pytn*solenx(frasol,xtn, * ytn,ztn)/gamman)*dtex c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 ztn = zt + cc25/2 pxtn = pxt + cc22/2 pytn = pyt + cc24/2 pztn = pzt + cc26/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1221 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1221 continue endif cc31 = pxtn/gamman*dtex cc32 = (eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dtex cc33 = pytn/gamman*dtex cc34 = (eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dtex cc35 = pztn/gamman*dtex cc36 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dtex c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 ztn = zt + cc35 pxtn = pxt + cc32 pytn = pyt + cc34 pztn = pzt + cc36 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1222 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1222 continue endif cc41 = pxtn/gamman*dtex cc42 = (eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dtex cc43 = pytn/gamman*dtex cc44 = (eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dtex cc45 = pztn/gamman*dtex cc46 = (- el/elmass*pxtn*soleny(frasol,xt,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dtex c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl c write(*,*) ionene(iio) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c Oliver 17.6.1997 (calculate energy and storing it in an array): iadele = iadele + 1 c vel2 = (xp(i)*xp(i)+yp(i)*yp(i)+zp(i)*zp(i)) c beta2 = vel2/vl/vl c beta2 = 1.0d0 - 1.0d0/gamma**2 dele(iadele) = (gamma-1.0d0)*elmass*vl*vl qele(iadele) = q(i) if (ib.eq.nbstep) then adele = adele + qele(iadele)*(gamma-1.0d0)*elmass*vl*vl qadele = qadele + qele(iadele) endif cccccccccccccccccccccccccccccccccccccccccccccccccc c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(i)/xbound)**2+(y(i)/ybound)**2 if (y(i).gt.zbound) amp = 2.0d0 if (y(i).lt.-zbound) amp = 2.0d0 if (iwave.eq.1) then amp2 = (x(i)**2+y(i)**2)/ rbound**2 else if (iwave.eq.2) then call dist(amp2, x(i), y(i), kw) endif if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif if (amp.gt.1.and.iloss.eq.1) then ptime(i) = t - ptime(i) if (ptime(i).gt.0.0.and.dele(iadele)/el.gt.ecut) then write(24,*) x(i), ptime(i)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).ge.0.0d0) c * write(27,*) x(i), ptime(i)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).lt.0.0d0) c * write(28,*) x(i), ptime(i)*1.0d9,dele(iadele)/el endif esign(i) = y(i) ptime(i) = t xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) engt=dele(iadele)/el qlosswh = qlosswh + qt/dtex if (engt.ge.1.0d0) then qlosstot = qlosstot + qt if (engt.ge.20.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt c write(*,*) ' ebinw =' call ebinw(webin,engt,qt) if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) if (iazi.eq.1) then c write(*,*) ' ebinwphi =' call ebinwphi(webinphi,webinph2,engt,qt,xt,yt) c write(*,*) ' ebinwx =' call ebinwx(webinx,webinx2,webinx3,engt,qt,xt,yt) endif endif qacc = qacc - qt qouter = qouter - qt c write(*,*) ' before seiler ' call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) c write(*,*) ' after seiler ' xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qouter = qouter + qtnew c qlosswh = qlosswh - qtnew/dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.ne.0) then ptime(i) = t - ptime(i) if (ptime(i).gt.0.0.and.dele(iadele)/el.gt.ecut) * write(25,*) x(i),ptime(i)*1.0d9,dele(iadele)/el ptime(i) = t esign(i) = y(i) xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qinner = qinner - qt c if (ib.eq.58) then c write(*,*) ' before seiler ', qt c endif call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,2,kw) c if (ib.eq.58) then c write(*,*) ' after seiler ', qt c endif xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qinner = qinner + qtnew endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c 23.06.1997 Oliver: Writing the electron distribution to a file. if (jb.eq.jebin.and.ib.eq.iebin.and.q(i).gt.0.0d0) then write(44,9444) x(i), y(i), q(i), z(i) 9444 format(4(1x,e12.4)) write(4444,9444) xp(i), yp(i), q(i), zp(i) endif if (imovie.eq.1.and.mod(ib,nbstep).eq.0.and. * q(i).gt.0.0d0.and. * abs(x(i)).lt.xbound.and.abs(y(i)).lt.ybound) * write(45,*) x(i), y(i) 11 continue if (imovie.eq.1.and.mod(ib,nbstep).eq.0) then do 112 id=1,40 write(45,*) boundix(id), boundiy(id) 112 continue do 113 id=1,80 write(45,*) boundox(id), boundoy(id) 113 continue write(45,*) " " write(45,*) " " call tem(one,one,wk,t,wgl,pre,pim) c if (vtem*pim/abs(vtem).le.0.0d0) write(46,*) * "plot 'edistr.movie.data' index ",mcount," with points 1" c if (vtem*pim/abs(vtem).gt.0.0d0) write(46,*) c * "plot 'edistr.movie.data' index ",mcount," with points 3" mcount = mcount + 1 write(46,*) "pause 0.8" endif endif c now create new ones... write(*,*) ' creating new e- ' int1 = 1 if (imodo.ne.1) int1 = nbini if (imodo.eq.1.and.mod(jb,nbini).eq.0) int1 = jb if ((jb.le.int1.and.ib.le.nsini.and.imodo.ne.1).or. * (jb.eq.int1.and.ib.le.nsini.and.imodo.eq.1)) then c write(*,*) ' before oliver s comment ' c 23.06.1997 Oliver: Introducing arbitrary bunch distributions. c npepbx = npepb/nbstep npepbx = nint(npepb*bweight(ib)) if(iflag.eq.1) npepbx = nint(npepbx*ppb1/ppb) if(iflag.eq.2) npepbx = nint(npepbx*ppb2/ppb) if(ib.eq.1.and.mod(jb,10).eq.0) * write(*,*) "Create new Photo-Electrons: ",jb,ib,npepbx ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c iseed = iseed+123498+ib c np = npepbx*4 c call ranuni(iseed,rn,np) c np1 = npepbx c call ranuni(iseed,rn1,np1) c initial coordinates of new particles c write(*,*) xbound, ybound, rn(2), fom, bl c write(*,*) ' prior to loop 13 ', npepbx, icoll do 13 i = 1, npepbx c write(*,*) ' 13 loop', i, ib c facx = 1. c facy = 1. c if (rn(i).gt.0.25.and.rn(i).le.0.75) facx = -1. c if (rn(i).gt.0.5) facy = -1. c tp = tan(2.*pi*rn(i)) c icount = icount + 1 c icountact = icountact + 1 c x(icount) = facx*sqrt(1.0d0/(1.0d0/xbound**2+(tp/ybound)**2)) c y(icount) = facy*facx*abs(tp*x(icount)) c z(icount) = (rn(i+npepbx)-0.5d0)*belen c 30.6.1997 Oliver: New routine for initial conditions of photo electrons: c angle dependence of the distribution on an elliptical surface. icount = icount + 1 icountact = icountact + 1 c frank, scale the charge of photoelectrons q(icount) = q(icount)*dntr(jb) c write(*,*) ' q(icount), dntr = ',q(icount),dntr(jb) ptime(icount) = t c new branch for collisional (gas) ionization c frank, 01.08.1999 if (icoll.ne.1) then c write(*,*) ' before generating new electrons ' reflrandom = ran2(idumy) c frank, introduce parameter refl c refl Percent of the photo electrons are uniformely distributed: if (reflrandom.lt.(refl/100.)) then cc 2 Percent of the photo electrons are uniformely distributed: c if (dble(i).lt.dble(npepbx)/50.0d0) c FRANK 22/05/2000 cos theta distribution a la Oleg Malyshev c * r2 = pi-2.*asin((2.*ran2(idumy)-1)) c giovanni 6/2000 different distributions of the reflected light c for uniform distribution [1] if(iirefl.eq.1) * r2 = 2.0d0*pi*(ran2(idumy)-0.5d0) c for cos distribution [2] if(iirefl.eq.2) * r2 = pi-2.*asin((2.*ran2(idumy)-1)) c for cos^2 [3] or parabolic distribution [4] if(iirefl.eq.3.or.iirefl.eq.4) then uni = ran2(idumy) IFAIL = 1 CALL C05ADF(-pi/2, pi/2, 1.0d-5, 0.0d0, CDF, XX, IFAIL) r2 = pi - 2.0d0*XX endif c for smooth parabolic or cos^3 distribution [5] if(iirefl.eq.5) then uni = ran2(idumy) IFAIL = 1 CALL C05ADF(-1.0d0,1.0d0,1.0d-5,0.0d0,CDF,XX,IFAIL) r2 = pi - 2.0d0*asin(XX) endif end if c 90 Percent of the photo electrons are limited by 'alimit': if (reflrandom.ge.(refl/100.).and. * abs(alimit).ne.2.0d0) cc 98 Percent of the photo electrons are limited by 'alimit': c if (dble(i).ge.dble(npepbx)/50.0d0.and.abs(alimit).ne.2.0d0) * r2 = sqrt(-2*log(ran2(idumy)))*cos(2*pi*ran2(idumy)) * * abs(alimit)*pi/2. c *(ran2(idumy)-0.5d0) c 100 Percent of the photo electrons are limited by 'alimit': c r2 = sqrt(-2*log(ran2(idumy)))*cos(2*pi*ran2(idumy)) * c * abs(alimit)*pi*(ran2(idumy)-0.5d0) if (reflrandom.ge.(refl/100.).and.abs(alimit) * .eq.2.0d0) then c FRANK 22/05/2000 cos theta distribution a la Oleg Malyshev c * r2 = pi-2.*asin((2.*ran2(idumy)-1)) c * r2 = abs(alimit)*pi*(ran2(idumy)-0.5d0) c r2 = abs(alimit)*pi*(rn(i)-0.5d0) c Giovanni 6/2000 different distributions if(iirefl.eq.1) * r2 = abs(alimit)*pi*(ran2(idumy)-0.5d0) if(iirefl.eq.2) * r2 = pi-2.*asin((2.*ran2(idumy)-1)) if(iirefl.eq.3.or.iirefl.eq.4) then uni = ran2(idumy) IFAIL = 1 CALL C05ADF(-pi/2,pi/2,1.0d-5,0.0d0,CDF,XX,IFAIL) r2 = pi - 2.0d0*XX endif c for cos^3 distribution if(iirefl.eq.5) then uni = ran2(idumy) IFAIL = 1 CALL C05ADF(-1.0d0,1.0d0,1.0d-5,0.0d0,CDF,XX,IFAIL) r2 = pi - 2.0d0*asin(XX) endif end if c Bining the angle distribution: vmin = 0.0d0 vmax = 2.0d0 iunit = 87 if(jb.eq.1) arrayr2(icount) = (r2 + pi)/ pi if(jb.eq.1.and.ib.eq.nbstep) * call ebin2(arrayr2,icount,iunit,vmax,vmin) avar = 1.0d0 if(alimit.lt.0.0) then 888 avar1 = (2.0 * ran2(idumy) - 1.0) avar2 = (2.0 * ran2(idumy) - 1.0) avar = sqrt(avar1 * avar1 + avar2 * avar2) if(avar.gt.1.0d0) goto 888 x(icount) = avar1*xbound*sigmr y(icount) = avar2*ybound*sigmr z(icount) = (ran2(idumy)-0.5d0)*belen if(iwave.eq.2) then do 678 nw=1,6 ddw=sqrt((x(icount)-x0r(nw))**2+(y(icount)-y0r(nw))**2) if(ddw.lt.rbound6) goto 888 678 enddo endif else x(icount) = avar*xbound*cos(r2) y(icount) = avar*ybound*sin(r2) z(icount) = (ran2(idumy)-0.5d0)*belen endif c 23.july.1998; oliver. c !Achtung: testing the initial photoelectron distribution: c write(71,*) x(icount), y(icount) c Calculate the angle of the surface normal. c The angle is used for the angular distribution of the momentum vector. if (abs(y(icount)).le.zbound) then rnorm = 1.0d0/ * sqrt(x(icount)**2/xbound**4+y(icount)**2/ybound**4) rnx = rnorm * x(icount)/ xbound**2 rny = rnorm * y(icount)/ ybound**2 angle = atan2(rny,rnx) + pi endif if (y(icount).gt.zbound) then y(icount) = zbound angle = -pi/2.0d0 endif if (y(icount).lt.-zbound) then y(icount) = -zbound angle = pi/2.0d0 endif esign(icount) = y(icount) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c energy 5 eV +/- 5 eV c write(*,*) epemax, epesig c enhelp = ((rn(i+2*npepbx)-0.5d0)*epemax+epemax)*el*2.d0/3.d0/elmass c Oliver 31.07.1997: c Gaussian energy distribution for the photo electrons: c double Gaussian with weight determined by 'ratio' if (ran2(idum).gt.ratio) then 123 continue enhelp = (epesig*sqrt(-2*log(ran2(idumy)))* * cos(2*pi*ran2(idumy)) + epemax) * * 2*el/elmass if (enhelp.lt.0.0d0) goto 123 else 124 continue enhelp = (epesig2*sqrt(-2*log(ran2(idumy)))* * cos(2*pi*ran2(idumy)) + epemax2) * * 2*el/elmass if (enhelp.lt.0.0d0) goto 124 endif c Oliver 17. 6. 1997 ephoto = ephoto + enhelp*q(icount)*elmass/el/2 cccccccccccccccccccccccccccccc c Oliver 10.9.1997: introducing a new routine for calculating the impulse c distribution: c aplimit limits the opening angle of the momentum distribution. aplimit = 1.0d0 r2 = angle + aplimit * pi * (ran2(idumy)-0.5d0) r3 = 2.0d0 * pi * (ran2(idumy)-0.5d0) xp(icount) = sqrt(4.0d0/3.0d0)*sqrt(enhelp)*cos(r2)*abs(sin(r3)) yp(icount) = sqrt(4.0d0/3.0d0)*sqrt(enhelp)*sin(r2)*abs(sin(r3)) zp(icount) = sqrt(2.0d0/3.0d0)*sqrt(enhelp)*cos(r3) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' after generating new electrons ' c c frank, 01.08.1999 c branch for collisional ionization else if (icoll.eq.1) then xof = x1 yof = y1 if(iflag.eq.1) then xof=x2 yof=y2 else if(iflag.eq.2) then xof=x3 yof=y3 endif x(icount) = sx*sqrt(-2*log(ran2(idumy))) & *cos(2*pi*ran2(idumy)) + xof y(icount) = sy*sqrt(-2*log(ran2(idumy))) & *cos(2*pi*ran2(idumy)) + yof z(icount) = (ran2(idumy)-0.5)*belen xp(icount) = 1.d-10*(ran2(idumy)-0.5) yp(icount) = 1.d-10*(ran2(idumy)-0.5) zp(icount) = 1.d-10*(ran2(idumy)-0.5) endif c note: we assume initially zero momentum for the ionization e- c ------------------------------------------------------------- if (jb.eq.1) then test(icount) = * (xp(icount)**2+yp(icount)**2+zp(icount)**2)*elmass/2.0d0/el c write(*,*) "Test EP:",icount,test(icount) endif qacc = qacc + q(icount) qouter = qouter + q(icount) c (ts - start time) of particles c dti = dtex*rn1(i) dti = dtex*ran2(idumy) c write(*,*) "TIME:", dti/dtex if (icount.eq.1) then ti=1.e9*t c x(icount)=0.025 c y(icount)=0.025 c z(icount)=0. c xp(icount)=-2000. c yp(icount)=-2000. c zp(icount) = 0. c velt = sqrt(yp(icount)*yp(icount)+xp(icount)*xp(icount) c & +zp(icount)*zp(icount)) c gf=gammaf(velt) c velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) write(144,900) ti,x(icount),y(icount),z(icount),x(icount+1), & y(icount+1),z(icount+1) endif dpx = 0.0 dpy = 0.0 dpz = 0.0 xt = x(icount) yt = y(icount) zt = z(icount) xpt = xp(icount) ypt = yp(icount) zpt = zp(icount) c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = 1.0d0*gammaf(velt)*ypt pxt = 1.0d0*gammaf(velt)*xpt pzt = 1.0d0*gammaf(velt)*zpt c space charge if (ispace.eq.1) then radi = sqrt(xt*xt+yt*yt) do 14 j1 = 1, ngrid if (radi.lt.rad(j1)) then c 19.08.1997 Oliver: Changing the interpolation routine. c Frank: c ef = efield(j1-1)+(radi-rad(j1))/ c & (rad(j1)-rad(j1-1))*efield(j1) c Oliver: ef = efield(j1-1)+(radi-rad(j1-1))/ & (rad(j1)-rad(j1-1))*(efield(j1)-efield(j1-1)) goto 201 endif 14 continue 201 continue dpx = dpx + xt/radi*ef c*dti dpy = dpy + yt/radi*ef c*dti eespacex = xt/radi*ef eespacey = yt/radi*ef ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c 18.8.1997 Oliver: New spacecharge routine. if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xt/xbound) indy = nint(ngrid2*yt/ymbound) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1202 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dpx = dpx + sign(efx3,xt) c * dti dpy = dpy + sign(efy3,yt) c * dti eespacex = sign(efx3,xt) eespacey = sign(efy3,yt) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1202 continue endif c end space charge yt = yt xt = xt xta = abs(xt-xoff) yta = abs(yt-yoff) if (iscatter.eq.1) goto 1121 if (ibeam.eq.1.and.iwave.eq.0) then if(iimageb.ne.1) * call ffrank(xt,yt,xoff,yoff,sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xt,yt,xoff,yoff,sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep /dt * dntr(jb) * cfac c * dti/dt pre = pre * bweight(ib) * nbstep /dt * dntr(jb) * cfac c * dti/dt dpx = dpx - pim * factor * (xt-xoff)/xta dpy = dpy - pre * factor * (yt-yoff)/yta c+ el*volt/ elmass c * dti eebeamx = - pim * factor * (xt-xoff)/xta eebeamy = - pre * factor * (yt-yoff)/yta endif c Oliver 30.07.1997: Introducing the kick from a TEM wave: if (ibeam.eq.1.and.iwave.eq.1) then call tem(xt,yt,wk,t,wgl,pre,pim) dpx = dpx + el * (vtem * pim)/ elmass c * dti/ elmass dpy = dpy + el * (vtem * pre)/ elmass c * dti/ elmass c Voltage between inner and outer conducter. if(vtem0.ne.1.0d-5) then dpx = dpx - c dti * * el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2)/elmass dpy = dpy - c dti * * el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2)/elmass endif eebeamx = - el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2) * /elmass eebeamy = - el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2) * /elmass endif c Oliver 23.07.1998: Introducing the kick from a TEM wave: if (ibeam.eq.1.and.iwave.eq.2) then vtem06 = vtem0/vtem call tem6(xt,yt,wk,t,wgl,xbound,pre,pim,vtem06) dpx = dpx + el * (vtem * pim)/ elmass c * dti/ elmass dpy = dpy + el * (vtem * pre)/ elmass c * dti/ elmass c Voltage between inner and outer conducter. c if(vtem0.ne.1.0d-5) then c dpx = dpx - cc dti * c * el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2)/elmass c dpy = dpy - cc dti * c * el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2)/elmass c endif eebeamx = el * (vtem * pim)/ elmass eebeamy = el * (vtem * pre)/ elmass endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1121 continue c 11.8.1998 Oliver: New module for case without magnetic field. if(ibend.eq.0) then px(icount) = pxt + dpx*dti py(icount) = pyt + dpy*dti pz(icount) = pzt gamma = *1.0d0*sqrt(vl**2+px(icount)**2+py(icount)**2+pz(icount)**2)/vl xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma x(icount) = xt + (xp(icount)+xpt)/2.0d0 * dti y(icount) = yt + (yp(icount)+ypt)/2.0d0 * dti z(icount) = zt + (zp(icount)+zpt)/2.0d0 * dti endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 17.11.1998 X. Zhang: For case with field of horizontal bend magnet. if(ibend.eq.1) then px(icount) = pxt py(icount) = pyt + dpy*dti pz(icount) = pzt gamma = 1.0d0*sqrt(vl**2+px(icount)**2+ * py(icount)**2+pz(icount)**2)/vl c gamma = sqrt(1.0d0+(py(icount)/vl)**2) xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma x(icount) = xt y(icount) = yt + (yp(icount)+ypt)/2.0d0 * dti endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c May 2002 Frank: for combined function magnet with motion frozen c on field lines c if(ibend.eq.50) then bx = + bgradient*y(icount) by = bfield - bgradient*x(icount) bmod = sqrt(bx*bx+by*by) projx = (bx*dpx+by*dpy)*bx*dti/bmod**2 projy = (bx*dpx+by*dpy)*by*dti/bmod**2 px(icount) = pxt + projx py(icount) = pyt + projy c gamma = sqrt(1.0d0+(py(i)/vl)**2) gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(icount) = px(i)/gamma yp(icount) = py(i)/gamma zp(icount) = pz(i)/gamma x(icount) = xt + 0.5* & ((px(icount)+pxt)*bx+ & (py(icount)+pyt)*by)*bx/bmod**2*dti y(icount) = yt + 0.5* & ((px(icount)+pxt)*bx+ & (py(icount)+pyt)*by)*by/bmod**2*dti endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 2.6.1998: New module for particle motion in magnetic fields: if(ibend.eq.2) then call bmap(icount,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dti) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma x(icount) = xt y(icount) = yt z(icount) = zt px(icount) = pxt py(icount) = pyt pz(icount) = pzt endif if(ibend.eq.3) then call bmap(icount,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dti) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma x(icount) = xt y(icount) = yt z(icount) = zt px(icount) = pxt py(icount) = pyt pz(icount) = pzt endif c -------------------------------------------------------------- c frank 06/01/2000, explicit solution for solenoid field c if(ibend.eq.4) then px(icount) = pxt + dpx*dti py(icount) = pyt + dpy*dti pxt = px(icount) pyt = py(icount) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl c gamma = 1. xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma fomc = fom/gamma argu = fomc*dti if (argu.le.0.001) then cofomc = 1-argu*argu/2. sifomc = argu else cofomc = cos(argu) sifomc = sin(argu) endif x(icount) = xt + yp(icount)/fomc*(1.-cofomc)+ & xp(icount)/fomc* & sifomc y(icount) = yt + xp(icount)/fomc*(-1.+cofomc)+ & yp(icount)/fomc* & sifomc z(icount) = zt xpt = yp(icount)*sifomc+ & xp(icount)*cofomc ypt = -xp(icount)*sifomc+ & yp(icount)*cofomc xp(icount) = xpt yp(icount) = ypt velt = sqrt(ypt*ypt+xpt*xpt+zp(icount)*zp(icount)) gfac = gammaf(velt) c gfac = 1. py(icount) = 1.0d0*gfac*ypt px(icount) = 1.0d0*gfac*xpt pz(icount) = 1.0d0*gfac*zp(icount) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c frank new if (ibend.eq.5) then c write(*,*) ' in generate 3 ', fom, dti px(icount) = pxt + dpx*dti py(icount) = pyt + dpy*dti pxt = px(icount) pyt = py(icount) pzt = pz(icount) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl c gamma = 1. xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma xpt = xp(icount) ypt = yp(icount) zpt = zp(icount) fomc=fom/gamma cofom = cos(fomc*dti) sifom = sin(fomc*dti) a2 = 1.0d0 a3 = (1.0d0-cofom)/fomc a4 = sifom/fomc b2 = 1.0d0 b3 = sifom/fomc b4 = (cofom-1.0d0)/fomc c2 = sifom c3 = cofom d2 = cofom d3 = -sifom c deltax = dpx / dtex c deltay = dpy / dtex z(icount) = zt+a3*xpt+a4*zpt x(icount) = xt+b3*xpt+b4*zpt y(icount) = yt + dti*ypt zp(icount) = c2*xpt+c3*zpt xp(icount) = d2*xpt+d3*zpt yp(icount) = ypt velt = sqrt(yp(icount)*yp(icount)+xp(icount)* & xp(icount)+zp(icount)*zp(icount)) gfac = gammaf(velt) pyt = 1.0d0*gfac*yp(icount) pxt = 1.0d0*gfac*xp(icount) pzt = 1.0d0*gfac*zp(icount) gamma = sqrt(vl**2+px(icount)**2+py(icount)**2 & +pz(icount)**2)/vl xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma if (i.eq.1) then write(*,*) ' fomc = ',fomc write(*,*) ' cofim = ',cofim,sifim write(*,*) xpt,zpt endif c x(icount) = xt + (xp(icount)+xpt)/2.0d0 * dti c y(icount) = yt + (yp(icount)+ypt)/2.0d0 * dti endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c symmetric KEKB yoke if(ibend.eq.11.or.ibend.eq.13.or.ibend.eq.16) then call bmap(icount,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dti) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma x(icount) = xt y(icount) = yt z(icount) = zt px(icount) = pxt py(icount) = pyt pz(icount) = pzt endif c end bmap c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c asymmetric KEKB yoke if(ibend.eq.12.or.ibend.eq.14.or.ibend.eq.17) then call bmap(icount,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dti) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma x(icount) = xt y(icount) = yt z(icount) = zt px(icount) = pxt py(icount) = pyt pz(icount) = pzt endif c end bmap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c solenoid with z dependence, for KEKB if(ibend.eq.15.or.ibend.eq.18.or.ibend.eq.38.or. & ibend.ge.19.and.ibend.lt.40) then c c write(*,*) ' in generate B ', fom call bmap(icount,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dti) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(icount) = pxt/gamma yp(icount) = pyt/gamma zp(icount) = pzt/gamma x(icount) = xt y(icount) = yt z(icount) = zt px(icount) = pxt py(icount) = pyt pz(icount) = pzt endif c Giovanni: introduces a Runge-Kutta algorithm on line for the electrons c motion in a dipole field. if(ibend.eq.40) then cc11 = pxt*dti/gamma cc12 = (eebeamx + eespacex + el/elmass*pzt*bfield * /gamma)*dti cc13 = pyt*dti/gamma cc14 = (eebeamy+eespacey)*dti cc15 = pzt*dti/gamma cc16 = - el/elmass*pxt/gamma*bfield*dti c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1207 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1207 continue endif cc cc21 = (pxt+cc12/2)/gamman*dti cc22 = (eebeamx + eespacex + el/elmass*(pzt+ * cc16/2)/gamman*bfield)*dti cc23 = (pyt+cc14/2)/gamman*dti cc24 = (eebeamy + eespacey)*dti cc25 = (pzt+cc16/2)/gamman*dti cc26 = - el/elmass*(pxt+cc12/2)* * bfield/gamman*dti c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1208 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1208 continue endif cc cc31 = (pxt+cc22/2)/gamman*dti cc32 = (eebeamx + eespacex + el/elmass*(pzt * +cc26/2)/gamman*bfield)*dti cc33 = (pyt+cc24/2)/gamman*dti cc34 = (eebeamy + eespacey)*dti cc35 = (pzt+cc26/2)/gamman*dti cc36 = - el/elmass*(pxt+cc22/2)* * bfield/gamman*dti c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1209 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1209 continue endif cc41 = (pxt+cc32)/gamman*dti cc42 = (eebeamx + eespacex + el/elmass*(pzt * +cc36)/gamman*bfield)*dti cc43 = (pyt+cc34)/gamman*dti cc44 = (eebeamy + eespacey)*dti cc45 = (pzt+cc36)/gamman*dti cc46 = - el/elmass*(pxt+cc32)* * bfield/gamman*dti c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(icount) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(icount) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(icount) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(icount) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(icount) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(icount) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(icount)**2+py(icount)**2 * + pz(icount)**2)/vl xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma c ene(icount) = (gamma-1.0d0)*elmass*vl*vl endif c Giovanni: an "on line" Runge-Kutta for the solution of the electron c motion in a finite length solenoid field. if(ibend.eq.41) then frasol = 0.8 cc11 = pxt*dti/gamma cc12 = (eebeamx + eespacex - el/elmass*pyt*solenz * (frasol,xt,yt,zt)/gamma + el/elmass* * pzt*soleny(frasol,xt,yt,zt)/gamma)*dti cc13 = pyt*dti/gamma cc14 = (eebeamy + eespacey - el/elmass*pzt*solenx * (frasol,xt,yt,zt)/gamma + el/elmass* * pxt*solenz(frasol,xt,yt,zt)/gamma)*dti cc15 = pzt*dti/gamma cc16 = (- el/elmass*pxt*soleny(frasol,xt,yt,zt) * /gamma + el/elmass*pyt*solenx(frasol,xt,yt, * zt)/gamma)*dti c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 ztn = zt + cc15/2 pxtn = pxt + cc12/2 pytn = pyt + cc14/2 pztn = pzt + cc16/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1240 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1240 continue endif cc21 = pxtn/gamman*dti cc22 = (eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dti cc23 = pytn/gamman*dti cc24 = (eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dti cc25 = pztn/gamman*dti cc26 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass * pytn*solenx(frasol,xtn, * ytn,ztn)/gamman)*dti c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 ztn = zt + cc25/2 pxtn = pxt + cc22/2 pytn = pyt + cc24/2 pztn = pzt + cc26/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1241 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1241 continue endif cc31 = pxtn/gamman*dti cc32 = (eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dti cc33 = pytn/gamman*dti cc34 = (eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dti cc35 = pztn/gamman*dti cc36 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dti c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 ztn = zt + cc35 pxtn = pxt + cc32 pytn = pyt + cc34 pztn = pzt + cc36 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) pim = pim * bweight(ib) * nbstep/dt * dntr(jb)*cfac pre = pre * bweight(ib) * nbstep/dt * dntr(jb)*cfac eebeamx = pim * factor * * (xtn-xoff)/xta eebeamy = pre * factor * * (ytn-yoff)/yta endif if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1242 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1242 continue endif cc41 = pxtn/gamman*dti cc42 = (eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dti cc43 = pytn/gamman*dti cc44 = (eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dti cc45 = pztn/gamman*dti cc46 = (- el/elmass*pxtn*soleny(frasol,xt,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dti c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(icount) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(icount) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(icount) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(icount) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(icount) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(icount) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(icount)**2+py(icount)**2 * + pz(icount)**2)/vl xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl c write(*,*) ionene(iio) endif c end bmap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c Oliver 17.6.1997 (calculate energy and storing it in an array): iadele = iadele + 1 c Oliver: 12.7.1998 (gamma is already defined above!) c vel2 = (xp(icount)*xp(icount)+yp(icount)*yp(icount) c * +zp(icount)*zp(icount)) c beta2 = vel2/vl/vl c gamma = 1.0d0/sqrt(1.0d0-beta2) dele(iadele) = (gamma-1.0d0)*elmass*vl*vl qele(iadele) = q(icount) if (ib.eq.nbstep) then adele = adele + qele(iadele)*(gamma-1.0d0)*elmass*vl*vl qadele = qadele + qele(iadele) endif cccccccccccccccccccccccccccccccccccccccccccccccccc c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(icount)/xbound)**2+(y(icount)/ybound)**2 if (y(icount).gt.zbound) amp = 2.0d0 if (y(icount).lt.-zbound) amp = 2.0d0 if (iwave.eq.1) then amp2 = (x(icount)**2+y(icount)**2)/ rbound**2 else if (iwave.eq.2) then call dist(amp2, x(icount), y(icount), kw) endif if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif if (amp.gt.1.and.iloss.eq.1) then ptime(icount) = t - ptime(icount) if (ptime(icount).gt.0.0.and.dele(iadele)/el.gt.ecut) then write(24,*) x(icount),ptime(icount)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).ge.0.0) c * write(27,*) x(i), ptime(i)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).lt.0.0) c * write(28,*) x(i), ptime(i)*1.0d9,dele(iadele)/el endif ptime(icount) = t esign(icount) = y(icount) xt = x(icount) yt = y(icount) xpt = xp(icount) ypt = yp(icount) zt = z(icount) zpt = zp(icount) qt = q(icount) engt=dele(iadele)/el qlosswh = qlosswh + qt/dtex if (engt.ge.1.0d0) then qlosstot = qlosstot + qt if (engt.ge.20.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt call ebinw(webin,engt,qt) if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) if (iazi.eq.1) then call ebinwphi(webinphi,webinph2,engt,qt,xt,yt) call ebinwx(webinx,webinx2,webinx3,engt,qt,xt,yt) endif endif qacc = qacc - qt qouter = qouter - qt icold = icount call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(icold) = xpt yp(icold) = ypt zp(icold) = zpt x(icold) = xt y(icold) = yt z(icold) = zt q(icold) = qt qacc = qacc + qt qouter = qouter + qtnew c qlosswh = qlosswh - qtnew/dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.ne.0) then ptime(icount) = t - ptime(icount) if (ptime(icount).gt.0.0.and.dele(iadele)/el.gt.ecut) * write(25,*) x(icount),ptime(icount)*1.0d9,dele(iadele)/el ptime(icount) = t esign(icount) = y(icount) xt = x(icount) yt = y(icount) xpt = xp(icount) ypt = yp(icount) zt = z(icount) zpt = zp(icount) qt = q(icount) qacc = qacc - qt qinner = qinner - qt icold = icount c write(*,*) ' seiler again =' call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,2,kw) xp(icold) = xpt yp(icold) = ypt zp(icold) = zpt x(icold) = xt y(icold) = yt z(icold) = zt q(icold) = qt qacc = qacc + qt qinner = qinner + qtnew endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 23.06.1997 Oliver: Writing the electron distribution to a file. if (jb.eq.jebin.and.ib.eq.iebin.and.q(icount).gt.0.0) then write(44,9444) x(icount), y(icount), q(icount), z(icount) write(4444,9444) xp(icount), yp(icount), q(icount), zp(icount) endif 13 continue endif qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') > jb,ib,t,icount,qacc,qdens c x(1),y(1),q(1) c write(21,'(i3,i3,e25.5,i8,2e25.5)') j,0,t,icount,qacc c Bin the energy distribution and write the result to an external file: if (jb.eq.jebin.and.ib.eq.iebin) then c close(24) c close(26) close(29) write(*,*) "jebin = ",jebin, "iebin = ",iebin call ebin endif c write(88,'(2e25.5)') t, elossq write(188,'(4e13.5)') t, qlosswh, qlosstot, qlosstot2 10 continue c write(*,*) ' after 10 continue =' iunit = 66 vmax = 100.0d0 vmin = 0.0d0 if (jb.eq.1) call ebin2(test,icount,iunit,vmax,vmin) iunit = 67 if (jb.eq.5) call ebin2(test,itest,iunit,vmax,vmin) write(*,*) ' exit subroutine generate ' end REAL*8 FUNCTION CDF(XX) COMMON / caso / uni COMMON / def2 / bfield, el, vl, fom, pi, re, elmass COMMON / swrefl / iirefl c .. Scalar Arguments .. REAL*8 XX, uni REAL*8 bfield, el, vl, fom, pi, re, elmass INTEGER iirefl c .. Executable Statements .. c to get a cos^2 angular distribution for the reflected light. if(iirefl.eq.3) * CDF = 2*XX + sin(2*XX) + pi*(1 - 2*uni) c to get a parabolic smooth angular distribution for the c reflected light. if(iirefl.eq.4) * CDF = 15/(8*pi)*XX-5./(pi**3)*(XX**3)+6./(pi**5)*(XX**5) * + 0.5-uni c to get a cos^3 angular distribution for the reflected light. if(iirefl.eq.5) * CDF = XX**3 - 3*XX + 2*(2*uni - 1) c uncomment the following line and comment out the active CDF RETURN END REAL*8 FUNCTION solenx(frac,posx,posy,posz) COMMON / def1 / rbound, xbound, ybound, zbound, energy, belen COMMON / def2 / bfield, el, vl, fom, pi, re, elmass INTEGER is REAL*8 posx, posy, posz, parz, onda, wind, rad, frac, IFAIL REAL*8 bfield, el, vl, fom, pi, re, elmass REAL*8 rbound, xbound, ybound, zbound, energy, belen REAL*8 S18ADF REAL*8 S18AFF external S18ADF external S18AFF parz = 0.0 onda = 2*pi/belen wind = dmax1(xbound,ybound) rad = sqrt(posx**2 + posy**2) do 137 is = 1, 100 parz = parz + 4/belen*wind*sin(is*onda*frac*belen/2)* * S18ADF(is*onda*wind,IFAIL)*S18AFF(is*onda*rad,IFAIL)* * sin(is*onda*posz) 137 continue solenx = parz*bfield*posx/rad RETURN END REAL*8 FUNCTION soleny(frac,posx,posy,posz) COMMON / def1 / rbound, xbound, ybound, zbound, energy, belen COMMON / def2 / bfield, el, vl, fom, pi, re, elmass INTEGER is REAL*8 posx, posy, posz, parz, onda, wind, rad, frac, IFAIL REAL*8 bfield, el, vl, fom, pi, re, elmass REAL*8 rbound, xbound, ybound, zbound, energy, belen REAL*8 S18ADF REAL*8 S18AFF external S18ADF external S18AFF parz = 0.0 onda = 2*pi/belen wind = dmax1(xbound,ybound) rad = sqrt(posx**2 + posy**2) do 138 is = 1, 100 parz = parz + 4/belen*wind*sin(is*onda*frac*belen/2)* * S18ADF(is*onda*wind,IFAIL)*S18AFF(is*onda*rad,IFAIL)* * sin(is*onda*posz) 138 continue soleny = parz*bfield*posy/rad RETURN END REAL*8 FUNCTION solenz(frac,posx,posy,posz) COMMON / def1 / rbound, xbound, ybound, zbound, energy, belen COMMON / def2 / bfield, el, vl, fom, pi, re, elmass INTEGER is REAL*8 posx, posy, posz, parz, onda, wind, rad, frac, IFAIL REAL*8 bfield, el, vl, fom, pi, re, elmass REAL*8 rbound, xbound, ybound, zbound, energy, belen REAL*8 S18ADF REAL*8 S18AEF external S18ADF external S18AEF parz = frac onda = 2*pi/belen wind = dmax1(xbound,ybound) rad = sqrt(posx**2 + posy**2) do 139 is = 1, 100 parz = parz + 4/belen*wind*sin(is*onda*frac*belen/2)* * S18ADF(is*onda*wind,IFAIL)*S18AEF(is*onda*rad,IFAIL)* * cos(is*onda*posz) 139 continue solenz = parz*bfield RETURN END subroutine interbunch(iflag) c purpose: propagates through interbunch gap c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,iybin=500) c parameter (nistep = 20) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,ngrid2=10) integer iycount(0:iybin) integer kw, iflag real*8 ayield(0:iybin), avcos(0:iybin) real*8 boundix(40), boundiy(40), boundox(80), boundoy(80) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm),yp(npelm),zp(npelm),py(npelm),pz(npelm) real*8 px(npelm), dele(npelm), qele(npelm), dele2(npelm) real*8 xpt, ypt, zpt, pxt, pyt, pzt real*8 ptime(npelm), esign(npelm) integer index(npelm) integer iazi real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 eloss, elossq, ephoto, adele, qadele, alimit real*8 epesig, epemax, ecut real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, sbt, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 dt real*8 radi real*8 xt, yt, zt real*8 volt, qouter, qinner real*8 dpx, dpy, dpz, dpxm, dpym, dpzm real*8 qlosswh, qlosstot, qlosstot2 real*8 denscenter real*8 eespacex, eespacey, eebeamx, eebeamy, gamman real*8 xtn,ytn,xta,yta,frasol real*8 c11,c12,c13,c14,c15,c16,c21,c22,c23,c24,c25,c26 real*8 c31,c32,c33,c34,c35,c36,c41,c42,c43,c44,c45,c46 real*8 bgradient c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / loss / eloss, elossq, ephoto, adele, qadele common / loss2 / qlosswh, qlosstot, qlosstot2 common / part / qacc common / part2 / icount, icountact, iadele common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c Oliver 18.06.1997 common / egain / dele, qele ccccccccccccccccccccccccccccc c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / eini / epemax,ecut common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig common / movie / boundix, boundiy, boundox, boundoy ccccccccccccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos common / image / iimage, iimageb, interspace, igeom ccccccccccccccccccccccccccccccccccccccc common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2,webinx3 c frank, nov 99, for azimuth common / azi / iazi common / center / denscenter external solenx,soleny,solenz if(interspace.ne.0) ismod = nistep/interspace if(interspace.eq.0) ismod = nistep + 1 sbt = sb if(iflag.eq.1) sbt = sb1 if(iflag.eq.2) sbt = sb2 if(iflag.eq.4) sbt = bl do 10 ib = 1, nistep qlosswh = 0. if(mod(ib,ismod).eq.0) then if(ispace.eq.2) call spacecharge2 c if(ispace.eq.2) then c write(*,*) "Calculating E-field:" c do 123 it=0,ngrid2 c do 124 jt =0,ngrid2 c if(efxa(it,jt).ne.0.0) c * write(*,*) it,jt,efxa(it,jt) c 124 continue c 123 continue c endif if(ispace.eq.1) call spacecharge(0) endif dt = sbt/vl/real(nistep) t = t + dt c c write(*,*) ' heureka!' c write(*,*) dt, sbt, iflag c elossq = 0.0d0 if (icount.gt.0) then if (ibend.eq.5) then a1 = (dt-1.0d0/fom*sin(fom*dt))/fom a2 = 1.0d0 a3 = (1.0d0-cos(fom*dt))/fom a4 = sin(fom*dt)/fom b1 = (1.0d0-cos(fom*dt))/fom**2 b2 = 1.0d0 b3 = sin(fom*dt)/fom b4 = (cos(fom*dt)-1.0d0)/fom c1 = (1.0d0-cos(fom*dt))/fom c2 = sin(fom*dt) c3 = cos(fom*dt) d1 = sin(fom*dt)/fom d2 = cos(fom*dt) d3 = -sin(fom*dt) endif endif if (icount.gt.0) then iadele2 = 0 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 24.06.1997 Oliver: Writing the particle positions to a file for a movie: c if (imovie.eq.1.and.mod(ib,iseq).eq.0) then c do 213 id=1,80 c write(45,*) boundox(id), boundoy(id) c 213 continue c write(45,*) " " c write(45,*) " " c if (ib.ne.1) c write(46,*) c * "plot 'edistr.movie.data' index ",mcount," with points 3" c if (ib.eq.1) write(46,*) c * "plot 'edistr.movie.data' index ",mcount," with points 1" c mcount = mcount + 1 c write(46,*) "pause 0.3" c endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do 11 i = 1, icount if(i.eq.1) then ihelp = index(i) qhelp = q(i) c write(*,*) ' ihelp = ',ihelp, qhelp endif if (index(i).eq.0.and.(q(i).gt.0)) then ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 24.06.1997 Oliver: Writing the particle positions to a file for a movie: if (imovie.eq.1.and.mod(ib,iseq).eq.0.and.q(i).gt.0.0d0.and. * abs(x(i)).lt.xbound.and.abs(y(i)).lt.ybound) * write(45,*) x(i), y(i) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 3.8.1997 (calculate energy and storing it in an array): iadele2 = iadele2 + 1 c Oliver: 12.8.1998 New definition for Gamma: c vel2 = (xp(i)*xp(i)+yp(i)*yp(i)+zp(i)*zp(i)) c beta2 = vel2/vl/vl c gamma = 1.0001d0/sqrt(1.0d0-beta2) c gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c c dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dpx = 0.0 dpy = 0.0 dpz = 0.0 xt = x(i) yt = y(i) zt = z(i) xpt = xp(i) ypt = yp(i) zpt = zp(i) c Oliver 12.8.1998: c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = 1.0d0*gammaf(velt)*ypt pxt = 1.0d0*gammaf(velt)*xpt pzt = 1.0d0*gammaf(velt)*zpt c frank 12/11/99 c recalculate gamma after updating px, py etc... gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl if (i.eq.1) then ti=1.e9*t write(144,900) ti,x(i),y(i),z(i),x(i+1), & y(i+1),z(i+1) 900 format(7(1x,e12.5)) endif c space charge if (ispace.eq.1) then radi = sqrt(xt*xt+yt*yt) do 12 j1 = 1, ngrid if (radi.lt.rad(j1)) then c 19.08.1997 Oliver: Changing the interpolation routine. c Frank: c ef = efield(j1-1)+(radi-rad(j1))/ c & (rad(j1)-rad(j1-1))*efield(j1) c Oliver: ef = efield(j1-1)+(radi-rad(j1-1))/ & (rad(j1)-rad(j1-1))*(efield(j1)-efield(j1-1)) goto 200 endif 12 continue 200 continue dpx = dpx + xt/radi*ef c*dt dpy = dpy + yt/radi*ef c*dt eespacex = xt/radi*ef eespacey = yt/radi*ef ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c 18.8.1997 Oliver: New spacecharge routine. if (ispace.eq.2.and. * abs(xt).lt.xbound.and.abs(yt).lt.ybound) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xt/xbound) indy = nint(ngrid2*yt/ymbound) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1201 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dpx = dpx + sign(efx3,xt) c*dt dpy = dpy + sign(efy3,yt) c*dt 1201 continue eespacex = sign(efx3,xt) eespacey = sign(efy3,yt) endif c end space charge c Oliver 31.07.1997: introducing the force of an additional c voltage across the vacuum chamber. c deltay = el*volt/ elmass c write(*,*) "space=",ispace,xp(i),yp(i) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 11.8.1998 Oliver: New module for case without magnetic field. if(ibend.eq.0) then px(i) = pxt + dpx*dt py(i) = pyt + dpy*dt pz(i) = pzt gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + (xp(i)+xpt)/2.0d0 * dt y(i) = yt + (yp(i)+ypt)/2.0d0 * dt z(i) = zt + (zp(i)+zpt)/2.0d0 * dt endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 17.11.1998 X. Zhang: For case with field of horizontal bend magnet. if(ibend.eq.1) then px(i) = pxt py(i) = pyt + dpy*dt pz(i) = pzt gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c gamma = sqrt(1.0d0+(py(i)/vl)**2) xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt y(i) = yt + (yp(i)+ypt)/2.0d0 * dt endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c May 2002 Frank: for combined function magnet with motion frozen c on field lines c if(ibend.eq.50) then bx = + bgradient*y(i) by = bfield - bgradient*x(i) bmod = sqrt(bx*bx+by*by) projx = (bx*dpx+by*dpy)*bx*dt/bmod**2 projy = (bx*dpx+by*dpy)*by*dt/bmod**2 px(i) = pxt + projx py(i) = pyt + projy c gamma = sqrt(1.0d0+(py(i)/vl)**2) gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + 0.5* & ((px(i)+pxt)*bx+(py(i)+pyt)*by)*bx/bmod**2*dt y(i) = yt + 0.5* & ((px(i)+pxt)*bx+(py(i)+pyt)*by)*by/bmod**2*dt endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 2.6.1998: New module for particle motion in magnetic fields: if(ibend.eq.2) then call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dt) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif if(ibend.eq.3) then call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dt) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c -------------------------------------------------------------- c frank 06/01/2000, explicit solution for solenoid field c if(ibend.eq.4) then px(i) = pxt + dpx*dt py(i) = pyt + dpy*dt pxt = px(i) pyt = py(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma fomc = fom/gamma argu = fomc*dt if (argu.le.0.001) then cofomc = 1-argu*argu/2. sifomc = argu else cofomc = cos(argu) sifomc = sin(argu) endif c c if (i.eq.1) then c write(*,*) ' fomc = ',fomc c write(*,*) ' dt = ', dt c write(*,*) ' dpx,dpy = ', dpx,dpy c write(*,*) ' gamma = ',gamma c write(*,*) ' pxt,...= ',pxt,pyt,pzt c write(*,*) ' xp,...= ',xp(i),yp(i),xpt,ypt c write(*,*) ' si,...= ',sifomc,cofomc c write(*,*) ' start = ',xp(i),yp(i) c endif c x(i) = xt + yp(i)/fomc*(1.-cofomc)+xp(i)/fomc* & sifomc y(i) = yt + xp(i)/fomc*(-1.+cofomc)+yp(i)/fomc* & sifomc z(i) = zt xpt = yp(i)*sifomc+xp(i)*cofomc ypt = -xp(i)*sifomc+yp(i)*cofomc xp(i) = xpt yp(i) = ypt velt = sqrt(ypt*ypt+xpt*xpt+zp(i)*zp(i)) gfac = gammaf(velt) py(i) = 1.0d0*gfac*ypt px(i) = 1.0d0*gfac*xpt pz(i) = 1.0d0*gfac*zp(i) c if (i.eq.1) then c write(*,*) ' gfac = ',gfac c write(*,*) ' end = ',xp(i),yp(i),sifomc,cofomc c endif endif c end bmap ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c frank 06/01/2000, explicit solution for weak bending magnet c if (ibend.eq.5) then pxt = px(i) + dpx*dt pyt = py(i) + dpy*dt pzt = pz(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma fomc = fom/gamma cofim = cos(fomc*dt) sifim = sin(fomc*dt) zt = z(i) + sifim/fomc*zp(i)+(1.-cofim)/fomc*xp(i) xt = x(i) + (cofim-1.)/fomc*zp(i)+sifim/fomc*xp(i) yt = y(i) + yp(i) * dt x(i) = xt y(i) = yt z(i) = zt zpt = sifim*xp(i)+cofim*zp(i) xpt = cofim*xp(i)-sifim*zp(i) ypt = yp(i) xp(i) = xpt zp(i) = zpt c if (i.eq.184) then c write(*,*) ' fomc = ',fomc,gamma c write(*,*) ' cofim = ',cofim,sifim c write(*,*) xpt,ypt,zpt,xt,yt,zt c endif velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) c if (i.eq.184) then c write(*,*) ' velt = ',velt c endif gfac = gammaf(velt) c if (i.eq.184) then c write(*,*) ' gfac = ',gfac c endif c pyt = 1.0d0*gfac*yp(i) c pxt = 1.0d0*gfac*xp(i) c pzt = 1.0d0*gfac*zp(i) py(i) = 1.0d0*gfac*ypt px(i) = 1.0d0*gfac*xpt pz(i) = 1.0d0*gfac*zpt c gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c xp(i) = px(i)/gamma c yp(i) = py(i)/gamma c zp(i) = pz(i)/gamma c x(i) = xt + (xp(i)+xpt)/2.0d0 * dtex endif c end bmap c z(i) = a2*zt+a3*xpt+a4*zpt c x(i) = b2*xt+b3*xpt+b4*zpt c y(i) = yt + dt*ypt c zp(i) = c2*xpt+c3*zpt c xp(i) = d2*xpt+d3*zpt c velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) c gfac = gammaf(velt) c pyt = 1.0d0*gfac*yp(i) c pxt = 1.0d0*gfac*xp(i) c pzt = 1.0d0*gfac*zp(i) c px(i) = pxt + dpx*dt c py(i) = pyt + dpy*dt c pz(i) = pzt c gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c xp(i) = px(i)/gamma c yp(i) = py(i)/gamma c zp(i) = pz(i)/gamma c x(i) = xt + (xp(i)+xpt)/2.0d0 * dt c y(i) = yt + (yp(i)+ypt)/2.0d0 * dt c endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c symmetric KEKB yoke if(ibend.eq.11.or.ibend.eq.13.or.ibend.eq.16) then call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dt) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c end bmap c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c asymmetric KEKB yoke if(ibend.eq.12.or.ibend.eq.14.or.ibend.eq.17) then call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dt) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c end bmap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c solenoid with z dependence, for KEKB if(ibend.eq.15.or.ibend.eq.18.or. & ibend.eq.38.or.ibend.ge.19.and.ibend.lt.40) then c c write(*,*) ' in generate C ', fom call bmap(i,ibend,xt,yt,zt,pxt,pyt,pzt,dpx,dpy,dpz,dt) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xp(i) = pxt/gamma yp(i) = pyt/gamma zp(i) = pzt/gamma x(i) = xt y(i) = yt z(i) = zt px(i) = pxt py(i) = pyt pz(i) = pzt endif c Giovanni: an "on line" Runge-Kutta algorithm to solve the electron c motion in a dipole field. if(ibend.eq.40) then cc11 = pxt*dt/gamma cc12 = (eespacex + el/elmass*pzt*bfield * /gamma)*dt cc13 = pyt*dt/gamma cc14 = (eespacey)*dt cc15 = pzt*dt/gamma cc16 = - el/elmass*pxt/gamma*bfield*dt c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1213 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1213 continue endif cc cc21 = (pxt+cc12/2)/gamman*dt cc22 = (eespacex + el/elmass*(pzt+ * cc16/2)/gamman*bfield)*dt cc23 = (pyt+cc14/2)/gamman*dt cc24 = eespacey*dt cc25 = (pzt+cc16/2)/gamman*dt cc26 = - el/elmass*(pxt+cc12/2)* * bfield/gamman*dt c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1214 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1214 continue endif cc cc31 = (pxt+cc22/2)/gamman*dt cc32 = (eespacex + el/elmass*(pzt * +cc26/2)/gamman*bfield)*dt cc33 = (pyt+cc24/2)/gamman*dt cc34 = eespacey*dt cc35 = (pzt+cc26/2)/gamman*dt cc36 = - el/elmass*(pxt+cc22/2)* * bfield/gamman*dt c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1215 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1215 continue endif cc41 = (pxt+cc32)/gamman*dt cc42 = (eespacex + el/elmass*(pzt * +cc36)/gamman*bfield)*dt cc43 = (pyt+cc34)/gamman*dt cc44 = eespacey*dt cc45 = (pzt+cc36)/gamman*dt cc46 = - el/elmass*(pxt+cc32)* * bfield/gamman*dt c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl endif c Giovanni: an "on line" Runge-Kutta for the solution of the electron c motion in a finite length solenoid field. if(ibend.eq.41) then frasol = 0.8 cc11 = pxt*dt/gamma cc12 = (eespacex - el/elmass*pyt*solenz * (frasol,xt,yt,zt)/gamma + el/elmass* * pzt*soleny(frasol,xt,yt,zt)/gamma)*dt cc13 = pyt*dt/gamma cc14 = (eespacey - el/elmass*pzt*solenx * (frasol,xt,yt,zt)/gamma + el/elmass* * pxt*solenz(frasol,xt,yt,zt)/gamma)*dt cc15 = pzt*dt/gamma cc16 = (- el/elmass*pxt*soleny(frasol,xt,yt,zt) * /gamma + el/elmass*pyt*solenx(frasol,xt,yt, * zt)/gamma)*dt c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 ztn = zt + cc15/2 pxtn = pxt + cc12/2 pytn = pyt + cc14/2 pztn = pzt + cc16/2 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1230 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1230 continue endif cc21 = pxtn/gamman*dt cc22 = (eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dt cc23 = pytn/gamman*dt cc24 = (eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dt cc25 = pztn/gamman*dt cc26 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass * pytn*solenx(frasol,xtn, * ytn,ztn)/gamman)*dt c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 ztn = zt + cc25/2 pxtn = pxt + cc22/2 pytn = pyt + cc24/2 pztn = pzt + cc26/2 cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1231 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1231 continue endif cc31 = pxtn/gamman*dt cc32 = (eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dt cc33 = pytn/gamman*dt cc34 = (eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dt cc35 = pztn/gamman*dt cc36 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dt c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 ztn = zt + cc35 pxtn = pxt + cc32 pytn = pyt + cc34 pztn = pzt + cc36 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1232 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1232 continue endif cc41 = pxtn/gamman*dt cc42 = (eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dt cc43 = pytn/gamman*dt cc44 = (eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dt cc45 = pztn/gamman*dt cc46 = (- el/elmass*pxtn*soleny(frasol,xt,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dt c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl c write(*,*) ionene(iio) endif c end bmap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(i)/xbound)**2+(y(i)/ybound)**2 if (y(i).gt.zbound) amp = 2.0 if (y(i).lt.-zbound) amp = 2.0 if (iwave.eq.1) then amp2 = (x(i)**2+y(i)**2)/ rbound**2 else if (iwave.eq.2) then call dist(amp2, x(i), y(i), kw) endif if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif c Oliver 3.8.1997: writing the time of flight to a file. if (amp.gt.1.and.iloss.eq.1) then ptime(i) = t - ptime(i) if (ptime(i).gt.0.0.and.dele2(iadele2)/el.gt.ecut) then write(24,*) x(i), ptime(i)*1.0d9,dele2(iadele2)/el c if (esign(i)*y(i).ge.0.0) c * write(27,*) x(i), ptime(i)*1.0d9,dele2(iadele2)/el c if (esign(i)*y(i).lt.0.0) c * write(28,*) x(i), ptime(i)*1.0d9,dele2(iadele2)/el endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if (amp.gt.1.and.iloss.eq.1) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) engt=dele2(iadele2)/el qlosswh = qlosswh + qt/dt if (engt.ge.1.0d0) then qlosstot = qlosstot + qt if (engt.ge.20.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt call ebinw(webin,engt,qt) if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) if (iazi.eq.1) then call ebinwphi(webinphi,webinph2,engt,qt,xt,yt) call ebinwx(webinx,webinx2,webinx3,engt,qt,xt,yt) endif endif qacc = qacc - qt qouter = qouter - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qouter = qouter + qtnew c qlosswh = qlosswh - qtnew/dt c frank 12/11/99 c recalculate gamma after updating px, py etc... velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) pyt = 1.0d0*gammaf(velt)*yp(i) pxt = 1.0d0*gammaf(velt)*xp(i) pzt = 1.0d0*gammaf(velt)*zp(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.ne.0) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qinner = qinner - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,2,kw) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qinner = qinner + qtnew c frank 12/11/99 c recalculate gamma after updating px, py etc... velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) pyt = 1.0d0*gammaf(velt)*yp(i) pxt = 1.0d0*gammaf(velt)*xp(i) pzt = 1.0d0*gammaf(velt)*zp(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 18.06.1997: setting the energy increase to zero for lost particles. if (q(i).eq.0.0) dele(i) = 0.0 if (q(i).eq.0.0) qele(i) = 0.0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif 11 continue endif if (imovie.eq.1.and.mod(ib,iseq).eq.0) then do 213 id=1,80 write(45,*) boundox(id), boundoy(id) 213 continue write(45,*) " " write(45,*) " " write(46,*) * "plot 'edistr.movie.data' index ",mcount," with points 3" if (ib.eq.1) write(46,*) * "plot 'edistr.movie.data' index ",mcount," with points 1" mcount = mcount + 1 write(46,*) "pause 0.3" endif c write(21,*) 0,0,t,icount,qacc,x(1),y(1),q(1) qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter c write(88,'(2e25.5)') t, elossq write(188,'(4e13.5)') t, qlosswh, qlosstot, qlosstot2 10 continue end subroutine spacecharge (ix) c purpose: calculate average self-field of electrons (simplified) c c for now assume radially symmetric el-distribution c (almost certainly wrong in bends and also for PEP-II) c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,ngrid2=10) c npelm - total maximum number of macroparticles (> product) real*8 x(npelm),y(npelm),z(npelm),q(npelm),t real*8 px(npelm), pz(npelm),py(npelm) real*8 ptime(npelm), esign(npelm) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 volt, qouter, qinner real*8 qacc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 bfield, el, vl, fom, pi, re, elmass common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c grid parameters radstep = xbound/real(ngrid) rad(0) = 0.d0 do 10 j = 1, ngrid crg(j) = 0.0d0 rad(j) = real(j) * radstep 10 continue do 11 i = 1, icount radius = sqrt(x(i)*x(i)+y(i)*y(i)) c write(*,*) ' succ 1 ',i,radius,rad(ngrid),x(i),y(i) do 12 j = ngrid, 1, -1 if (radius.lt.rad(j)) then crg(j) = crg(j) + q(i) cc write(*,*) ' success ',crg(j),q(i),j, i,x(i),y(i) else goto 95 endif 12 continue 95 continue 11 continue mec2 = 511000. coef = 2.d0*re*vl*vl/belen open(22,file="space.dat",status='unknown') write(22,*) "Icount = ",icount efield(0) = 0.d0 do 210 i = 1, ngrid efield(i) = coef * crg(i) / rad(i) c set efield = 0 for no space charge c EFIELD(i) = 0.d0 if (ix.eq.1) then write(22,*) rad(i),efield(i),crg(i),coef,qacc,icount endif 210 continue close(22) end subroutine spacecharge2old c purpose: New space charge routine that uses a two dimensional Mesh c for the field calculation and allows the evaluation of the c effect of image charges on the boundary. c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,ngrid2=10,nimage=50,nimage2=4) parameter(eta=8.8542d-12) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) real*8 rolimit, rilimit parameter(rolimit=0.97d0,rilimit=1.02d0) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 px(npelm), pz(npelm), py(npelm) real*8 ptime(npelm), esign(npelm) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) real*8 r1x(0:nimage2),r1y(0:nimage2),r2x(0:nimage2),r2y(0:nimage2) real*8 rg, rm1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 voltx, volty real*8 rmax, rmin real*8 rm0 real*8 rphi, rphi0, rphi1, rphi2, rphi3 real*8 xl, yl c Complex variables for the calculation of the elliptical coordinates: complex*16 z1, z2, z3, z4, zi, zone complex*16 efz1(-ngrid2:ngrid2,-ngrid2:ngrid2) complex*16 zeric,zdiv,zr,zri,zzr,zzri common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / image / iimage, iimageb, interspace, igeom common / beam / rg, rm1 common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc charge = 1.0d0 coef = 2.0d0*re*vl*vl/belen ymbound = min(ybound,zbound) rmax = max(xbound,ymbound) rmin = min(xbound,ymbound) zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) if(igeom.eq.2) then rg = sqrt(rmax**2 - rmin**2) rm1 = log((rmax+rmin)/(rmax-rmin))/2.0d0 endif c testx = rg*(exp(rm1)+exp(-rm1))/2.0d0 c testy = rg*(exp(rm1)-exp(-rm1))/2.0d0 c write(*,*) "Test1: ",testx, testy c Distributing the charge on the grid: do 103 i=1,icount c c frank: i do not understand the abs( ) - correct for quads? linx = nint(ngrid2*x(i)/xbound) liny = nint(ngrid2*y(i)/ymbound) c Avoiding charges which are outside the boundary for the c image charge calculation: rl1 = (dble(linx)/dble(ngrid2))**2+(dble(liny)/dble(ngrid2))**2 c if(rl1.gt.rolimit.and.iimage.eq.1) then if(rl1.gt.rolimit) then c write(*,*) "Changing the mesh position 1 from: ",linx,liny 331 rl2 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 rl3 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 rl4 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 if(rl2.gt.rolimit) rl2 = 0.0 if(rl3.gt.rolimit) rl3 = 0.0 if(rl4.gt.rolimit) rl4 = 0.0 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).gt.0) * linx = linx - 1 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).lt.0) * linx = linx + 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).gt.0) * liny = liny - 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).lt.0) * liny = liny + 1 if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx - 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx - 1 liny = liny + 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx + 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx + 1 liny = liny + 1 endif c if(linx.lt.0) linx = 0 c if(liny.lt.0) liny = 0 rl1 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 if(rl1.gt.rolimit) goto 331 c write(*,*) " to : ",linx,liny endif c Avoiding charges which are inside the inner conductor for the c image charge calculation with a wave guide geometry: rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit.and.igeom.eq.3.and.iimage.eq.1) then c write(*,*) "Changing the mesh position 2 from: ",linx,liny 332 if(linx.le.nint(ngrid2*rbound/xbound)) linx = linx + 1 if(liny.le.nint(ngrid2*rbound/ymbound)) liny = liny + 1 if(linx.gt.ngrid2) linx = ngrid2 - 1 if(liny.gt.ngrid2) liny = ngrid2 - 1 rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit) goto 332 c write(*,*) " to : ",linx,liny endif qgrid(linx,liny) = qgrid(linx,liny) + q(i) 103 continue c Achtung! c Introducing a wire with negative charge in the corner of the chamber: c ixq = 14 c iyq = 18 c qgrid(ixq,iyq) = qgrid(ixq,iyq) + volt*1.0e10 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Generating the Field-Mesh: do 104 i=-ngrid2,ngrid2 xg = i*xbound/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.xg.eq.0.0) xg = 1.0d-5 do 105 j=-ngrid2,ngrid2 efxa(i,j) = 0.0d0 efya(i,j) = 0.0d0 yg = j*ymbound/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.yg.eq.0.0) yg = 1.0d-5 c Test lines: c This Test calculates the tangential field on the elliptical boundary. c xg = rbound*cos(2*pi*j/ngrid2) c yg = rbound*sin(2*pi*j/ngrid2) c rnx = xg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rny = yg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rtx = rny c rty = -rnx c xg = rmax*cos(2*pi*j/ngrid2) c yg = rmin*sin(2*pi*j/ngrid2) c rnx = xg/ rmax**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rny = yg/ rmin**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rtx = rny c rty = -rnx cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Calculate the elliptic coordinates for the image charge calculation: if(iimage.eq.1.and.igeom.eq.2) then z1 = xg/rg * zone + yg/rg * zi z2 = xg/rg * zone - yg/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 if(rphi*yg.lt.0.0d0) rphi = -rphi c testx = rg*(exp(rmi)+exp(-rmi))*cos(rphi)/2.0d0 c testy = rg*(exp(rmi)-exp(-rmi))*sin(rphi)/2.0d0 c write(*,*) "Testi: ",testx, xg, testy, yg endif do 106 k=-ngrid2,ngrid2 xl = k*rmax/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.xl.eq.0.0) c * xl = 1.0d-5 do 107 l=-ngrid2,ngrid2 if(qgrid(k,l).ne.0.0) then charge = 1.0d0 yl = l*rmin/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.yl.eq.0.0) c * yl = 1.0d-5 rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 if(xl.ne.xg.or.yl.ne.yg) * rad1 = (xg-xl)**2 + (yg-yl)**2 c if(yl.ne.yg.or.xl.ne.0.0.or.xg.ne.0.0) c * rad2 = (xg+xl)**2 + (yg-yl)**2 c if(xl.ne.xg.or.yl.ne.0.0.or.yg.ne.0.0) c * rad3 = (xg-xl)**2 + (yg+yl)**2 c if(xg.ne.0.0.or.xl.ne.0.0.or.yl.ne.0.0.or.yg.ne.0.0) c * rad4 = (xg+xl)**2 + (yg+yl)**2 efxa(i,j) = * efxa(i,j) + coef * qgrid(k,l) * * (xg-xl)/ rad1 c * + (xg+xl)/ rad2 c * + (xg-xl)/ rad3 c * + (xg+xl)/ rad4 )/ 4.0d0 efya(i,j) = * efya(i,j) + coef * qgrid(k,l) * * (yg-yl)/ rad1 c * + (yg-yl)/ rad2 c * + (yg+yl)/ rad3 c * + (yg+yl)/ rad4 )/ 4.0d0 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for an elliptical vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.2) then c Introducing complex notation for the electric field. c Calculate the elliptical coordinates ('rm' and 'phi') c of the charge on the mesh: z1 = xl/rg * zone + yl/rg * zi z2 = xl/rg * zone - yl/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rm0 = dabs(dreal(z3+z4)/2.0d0) rphi0 = dreal((z4-z3)*zi)/2.0d0 if(rphi0*yl.lt.0.0d0) rphi0 = -rphi0 c testx = rg*(exp(rm0)+exp(-rm0))*cos(rphi0)/2.0d0 c testy = rg*(exp(rm0)-exp(-rm0))*sin(rphi0)/2.0d0 c write(*,*) "Test0: ",testx, xl, testy, yl rphi1 = -rphi0 rphi2 = rphi0 + pi rphi3 = -rphi2 c rphi1 = rphi0 c rphi2 = rphi0 c rphi3 = rphi0 c THIS WAS, SO FAR SO GOOD........ C efz1(i,j) = efz1(i,j)+coef*qgrid(k,l)*2.0d0*exp(-ii*rm1)* C * ( (exp(ii*rm0)+exp(-ii*rm0)) * C * (4d0*cos(ii*rphi0))/ C * (exp(ii*rm1)+exp(-ii*rm1)) * zone ) * C * (cdexp(ii*(rmi*zone-rphi*zi))-cdexp(-ii*(rmi*zone-rphi*zi)))/ C * (cdexp(rmi*zone-rphi*zi)-cdexp(-(rmi*zone-rphi*zi)))/rg/4.0d0 c print *,' ii ',ii,' E ',efz1(i,j) c Adding the contributions from the image charges: c efz1(i,j)=efxa(i,j)*zone+efya(i,j)*zi c zeric=(0d0,0d0) ericreal = 0d0 ericimag = 0d0 const=coef*qgrid(k,l)/rg*2d0 c zr=dcmplx(rmi,-rphi) c zzr=cdexp(zr)-(1d0,0d0)/cdexp(zr) rreal=rmi rimag=-rphi r1real=exp(rreal)*cos(rimag) r1imag=exp(rreal)*sin(rimag) a2b2=r1real*r1real+r1imag*r1imag rzreal=r1real-r1real/a2b2 rzimag=r1imag+r1imag/a2b2 c2d2=rzreal*rzreal+rzimag*rzimag c print *,' init ' c print *,zr,rreal,rimag c print *,cdexp(zr),r1real,r1imag c print *,zzr,rzreal,rzimag do 109 ii=2,nimage,2 c print *,' ii ',ii,' E ',efz1(i,j) c print *,' looping ' erm0=exp(ii*rm0) erm1=exp(ii*rm1) rireal=ii*rreal riimag=ii*rimag c zri=ii*zr c print *,' zri ',zri,rireal,riimag c zzri=cdexp(zri)-(1d0,0d0)/cdexp(zri) rz1real=exp(rireal)*cos(riimag) rz1imag=exp(rireal)*sin(riimag) e2f2=rz1real*rz1real+rz1imag*rz1imag rzireal=rz1real-rz1real/e2f2 rziimag=rz1imag+rz1imag/e2f2 c print *,' rzi ',zzri,rzireal,rziimag eric=(erm0+1d0/erm0)/erm1*cos(ii*rphi0)/(erm1+1d0/erm1) c zeric=zeric + eric * zzri / zzr c a+ib/c+id=ac/(c2+d2)+bd/c2+d2)+( bc/(c2+d2)-ad/(c2+d2) )i ericreal=ericreal+eric*(rzireal*rzreal+rziimag*rzimag)/c2d2 ericimag=ericimag+eric*(rziimag*rzreal-rzireal*rzimag)/c2d2 c print *,' eric ',zeric,ericreal,ericimag 109 continue c efz1(i,j) = efz1(i,j)+const*zeric efxa(i,j) = efxa(i,j)+const*ericreal efya(i,j) = efya(i,j)+const*ericimag c Transforming back to cartesian coordinates: c efxa(i,j) = dreal(efz1(i,j)) c efya(i,j) = dreal(-efz1(i,j)*zi) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for a circular vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.1) then scale = sqrt(xl**2+yl**2)/xbound if(scale.eq.0.0) goto 108 xim = xl/scale**2 yim = yl/scale**2 rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 if(xim.ne.xg.or.yim.ne.yg) * rad1 = (xg-xim)**2 + (yg-yim)**2 if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.yg) * rad2 = (xg+xim)**2 + (yg-yim)**2 if(xim.ne.xg.or.yim.ne.0.0.or.yg.ne.0.0) * rad3 = (xg-xim)**2 + (yg+yim)**2 if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.0.0.or.yg.ne.0.0) * rad4 = (xg+xim)**2 + (yg+yim)**2 efxa(i,j) = efxa(i,j) * - coef * qgrid(k,l)*(xg-xim)/ rad1 c * - coef * qgrid(k,l)*(xg+xim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(xg-xim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(xg+xim)/ rad4/ 4.0d0 efya(i,j) = efya(i,j) * - coef * qgrid(k,l)*(yg-yim)/ rad1 c * - coef * qgrid(k,l)*(yg-yim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad4/ 4.0d0 endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for the wave guide geometry: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.3) then r1x(0) = xl r1y(0) = yl r2x(0) = xl r2y(0) = yl do 110 iw=1,nimage2 charge = -charge c Position of the image charge at the outer boundary (rmax): scale = dsqrt(r2x(iw-1)**2+r2y(iw-1)**2)/rmax if(scale.eq.0.0) goto 208 r1x(iw) = r2x(iw-1)/scale**2 r1y(iw) = r2y(iw-1)/scale**2 c Position of the image charge at the inner boundary (rmin): 208 scale = dsqrt(r1x(iw-1)**2+r1y(iw-1)**2)/rbound if(scale.eq.0.0) goto 108 r2x(iw) = r1x(iw-1)/scale**2 r2y(iw) = r1y(iw-1)/scale**2 rad11 = 1.0d0 rad12 = 1.0d0 rad13 = 1.0d0 rad14 = 1.0d0 rad21 = 1.0d0 rad22 = 1.0d0 rad23 = 1.0d0 rad24 = 1.0d0 if(r1x(iw).ne.xg.or.r1y(iw).ne.yg) * rad11 = (xg-r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.yg) * rad12 = (xg+r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.xg.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad13 = (xg-r1x(iw))**2 + (yg+r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad14 = (xg+r1x(iw))**2 + (yg+r1y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.yg) * rad21 = (xg-r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.yg) * rad22 = (xg+r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad23 = (xg-r2x(iw))**2 + (yg+r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad24 = (xg+r2x(iw))**2 + (yg+r2y(iw))**2 c Calculate the Field of the image charges: efxa(i,j) = efxa(i,j) + * charge*coef*qgrid(k,l)* * ( * (xg-r1x(iw))/rad11 * + (xg+r1x(iw))/rad12 * + (xg-r1x(iw))/rad13 * + (xg+r1x(iw))/rad14 * + (xg-r2x(iw))/rad21 * + (xg+r2x(iw))/rad22 * + (xg-r2x(iw))/rad23 * + (xg+r2x(iw))/rad24 * )/ 4.0d0 efya(i,j) = efya(i,j) + * charge*coef*qgrid(k,l)* * ( * (yg-r1y(iw))/rad11 * + (yg-r1y(iw))/rad12 * + (yg+r1y(iw))/rad13 * + (yg+r1y(iw))/rad14 * + (yg-r2y(iw))/rad21 * + (yg-r2y(iw))/rad22 * + (yg+r2y(iw))/rad23 * + (yg+r2y(iw))/rad24 * )/4.0d0 110 continue endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 108 if(i.eq.ngrid2.and.j.eq.ngrid2) qgrid(k,l) = 0.0 107 continue 106 continue c Testing the image charge routine for the wave guide mode: c write(*,*) "T-f:",j, c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential field on the elliptical boundary: c write(*,*) "Test-f:", j, c * rtx*efxa(i,j)+rty*efya(i,j), c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential E-field on the circular boundary: c if(abs(xbound**2-xg**2-yg**2).lt.1.0e-12) then c write(*,*) "Image: ",xg,yg c write(*,*) (yg*efxa(i,j)-xg*efya(i,j))/ c * sqrt(xg**2+yg**2)/coef c endif c if(efya(i,j).ne.0.0) write(*,*) "Test: ", i, j, efya(i,j) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 105 continue 104 continue c Calculating the potential between the two conductors of the c wave guide geometry due to image charges: if(iimage.eq.1.and.igeom.eq.3) then voltx = 0.0d0 volty = 0.0d0 voltz = 0.0d0 do 203 i=0,ngrid2 if(i*xbound/ngrid2.lt.rbound) goto 203 if(i*xbound/ngrid2.gt.xbound) goto 203 voltx = voltx - elmass*xbound*efxa(i,0)/ngrid2/ el volty = volty - elmass*xbound*efya(0,i)/ngrid2/ el c voltz = voltz - c * elmass*xbound*(efxa(i,i)+efya(i,i))/ngrid2/el voltq = -el*qinner*log(xbound/rbound)/ * (2.0d0*pi*eta) 203 continue write(29,fmt='(5e25.5)') t, voltx, volty, voltq c write(*,*) c * "Voltage between boundaries: ",t,voltx,volty,voltq endif c Achtung! c Calculating the potential between the wire and the vacuum chmaber c for electrostatic field: if(iimage.eq.1.and.igeom.ne.3) then voltx = 0.0d0 volty = 0.0d0 voltz = 0.0d0 c Wire in the corner of the liner: do 204 i=ixq,ngrid2 if((sqrt(dble(i)**2+dble(iyq)**2)/ngrid2). * gt.1.0d0) goto 204 voltx = voltx-elmass*xbound*efxa(i,iyq)/ngrid2/el 204 continue do 205 i=iyq,ngrid2 if((sqrt(dble(ixq)**2+dble(i)**2)/ngrid2). * gt.1.0d0) goto 205 if(i*ymbound/ngrid2.gt.ymbound) goto 205 volty = volty-elmass*ymbound*efya(ixq,i)/ngrid2/el 205 continue cc Ploting the electrostatic field: c open(unit=77,file="efield.data",status='unknown') c c do 304 i=0,ngrid2 c do 305 j=0,ngrid2 c if((dble(i)/ngrid2)**2+(dble(j)/ngrid2)**2.gt.1.0d0) c * goto 305 c if(dble(j)*ymbound/ngrid2.gt.ymbound) goto 305 c write(77,*) dble(i)*xbound/ngrid2,dble(j)*ymbound/ngrid2, c * i, j c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17 c c rnorm = sqrt((efxa(i,j)*1.0d-17)**2+ c * (efya(i,j)*1.0d-17)**2) c rlx = 1.0e-4*(efxa(i,j)*1.0d-17)/ rnorm c rly = 1.0e-4*(efya(i,j)*1.0d-17)/ rnorm c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17+rly, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17-rlx c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17+rlx, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17+rly c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17-rly, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17+rlx c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17 c write(77,*) c write(77,*) c 305 continue c 304 continue c do 301 i=1,80 c write(77,*) xbound*cos(pi*i/160), ybound*sin(pi*i/160) c 301 continue c close(unit=77) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc write(29,fmt='(5e25.5)') t, voltx, volty, voltq c write(*,*) c * "Voltage between boundaries: ",t,voltx,volty,voltq endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc end subroutine clean c purpose: eliminate indices for electrons with vanishing charge. implicit real*8 (a-h,o-z) c implicit integer (a-z) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer index(npelm) integer icount integer i, incount real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), * pz(npelm), py(npelm), px(npelm) real*8 ptime(npelm), esign(npelm) real*8 rtest common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / part2 / icount, icountact, iadele write(*,*)' in clean ' incount = 0 qlimit = 10.d0 do 101 i=1,icount if (q(i).lt.qlimit) then rtest=ran2(idum) if ((q(i)/qlimit).ge.rtest) q(i)=qlimit endif if (q(i).ge.qlimit) then incount = incount + 1 q(incount) = q(i) index(incount) = index(i) x(incount) = x(i) y(incount) = y(i) z(incount) = z(i) xp(incount) = xp(i) yp(incount) = yp(i) zp(incount) = zp(i) px(incount) = px(i) py(incount) = py(i) pz(incount) = pz(i) ptime(incount) = ptime(i) esign(incount) = esign(i) endif 101 continue do i = incount+1,icount q(i) = q(npelm) index(i) = index(npelm) end do icount = incount end c ---------------------------------------------------------- subroutine bin c purpose: bin charge distribution implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500) c npelm - total maximum number of macroparticles (> product) real*8 x (npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), py(npelm) real*8 px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) integer index(npelm) real*8 xg(0:ngrid), yg(0:ngrid) real*8 charge(ngrid,ngrid) real*8 cxp(ngrid), cyp(ngrid) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 qacc common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / part / qacc common / part2 / icount, icountact, iadele common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c grid parameters xstep = 2.d0*xbound/real(ngrid) ystep = 2.d0*ybound/real(ngrid) xg(0) = - xbound yg(0) = - ybound do 10 j = 1, ngrid cxp(j) = 0.d0 cyp(j) = 0.d0 xg(j) = -xbound + real(j)*xstep yg(j) = -ybound + real(j)*ystep 10 continue do 11 j1 = 1, ngrid do 12 j2 = 1, ngrid charge(j1,j2) =0.d0 12 continue 11 continue do 13 i = 1, icount do 14 j1 = 1, ngrid if ((x(i).lt.xg(j1)).and.(x(i).ge.xg(j1-1))) then do 15 j2 = 1, ngrid if ((y(i).lt.yg(j2)).and.(y(i).ge.yg(j2-1))) then charge (j1,j2) = charge(j1,j2) + q(i) cxp (j1) = cxp(j1) + q(i) cyp (j2) = cyp(j2) + q(i) goto 90 endif 15 continue endif 14 continue 90 continue 13 continue open(19,file="charge.dat",status='unknown') open(20,file="proj.dat.seed",status='unknown') do 16 j1= 1, ngrid do 17 j2= 1, ngrid write(19,*) xg(j1), yg(j2), charge(j1,j2) 17 continue 16 continue do 18 j = 1, ngrid write(20,*) xg(j),yg(j),cxp(j),cyp(j) 18 continue close(19) close(20) end real*8 function gammaf(v) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 bfield, el, vl, fom, pi, re, elmass, v common / def2 / bfield, el, vl, fom, pi, re, elmass gammaf = 1.d0/sqrt(1.0d0-(v/vl)**2) return end c 18.06.1997 Oliver subroutine ebin c purpose: bin distribution of energy kicks. implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) c npelm - total maximum number of macroparticles (> product) real*8 x (npelm), y(npelm), z(npelm), q(npelm), t real*8 py(npelm), px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 max, min, estepe, estepv, maxv real*8 enbin(0:nbin), vbin(0:nbin) real*8 dele(npelm), qele(npelm) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 bfield, el, vl, fom, pi, re, elmass real*8 qacc common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / egain / dele, qele c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave ccccccccccccccccccccccccccccccccccccccccccccccc avenergy = 0.0d0 avvelocity = 0.0d0 inumetot = 0 inumvtot = 0 c max = 2000.0d0 max = 1000.0d0 min = 0.0 c maxv = maximum velocity/ c maxv = 0.1d0 estepe = (max-min)*el/ (nbin-1) estepv = maxv/ (nbin-1) do 100 i=0,nbin enbin(i) = 0.0d0 vbin(i) = 0.0d0 100 continue c Ploting the energy distribution: if(iadele.gt.npelm) iadele = npelm do 101 i=1,iadele if ((dele(i)/el).lt.max) then enbin(nint(dele(i)/estepe)) = * enbin(nint(dele(i)/estepe)) + * qele(i)/real(npepb) inumetot = inumetot + enbin(nint(dele(i)/estepe)) c write(*,*) "Test",i,sqrt(2*dele(i)/elmass)/1.0d4 endif 101 continue c Ploting the velocity distribution: do 111 i=1,iadele c write(*,*) "Test",i,dele(i),sqrt(2*dele(i)/el/0.511d6) if (sqrt(2*dele(i)/el/0.511d6)/estepv.lt.1.0*nbin) then vbin(nint(sqrt(2*dele(i)/el/0.511d6)/estepv)) = * vbin(nint(sqrt(2*dele(i)/el/0.511d6)/estepv)) + * qele(i)/real(npepb) inumvtot = inumvtot + * vbin(nint(sqrt(2*dele(i)/el/0.511d6)/estepv)) endif 111 continue open(33,file="energy.distr.data",status='unknown') open(34,file="velocity.distr.data",status='unknown') do 102 i=0,nbin write(33,*) i*estepe/el, enbin(i) write(34,*) i*estepv, vbin(i) avenergy = avenergy + enbin(i)*i*estepe/el avvelocity = avvelocity + vbin(i)*i*estepv 102 continue c write(*,*) "Average energy of the photo electrons:", c * avenergy/inumetot c write(*,*) "Average velocity of the photo electrons:", c * avvelocity/inumvtot close(33) close(34) close(44) c close(45) end subroutine ebin2(test,ipec,iunit,vmax,vmin) c purpose: bin an arbitrary distribution. implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) c npelm - total maximum number of macroparticles (> product) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 py(npelm), px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 vmax, vmin, estep real*8 enbin(0:nbin) real*8 dele(npelm), qele(npelm), test(npelm) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / egain / dele, qele c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave ccccccccccccccccccccccccccccccccccccccccccccccc c vmax = 100.0d0 c vmin = 0.0d0 estep = (vmax-vmin)/ (nbin-1) do 100 i=0,nbin enbin(i) = 0.0d0 100 continue c Ploting the energy distribution: if(ipec.gt.npelm) ipec = npelm do 101 i=1,ipec if ((test(i)).lt.vmax) then if(nint(test(i)/estep).gt.nbin) goto 101 enbin(nint(test(i)/estep)) = * enbin(nint(test(i)/estep)) + * qele(i)/real(npepb) c write(*,*) "Test",i,test(i) endif 101 continue do 102 i=0,nbin write(iunit,*) i*estep+vmin, enbin(i) 102 continue c close(iunit) end subroutine binx c purpose: bin the charge distribution and write the density to a file: implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) c npelm - total maximum number of macroparticles (> product) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 py(npelm), px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 xbin(0:nbin), rbin(0:nbin) real*8 dele(npelm), qele(npelm) cccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 bfield, el, vl, fom, pi, re, elmass real*8 qacc real*8 rboundl common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / egain / dele, qele c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def1 / rbound, xbound, ybound, zbound, energy, belen common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc open(61,file="horiz.distr.data",status='unknown') open(62,file="radia.distr.data",status='unknown') rboundl = max(xbound,ybound) do 300 i=0,nbin xbin(i) = 0.0 rbin(i) = 0.0 300 continue c Bining the horizontal distribution: do 301 i=1,icount if(nint((nbin*x(i)/xbound+nbin)/2.0d0).gt.nbin) goto 301 xbin(nint((nbin*x(i)/xbound+nbin)/2.0d0)) = * xbin(nint((nbin*x(i)/xbound+nbin)/2)) + * q(i) c frank 12/11/99 remove: /real(npepb) c write(*,*) "Test-x",i,x(i) 301 continue c Bining the radial distribution: do 302 i=1,icount nindhg=nint(nbin*sqrt(x(i)**2+y(i)**2)/rboundl) if(nindhg.gt.nbin) goto 302 rbin(nindhg) = * rbin(nindhg) + * q(i) c frank 12/11/99 remove: /real(npepb) c write(*,*) "Test-r",i,x(i) 302 continue do 303 i=0,nbin if(xbin(i).ne.0.0d0) * write(61,*) (2.0d0*i/nbin-1.0d0)*xbound, xbin(i) if(rbin(i).ne.0.0d0) * write(62,*) i*rboundl/nbin, rbin(i) 303 continue close(61) close(62) end real*8 function ran2(idum) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c The Function Returns a Uniform Random Number between 0.0 and 1.0. c c The Function uses a 'Subtractive Method'!!! c c Set 'idum' to a negative value to initialize or reinitialize the Sequence. c c (Numerical Recipies ran3(idumy), pg. 273.) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer idum integer mbig, mseed, mz real*8 fac parameter(mbig=1000000000,mseed=161803398,mz=0,fac=1.0d0/mbig) integer i, iff, ii, inext, inextp, k integer mj, mk, ma(55) save iff, inext, inextp, ma data iff /0/ c Initialization: if(idum.lt.0.or.iff.eq.0) then iff = 1 mj = mseed-iabs(idum) mj = mod(mj,mbig) mk = 1 do 11 i=1,54 ii = mod(2*i,55) ma(ii) = mk mk = mj - mk if(mk.lt.mz) mk = mk + mbig mj = ma(ii) 11 continue do 13 k=1,4 do 12 i=1,55 ma(i) = ma(i) - ma(1+mod(i+30,55)) if(ma(i).lt.mz) ma(i) = ma(i) + mbig 12 continue 13 continue inext = 0 inextp = 31 idum = 1 end if inext = inext + 1 if(inext.eq.56) inext = 1 inextp = inextp + 1 if(inextp.eq.56) inextp = 1 mj = ma(inext) - ma(inextp) if(mj.lt.mz) mj = mj + mbig ma(inext) = mj ran2 = mj * fac return end subroutine dist(ampl,xx,yy,jw) ********************************************************* * * * Calculate the distance between wire and a particle. * * * ********************************************************* integer k, jw real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 tmp, ampl real*8 xx,yy common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ampl=10.0d0 jw=1 do 111 k=1,6 tmp=((xx-x0r(k))*(xx-x0r(k))+(yy-y0r(k))*(yy-y0r(k))) tmp=tmp/rbound6/rbound6 ampl=min(ampl,tmp) if(tmp.eq.ampl) jw = k 111 continue return end subroutine ebinw(binwe, wen, qw) c purpose: bin energy distribution of the electron that c hit the wall. implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binwe(0:500), wen, qw ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc vmax = 250.0d0 vmin = 0.0d0 estep = (vmax-vmin)/(nbin-1) wenmax = dmax1(wen,wenmax) if (wen.gt.vmax) then if (wen.lt.deltaemax) then wen1 = wen1+qw*wen qne1 = qne1+qw else wen2 = wen2+qw*wen qne2 = qne2 + qw endif endif k=nint(wen/estep) if (wen.lt.vmax) then if(k.gt.nbin.or.k.lt.0) then goto 101 endif binwe(k) = binwe(k) + qw endif 101 continue end subroutine ebinwnew(binwe, wen, qw) c purpose: bin energy distribution of the electron that c hit the wall. implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binwe(0:500), wen, qw ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc vmax = 250.0d0 vmin = 0.0d0 estep = (vmax-vmin)/(nbin-1) wenmax = dmax1(wen,wenmax) if (wen.gt.vmax) then if (wen.lt.deltaemax) then wen1 = wen1+qw*wen qne1 = qne1+qw else wen2 = wen2+qw*wen qne2 = qne2 + qw endif endif k=nint(wen/estep) if (wen.lt.vmax) then if(k.gt.nbin.or.k.lt.0) then goto 101 endif binwe(k) = binwe(k) + qw endif 101 continue end subroutine ebinwphi(binwephi,binweph2,wen,qw,x,y) c purpose: bin azimuthal distribution of the heat load c on the wall implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binweph2(0:500) real*8 binwephi(0:500), wen, qw, x, y real*8 bfield, el, vl, fom, pi, re, elmass common / def2 / bfield, el, vl, fom, pi, re, elmass ccccccccccccccccccccccccccccccccccccccc vmax = 2.*pi vmin = 0.0 phistep = (vmax-vmin)/(nbin-1) if (dabs(x).gt.1.e-20) then phi = datan2(y,x) else if (y.gt.0.d0) then phi = pi/2. else phi = 3.*pi/2. endif if (phi.lt.0) then phi = phi+2.*pi endif k=nint(phi/phistep) if (k.le.nbin.and.k.ge.0) then binwephi(k) = binwephi(k) + wen*qw binweph2(k) = binweph2(k) + qw else binwephi(nbin) = binwephi(nbin) + wen*qw binweph2(nbin) = binweph2(nbin) + qw endif 101 continue end subroutine ebinwx(binwex,binwex2,binwex3,wen,qw,x,y) c purpose: bin x distribution of the heat load c on the wall implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binwex(0:500), binwex3(0:500) real*8 binwex2(0:500), wen, qw, x, y real*8 bfield, el, vl, fom, pi, re, elmass common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen ccccccccccccccccccccccccccccccccccccccc vmax = xbound vmin = -xbound xstep = vmax/real(nbin) k=nint(abs(x)/xstep) if (k.le.nbin.and.k.ge.0) then binwex(k) = binwex(k) + wen*qw binwex2(k) = binwex2(k) + qw if (wen.gt.30) then binwex3(k) = binwex3(k) + qw endif c else c binwex(nbin) = binwex(nbin) + wen*qw c binwex2(nbin) = binwex2(nbin) + qw endif 101 continue end subroutine spacecharge2 c fixed several bugs of previous version c 29.08.99 frankz c purpose: New space charge routine that uses a two dimensional Mesh c for the field calculation and allows the evaluation of the c effect of image charges on the boundary. c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,ngrid2=10,nimage=50,nimage2=4, & ngridffts=32,ngridfft=3200) parameter(eta=8.8542d-12) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) real*8 rolimit, rilimit parameter(rolimit=0.97d0,rilimit=1.02d0) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 px(npelm), pz(npelm), py(npelm) real*8 ptime(npelm), esign(npelm) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgridfft(ngridffts,ngridffts), acoef(ngridffts/2,ngridffts/2) real*8 r1x(0:nimage2),r1y(0:nimage2),r2x(0:nimage2),r2y(0:nimage2) real*8 rg, rm1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 voltx, volty real*8 rmax, rmin real*8 rm0 real*8 rphi, rphi0, rphi1, rphi2, rphi3 real*8 xl, yl real*8 denscenter c complex*16 datafft (ngridffts/2,ngridffts,1) integer nnfft(3) integer nnfft1,nnfft2,nnfft3,isign complex*16 speq(ngridffts/2,ngridffts) real*8 ukl (ngridffts/2,ngridffts) real*8 xr(20) c Complex variables for the calculation of the elliptical coordinates: complex*16 z1, z2, z3, z4, zi, zone complex*16 efz1(0:ngrid2,0:ngrid2), efz complex*16 zeric,zdiv,zr,zri,zzr,zzri common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / image / iimage, iimageb, interspace, igeom common / beam / rg, rm1 common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 common / center / denscenter ccccccccccccccccccccccccccccccccccccccccccccccc c c parameter for avoiding zero charge and grid points epsi=1.d-5 c write(*,*) ' in spacecharge2 ' open(444,file="esc.check.data") charge = 1.0d0 coef = 2.0d0*re*vl*vl/belen ymbound = min(ybound,zbound) amp = sqrt(xbound**2+ymbound**2) rmax = max(xbound,ymbound) rmin = min(xbound,ymbound) zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) if(igeom.eq.2) then rg = sqrt(rmax**2 - rmin**2) rm1 = log((rmax+rmin)/(rmax-rmin))/2.0d0 endif c testx = rg*(exp(rm1)+exp(-rm1))/2.0d0 c testy = rg*(exp(rm1)-exp(-rm1))/2.0d0 c write(*,*) "Test1: ",testx, testy deltaxx = xbound/real(ngrid2) deltayy = ymbound/real(ngrid2) c Distributing the charge on the grid: if (igeom.ne.4) then do 103 i=1,icount c c frank: i do not understand the abs( ) - correct for quads? linx = nint(ngrid2*x(i)/xbound) liny = nint(ngrid2*y(i)/ymbound) c Avoiding charges which are outside the boundary for the c image charge calculation: rl1 = (dble(linx)/dble(ngrid2))**2+(dble(liny)/dble(ngrid2))**2 if (rl1.gt.rolimit) then c write(*,*) "Changing the mesh position 1 from: ",linx,liny 331 rl2 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 rl3 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 rl4 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 if(rl2.gt.rolimit) rl2 = 0.0 if(rl3.gt.rolimit) rl3 = 0.0 if(rl4.gt.rolimit) rl4 = 0.0 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).gt.0) * linx = linx - 1 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).lt.0) * linx = linx + 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).gt.0) * liny = liny - 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).lt.0) * liny = liny + 1 if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx - 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx - 1 liny = liny + 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx + 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx + 1 liny = liny + 1 endif c if(linx.lt.0) linx = 0 c if(liny.lt.0) liny = 0 rl1 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 if(rl1.gt.rolimit) goto 331 c write(*,*) " to : ",linx,liny endif c write(*,*) ' i = ',i c Avoiding charges which are inside the inner conductor for the c image charge calculation with a wave guide geometry: rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit.and.igeom.eq.3.and.iimage.eq.1) then c write(*,*) "Changing the mesh position 2 from: ",linx,liny 332 if(linx.le.nint(ngrid2*rbound/xbound)) linx = linx + 1 if(liny.le.nint(ngrid2*rbound/ymbound)) liny = liny + 1 if(linx.gt.ngrid2) linx = ngrid2 - 1 if(liny.gt.ngrid2) liny = ngrid2 - 1 rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit) goto 332 c write(*,*) " to : ",linx,liny endif if(abs(linx).le.ngrid2.and.abs(liny).le.ngrid2) then qgrid(linx,liny) = qgrid(linx,liny) + q(i) endif 103 continue ind0 = 0 denscenter = qgrid(ind0,ind0)/(deltaxx*deltayy*belen) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c compute 2-D FFT of charge distribution c if (igeom.eq.4) then do 1031 i=1,icount c note right/top border are outside the range linx = nint((ngridffts/2)*(xbound+x(i))/(2.*xbound))+1 liny = nint((ngridffts/2)*(ymbound+y(i))/(2.*ymbound))+1 if (linx.ge.1.and.linx.le.ngridffts.and.liny.ge.1.and. & liny.le.ngridffts) then qgridfft(linx,liny) = qgridfft(linx,liny) + q(i) endif 1031 continue do 1034 ifft2=1,ngridffts/2 do 1033 ifft1=ngridffts/2+2,ngridffts qgridfft(ifft1,ifft2) = -qgridfft(ngridffts+2-ifft1,ifft2) 1033 continue 1034 continue do 1036 ifft2=ngridffts/2+2,ngridffts do 1035 ifft1=1,ngridffts/2 qgridfft(ifft1,ifft2) = -qgridfft(ifft1,ngridffts+2-ifft2) 1035 continue 1036 continue do 1038 ifft2=ngridffts/2+2,ngridffts do 1037 ifft1=ngridffts/2+2,ngridffts qgridfft(ifft1,ifft2) = & +qgridfft(ngridffts+2-ifft1,ngridffts+2-ifft2) 1037 continue 1038 continue n1grid = ngridffts n1gridlimit = ngridffts**2 nnfft1 = ngridffts nnfft2 = ngridffts nnfft3 = 1 isign = 1 ndimfft = 2 indexfft = 0 ifft3 = 1 do 1104 ifft2 = 1, ngridffts do 1103 ifft1 = 1, ngridffts-1, 2 if (ifft1.lt.ngridffts.or.ifft2.lt.ngridffts) then datafft ((ifft1-1)/2+1,ifft2,ifft3) = & cmplx(qgridfft(ifft1,ifft2),qgridfft(ifft1+1,ifft2)) endif 1103 end do 1104 end do c c call Fourier transform c call fourn (datafft,nnfft,ndimfft,isign) call rlft3(datafft,speq,nnfft1,nnfft2,nnfft3,isign) do 1106 ifft2 = 1, ngridffts do 1105 ifft1 = 1, ngridffts/2 itesta=ifft2 itestb=ngridffts-ifft2+2 indexfftt2a = ifft1*2 + (ifft2-1)*nnfft1*2 indexfftt2b = (ngridffts-ifft1+2)*2 + & (ifft2-1)*nnfft1*2 if (ifft2.eq.1) then acoef (ifft1,ifft2) = 0. else acoef (ifft1,ifft2) = 2./(nnfft1*nnfft2) & *(real(datafft(ifft1,ifft2,1))- & real(datafft(ifft1,ngridffts-ifft2+2,1))) endif 1105 end do 1106 end do endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Achtung! c Introducing a wire with negative charge in the corner of the chamber: c ixq = 14 c iyq = 18 c qgrid(ixq,iyq) = qgrid(ixq,iyq) + volt*1.0e10 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Generating the Field-Mesh: do 104 i=-ngrid2,ngrid2 xg = i*xbound/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(xg).lt.epsi) * xg = epsi do 105 j=-ngrid2,ngrid2 efxa(i,j) = 0.0d0 efya(i,j) = 0.0d0 yg = j*ymbound/ngrid2 c if (j.eq.0) then c yg = ymbound*sqrt(1.-(xg/xbound)**2) c else if (j.eq.1) then c yg = -ymbound*sqrt(1.-(xg/xbound)**2) c endif c if (abs(xg).lt.xbound) then c dn1 = ymbound/xbound*xg/sqrt(xbound**2-xg**2) c dn2 = 1. c dnnorm = sqrt(dn1*dn1+dn2*dn2) c if (xg.gt.0.and.yg.ge.0) then c dn1n=-dn1/dnnorm c dn2n=-dn2/dnnorm c dm1n=dn2/dnnorm c dm2n=-dn1/dnnorm c else if (xg.lt.0.and.yg.ge.0) then c dn1n=-dn1/dnnorm c dn2n=-dn2/dnnorm c dm1n=-dn2/dnnorm c dm2n=dn1/dnnorm c else if (xg.gt.0.and.yg.lt.0) then c dn1n=-dn1/dnnorm c dn2n=dn2/dnnorm c dm1n=dn2/dnnorm c dm2n=dn1/dnnorm c else if (xg.lt.0.and.yg.lt.0) then c dn1n=-dn1/dnnorm c dn2n=dn2/dnnorm c dm1n=-dn2/dnnorm c dm2n=-dn1/dnnorm c endif c else if (xg.eq.(-xbound)) then c dn1n= 1. c dn2 = 0. c else if (xg.eq.xbound) then c dn1n= -1. c dn2 = 0. c endif c write(*,*) ' 104 loop, i,j = ',i,j c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(yg).lt.epsi) * yg = epsi c Test lines: c This Test calculates the tangential field on the elliptical boundary. c xg = rbound*cos(2*pi*j/ngrid2) c yg = rbound*sin(2*pi*j/ngrid2) c rnx = xg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rny = yg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rtx = rny c rty = -rnx c xg = rmax*cos(2*pi*j/ngrid2) c yg = rmin*sin(2*pi*j/ngrid2) c rnx = xg/ rmax**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rny = yg/ rmin**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rtx = rny c rty = -rnx cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Calculate the elliptic coordinates for the image charge calculation: if(iimage.eq.1.and.igeom.eq.2) then z1 = xg/rg * zone + yg/rg * zi z2 = xg/rg * zone - yg/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 if(rphi*yg.lt.0.0d0) rphi = -rphi c write(*,*) ' rphi = ',rphi c if (xg.lt.0.and.yg.ge.0) then c rphi = rphi + pi/2. c else if (xg.lt.0.and.yg.lt.0) then c rphi = rphi - pi c else if (xg.ge.0.and.yg.lt.0) then c rphi = rphi - pi/2. c endif c testx = rg*(exp(rmi)+exp(-rmi))*cos(rphi)/2.0d0 c testy = rg*(exp(rmi)-exp(-rmi))*sin(rphi)/2.0d0 c write(*,*) "Testi: ",testx, xg, testy, yg endif if(igeom.ne.4) then do 106 k=-ngrid2,ngrid2 xl = k*rmax/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(xl).lt.epsi) * xl = epsi do 107 l=-ngrid2,ngrid2 if(qgrid(k,l).ne.0.0) then charge = 1.0d0 yl = l*rmin/ngrid2 c write(*,*) ' 107 loop, i,j,k,l = ',i,j,k,l c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(yl).lt.epsi) * yl = epsi rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 c c direct field from electrons ! c if(abs(xl-xg).gt.epsi.or.abs(yl-yg).gt.epsi) * rad1 = (xg-xl)**2 + (yg-yl)**2 c if(yl.ne.yg.or.xl.ne.0.0.or.xg.ne.0.0) c * rad2 = (xg+xl)**2 + (yg-yl)**2 c if(xl.ne.xg.or.yl.ne.0.0.or.yg.ne.0.0) c * rad3 = (xg-xl)**2 + (yg+yl)**2 c if(xg.ne.0.0.or.xl.ne.0.0.or.yl.ne.0.0.or.yg.ne.0.0) c * rad4 = (xg+xl)**2 + (yg+yl)**2 if (iimage.eq.0.or.igeom.ne.4) then efxa(i,j) = * efxa(i,j) + coef * qgrid(k,l) * * (xg-xl)/ rad1 c * + (xg+xl)/ rad2 c * + (xg-xl)/ rad3 c * + (xg+xl)/ rad4 )/ 4.0d0 efya(i,j) = * efya(i,j) + coef * qgrid(k,l) * * (yg-yl)/ rad1 c * + (yg-yl)/ rad2 c * + (yg+yl)/ rad3 c * + (yg+yl)/ rad4 )/ 4.0d0 endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for a round vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.1) then radimr2 = xl**2+yl**2 if (radimr2.gt.epsi) then coefimr = xbound**2/radimr2 xla = xl*coefimr yla = yl*coefimr if(abs(xla-xg).gt.epsi.or.abs(yla-yg).gt.epsi) * rad1i = (xg-xla)**2 + (yg-yla)**2 efxa(i,j) = efxa(i,j) - coef * qgrid(k,l) * * (xg-xla)/ rad1i efya(i,j) = efya(i,j) - coef * qgrid(k,l) * * (yg-yla)/ rad1i endif endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for an elliptical vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.2) then c Introducing complex notation for the electric field. c Calculate the elliptical coordinates ('rm' and 'phi') c of the charge on the mesh: z1 = xl/rg * zone + yl/rg * zi z2 = xl/rg * zone - yl/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rm0 = dabs(dreal(z3+z4)/2.0d0) rphi0 = dreal((z4-z3)*zi)/2.0d0 if(rphi0*yl.lt.0.0d0) rphi0 = -rphi0 c write(*,*) ' rphi0 = ',rphi c if (xl.lt.0.and.yl.ge.0) then c rphi0 = rphi0 + pi/2. c else if (xl.lt.0.and.yl.lt.0) then c rphi0 = rphi0 - pi c else if (xl.ge.0.and.yl.lt.0) then c rphi0 = rphi0 - pi/2. c endif rphib=rphi0 rmib=rm0 c testx = rg*(exp(rm0)+exp(-rm0))*cos(rphi0)/2.0d0 c testy = rg*(exp(rm0)-exp(-rm0))*sin(rphi0)/2.0d0 c write(*,*) "Test0: ",testx, xl, testy, yl rphi1 = -rphi0 rphi2 = rphi0 + pi rphi3 = -rphi2 c rphi1 = rphi0 c rphi2 = rphi0 c rphi3 = rphi0 const=coef*qgrid(k,l)/rg*2d0 c efz = efxa(i,j) * zone + efya(i,j) * zi efz = (0.,0.) do 114 ii=1,nimage/2 c charge = -1.0d0 charge = 1.0d0 efz = efz+const*charge*dexp(-ii*rm1)*( * (dexp(ii*rmib)+dexp(-ii*rmib))* * cos(ii*rphib)/(dexp(ii*rm1)+dexp(-ii*rm1))+ * zi*(dexp(ii*rmib)-dexp(-ii*rmib))* * sin(ii*rphib)/(dexp(ii*rm1)-dexp(-ii*rm1)))* * (cdexp(ii*(rmi*zone-rphi*zi))- * cdexp(-ii*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi))- * cdexp(-(rmi*zone-rphi*zi))) 114 continue efxa(i,j)=efxa(i,j)+dreal(efz) efya(i,j)=efya(i,j)+dreal(-efz*zi) cc goto 1113 cc do 109 ii=2,nimage,2 c print *,' ii ',ii,' E ',efz1(i,j) c print *,' looping ' cc erm0=exp(ii*rm0) cc erm1=exp(ii*rm1) cc rireal=ii*rreal cc riimag=ii*rimag c zri=ii*zr c print *,' zri ',zri,rireal,riimag c zzri=cdexp(zri)-(1d0,0d0)/cdexp(zri) cc rz1real=exp(rireal)*cos(riimag) cc rz1imag=exp(rireal)*sin(riimag) cc e2f2=rz1real*rz1real+rz1imag*rz1imag cc rzireal=rz1real-rz1real/e2f2 cc rziimag=rz1imag+rz1imag/e2f2 c print *,' rzi ',zzri,rzireal,rziimag cc eric=(erm0+1d0/erm0)/erm1*cos(ii*rphi0)/(erm1+1d0/erm1) c zeric=zeric + eric * zzri / zzr c a+ib/c+id=ac/(c2+d2)+bd/c2+d2)+( bc/(c2+d2)-ad/(c2+d2) )i cc ericreal=ericreal+eric*(rzireal*rzreal+rziimag*rzimag)/c2d2 cc ericimag=ericimag+eric*(rziimag*rzreal-rzireal*rzimag)/c2d2 c print *,' eric ',zeric,ericreal,ericimag cc 109 continue c 1113 continue c efz1(i,j) = efz1(i,j)+const*zeric cc efxa(i,j) = efxa(i,j)+const*ericreal cc efya(i,j) = efya(i,j)+const*ericimag c Transforming back to cartesian coordinates: c efxa(i,j) = dreal(efz1(i,j)) c efya(i,j) = dreal(-efz1(i,j)*zi) endif cc 1113 continue c write(*,*) ' space charge and image= ',efxa(i,j),ericreal,const ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for a circular vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc frankz: comment out this part July 2, 2002 cc if(iimage.eq.1.and.igeom.eq.1) then cc scale = sqrt(xl**2+yl**2)/xbound cc if(scale.lt.epsi) goto 108 cc xim = xl/scale**2 cc yim = yl/scale**2 cc rad1 = 1.0d0 cc rad2 = 1.0d0 cc rad3 = 1.0d0 cc rad4 = 1.0d0 cc if(abs(xim-xg).gt.epsi.or.abs(yim-yg).gt.epsi) cc * rad1 = (xg-xim)**2 + (yg-yim)**2 c if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.yg) c * rad2 = (xg+xim)**2 + (yg-yim)**2 c if(xim.ne.xg.or.yim.ne.0.0.or.yg.ne.0.0) c * rad3 = (xg-xim)**2 + (yg+yim)**2 c if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.0.0.or.yg.ne.0.0) c * rad4 = (xg+xim)**2 + (yg+yim)**2 cc efxa(i,j) = efxa(i,j) cc * - coef * qgrid(k,l)*(xg-xim)/ rad1 c * - coef * qgrid(k,l)*(xg+xim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(xg-xim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(xg+xim)/ rad4/ 4.0d0 cc efya(i,j) = efya(i,j) cc * - coef * qgrid(k,l)*(yg-yim)/ rad1 c * - coef * qgrid(k,l)*(yg-yim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad4/ 4.0d0 cc endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for the wave guide geometry: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.3) then r1x(0) = xl r1y(0) = yl r2x(0) = xl r2y(0) = yl do 110 iw=1,nimage2 charge = -charge c Position of the image charge at the outer boundary (rmax): scale = dsqrt(r2x(iw-1)**2+r2y(iw-1)**2)/rmax if(scale.eq.0.0) goto 208 r1x(iw) = r2x(iw-1)/scale**2 r1y(iw) = r2y(iw-1)/scale**2 c Position of the image charge at the inner boundary (rmin): 208 scale = dsqrt(r1x(iw-1)**2+r1y(iw-1)**2)/rbound if(scale.eq.0.0) goto 108 r2x(iw) = r1x(iw-1)/scale**2 r2y(iw) = r1y(iw-1)/scale**2 rad11 = 1.0d0 rad12 = 1.0d0 rad13 = 1.0d0 rad14 = 1.0d0 rad21 = 1.0d0 rad22 = 1.0d0 rad23 = 1.0d0 rad24 = 1.0d0 if(r1x(iw).ne.xg.or.r1y(iw).ne.yg) * rad11 = (xg-r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.yg) * rad12 = (xg+r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.xg.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad13 = (xg-r1x(iw))**2 + (yg+r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad14 = (xg+r1x(iw))**2 + (yg+r1y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.yg) * rad21 = (xg-r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.yg) * rad22 = (xg+r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad23 = (xg-r2x(iw))**2 + (yg+r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad24 = (xg+r2x(iw))**2 + (yg+r2y(iw))**2 c Calculate the Field of the image charges: efxa(i,j) = efxa(i,j) + * charge*coef*qgrid(k,l)* * ( * (xg-r1x(iw))/rad11 * + (xg+r1x(iw))/rad12 * + (xg-r1x(iw))/rad13 * + (xg+r1x(iw))/rad14 * + (xg-r2x(iw))/rad21 * + (xg+r2x(iw))/rad22 * + (xg-r2x(iw))/rad23 * + (xg+r2x(iw))/rad24 * )/ 4.0d0 efya(i,j) = efya(i,j) + * charge*coef*qgrid(k,l)* * ( * (yg-r1y(iw))/rad11 * + (yg-r1y(iw))/rad12 * + (yg+r1y(iw))/rad13 * + (yg+r1y(iw))/rad14 * + (yg-r2y(iw))/rad21 * + (yg-r2y(iw))/rad22 * + (yg+r2y(iw))/rad23 * + (yg+r2y(iw))/rad24 * )/4.0d0 110 continue endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 108 if(i.eq.ngrid2.and.j.eq.ngrid2) qgrid(k,l) = 0.0 107 continue 106 continue endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c image charges for rectangular chamber cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.4) then deltagridx = (4*xbound)/real(ngridffts) deltagridy = (4*ymbound)/real(ngridffts) ratiodelta = (deltagridx/deltagridy)**2 do 1067 l = 1, ngridffts/2 do 1066 k = 1, ngridffts/2 if (k.ne.1.or.l.ne.1) then ukl(k,l) = acoef(k,l)*deltagridx/deltagridy/ & (2.*(cos(pi*real(k-1)/ngridffts)+ & ratiodelta*cos(pi*real(l-1)/ngridffts) & -1.-ratiodelta)) endif 1066 end do 1067 end do do 1069 l = 1, ngridffts/2 do 1068 k = 1, ngridffts/2 dkx = pi*real(k-1)/(xbound*2) dky = pi*real(l-1)/(ymbound*2) if (k.ne.1.or.l.ne.1) then efxa(i,j) = efxa(i,j) - coef * ukl(k,l) * dkx * * cos(dkx*(xg+xbound)) * * sin(dky*(yg+ymbound)) efya(i,j) = efya(i,j) - coef * ukl(k,l) * dky * * sin(dkx*(xg+xbound)) * * cos(dky*(yg+ymbound)) endif 1068 end do 1069 end do endif c Testing the image charge routine for the wave guide mode: c write(*,*) "T-f:",j, c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential field on the elliptical boundary: c write(*,*) "Test-f:", j, c * rtx*efxa(i,j)+rty*efya(i,j), c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential E-field on the circular boundary: c if(abs(xbound**2-xg**2-yg**2).lt.1.0e-12) then c write(*,*) "Image: ",xg,yg c write(*,*) (yg*efxa(i,j)-xg*efya(i,j))/ c * sqrt(xg**2+yg**2)/coef c endif c if(efya(i,j).ne.0.0) write(*,*) "Test: ", i, j, efya(i,j) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' efxy = ',efya(i,j),efxa(i,j),i,j c dprodperp = efxa(i,j)*dn1n+efya(i,j)*dn2n c dprodpar = efxa(i,j)*dm1n+efya(i,j)*dm2n c write(444,9444) xg,yg,dprodperp,dprodpar c 9444 format(4(1x,e12.4)) 105 continue 104 continue close(444) c Calculating the potential between the two conductors of the c wave guide geometry due to image charges: if(iimage.eq.1.and.igeom.eq.3) then voltx = 0.0d0 volty = 0.0d0 voltz = 0.0d0 do 203 i=0,ngrid2 if(i*xbound/ngrid2.lt.rbound) goto 203 if(i*xbound/ngrid2.gt.xbound) goto 203 voltx = voltx - elmass*xbound*efxa(i,0)/ngrid2/ el volty = volty - elmass*xbound*efya(0,i)/ngrid2/ el c voltz = voltz - c * elmass*xbound*(efxa(i,i)+efya(i,i))/ngrid2/el voltq = -el*qinner*log(xbound/rbound)/ * (2.0d0*pi*eta) 203 continue write(29,fmt='(5e25.5)') t, voltx, volty, voltq c write(*,*) c * "Voltage between boundaries: ",t,voltx,volty,voltq endif c Achtung! c Calculating the potential between the wire and the vacuum chmaber c for electrostatic field: if(iimage.eq.1.and.igeom.ne.3) then voltx = 0.0d0 volty = 0.0d0 voltz = 0.0d0 c Wire in the corner of the liner: do 204 i=ixq,ngrid2 if((sqrt(dble(i)**2+dble(iyq)**2)/ngrid2). * gt.1.0d0) goto 204 voltx = voltx-elmass*xbound*efxa(i,iyq)/ngrid2/el 204 continue do 205 i=iyq,ngrid2 if((sqrt(dble(ixq)**2+dble(i)**2)/ngrid2). * gt.1.0d0) goto 205 if(i*ymbound/ngrid2.gt.ymbound) goto 205 volty = volty-elmass*ymbound*efya(ixq,i)/ngrid2/el 205 continue cc Ploting the electrostatic field: c open(unit=77,file="efield.data",status='unknown') c c do 304 i=0,ngrid2 c do 305 j=0,ngrid2 c if((dble(i)/ngrid2)**2+(dble(j)/ngrid2)**2.gt.1.0d0) c * goto 305 c if(dble(j)*ymbound/ngrid2.gt.ymbound) goto 305 c write(77,*) dble(i)*xbound/ngrid2,dble(j)*ymbound/ngrid2, c * i, j c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17 c c rnorm = sqrt((efxa(i,j)*1.0d-17)**2+ c * (efya(i,j)*1.0d-17)**2) c rlx = 1.0e-4*(efxa(i,j)*1.0d-17)/ rnorm c rly = 1.0e-4*(efya(i,j)*1.0d-17)/ rnorm c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17+rly, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17-rlx c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17+rlx, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17+rly c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17-rly, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17+rlx c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17 c write(77,*) c write(77,*) c 305 continue c 304 continue c do 301 i=1,80 c write(77,*) xbound*cos(pi*i/160), ybound*sin(pi*i/160) c 301 continue c close(unit=77) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc write(29,fmt='(5e25.5)') t, voltx, volty, voltq c write(*,*) c * "Voltage between boundaries: ",t,voltx,volty,voltq endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' end spacecharge2 ' end subroutine offsetkick(j,dkickx,dkicky,yoff,xoff) c purpose: calculates kick on next bunch from disturbed photoelectrons c growth rate is deduced from this kick using Alex Chao's formula c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: parameter (npelm=600000,iybin=500,ngrid=500,ngrid2=10) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm),yp(npelm),zp(npelm),py(npelm),pz(npelm) real*8 px(npelm), dele(npelm), qele(npelm) real*8 ptime(npelm), esign(npelm) real*8 xpt, ypt, zpt, pxt, pyt, pzt integer index(npelm) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 rg, rm1 c oliver 23.6.197:cccccccccccccccccc real*8 bweight(50000) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 bfield, el, vl, fom, pi, re, elmass real*8 ppb, bl, sb, sx, sy real*8 circum real*8 volt, qouter, qinner real*8 wgl, wk, vtem, vtem0 real*8 voltx, volty real*8 qacc real*8 xt, yt integer iscatter common / bunch / bweight ccccccccccccccccccccccccccccccccccccccccccccccc c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / def4 / circum common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c Oliver 18.06.1997: common / egain / dele, qele ccccccccccccccccccccccccccccc c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave c 01.07.1997 Oliver: adding an TEM field: common / def9 / wgl, wk, vtem, vtem0 ccccccccccccccccccccccccccccccccccccccccccccccc common / beam / rg, rm1 common / immage / iimage, iimageb, interspace, igeom common / wgvolt / voltx, volty common / delay / iscatter c Achtung! npstep = 1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc write(*,*) ' off = ',xoff,yoff factor = ppb * re * vl & * sqrt(2.0d0*pi) if (iscatter.eq.1) then factor = - factor endif c not generating new photoelectrons here rp = 1.4d-18 dt = bl/vl dtex = bl/vl/real(nostep) t = t + dt if (ibend.eq.5) then a1 = (dtex-1.d0/fom*sin(fom*dtex))/fom a2 = 1.d0 a3 = (1.d0-cos(fom*dtex))/fom a4 = sin(fom*dtex)/fom b1 = (1.d0-cos(fom*dtex))/fom**2 b2 = 1.d0 b3 = sin(fom*dtex)/fom b4 = (cos(fom*dtex)-1.)/fom c1 = (1.d0-cos(fom*dtex))/fom c2 = sin(fom*dtex) c3 = cos(fom*dtex) d1 = sin(fom*dtex)/fom d2 = cos(fom*dtex) d3 = -sin(fom*dtex) endif dkickx = 0.d0 dkicky = 0.d0 do 10 ib = 1, nostep do 11 i = 1, icount if (index(i).eq.0.and.(q(i).gt.0)) then xt = x(i) yt = y(i) zt = z(i) xpt = xp(i) ypt = yp(i) zpt = zp(i) c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = gammaf(velt)*ypt pxt = gammaf(velt)*xpt pzt = gammaf(velt)*zpt c space charge if (ispace.eq.1) then radi = sqrt(xt*xt+yt*yt) do 12 j1 = 1, ngrid if (radi.lt.rad(j1)) then c 19.08.1997 Oliver: Changing the interpolation routine. c Frank: c ef = efield(j1-1)+(radi-rad(j1))/ c & (rad(j1)-rad(j1-1))*efield(j1) c Oliver: ef = efield(j1-1)+(radi-rad(j1-1))/ & (rad(j1)-rad(j1-1))*(efield(j1)-efield(j1-1)) goto 200 endif 12 continue ef = 0. 200 continue dpx = xt/radi*ef*dtex dpy = yt/radi*ef*dtex c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.0) then pxt = pxt + dpx pyt = pyt + dpy gamma = sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xpt = pxt/gamma ypt = pyt/gamma zpt = pzt/gamma endif if (ibend.eq.1) then pyt = pyt + dpy gamma = sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xpt = pxt/gamma ypt = pyt/gamma zpt = pzt/gamma endif endif c 18.8.1997 Oliver: New spacecharge routine. if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xt/xbound) indy = nint(ngrid2*yt/ymbound) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1201 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif dpx = sign(efx3,xt)*dtex dpy = sign(efy3,yt)*dtex 1201 continue c end space charge c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.0) then pxt = pxt + dpx pyt = pyt + dpy gamma = sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xpt = pxt/gamma ypt = pyt/gamma zpt = pzt/gamma endif if (ibend.eq.1) then pyt = pyt + dpy gamma = sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl xpt = pxt/gamma ypt = pyt/gamma zpt = pzt/gamma endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c end space charge yt = yt xt = xt xta = abs(xt-xoff) yta = abs(yt-yoff) if (ibeam.eq.1.and.iwave.eq.0) then if(iimageb.ne.1) call ffrank(xt,yt,xoff,yoff,sx,sy,pre,pim) if(iimageb.eq.1) call foliver(xt,yt,xoff,yoff,sx,sy,rg,rm1, & pre,pim) c call bbkick(pre,pim,xta,yta,sx,sy) c Oliver 23.06.1997: Introducing arbitrary bunch distributions: pim = pim * bweight(ib) * nbstep pre = pre * bweight(ib) * nbstep c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.1) then dpx = 0.0d0 else if (ibend.eq.0.or.ibend.eq.5.or.ibend.eq.4) then dpx = - pim * factor * (xt-xoff)/xta endif dpy = - pre * factor * (yt-yoff)/yta deltax = dpx / dt deltay = dpy / dt + el*volt/ elmass endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 30.07.1997: Introducing the kick from a TEM wave: if (ibeam.eq.1.and.iwave.eq.1) then call tem(xt,yt,wk,t,wgl,pre,pim) c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.0.or.ibend.eq.5.or.ibend.eq.4) then dpx = el * (vtem * pim) * dtex/ elmass else if (ibend.eq.1) then dpx = 0.d0 endif dpy = el * (vtem * pre) * dtex/ elmass c No ground connection -> floating voltage between inner and outer conducter if(vtem0.ge.1.0d-5) then deltax = dpx / dtex deltay = dpy / dtex endif c Ground connection -> fixed voltage between inner and outer conducter. if(vtem0.ne.1.0d-5) then deltax = dpx / dtex - * el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2)/elmass deltay = dpy / dtex - * el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2)/elmass endif endif c Oliver 23.07.1998: Introducing the kick from a TEM wave: if (ibeam.eq.1.and.iwave.eq.2) then call tem6(xt,yt,wk,t,wgl,rbound,xbound,pre,pim) c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.0.or.ibend.eq.5.or.ibend.eq.4) then dpx = el * (vtem * pim) * dtex/ elmass else if (ibend.eq.1) then dpx = 0.d0 endif dpy = el * (vtem * pre) * dtex/ elmass c No ground connection -> floating voltage between inner and outer conducter if(vtem0.ge.1.0d-5) then deltax = dpx / dtex deltay = dpy / dtex endif c Ground connection -> fixed voltage between inner and outer conducter. if(vtem0.ne.1.0d-5) then deltax = dpx / dtex - * el*(vtem0-(voltx+volty)/2.0d0)*xt/(xt**2+yt**2)/elmass deltay = dpy / dtex - * el*(vtem0-(voltx+volty)/2.0d0)*yt/(xt**2+yt**2)/elmass endif endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dkickx=dkickx+(xt-xoff)/xta*pim*factor/ppb*q(i)/ & real(nostep) /re/vl/ppb*circum/belen dkicky=dkicky+(yt-yoff)/yta*pre*factor/ppb*q(i)/ & real(nostep)/re/vl/ppb*circum/belen endif c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.1) then c z(i) = deltax*a1+a2*zt+a3*xpt+a4*zpt c x(i) = xoff + deltax*b1+b2*xt+b3*xpt+b4*zpt c zp(i) = deltax*c1+c2*xpt+c3*zpt c xp(i) = deltax*d1+d2*xpt+d3*zpt c px(i) = pxt + deltax*dtex c py(i) = pyt + deltay*dtex c pz(i) = pzt c gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c xp(i) = px(i)/gamma c yp(i) = py(i)/gamma c zp(i) = pz(i)/gamma py(i) = pyt + deltay*dtex yp(i) = py(i)/sqrt(1.0d0+(py(i)/vl)**2) y(i) = yt + yoff + (yp(i)+ypt)/2.0d0 * dtex cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else px(i) = pxt + deltax*dtex py(i) = pyt + deltay*dtex pz(i) = pzt gamma = sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + xoff + (xp(i)+xpt)/2.0d0 * dtex y(i) = yt + yoff + (yp(i)+ypt)/2.0d0 * dtex c z(i) = zt + (zp(i)+zpt)/2.0d0 * dtex endif c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(i)/xbound)**2+(y(i)/ybound)**2 amp2 = (x(i)**2+y(i)**2)/ rbound**2 if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif if (amp.gt.1.and.iloss.eq.1) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qouter = qouter - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qouter = qouter + qtnew endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.eq.1) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qinner = qinner - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qinner = qinner + qtnew endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 18.06.1997: setting the energy increase to zero once a particle is lost. if (q(i).eq.0.0) dele(i) = 0.0 if (q(i).eq.0.0) qele(i) = 0.0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 11 continue 10 continue end subroutine spacecharge3 c fixed several bugs of previous version c 29.08.99 frankz c purpose: New space charge routine that uses a two dimensional Mesh c for the field calculation and allows the evaluation of the c effect of image charges on the boundary. c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,ngrid2=10,nimage=50,nimage2=4) parameter(eta=8.8542d-12) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) real*8 rolimit, rilimit parameter(rolimit=0.97d0,rilimit=1.02d0) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 px(npelm), pz(npelm), py(npelm) real*8 ptime(npelm), esign(npelm) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) real*8 r1x(0:nimage2),r1y(0:nimage2),r2x(0:nimage2),r2y(0:nimage2) real*8 rg, rm1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 voltx, volty real*8 rmax, rmin real*8 rm0 real*8 rphi, rphi0, rphi1, rphi2, rphi3 real*8 xl, yl c Complex variables for the calculation of the elliptical coordinates: complex*16 z1, z2, z3, z4, zi, zone complex*16 efz1(0:ngrid2,0:ngrid2), efz complex*16 zeric,zdiv,zr,zri,zzr,zzri common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / image / iimage, iimageb, interspace, igeom common / beam / rg, rm1 common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c c parameter for avoiding zero charge and grid points epsi=1.d-5 write(*,*) ' enter sc 3 ' open(444,file="esc.check.data") charge = 1.0d0 coef = 2.0d0*re*vl*vl/belen ymbound = min(ybound,zbound) amp = sqrt(xbound**2+ymbound**2) rmax = max(xbound,ymbound) rmin = min(xbound,ymbound) zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) if(igeom.eq.2) then rg = sqrt(rmax**2 - rmin**2) rm1 = log((rmax+rmin)/(rmax-rmin))/2.0d0 endif c testx = rg*(exp(rm1)+exp(-rm1))/2.0d0 c testy = rg*(exp(rm1)-exp(-rm1))/2.0d0 c write(*,*) "Test1: ",testx, testy write(*,*) ' icount ',icount c Distributing the charge on the grid: do 103 i=1,icount c write(*,*) ' i ',i,icount c c frank: i do not understand the abs( ) - correct for quads? linx = nint(ngrid2*x(i)/xbound) liny = nint(ngrid2*y(i)/ymbound) deltaxx = xbound/real(ngrid2) deltayy = ymbound/real(ngrid2) c Avoiding charges which are outside the boundary for the c image charge calculation: rl1 = (dble(linx)/dble(ngrid2))**2+(dble(liny)/dble(ngrid2))**2 if (rl1.gt.rolimit) then c write(*,*) "Changing the mesh position 1 from: ",linx,liny 331 rl2 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 rl3 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 rl4 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 if(rl2.gt.rolimit) rl2 = 0.0 if(rl3.gt.rolimit) rl3 = 0.0 if(rl4.gt.rolimit) rl4 = 0.0 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).gt.0) * linx = linx - 1 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).lt.0) * linx = linx + 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).gt.0) * liny = liny - 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).lt.0) * liny = liny + 1 if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx - 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx - 1 liny = liny + 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx + 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx + 1 liny = liny + 1 endif c if(linx.lt.0) linx = 0 c if(liny.lt.0) liny = 0 rl1 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 if(rl1.gt.rolimit) goto 331 c write(*,*) " to : ",linx,liny endif c write(*,*) ' linx,y = ',linx,liny c Avoiding charges which are inside the inner conductor for the c image charge calculation with a wave guide geometry: rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit.and.igeom.eq.3.and.iimage.eq.1) then c write(*,*) "Changing the mesh position 2 from: ",linx,liny 332 if(linx.le.nint(ngrid2*rbound/xbound)) linx = linx + 1 if(liny.le.nint(ngrid2*rbound/ymbound)) liny = liny + 1 if(linx.gt.ngrid2) linx = ngrid2 - 1 if(liny.gt.ngrid2) liny = ngrid2 - 1 rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit) goto 332 c write(*,*) " to : ",linx,liny endif if (abs(linx).le.ngrid2.and.abs(liny).le.ngrid2) then qgrid(linx,liny) = qgrid(linx,liny) + q(i) endif 103 continue ind0 = 0 density = qgrid(ind0,ind0)/(deltaxx*deltayy*belen) open(990,file="density.dat") write(990,*) density close(990) c Achtung! c Introducing a wire with negative charge in the corner of the chamber: c ixq = 14 c iyq = 18 c qgrid(ixq,iyq) = qgrid(ixq,iyq) + volt*1.0e10 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Generating the Field-Mesh: open(1090,file="efxy.dat") open(1092,file="eygrad.dat") c write(*,*) ' start 104 loop = ' do 104 i=-ngrid2,ngrid2 xg = i*xbound/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(xg).lt.epsi) * xg = epsi do 105 j=-ngrid2,ngrid2 efxa(i,j) = 0.0d0 efya(i,j) = 0.0d0 yg = j*ymbound/ngrid2+1.e-20 c if (j.eq.0) then c yg = ymbound*sqrt(1.-(xg/xbound)**2) c else if (j.eq.1) then c yg = -ymbound*sqrt(1.-(xg/xbound)**2) c endif c if (abs(xg).lt.xbound) then c dn1 = ymbound/xbound*xg/sqrt(xbound**2-xg**2) c dn2 = 1. c dnnorm = sqrt(dn1*dn1+dn2*dn2) c if (xg.gt.0.and.yg.ge.0) then c dn1n=-dn1/dnnorm c dn2n=-dn2/dnnorm c dm1n=dn2/dnnorm c dm2n=-dn1/dnnorm c else if (xg.lt.0.and.yg.ge.0) then c dn1n=-dn1/dnnorm c dn2n=-dn2/dnnorm c dm1n=-dn2/dnnorm c dm2n=dn1/dnnorm c else if (xg.gt.0.and.yg.lt.0) then c dn1n=-dn1/dnnorm c dn2n=dn2/dnnorm c dm1n=dn2/dnnorm c dm2n=dn1/dnnorm c else if (xg.lt.0.and.yg.lt.0) then c dn1n=-dn1/dnnorm c dn2n=dn2/dnnorm c dm1n=-dn2/dnnorm c dm2n=-dn1/dnnorm c endif c else if (xg.eq.(-xbound)) then c dn1n= 1. c dn2 = 0. c else if (xg.eq.xbound) then c dn1n= -1. c dn2 = 0. c endif c write(*,*) ' 104 loop, i,j = ',i,j c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(yg).lt.epsi) * yg = epsi c Test lines: c This Test calculates the tangential field on the elliptical boundary. c xg = rbound*cos(2*pi*j/ngrid2) c yg = rbound*sin(2*pi*j/ngrid2) c rnx = xg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rny = yg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rtx = rny c rty = -rnx c xg = rmax*cos(2*pi*j/ngrid2) c yg = rmin*sin(2*pi*j/ngrid2) c rnx = xg/ rmax**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rny = yg/ rmin**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rtx = rny c rty = -rnx cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Calculate the elliptic coordinates for the image charge calculation: if(iimage.eq.1.and.igeom.eq.2) then z1 = xg/rg * zone + yg/rg * zi z2 = xg/rg * zone - yg/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 if(rphi*yg.lt.0.0d0) rphi = -rphi c write(*,*) ' rphi = ',rphi c if (xg.lt.0.and.yg.ge.0) then c rphi = rphi + pi/2. c else if (xg.lt.0.and.yg.lt.0) then c rphi = rphi - pi c else if (xg.ge.0.and.yg.lt.0) then c rphi = rphi - pi/2. c endif c testx = rg*(exp(rmi)+exp(-rmi))*cos(rphi)/2.0d0 c testy = rg*(exp(rmi)-exp(-rmi))*sin(rphi)/2.0d0 c write(*,*) "Testi: ",testx, xg, testy, yg endif do 106 k=-ngrid2,ngrid2 xl = k*rmax/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(xl).lt.epsi) * xl = epsi do 107 l=-ngrid2,ngrid2 if(qgrid(k,l).ne.0.0) then charge = 1.0d0 yl = l*rmin/ngrid2 c write(*,*) ' 107 loop, i,j,k,l = ',i,j,k,l c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: if(iimage.eq.1.and.igeom.eq.2.and.abs(yl).lt.epsi) * yl = epsi rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 if(abs(xl-xg).gt.epsi.or.abs(yl-yg).gt.epsi) * rad1 = (xg-xl)**2 + (yg-yl)**2 c if(yl.ne.yg.or.xl.ne.0.0.or.xg.ne.0.0) c * rad2 = (xg+xl)**2 + (yg-yl)**2 c if(xl.ne.xg.or.yl.ne.0.0.or.yg.ne.0.0) c * rad3 = (xg-xl)**2 + (yg+yl)**2 c if(xg.ne.0.0.or.xl.ne.0.0.or.yl.ne.0.0.or.yg.ne.0.0) c * rad4 = (xg+xl)**2 + (yg+yl)**2 efxa(i,j) = * efxa(i,j) + coef * qgrid(k,l) * * (xg-xl)/ rad1 c * + (xg+xl)/ rad2 c * + (xg-xl)/ rad3 c * + (xg+xl)/ rad4 )/ 4.0d0 efya(i,j) = * efya(i,j) + coef * qgrid(k,l) * * (yg-yl)/ rad1 c * + (yg-yl)/ rad2 c * + (yg+yl)/ rad3 c * + (yg+yl)/ rad4 )/ 4.0d0 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for an elliptical vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.2) then c Introducing complex notation for the electric field. c Calculate the elliptical coordinates ('rm' and 'phi') c of the charge on the mesh: z1 = xl/rg * zone + yl/rg * zi z2 = xl/rg * zone - yl/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rm0 = dabs(dreal(z3+z4)/2.0d0) rphi0 = dreal((z4-z3)*zi)/2.0d0 if(rphi0*yl.lt.0.0d0) rphi0 = -rphi0 c write(*,*) ' rphi0 = ',rphi c if (xl.lt.0.and.yl.ge.0) then c rphi0 = rphi0 + pi/2. c else if (xl.lt.0.and.yl.lt.0) then c rphi0 = rphi0 - pi c else if (xl.ge.0.and.yl.lt.0) then c rphi0 = rphi0 - pi/2. c endif rphib=rphi0 rmib=rm0 c testx = rg*(exp(rm0)+exp(-rm0))*cos(rphi0)/2.0d0 c testy = rg*(exp(rm0)-exp(-rm0))*sin(rphi0)/2.0d0 c write(*,*) "Test0: ",testx, xl, testy, yl rphi1 = -rphi0 rphi2 = rphi0 + pi rphi3 = -rphi2 c rphi1 = rphi0 c rphi2 = rphi0 c rphi3 = rphi0 const=coef*qgrid(k,l)/rg*2d0 c efz = efxa(i,j) * zone + efya(i,j) * zi efz = (0.,0.) do 114 ii=1,nimage/2 c charge = -1.0d0 charge = 1.0d0 efz = efz+const*charge*dexp(-ii*rm1)*( * (dexp(ii*rmib)+dexp(-ii*rmib))* * cos(ii*rphib)/(dexp(ii*rm1)+dexp(-ii*rm1))+ * zi*(dexp(ii*rmib)-dexp(-ii*rmib))* * sin(ii*rphib)/(dexp(ii*rm1)-dexp(-ii*rm1)))* * (cdexp(ii*(rmi*zone-rphi*zi))- * cdexp(-ii*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi))- * cdexp(-(rmi*zone-rphi*zi))) 114 continue efxa(i,j)=efxa(i,j)+dreal(efz) efya(i,j)=efya(i,j)+dreal(-efz*zi) cc goto 1113 cc do 109 ii=2,nimage,2 c print *,' ii ',ii,' E ',efz1(i,j) c print *,' looping ' cc erm0=exp(ii*rm0) cc erm1=exp(ii*rm1) cc rireal=ii*rreal cc riimag=ii*rimag c zri=ii*zr c print *,' zri ',zri,rireal,riimag c zzri=cdexp(zri)-(1d0,0d0)/cdexp(zri) cc rz1real=exp(rireal)*cos(riimag) cc rz1imag=exp(rireal)*sin(riimag) cc e2f2=rz1real*rz1real+rz1imag*rz1imag cc rzireal=rz1real-rz1real/e2f2 cc rziimag=rz1imag+rz1imag/e2f2 c print *,' rzi ',zzri,rzireal,rziimag cc eric=(erm0+1d0/erm0)/erm1*cos(ii*rphi0)/(erm1+1d0/erm1) c zeric=zeric + eric * zzri / zzr c a+ib/c+id=ac/(c2+d2)+bd/c2+d2)+( bc/(c2+d2)-ad/(c2+d2) )i cc ericreal=ericreal+eric*(rzireal*rzreal+rziimag*rzimag)/c2d2 cc ericimag=ericimag+eric*(rziimag*rzreal-rzireal*rzimag)/c2d2 c print *,' eric ',zeric,ericreal,ericimag cc 109 continue c 1113 continue c efz1(i,j) = efz1(i,j)+const*zeric cc efxa(i,j) = efxa(i,j)+const*ericreal cc efya(i,j) = efya(i,j)+const*ericimag c Transforming back to cartesian coordinates: c efxa(i,j) = dreal(efz1(i,j)) c efya(i,j) = dreal(-efz1(i,j)*zi) endif cc 1113 continue c write(*,*) ' space charge and image= ',efxa(i,j),ericreal,const ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for a circular vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.1) then scale = sqrt(xl**2+yl**2)/xbound if(scale.lt.epsi) goto 108 xim = xl/scale**2 yim = yl/scale**2 rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 if(abs(xim-xg).gt.epsi.or.abs(yim-yg).gt.epsi) * rad1 = (xg-xim)**2 + (yg-yim)**2 c if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.yg) c * rad2 = (xg+xim)**2 + (yg-yim)**2 c if(xim.ne.xg.or.yim.ne.0.0.or.yg.ne.0.0) c * rad3 = (xg-xim)**2 + (yg+yim)**2 c if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.0.0.or.yg.ne.0.0) c * rad4 = (xg+xim)**2 + (yg+yim)**2 efxa(i,j) = efxa(i,j) * - coef * qgrid(k,l)*(xg-xim)/ rad1 c * - coef * qgrid(k,l)*(xg+xim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(xg-xim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(xg+xim)/ rad4/ 4.0d0 efya(i,j) = efya(i,j) * - coef * qgrid(k,l)*(yg-yim)/ rad1 c * - coef * qgrid(k,l)*(yg-yim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad4/ 4.0d0 endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for the wave guide geometry: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.3) then r1x(0) = xl r1y(0) = yl r2x(0) = xl r2y(0) = yl do 110 iw=1,nimage2 charge = -charge c Position of the image charge at the outer boundary (rmax): scale = dsqrt(r2x(iw-1)**2+r2y(iw-1)**2)/rmax if(scale.eq.0.0) goto 208 r1x(iw) = r2x(iw-1)/scale**2 r1y(iw) = r2y(iw-1)/scale**2 c Position of the image charge at the inner boundary (rmin): 208 scale = dsqrt(r1x(iw-1)**2+r1y(iw-1)**2)/rbound if(scale.eq.0.0) goto 108 r2x(iw) = r1x(iw-1)/scale**2 r2y(iw) = r1y(iw-1)/scale**2 rad11 = 1.0d0 rad12 = 1.0d0 rad13 = 1.0d0 rad14 = 1.0d0 rad21 = 1.0d0 rad22 = 1.0d0 rad23 = 1.0d0 rad24 = 1.0d0 if(r1x(iw).ne.xg.or.r1y(iw).ne.yg) * rad11 = (xg-r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.yg) * rad12 = (xg+r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.xg.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad13 = (xg-r1x(iw))**2 + (yg+r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad14 = (xg+r1x(iw))**2 + (yg+r1y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.yg) * rad21 = (xg-r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.yg) * rad22 = (xg+r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad23 = (xg-r2x(iw))**2 + (yg+r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad24 = (xg+r2x(iw))**2 + (yg+r2y(iw))**2 c Calculate the Field of the image charges: efxa(i,j) = efxa(i,j) + * charge*coef*qgrid(k,l)* * ( * (xg-r1x(iw))/rad11 * + (xg+r1x(iw))/rad12 * + (xg-r1x(iw))/rad13 * + (xg+r1x(iw))/rad14 * + (xg-r2x(iw))/rad21 * + (xg+r2x(iw))/rad22 * + (xg-r2x(iw))/rad23 * + (xg+r2x(iw))/rad24 * )/ 4.0d0 efya(i,j) = efya(i,j) + * charge*coef*qgrid(k,l)* * ( * (yg-r1y(iw))/rad11 * + (yg-r1y(iw))/rad12 * + (yg+r1y(iw))/rad13 * + (yg+r1y(iw))/rad14 * + (yg-r2y(iw))/rad21 * + (yg-r2y(iw))/rad22 * + (yg+r2y(iw))/rad23 * + (yg+r2y(iw))/rad24 * )/4.0d0 110 continue endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 108 continue c if(i.eq.ngrid2.and.j.eq.ngrid2) qgrid(k,l) = 0.0 107 continue 106 continue c Testing the image charge routine for the wave guide mode: c write(*,*) "T-f:",j, c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential field on the elliptical boundary: c write(*,*) "Test-f:", j, c * rtx*efxa(i,j)+rty*efya(i,j), c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential E-field on the circular boundary: c if(abs(xbound**2-xg**2-yg**2).lt.1.0e-12) then c write(*,*) "Image: ",xg,yg c write(*,*) (yg*efxa(i,j)-xg*efya(i,j))/ c * sqrt(xg**2+yg**2)/coef c endif c if(efya(i,j).ne.0.0) write(*,*) "Test: ", i, j, efya(i,j) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' efxy = ',efya(i,j),efxa(i,j),i,j c dprodperp = efxa(i,j)*dn1n+efya(i,j)*dn2n c dprodpar = efxa(i,j)*dm1n+efya(i,j)*dm2n c write(444,9444) xg,yg,dprodperp,dprodpar c 9444 format(4(1x,e12.4)) 105 continue 104 continue xmin = -xbound xmax = +xbound nstep = 200 xstep = (xmax-xmin)/real(nstep) xt = 1.e-20 n3 = nstep/2 n2 = n3-10 n1 = n3-20 n0 = n3-30 n4 = n3+10 n5 = n3+20 n6 = n3+30 do ifx = 1, nstep-1 yt = xmin + real(ifx)*xstep indx = nint(ngrid2*xt/xbound) indy = nint(ngrid2*yt/ymbound) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 c Bivariate linear Interpolation: efx1=0. efx2=0. efx3=0. efy1=0. efy2=0. efy3=0. if(abs(indx).lt.ngrid2.and.abs(indy).lt.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif c frank e-field c radxtyt = sqrt(xt*xt+yt*yt) c field in V/m c efieldmag = 1.e6 c domegaf = 1.e10 c efmag = sqrt(1.-radxtyt**2/xbound**2)*efieldmag*sin(domegaf*t) c dpx = dpx + efmag*(xt/radxtyt) c dpy = dpy + efmag*(yt/radxtyt) c endif c end space charge efx3 = efx3*5.7e-12 efy3 = efy3*5.7e-12 write(1090,1091) xt,yt,efx3,efy3 1091 format(4(1x,e12.5)) if (ifx.eq.n0) then yef0 = yt efy30 = efy3 endif if (ifx.eq.n1) then yef1 = yt efy31 = efy3 endif if (ifx.eq.n2) then yef2 = yt efy32 = efy3 endif if (ifx.eq.n4) then yef4 = yt efy34 = efy3 endif if (ifx.eq.n5) then yef5 = yt efy35 = efy3 endif if (ifx.eq.n6) then yef6 = yt efy36 = efy3 endif end do if (((yef5-yef1).ne.0).and.((yef4-yef2).ne.0.). & and.((yef6-yef0).ne.0)) then efgrad = ((efy35-efy31)/(yef5-yef1)+ & (efy34-efy32)/(yef4-yef2)+ & (efy36-efy30)/(yef6-yef0))/3. else efgrad = 0. endif close(1090) close(444) write (1092,*) ' ey gradient = ', efgrad , ' V/m' close(1092) end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine fourn(data,nn,ndim,isign) implicit real*8 (a-h,o-z) c purpose: perform 2-D complex fft c Numerical Recipes, Fortran, p. 518 c integer isign, ndim, nn(ndim) real*8 data (*) c replaces data by its ndim. discrete Fourier c transform c ndim is integer array whose entries must c all be powers of two c isign=-1 performs inverse transformation integer i1,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2,ip1,ip2, & ip3,k1,k2,n,nprev,nrem,ntot real*8 tempi,tempr real*8 theta,wi,wpi,wpr,wr,wtemp c ncheck = nn(1)*nn(2) c do j = 1, ncheck c write(*,*) j,data(j) c end do ntot=1 do 11 idim=1,ndim ntot=ntot*nn(idim) 11 end do nprev=1 do 18 idim=1,ndim n=nn(idim) nrem=ntot/(n*nprev) ip1=2*nprev ip2=ip1*n ip3=ip2*nrem i2rev=1 do 14 i2=1,ip2,ip1 if(i2.lt.i2rev)then do 13 i1=i2,i2+ip1-2,2 do 12 i3=i1,ip3,ip2 i3rev=i2rev+i3-i2 tempr=data(i3) tempi=data(i3+1) data(i3)=data(i3rev) data(i3+1)=data(i3rev+1) data(i3rev)=tempr data(i3rev+1)=tempi 12 end do 13 end do endif ibit=ip2/2 1 if((ibit.ge.ip1).and.(i2rev.gt.ibit))then i2rev=i2rev-ibit ibit=ibit/2 goto 1 endif i2rev=i2rev+ibit 14 end do ifp1=ip1 2 if(ifp1.lt.ip2)then ifp2=2*ifp1 theta=isign*6.28318530717959d0/(ifp2/ip1) wpr=-2.d0*sin(0.5d0*theta)**2 wpi=sin(theta) wr=1.d0 wi=0.d0 do 17 i3=1,ifp1,ip1 do 16 i1=i3,i3+ip1-2,2 do 15 i2=i1,ip3,ifp2 k1=i2 k2=k1+ifp1 tempr=(wr)*data(k2)-(wi)*data(k2+1) tempi=(wr)*data(k2+1)+(wi)*data(k2) data(k2)=data(k1)-tempr data(k2+1)=data(k1+1)-tempi data(k1)=data(k1)+tempr data(k1+1)=data(k1+1)+tempi 15 end do 16 end do wtemp=wr wr=wr*wpr-wi*wpi+wr wi=wi*wpr+wtemp*wpi+wi 17 end do ifp1=ifp2 goto 2 endif nprev=n*nprev 18 enddo return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine rlft3(data1,speq,nn1,nn2,nn3,isign) implicit real*8 (a-h,o-z) integer isign, nn1, nn2, nn3 parameter ( & ngridffts=32,ngridfft=3200) c complex*16 data(nn1/2,nn2,nn3),speq(nn2,nn3) complex*16 data1(ngridffts/2,ngridffts,1),speq(ngridffts,1) c uses fourn c Numerical Recipes Fortran, p. 522 c given a 2- or 3-dim real data array with dim. nn1, nn2, nn3, c (nn3=1 for 2-dim array), returns (isign=1) the complax fast c fourier transformas two complex arrays: c on output, data contains the zero and positive frequency values c of the 1st frequency component, while speq contains the Nyquist c critical frequency values for the 1st frequency component. c second and third frequency components are stored in standard c wrap-around order. For isign=-1 inverse transform is calculated c (times nn1*nn2*nn3/2 as multiplicative factor). c nn1,nn2,and nn3 must always be multiples of 2. integer i1,i2,i3,j1,j2,j3,nn(3) real*8 theta,wi,wpi,wpr,wr,wtemp complex*16 c1,c2,h1,h2,w write(*,*) ' in rlft3 ' write(*,*) ' nn1 =',nn1 write(*,*) ' nn2 =',nn2 write(*,*) ' nn3 =',nn3 write(*,*) ' isign =',isign do j = 1, nn2 do i = 1, nn1/2 c if (data1(i,j,1).ne.(0.,0.)) then c write(*,*) i,j,data1(i,j,1) c endif end do end do c1 = cmplx(0.5,0.) c2 = cmplx(0.0,-0.5*isign) theta=6.28318530717959d0/dble(isign*nn1) wpr=-2.0d0*sin(0.5d0*theta)**2 wpi=dsin(theta) nn(1) = nn1/2 nn(2) = nn2 nn(3) = nn3 if(isign.eq.1) then call fourn(data1,nn,3,isign) do 12 i3=1,nn3 do 11 i2=1,nn2 speq(i2,i3)=data1(1,i2,i3) 11 end do 12 end do endif do 15 i3=1,nn3 j3=1 if(i3.ne.1) j3=nn3-i3+2 wr=1.0d0 wi=0.0d0 do 14 i1=1,nn1/4+1 j1=nn1/2-i1+2 do 13 i2=1,nn2 j2=1 if(i2.ne.1) j2=nn2-i2+2 if(i1.eq.1)then h1=c1*(data1(1,i2,i3)+conjg(speq(j2,j3))) h2=c2*(data1(1,i2,i3)-conjg(speq(j2,j3))) data1(1,i2,i3)=h1+h2 speq(j2,j3)=conjg(h1-h2) else h1=c1*(data1(i1,i2,i3)+conjg(data1(j1,j2,j3))) h2=c2*(data1(i1,i2,i3)-conjg(data1(j1,j2,j3))) data1(i1,i2,i3)=h1+w*h2 data1(j1,j2,j3)=conjg(h1-w*h2) endif 13 end do wtemp=wr wr=wr*wpr-wi*wpi+wr wi=wi*wpr+wtemp*wpi+wi w=cmplx(wr,wi) 14 end do 15 end do if (isign.eq.-1) then call fourn(data1,nn,3,isign) endif write(*,*) ' end of rlft3 ' do j = 1, nn2 do i = 1, nn1/2 c if (data1(i,j,1).ne.(0.,0.)) then c write(*,*) i,j,data1(i,j,1) c endif end do end do return end c---------------------------------------------------------- c This program calculates the beam-beam-kick with image charges for c an elliptical boundary. c c 25.08.99 FZ, include offset xof, yof for correct treatment c of image charges c subroutine foliver(x,y,xof,yof,sx,sy,rg,rm1,fr,fi) implicit real*8 (a-h,o-z) c implicit integer (a-z) parameter(nimage=30) double precision xt,yt real*8 x,y,sx,sy,rg,rm1,fr,fi, efx, efy, r2 complex*16 zone, zi, z1, z2, z3, z4, efz complex*16 z1b, z2b, z3b, z4b charge = 1.0d0 zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) c new variables dx = x-xof dy = y-yof c xt = abs(dx) yt = abs(dy) if (xt.lt.(1d-7)) xt=1.d-7 if (yt.lt.(1d-7)) yt=1.d-7 r2 = xt*xt+yt*yt r = dsqrt(r2) c write(*,*) ' in foliver ',dx,dy,sx,sy,rg,rm1 c write(*,*) xof,yof,x,y pi = acos(-1.0d0) res = 2.0d0/sqrt(2.0d0*pi)/r2 resmod = 2./sqrt(2.*pi) sx1 = sx sy1 = sy if (abs((sx/sy)-1.0d0).lt.1.0d-2) then if(r2.le.sx*sy) then co = (1.0d0-exp(-r2/(2.0d0*sx*sy))) fr = res*co*yt fi = res*co*xt return endif if(r2.gt.sx*sy) then efx = dx/ r2 efy = dy/ r2 efz = efx * zone + efy * zi z1 = x/rg * zone + y/rg * zi z2 = x/rg * zone - y/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 c introduce the same quantities for the beam z1b = xof/rg * zone + yof/rg * zi z2b = xof/rg * zone - yof/rg * zi z3b = cdlog(z1b - cdsqrt(z1b**2 - zone)) z4b = cdlog(z2b - cdsqrt(z2b**2 - zone)) rmib = dabs(dreal(z3b+z4b)/2.0d0) rphib = dreal((z4b-z3b)*zi)/2.0d0 if(rphi*y.lt.0.0d0) rphi = -rphi if(rphib*yof.lt.0.0d0) rphib = -rphib do 100 i=1,nimage charge = 1.0d0 if ((xof.eq.0.0).and.(yof.eq.0.0)) then efz = efz+((-1)**i)* * 8.0d0*charge/(dexp(4.0d0*i*rm1)+1.0d0) * * (cdexp(2.0d0*i*(rmi*zone-rphi*zi)) - * cdexp(-2.0d0*i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi)) - * cdexp(-(rmi*zone-rphi*zi)))/ rg else efz = efz+2.d0*charge*dexp(-i*rm1)*( * (dexp(i*rmib)+dexp(-i*rmib))* * cos(i*rphib)/(dexp(i*rm1)+dexp(-i*rm1))+ * zi*(dexp(i*rmib)-dexp(-i*rmib))* * sin(i*rphib)/(dexp(i*rm1)-dexp(-i*rm1)))* * (cdexp(i*(rmi*zone-rphi*zi))- * cdexp(-i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi))- * cdexp(-(rmi*zone-rphi*zi)))/rg endif 100 continue efx = dreal(efz) efy = dreal(-efz*zi) fi = abs(efx)*2.0d0/sqrt(2.0d0*pi) fr = abs(efy)*2.0d0/sqrt(2.0d0*pi) return endif else c flat beam fr2 = resmod * yt/r * co fi2 = resmod * xt/r * co call bbkick(pre1,pre2,pim1,pim2,xt,yt,sx1,sy1) expon = dexp(-xt**2/(2.d0*sx1**2)-yt**2/(2.d0*sy1**2)) fr1 = ( pre1 - expon * pre2 )/ sqrt(sx*sx-sy*sy) fi1 = ( pim1 - expon * pim2 ) / sqrt(sx*sx-sy*sy) fr = fr2 fi = fi2 c den = sqrt((40.*sx)**2+r*r) w1 = 40.*sx/den w2 = 1./den c image charge: use oliver's routine and subtract round-beam kick c and add flat beam kick instead frc = 0. fic = 0. if(r2.gt.sx*sy) then efx = x/ r2 efy = y/ r2 efz = efx * zone + efy * zi z1 = x/rg * zone + y/rg * zi z2 = x/rg * zone - y/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 c introduce the same quantities for the beam z1b = xof/rg * zone + yof/rg * zi z2b = xof/rg * zone - yof/rg * zi z3b = cdlog(z1b - cdsqrt(z1b**2 - zone)) z4b = cdlog(z2b - cdsqrt(z2b**2 - zone)) rmib = dabs(dreal(z3b+z4b)/2.0d0) rphib = dreal((z4b-z3b)*zi)/2.0d0 if(rphi*y.lt.0.0d0) rphi = -rphi if(rphib*yof.lt.0.0d0) rphib = -rphib do 101 i=1,nimage charge = 1.0d0 if ((xof.eq.0.0).and.(yof.eq.0.0)) then efz = efz+((-1)**i)* * 8.0d0*charge/(dexp(4.0d0*i*rm1)+1.0d0) * * (cdexp(2.0d0*i*(rmi*zone-rphi*zi)) - * cdexp(-2.0d0*i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi)) - * cdexp(-(rmi*zone-rphi*zi)))/ rg else efz = efz+2.d0*charge*dexp(-i*rm1)*( * (dexp(i*rmib)+dexp(-i*rmib))* * cos(i*rphib)/(dexp(i*rm1)+dexp(-i*rm1))+ * zi*(dexp(i*rmib)-dexp(-i*rmib))* * sin(i*rphib)/(dexp(i*rm1)-dexp(-i*rm1)))* * (cdexp(i*(rmi*zone-rphi*zi))- * cdexp(-i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi))- * cdexp(-(rmi*zone-rphi*zi)))/rg endif 101 continue efx = dreal(efz) efy = dreal(-efz*zi) firs = abs(efx)*2.0d0/sqrt(2.0d0*pi) frrs = abs(efy)*2.0d0/sqrt(2.0d0*pi) cor = (1.0d0-exp(-r2/(2.0d0*sx*sy))) frr = res*co*yt fir = res*co*xt frc = frrs-frr fic = firs-fir endif c arg = sqrt(sx*sy)/5. c if (r.lt.arg) then c fr = fr1 c fi = fi1 c else fr = w1 * fr1 + w2 * fr2 + frc fi = w1 * fi1 + w2 * fi2 + fic c endif return endif c write(*,*) "Message from foliver: The beams are not round!" end c---------------------------------------------------------- subroutine ffrank(x,y,xof,yof,sx,sy,fr,fi) c 25.08.99 FZ, include offset xof, yof to be c consistent with foliver implicit real*8 (a-h,o-z) c implicit integer (a-z) double precision sx1,sy1,xt,yt real*8 x,y,sx,sy,fr,fi pi = 4.*datan(1.0d0) xt = abs(x-xof) yt = abs(y-yof) r = sqrt(xt*xt+yt*yt) resmod = 2./sqrt(2.*pi) c if (r.gt.(10.0d0*sx)) then pi = 4.0d0*atan(1.0d0) res = 2.0d0/sqrt(2.0d0*pi)/(r*r) sx1 = sx sy1 = sy if (abs((sx/sy)-1.0d0).lt.1.0d-2) then co = (1.0d0-exp(-r*r/(2.0d0*sx1*sy1))) fr = res*co*yt fi = res*co*xt return else c flat beam fr2 = resmod * yt/r * co fi2 = resmod * xt/r * co call bbkick(pre1,pre2,pim1,pim2,xt,yt,sx1,sy1) expon = dexp(-xt**2/(2.d0*sx1**2)-yt**2/(2.d0*sy1**2)) fr1 = ( pre1 - expon * pre2 )/ sqrt(sx*sx-sy*sy) fi1 = ( pim1 - expon * pim2 ) / sqrt(sx*sx-sy*sy) fr = fr2 fi = fi2 c den = sqrt((40.*sx)**2+r*r) w1 = 40.*sx/den w2 = 1./den fr = w1 * fr1 + w2 * fr2 fi = w1 * fi1 + w2 * fi2 return endif end c---------------------------------------------------------- c Oliver 30.06.1997 c This program calculates the kick from a TEM wave c excited in a coaxial transmission line. subroutine tem(x,y,wk,time,length,fr,fi) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 xt,yt real*8 x,y,fr,fi,wk,time,length real*8 vl parameter(vl=2.9889d8) xt = abs(x) yt = abs(y) r = sqrt(xt*xt+yt*yt) if(r.ne.0.0d0) then vcos = x/r vsin = y/r c pi = 4.0d0*atan(1.0d0) pi = acos(-1.0d0) fi = sin(2*pi*mod(wk*vl*time/length,1.0d0))/r c fi = 1.0d0/r fr = -vsin * fi fi = -vcos * fi endif if(r.eq.0.0d0) then fr = 0.0d0 fi = 0.0d0 endif c write(*,*) "TEM: ",mod(wk*vl*time/length,1.0d0),fi,1.0d0/r return end c---------------------------------------------------------- c Oliver 30.06.1997 c This program calculates the kick from a TEM wave c excited in a coaxial transmission line. subroutine tem6(x,y,wk,time,length,rout,fr,fi,vt0) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 xt,yt,vt0 real*8 x,y,fr,fi,ftmp,wk,time,length real*8 vl,ftmp1 real*8 rr(6), ri(6), x0r(6), y0r(6), vcosr(6), vsinr(6) real*8 x0i(6), y0i(6), rbound6, webin(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500) real*8 rin, rout, pi, vcosi(6), vsini(6) common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2 common / wavgui17 / webinx, webinx2 parameter(vl=2.9889d8) c parameter(rin=0.01d0,rout=0.20) pi = dacos(-1.0d0) fr = 0.0d0 fi = 0.0d0 c Electric Field due to the six wires: do 10 i=1,6 rr(i)=sqrt((x-x0r(i))*(x-x0r(i))+(y-y0r(i))*(y-y0r(i))) if(rr(i).gt.rbound6) then vcosr(i) = (x-x0r(i))/rr(i) vsinr(i) = (y-y0r(i))/rr(i) c ftmp = sin(2*pi*mod(wk*vl*time/length,1.0d0))/rr(i) c c For square wave: (By X .ZHANG) c length->wavelength, wk->peroid over pulse duration c ftmp1=mod(time*vl/length, 1.0d0) if(ftmp1.le.(1.0d0/wk)) then ftmp=(1.0d0+vt0)/rr(i) else ftmp=vt0/rr(i) endif fr = fr - vsinr(i) * ftmp fi = fi - vcosr(i) * ftmp endif 10 continue c Electric Field due to six immage wires: do 20 i=1,6 scale = sqrt(x0r(i)*x0r(i)+y0r(i)*y0r(i))/rout if(scale.eq.0.0) goto 20 x0i(i) = x0r(i)/scale**2 y0i(i) = y0r(i)/scale**2 ri(i)=sqrt((x-x0i(i))*(x-x0i(i))+(y-y0i(i))*(y-y0i(i))) if(ri(i).gt.rbound6) then vcosi(i) = (x-x0i(i))/ri(i) vsini(i) = (y-y0i(i))/ri(i) c ftmp = sin(2*pi*mod(wk*vl*time/length,1.0d0))/ri(i) c c For square wave: (By X. ZHANG) c length->wavelength, wk->peroid over pulse duration c ftmp1=mod(time*vl/length, 1.0d0) if(ftmp1.le.(1.0d0/wk)) then ftmp=(1.0d0+vt0)/ri(i) else ftmp=vt0/ri(i) endif fr = fr + vsini(i) * ftmp fi = fi + vcosi(i) * ftmp endif 20 continue fr = fr/5.4 fi = fi/5.4 c write(*,*) "TEM: ",mod(wk*vl*time/length,1.0d0),fi,1.0d0/r return end c--------------------------------------------------------- subroutine ffranklin(x,y,sx,sy,fr,fi) implicit real*8 (a-h,o-z) real x,y,sx,sy,fr,fi xt = abs(x) yt = abs(y) r = dsqrt(xt*xt+yt*yt) pi = 4.*datan(1.d0) fr = 2./(sy*(sx+sy)) / sqrt(2.*pi) * & yt fi = 2./(sx*(sx+sy)) / sqrt(2.*pi) * & xt return end c--------------------------------------------------------- c this routine converts into the first quadrant c and then calls Tong's/Talman's programs c subroutine bbkick(pre1,pre2,pim1,pim2,x,y,sx,sy) implicit double precision(a-h,o-z) fac = dsqrt(2.d0*(sx**2-sy**2)) r = sy/sx u = x v = y c u = x / fac c v = y / r / fac u1 = dabs(u) v1 = dabs(v) u1a = u1 / fac v1a = v1 / fac call errf(u1a,v1a,wr1,wi1) u1b = u1 / fac * r v1b = v1 / fac / r call errf(u1b,v1b,wr2,wi2) pre1 = wr1 pre2 = wr2 pim1 = wi1 pim2 = wi2 goto 900 texp1 = 2.d0*dexp(-u**2+(r*v)**2) texp2 = 2.d0*dexp(-(r*u)**2+v**2) arguvr = 2.d0*u*r*v if(u.gt.0.and.v.gt.0)then call fbbclc(wr1,wr2,wi1,wi2,u,v,r) pre1 = wr1 pre2 = wr2 pim1 = wi1 pim2 = wi2 else if(u.gt.0.and.v.lt.0)then call fbbclc(wr1,wr2,wi1,wi2,u,-v,r) pre1 = texp1*dcos(arguvr)-wr1 pre2 = texp2*dcos(arguvr)-wr2 pim1 = texp1*dsin(arguvr)+wi1 pim2 = texp2*dsin(arguvr)+wi2 else if(u.lt.0.and.v.gt.0)then call fbbclc(wr1,wr2,wi1,wi2,-u,v,r) pre1 = wr1 pre2 = wr2 pim1 = -wi1 pim2 = -wi2 else if(u.lt.0.and.v.lt.0)then call fbbclc(wr1,wr2,wi1,wi2,-u,-v,r) pre1 = texp1*dcos(arguvr)-wr1 pre2 = texp2*dcos(arguvr)-wr2 pim1 = -texp1*dsin(arguvr)-wi1 pim2 = -texp2*dsin(arguvr)-wi2 endif 900 continue end c c #################################################################### c c 2 2 2 c -(1-r )(v +u ) c f(u,v,r) = w(u+irv) - e w(ru+iv) c c #################################################################### c subroutine fbbclc(wr1,wr2,wi1,wi2,u,v,r) implicit double precision(a-h,o-z) call errf(u,r*v,wr1,wi1) call errf(r*u,v,wr2,wi2) arg=(1.0-r*r)*(v*v+u*u) if(arg.gt.100.) then arg = 100. wr2 = 0.0 wi2 = 0.0 endif expon=exp(-arg) c fr=wr1-expon*wr2 fi=wi1-expon*wi2 return end c c fnctnw.fortran c c this program evaluates the function w(z) c (where z = zr + zi) in the first quadrant of c the complex plane (i.e. zr > 0 and zi > 0). c three different expressions, pade1, pade2, and c asymp, are used, depending on where z lies in c the quadrant. c subroutine fcnw(wr,wi,zr,zi) implicit double precision(a-h,o-z) data x1/4.1e0/,x2/3.6e0/,x3/3.5e0/,x4/2.7e0/,x5/2.2e0/ data y1/1.275e0/,y2/1.095e0/ data r2/8.7025e0/ if(zr-x1)200,30,30 200 eps1=.0625e0*(zr-x3) if(zr-x2)300,210,210 210 yc=-1.4e0*(zr-x2)+y2 if(zi-yc)220,30,30 220 if(zr*zi.lt.eps1)then call asymp(wr,wi,zr,zi) else call pade2(wr,wi,zr,zi) endif 300 if(zr-x4)400,310,310 310 yc=-.2e0*(zr-x4)+y1 if(zi-yc)320,30,30 320 if(zr.ge.x3.and.zr*zi.lt.eps1) then call asymp(wr,wi,zr,zi) else call pade2(wr,wi,zr,zi) endif 400 if(zr-x5)500,410,410 410 yc1=-1.4e0*(zr-x4)+y1 yc2=1.75e0*(zr-x4)+y1 if(zi-yc1)420,30,30 420 if(zi-yc2)20,10,10 500 if(zr*zr+zi*zi-r2)10,30,30 10 call pade1(wr,wi,zr,zi) return 20 call pade2(wr,wi,zr,zi) return 30 call asymp(wr,wi,zr,zi) return end c wasymp.fortran c c this program calculates an asymptotic expression of c w(z) valid away from the origin. c subroutine asymp(wr,wi,zr,zi) implicit double precision(a-h,o-z) data a1p/1.94443615e-1/,a2p/7.64384940e-2/, 1 a3p/1.07825546e-2/,a4p/4.27695730e-4/,a5p/2.43202531e-6/ data b1/3.42901327e-1/,b2/1.036610830e0/,b3/1.756683649e0/, 1 b4/2.532731674e0/,b5/3.436159119e0/ data pi2/1.12837917e0/ data x1/3.5e0/,x2/4.2e0/ data eps/.01e0/,check/0.e0/ 10 dr1=zr+b1 d1r=zr-b1 dr2=zr+b2 d2r=zr-b2 dr3=zr+b3 d3r=zr-b3 dr4=zr+b4 d4r=zr-b4 dr5=zr+b5 d5r=zr-b5 de1=dr1*dr1+zi*zi d1e=d1r*d1r+zi*zi de2=dr2*dr2+zi*zi d2e=d2r*d2r+zi*zi de3=dr3*dr3+zi*zi d3e=d3r*d3r+zi*zi de4=dr4*dr4+zi*zi d4e=d4r*d4r+zi*zi de5=dr5*dr5+zi*zi d5e=d5r*d5r+zi*zi if(1.e0-check)70,70,20 20 if(zr.lt.x1) goto 60 eps1=.04e0/(zr-3.29e0)-.034e0 if(zr*zi.lt.eps1) goto 50 if(.not.((zr.ge.x2).and.(zr*zi.lt.eps))) goto 60 50 check=1.e0 wi0=a1p*(dr1/de1+d1r/d1e)+a2p*(dr2/de2+d2r/d2e)+ 1 a3p*(dr3/de3+d3r/d3e)+a4p*(dr4/de4+d4r/d4e)+ 1 a5p*(dr5/de5+d5r/d5e) zi0=zi zi=0.e0 go to 10 60 wr=(a1p*(1.e0/de1+1.e0/d1e)+a2p*(1.e0/de2+1.e0/d2e)+ 1 a3p*(1.e0/de3+1.e0/d3e)+a4p*(1.e0/de4+1.e0/d4e)+ 1 a5p*(1.e0/de5+1.e0/d5e))*zi 70 wi=a1p*(dr1/de1+d1r/d1e)+a2p*(dr2/de2+d2r/d2e)+ 1 a3p*(dr3/de3+d3r/d3e)+a4p*(dr4/de4+d4r/d4e)+ 1 a5p*(dr5/de5+d5r/d5e) if(1.e0-check)80,80,90 80 wr=exp(-zr*zr)+2.e0*wi*zr*zi0-pi2*zi0 wi=wi0 zi=zi0 check=0.e0 90 return c c ################################################################## c ###################################################################### entry errasymp c write(41,*)'zi,zr,ck=',zi,zr,ck return c end c wpade1.fortran c c this program calculates a pade approximation of w(z) c around the origin. c subroutine pade1(wr,wi,zr,zi) implicit double precision(a-h,o-z) data c1/-1.25647718e0/,c2/8.25059158e-1/, 1 c3/-3.19300157e-1/,c4/7.63191605e-2/, 1 c5/-1.04697938e-2/,c6/6.44878652e-4/ data d1/-2.38485635e0/,d2/2.51608137e0/, 1 d3/-1.52579040e0/,d4/5.75922693e-1/, 1 d5/-1.35740709e-1/,d6/1.85678083e-2/, 1 d7/-1.14243694e-3/ u2r=zi*zi-zr*zr u2i=-2.e0*zr*zi u3r=-u2r*zi-u2i*zr u3i=u2r*zr-u2i*zi u4r=-u3r*zi-u3i*zr u4i=u3r*zr-u3i*zi u5r=-u4r*zi-u4i*zr u5i=u4r*zr-u4i*zi u6r=-u5r*zi-u5i*zr u6i=u5r*zr-u5i*zi u7r=-u6r*zi-u6i*zr u7i=u6r*zr-u6i*zi fr=1.e0-c1*zi+c2*u2r+c3*u3r+c4*u4r+c5*u5r+c6*u6r fi=c1*zr+c2*u2i+c3*u3i+c4*u4i+c5*u5i+c6*u6i dr=1.e0-d1*zi+d2*u2r+d3*u3r+d4*u4r+d5*u5r+d6*u6r+d7*u7r di=d1*zr+d2*u2i+d3*u3i+d4*u4i+d5*u5i+d6*u6i+d7*u7i de=dr*dr+di*di wr=(fr*dr+fi*di)/de wi=(fi*dr-fr*di)/de return end c wpade2.fortran c c this program calculates a pade approximation of w(z) c around the point z = 3. c subroutine pade2(wr,wi,zr,zi) implicit double precision(a-h,o-z) data c0r/1.23409804e-4/,c0i/2.01157318e-1/, 1 c1r/2.33746715e-1/,c1i/1.61133338e-1/, 1 c2r/1.25689814e-1/,c2i/-4.0422725e-2/, 1 c3r/8.92089179e-3/,c3i/-1.81293213e-2/ data d1r/1.19230984e0/,d1i/-1.16495901e0/, 1 d2r/8.9401545e-2/,d2i/-1.07372867e0/, 1 d3r/-1.68547429e-1/,d3i/-2.70096451e-1/, 1 d4r/-3.20997564e-2/,d4i/-1.58578639e-2/ zr=zr-3.e0 z2r=zr*zr-zi*zi z2i=2.e0*zr*zi z3r=z2r*zr-z2i*zi z3i=z2r*zi+z2i*zr z4r=z3r*zr-z3i*zi z4i=z3r*zi+z3i*zr fr=c0r+c1r*zr-c1i*zi+c2r*z2r-c2i*z2i+c3r*z3r-c3i*z3i fi=c0i+c1r*zi+c1i*zr+c2r*z2i+c2i*z2r+c3r*z3i+c3i*z3r dr=1.e0+d1r*zr-d1i*zi+d2r*z2r-d2i*z2i+d3r*z3r-d3i*z3i+ 1 d4r*z4r-d4i*z4i di=d1r*zi+d1i*zr+d2r*z2i+d2i*z2r+d3r*z3i+d3i*z3r+d4r*z4i+ 1 d4i*z4r de=dr*dr+di*di wr=(fr*dr+fi*di)/de wi=(fi*dr-fr*di)/de zr=zr+3.e0 return end SUBROUTINE ERRF(XX, YY, WX, WY) *----------------------------------------------------------------------* * Purpose: * * Modification of WWERF, double precision complex error function, * * written at CERN by K. Koelbig. * * Input: * * XX, YY (real) Argument to CERF. * * Output: * * WX, WY (real) Function result. * *----------------------------------------------------------------------* *---- Double precision version. IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N) PARAMETER (MWFLT = 2, MREAL = 4) PARAMETER (MCWRD = 4) PARAMETER (MCNAM = 16, MWNAM = MCNAM / MCWRD) PARAMETER (MCFIL = 80, MCRNG = 40, MCSTR = 80) PARAMETER (CC = 1.12837 91670 9551D0) PARAMETER (ONE = 1.D0) PARAMETER (TWO = 2.D0) PARAMETER (XLIM = 5.33D0) PARAMETER (YLIM = 4.29D0) DIMENSION RX(33), RY(33) X = ABS(XX) Y = ABS(YY) IF (Y .LT. YLIM .AND. X .LT. XLIM) THEN Q = (ONE - Y / YLIM) * SQRT(ONE - (X/XLIM)**2) H = ONE / (3.2D0 * Q) NC = 7 + INT(23.0*Q) XL = H**(1 - NC) XH = Y + 0.5D0/H YH = X NU = 10 + INT(21.0*Q) RX(NU+1) = 0. RY(NU+1) = 0. DO 10 N = NU, 1, -1 TX = XH + N * RX(N+1) TY = YH - N * RY(N+1) TN = TX*TX + TY*TY RX(N) = 0.5D0 * TX / TN RY(N) = 0.5D0 * TY / TN 10 CONTINUE SX = 0. SY = 0. DO 20 N = NC, 1, -1 SAUX = SX + XL SX = RX(N) * SAUX - RY(N) * SY SY = RX(N) * SY + RY(N) * SAUX XL = H * XL 20 CONTINUE WX = CC * SX WY = CC * SY ELSE XH = Y YH = X RX(1) = 0. RY(1) = 0. DO 30 N = 9, 1, -1 TX = XH + N * RX(1) TY = YH - N * RY(1) TN = TX*TX + TY*TY RX(1) = 0.5D0 * TX / TN RY(1) = 0.5D0 * TY / TN 30 CONTINUE WX = CC * RX(1) WY = CC * RY(1) ENDIF IF(Y .EQ. 0.) WX = EXP(-X**2) IF(YY .LT. 0.) THEN WX = TWO * EXP(Y*Y-X*X) * COS(TWO*X*Y) - WX WY = - TWO * EXP(Y*Y-X*X) * SIN(TWO*X*Y) - WY IF(XX .GT. 0.) WY = -WY ELSE IF(XX .LT. 0.) WY = -WY ENDIF END subroutine ranuni(iseed,x,n) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 x(n) real*8 am c c creates uniform distribution between 0 and 1 c parameter(ia=16807,im=2147483647,am=1.d0/im,iq=127773,ir=2836, & mask=123459876) c initial seed idum idum = iseed c do i = 1, n idum=ieor(idum,mask) k=idum/iq idum=ia*(idum-k*iq)-ir*k if(idum.lt.0) idum=idum+IM x(i) = am*idum end do iseed = idum end subroutine seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,ibd,iw) c purpose: computes secondary emitted electron c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,iybin=500) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer index(npelm) integer iycount(0:iybin) real*8 ayield(0:iybin),avcos(0:iybin) c real*8 rn(8000) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), * pz(npelm), py(npelm), px(npelm), test(npelm) real*8 ptime(npelm), esign(npelm) c oliver 6.6.1997:cccccccccccccccccc real*8 eloss, elossq, enein, ephoto, adele, qadele real*8 peeff, yim, yemax ccccccccccccccccccccccccccccccccccccccc c oliver 24.7.1997:cccccccccccccccccc real*8 semax ccccccccccccccccccccccccccccccccccccccc real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinth(0:500), webinth2(0:500) real*8 webebb(0:500,0:500), webcos(0:500) real*8 xt, yt, zt, xpt, ypt, zpt real*8 ran2 real*8 dn1, dn2, dn3, dm1, dm2, dm3, do1, do2, do3 real*8 costheta, dphi c oliver 27.10.1997: variables for miguel: integer intn cccccccccccccccccccccccccccccccccccc c X.Zhang 14.10.1998 integer ibd, iw real*8 distw cccccccccccccccccccccccccccccccccccccc parameter (intn=1000) real*8 limit(intn), lcount(intn) real*8 avq, isectot, ltest common / miguel1 / isectot, ltest, avq common / miguel2 / lcount, limit ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc save / miguel1 / save / miguel2 / common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / rann / iseed, idumy c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def6 / peeff, yim, yemax common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave ccccccccccccccccccccccccccccccccccccccccccccccc c switch for elastic scattering common / def20 / inel c oliver 6.6.197:cccccccccccccccccc common / loss / eloss, elossq, ephoto, adele, qadele ccccccccccccccccccccccccccccccccccccccc c oliver 24.7.197:cccccccccccccccccc common / emax / semax, emax0 ccccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos ccccccccccccccccccccccccccccccccccccccc c X.Zhang 14.10.1998 common / wavguid6 / x0r, y0r, rbound6, webin, webinphi c common / wavguid7 / webinph2 common / wavguid7 / webinph2, webinn c , webinth, webinth2 common / wavguid8 / webebb, webcos ccccccccccccccccccccccccccccccccccccccc common / test1 / itest common / test2 / test c frank, add this block to seiler for igeom=4 common / image / iimage, iimageb, interspace, igeom c write(*,*) ' entrance seiler ' c X.Zhang 14.10.1998 c ibd: 1 = outboundary, 2 = inner conductor, iw: wire index. if(iwave.eq.2) then distw = sqrt((xt-x0r(iw))**2+(yt-y0r(iw))**2) else distw = sqrt(xt*xt+yt*yt) endif c Projecting the particles back to the boundary: if (ibd.eq.1) then if (ibend.eq.1) then if (igeom.ne.4) then if (abs(xt).lt.xbound) then yt = yt/abs(yt)*ybound*sqrt(1.-(xt/xbound)**2) else yt = yt/abs(yt)*1.d-7 xt = xt/abs(xt)*(xbound-1.d-7) endif endif if (yt.gt.zbound) yt = zbound if (yt.lt.-zbound) yt = -zbound if (igeom.eq.4.and.abs(xt).ge.xbound) then xt = xt/abs(xt)*(xbound-1.d-7) endif else c if (ibend.ne.1) then if (igeom.ne.4) then scale = 1.0d0/sqrt((xt/xbound)**2+(yt/ybound)**2) xt = xt * scale yt = yt * scale if (yt.gt.zbound) yt = zbound if (yt.lt.-zbound) yt = -zbound else if (abs(x(i)/y(i)).gt.xbound/zbound) then scale = xbound/abs(x(i)) else scale = zbound/abs(y(i)) endif xt = xt * scale yt = yt * scale endif endif endif ccccccccccccccccccccccccccccccccccccccccccccccccc c 01.07.1997 Oliver: wave guide boundaries. c 14.10.1998 X.Zhang: add 6-wire waveguide geometry. if(ibd.eq.2) then if(iwave.eq.1) then if (ibend.eq.1) then yt = yt/abs(yt)*(sqrt(rbound**2-xt**2)+1.d-7) else c if (ibend.eq.0.or.ibend.eq.5) then scale = 1.0d0/(distw/rbound) xt = xt * scale yt = yt * scale endif else if(iwave.eq.2) then xt = rbound6 * (xt-x0r(iw))/distw + x0r(iw) yt = rbound6 * (yt-y0r(iw))/distw + y0r(iw) endif endif ccccccccccccccccccccccccccccccccccccccccccccccccc c introduce 3 orthonormal vectors dn, dm and do dn3 = 0. 0d0 c 01.07.1997 Oliver: Normal vector for the outer boundary: if(ibd.eq.1) then dn1 = xt/ xbound**2/ * sqrt(xt**2/xbound**4+yt**2/ybound**4) dn2 = yt/ ybound**2/ * sqrt(xt**2/xbound**4+yt**2/ybound**4) if (abs(yt).eq.zbound) dn1 = 0.0d0 c dn3 removed dnorm = sqrt(dn1*dn1+dn2*dn2) dn1 = -dn1/dnorm dn2 = -dn2/dnorm else if(ibd.eq.2) then c 01.07.1997 Oliver: Normal vector for the inner waveguide: if(iwave.eq.1) then dn1 = xt/distw dn2 = yt/distw else if(iwave.eq.2) then c 14.10.1998 X.Zhang: add 6-wire waveguid geometry. dn1 = (xt-x0r(iw))/distw dn2 = (yt-y0r(iw))/distw endif dnorm = sqrt(dn1*dn1+dn2*dn2) dn1 = dn1/dnorm dn2 = dn2/dnorm endif dm1 = -dn2 dm2 = dn1 dm3 = 0.0d0 do1 = 0.0d0 do2 = 0.0d0 do3 = 1.0d0 xpto=xpt ypto=ypt zpto=zpt xto=xt yto=yt zto=zt c dn3 removed costheta = abs(dn1*xpt+dn2*ypt)/ * sqrt(xpt**2+ypt**2+zpt**2) costheta = max(costheta,0.2d0) c Calculate the angle of the surface normal. c The angle is used for the angular distribution of the momentum vector. angle = atan2(dn2,dn1) c incoming energy in eV: c 19.06.1997 Oliver vel2 = (xpt*xpt+ypt*ypt+zpt*zpt) beta2 = vel2/vl/vl ! Achtung: 12.7.1998 if(beta2.ge.1.0d0) write(*,*) "Seiler", beta2 if(beta2.ge.1.0d0) beta2 = 0.999d0 c write(*,*) "Seiler", vel2, beta2 ccccccccccccccccccccccccccccccccc c beta2 = max(ypt*ypt,xpt*xpt)/vl/vl gamma = 1.0d0/sqrt(1.0d0-beta2) ene = (gamma-1.0d0)*elmass*vl*vl/el enein = ene*qt eloss = eloss + enein c highly dubious statement for elastic scattering c comment this out, frank c if (ene.lt.5) then c qt = 0.0d0 c return c endif c charge of emitted secondary e- qtnew = yield(ene,costheta,yim,yemax)*qt c if (inel.eq.1) then c qtel = (0.02+0.08*exp(-(ene-5.0d0)**2 c & /50.0))*(1.0+0.26*(1-costheta**2))*qtold c most recent parametrization for elastically reflected c electrons, before Noel's note (July 2001) was released c qtel = (0.02+0.56*exp(-ene**2 c & /5408.))*(1.0+0.26*(1-costheta**2))*qtold if(ene.le.300) then qtnew = qtnew/(1-frac1(ene)) qtold = qt else qtnew = qtnew/(1-frac2(ene)) qtold = qt endif if (qtnew.gt.0.0.and.ene.le.300) then ratio = frac1(ene) else if (qtnew.gt.0.0.and.ene.gt.300) then ratio = frac2(ene) else if (qtnew.le.0.0) then return endif if (ran2(idumy).lt.ratio) goto 980 c qtnew = qtel+qtnew c qtel = qtnew endif c c qtnew = qt nindhg=nint(iybin*xt/xbound+iybin)/2 if (nindhg.gt.iybin.or.nindhg.lt.0) goto 123 c 4.8.1997 Oliver: Bining the secondary yield: iycount(nindhg) = * iycount(nindhg) + 1 if(ene.le.300) then ayield(nindhg) = * ayield(nindhg)+yield(ene,costheta,yim,yemax)/(1-frac1(ene)) else ayield(nindhg) = * ayield(nindhg)+yield(ene,costheta,yim,yemax)/(1-frac2(ene)) endif avcos(nindhg) = * avcos(nindhg) + * costheta c write(55,*) xt,yield(ene,costheta,yim,yemax),costheta cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 123 qtref = ppb*peeff/real(npepb) c frank, change this number, 22 May 2002 c if (peeff.lt.1.e-5) then if (peeff.lt.1.e2) then qtref=amax1(qtref*1.e4,1.e3) endif if (qtnew.gt.qtref) then iq = max(2,int(qtnew/qtref+0.5d0)) if (ibend.eq.1.and. & (abs(xbound-xt).lt.0.002.or.abs(xbound+xt).lt.0.002)) & then qtnew = qtref iq = 1 endif else iq = 1 endif c c frank, set iq = 1 temporarily, November 4, 2001 c c iq = 1 do 10 i = 1, iq qt = abs(qtnew / real(iq)) c energy & angles of emitted particle c c for now assume uniform energy distribution between 1 and 20 eV c c iseed = iseed + 1 c call ranuni(iseed,rn,3) c emax = 20. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc Oliver 31.07.1997: cc Gaussian energy distribution for the secondary electrons: c emax0 = semax c if (ene.lt.emax0) emax0 = ene c eneemit = (emax0*sqrt(-2*log(ran2(idumy)))* c * cos(2*pi*ran2(idumy)) ) c if (eneemit.lt.0.0) eneemit = -eneemit cc goto 33 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 27.10.1997: c Arbitrary energy distribution defined in 'init': c c count total number of produced secondary electrons: c emax0 = 15.0d0*semax isectot = isectot + 1 avq = avq + qt if(isectot.eq.3000) then c open(unit=69,file="distr.test.data",status='UNKNOWN') c do 35 idt=1,intn c write(69,*) dble(idt+1)*emax0/dble(intn), c * lcount(idt)/avq, limit(idt) c 35 continue c close(unit=69) endif c c dice uniform energy distribution in the relevant intervall: 30 eneemit = ran2(idumy)*emax0 c c check the distribution: do 32 im=1,intn if(eneemit.lt.dble(im)*emax0/dble(intn)) then if(0.97*lcount(im)/avq.ge.limit(im)) goto 30 lcount(im) = lcount(im) + qt goto 33 endif 32 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Bin the energy distribution: 33 itest = itest + 1 if (itest.lt.npelm) test(itest) = eneemit c Oliver: 6.Juni.1997: Calculate the energy deposition in the wall c by the lost electrons. eloss = eloss - eneemit*qt ccccccccccccccccccccccccccccccccccccccccccccc c c next determine angular distribution c c scale with energy energyscale = eneemit * el velo = sqrt(2.0d0*energyscale/elmass) c New routine for uniform angle distribution: c 'aplimit' limits the opening angle of the momentum distribution. c aplimit = 1.0d0 c r2 = angle + aplimit * pi * (ran2(idumy)-0.5d0) c r3 = 2.0d0 * pi * (ran2(idumy)-0.5d0) c xpt = sqrt(4.0d0/3.0d0)*velo*cos(r2)*abs(sin(r3)) c ypt = sqrt(4.0d0/3.0d0)*velo*sin(r2)*abs(sin(r3)) c zpt = sqrt(2.0d0/3.0d0)*velo*cos(r3) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Frank's old cos theta distribution: c cos theta = c xco = sqrt(rn(2)) xsi = sqrt(ran2(idumy)) xco = sqrt(1.0d0-xsi*xsi) c phi c dphi = rn(3)*2.0d0*pi dphi = ran2(idumy)*2.0d0*pi dpco = cos(dphi) dpsi = sin(dphi) xpt = dn1*xco+xsi*(dm1*dpco+do1*dpsi) ypt = dn2*xco+xsi*(dm2*dpco+do2*dpsi) zpt = dn3*xco+xsi*(dm3*dpco+do3*dpsi) xpt = xpt * velo ypt = ypt * velo zpt = zpt * velo ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) "Seiler",semax,velo,xpt,ypt,zpt c treat newly generated electrons c (introduced to reduce fluctuations) if (i.lt.iq) then icount = icount + 1 icountact = icountact + 1 qacc = qacc + qt q(icount) = qt c smear out x-coordinate over typical width c of exit area according to Seiler rho = 9000. c density in kg/m^3 for Copper xwid = 1.15d-4/rho *(ene/1000.0d0)**(1.35) c call ranuni(iseed,rn,1) c x(icount) = xt + (rn(1)-0.5d0)*2.0d0*xwid x(icount) = xt + (ran2(idumy)-0.5d0)*2.0d0*xwid if (qtnew.eq.0.0) then xpt = 0.0d0 ypt = 0.0d0 zpt = 0.0d0 endif c x(icount) = xt y(icount) = yt z(icount) = zt xp(icount) = xpt yp(icount) = ypt zp(icount) = zpt endif 10 continue return c c elastic scattering... c c goto 900 980 continue c qtnew = qtel+qtnew c qtel = qtnew qtref = ppb*peeff/real(npepb) c frank, change this number, 22 May 2002 c if (peeff.lt.1.e-5) then if (peeff.lt.1.e2) then qtref=amax1(qtref*1.e4,1.e3) endif if (qtnew.gt.qtref) then iq = max(2,int(qtnew/qtref+0.5d0)) if (ibend.eq.1.and. & (abs(xbound-xt).lt.0.002.or.abs(xbound+xt).lt.0.002)) & then qtnew = qtref iq = 1 endif else iq = 1 endif c c frank, set iq = 1 temporarily, November 4, 2001 c c iq = 1 eneemit=ene eloss = eloss - eneemit*qtnew c c next determine angular distribution c c scale with energy energyscale = eneemit * el velo = sqrt(2.0d0*energyscale/elmass) dncomp = dn1*xpto+dn2*ypto+dn3*zpto dmcomp = dm1*xpto+dm2*ypto+dm3*zpto docomp = do1*xpto+do2*ypto+do3*zpto xt = xto yt = yto zt = zto xpt = (-dn1*dncomp+dm1*dmcomp+do1*docomp) ypt = (-dn2*dncomp+dm2*dmcomp+do2*docomp) zpt = (-dn3*dncomp+dm3*dmcomp+do3*docomp) do 110 i = 1, iq qt = abs(qtnew / real(iq)) c c if (inel.eq.1) then c c qtel = (0.02+0.08*exp(-(ene-5.0d0)**2 c & /50.0))*(1.0+0.26*(1-costheta**2))*qtold c c if (qtel.gt.1.e3) then if (i.lt.iq) then icount = icount + 1 icountact = icountact + 1 qacc = qacc + qt q(icount) = qt c smear out x-coordinate over typical width c of exit area according to Seiler rho = 9000. c density in kg/m^3 for Copper xwid = 1.15d-4/rho *(ene/1000.0d0)**(1.35) c call ranuni(iseed,rn,1) c x(icount) = xt + (rn(1)-0.5d0)*2.0d0*xwid x(icount) = xt + (ran2(idumy)-0.5d0)*2.0d0*xwid if (qtnew.eq.0.0) then xpt = 0.0d0 ypt = 0.0d0 zpt = 0.0d0 endif c x(icount) = xt y(icount) = yt z(icount) = zt xp(icount) = xpt yp(icount) = ypt zp(icount) = zpt endif 110 continue cc nindhg=nint(iybin*xt/xbound+iybin)/2 cc if (nindhg.gt.iybin.or.nindhg.lt.0) goto 923 ccc comment out from this part of the code for debugging, fz, oct.99 ccc 4.8.1997 Oliver: Bining the secondary yield: cc iycount(nindhg) = cc * iycount(nindhg) + 1 cc ayield(nindhg) = cc * ayield(nindhg) + cc * yield(ene,costheta,yim,yemax) cc avcos(nindhg) = cc * avcos(nindhg) + cc * costheta ccc 923 continue c c 900 continue c c if(isectot.eq.3000) then c open(unit=169,file="inel.data",status='UNKNOWN') c write(169,*) xpto,ypto,zpto,xp(icount),yp(icount), c * zp(icount),xt,yt,zt,eneemit,qtel,qtold c c close(unit=169) c endif c endif c endif c if (qtnew.eq.0.0) then c xpt = 0.0d0 c ypt = 0.0d0 c zpt = 0.0d0 c endif c write(*,*) ' exit seiler ' return end real*8 function yield(ene,costheta,yim,yemax) c secondary emission yield implicit real*8 (a-h,o-z) c reduced energy (energy at maximum = 840 eV) cc er = ene / 840. c er = ene / 400.0d0 c er = ene / yemax c NEW cc er = ene*(1.+0.7*(1.-costheta))/yemax er = ene*(1.+0.7*(1.-costheta))/yemax c OLD WRONG cc er = ene / yemax c YIELD PARAMETER: c NEW c activate temporarily March2002 c yield = yim * 1.11d0 * er**(-0.35d0) * (1.0d0- c & exp(-2.3d0*er**(1.35d0)))*dexp(0.5*(1.-costheta)) c return c c OLD WRONG c yield = yim * 1.11d0 * er**(-0.35d0) * (1.0d0- c & exp(-2.3d0*er**(1.35d0)))/costheta c c costheta C Jan. 1999 by X. Zhang: (ref. M.A. Furman Note) C Add elastically reflected electrons C yield = yield + (0.02+0.08*exp(-(ene-5.0d0)**2 c & /50.0))*(1.0+0.26*(1-costheta**2)) C Add rediffused electrons c yield = yield + 0.1*(1.0-exp(-(ene/5.0)**2)) c & *(1.0+0.26*(1-costheta**2)) c NEW NEW according to Furman's formula and Noel's c correction for the reflected ions c frac1[2] represents the fraction of elastically c reflected electrons c for copper fully conditioned c otherwise it's ess = 1.39, but yim and yemax are c different, too. ess = 1.35 c comment temporarily March2002 yield = yim*ess*er/(ess-1+er**ess)*dexp(0.5*(1.-costheta)) cc yield = yim*ess*er/(ess-1+er**ess) return end c the following two functions express the fraction of elastically c back-scattered electrons for two different energy ranges. real*8 function frac1(ene) implicit real*8 (a-h,o-z) ee0 = 56.914686 aa0 = 20.699890 aa1 = -7.07605 aa2 = 0.483547 frac1 = dexp(aa0+aa1*dlog(ene + ee0)+aa2*(dlog(ene + ee0))**2) return end c real*8 function frac2(ene) implicit real*8 (a-h,o-z) c ee0 = 29.0 c aa0 = -5.078 c aa1 = 5.61 c aa2 = -1.62 c aa3 = 0.1187*10**(-4) c c coefficients revised by Noel Hilleret, 20.06.02 ee0 = 0. aa0 = 0.300207076 aa1 = 0.044915014 aa2 = -0.155498672 aa3 = 9.50318e-4 frac2 = dexp(aa0+aa1*dlog(ene + ee0)+aa2*(dlog(ene + ee0))**2 & + aa3*(dlog(ene + ee0))**3) return end subroutine bmap(lisel,libend,x,y,z,vx,vy,vz,dpxi,dpyi,dpzi,dt) c purpose: describes particle motion in a magnetic field. c implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer n, ifail, ibend, isel, lisel, libend parameter(n=6) real*8 t, dt, tend, tol real*8 var(n) real*8 x, y, z, vx, vy, vz real*8 dpxi, dpyi, dpzi, dpx, dpy, dpz real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient real*8 w(28+21*n) real*8 D02CJW, D02CJX EXTERNAL D02CJW, D02CJX, out, fcn common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / nagv / ibend, isel, tend, dpx, dpy, dpz common / pel52 / time0 vrel = sqrt(vx*vx+vy*vy+vz*vz) gammaf = 1.d0/sqrt(1.0d0-(vrel/vl)**2) dpx = dpxi dpy = dpyi dpz = dpzi c dpx = 0.0d0 c dpy = 0.0d0 c dpz = 0.0d0 isel = lisel ibend = libend c write(*,*) 'gamma:',gammaf c write(*,*) 'vel: ',vx,vy,vz c write(*,*) 'DP: ',dpx,dpy,dpz if(ibend.eq.1) then tol = 1.0d-3 t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-4 ifail = 0 c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif if(ibend.eq.2) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-6 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif if(ibend.eq.3) then tol = 1.0d-5 t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-4 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB symmetric C yoke quadrupole type if(ibend.eq.11) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB asymmetric C yoke quadrupole type if(ibend.eq.12) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB symmetric C yoke dipole type if(ibend.eq.13) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB asymmetric C yoke dipole type if(ibend.eq.14) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB solenoid if(ibend.eq.15) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c uniform dipole if(ibend.eq.16) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c uniform solenoid if(ibend.eq.17) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c strong dipole if(ibend.eq.18) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-6 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB solenoid, adjacent coils with equal polarity if(ibend.eq.19) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c exact solenoid, symmetric if(ibend.eq.20) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c exact solenoid, antisymmetric if(ibend.eq.21) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c more exact C yoke, symmetric if(ibend.eq.22) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c more exact C yoke, antisymmetric if(ibend.eq.23) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c combined function magnet if(ibend.eq.24) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c TE_1,0 wave if(ibend.eq.25) then t = time0-dt tend = time0 ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c strong dipole with y el. field for IPM simulation if(ibend.eq.38) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-6 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif return end subroutine fcn(t,var,f) c purpose: defines the system of differential equations. implicit real*8 (a-h,o-z) integer n, isel, ibend parameter(n=6) real*8 gammaf, vrel, dpx, dpy, dpz real*8 t, tend, var(n), f(n) real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient, f0, efieldrf real*8 k real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail real*8 function s17aff, s17aef common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf common / def1 / rbound, xbound, ybound, zbound, energy, belen if(ibend.eq.1) then gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = (dpx - el*var(6)*bfield/elmass) f(5) = dpy f(6) = (dpz + el*var(4)*bfield/elmass) endif if(ibend.eq.2) then gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = (dpx - el*var(6)*bfield*var(1)/elmass) f(5) = (dpy + el*var(6)*bfield*var(2)/elmass) f(6) = (dpz + el*var(4)*bfield*var(1)/elmass * - el*var(5)*bfield*var(2)/elmass) c write(*,*) bfield*var(1), bfield*var(2) endif if(ibend.eq.3) then gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = (dpx - el*var(5)*bfield/elmass) f(5) = (dpy + el*var(4)*bfield/elmass) f(6) = dpz endif if (ibend.eq.11) then c kekb symmetric c yoke c a and b are in Tesla/meter, k in 1/meter a = 0.3 b = 0.2 k=2.*pi/0.1 bx = (a+b*cos(k*var(3)))*var(2) by = (a+b*cos(k*var(3)))*var(1) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.12) then c kekb asymmetric c yoke c a and b are in Tesla/meter, k in 1/meter a = 0.0 b = 0.5 k=2.*pi/0.2 bx = (a+b*cos(k*var(3)))*var(2) by = (a+b*cos(k*var(3)))*var(1) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.13) then c kekb symmetric c yoke dipole type c a and b are in Tesla, k in 1/meter a = 0.0141 b = 0.0094 k=2.*pi/0.1 bx = 0. by = (a+b*cos(k*var(3))) bz = (-b*k*sin(k*var(3)))*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.14) then c kekb asymmetric c yoke dipole type c a and b are in Tesla, k in 1/meter a = 0.0 c b = 0.0235 b = 1. k=2.*pi/0.2 bx = 0. by = (a+b*cos(k*var(3))) bz = (-b*k*sin(k*var(3)))*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.15) then c kekb solenoid c b is in Tesla, k in 1/meter b = 0.0050 k = 2.*pi/15. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = -0.5*b*rad*k*cos(k*var(3))*cos(phi) by = -0.5*b*rad*k*cos(k*var(3))*sin(phi) bz = b*sin(k*var(3)) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.16) then c uniform dipole c a and b are in Tesla, k in 1/meter a = 1. b = 0.0 k= 2.*pi/0.1 gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl bx = 0. by = (a+b*cos(k*var(3))) bz = (-b*k*sin(k*var(3)))*var(2) f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.17) then c uniform weak solenoid c b is in Tesla, k in 1/meter b = 0.0050 k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = 0. by = 0. bz = b gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)/gamma*bz & -var(6)/gamma*by) f(5) = dpy - el/elmass*(var(6)/gamma*bx & -var(4)/gamma*bz) f(6) = dpz - el/elmass*(var(4)/gamma*by & -var(5)/gamma*bx) endif if (ibend.eq.18) then c strong dipole c b is in Tesla, k in 1/meter b = bfield k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = 0. by = b bz = 0. gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)/gamma*bz & -var(6)/gamma*by) f(5) = dpy - el/elmass*(var(6)/gamma*bx & -var(4)/gamma*bz) f(6) = dpz - el/elmass*(var(4)/gamma*by & -var(5)/gamma*bx) endif if (ibend.eq.19) then c kekb solenoid, two adjacent coils with equal polarity c b is in Tesla, k in 1/meter b = 0.0020 bz0 = 0.0030 k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = -0.5*b*rad*k*cos(k*var(3))*cos(phi) by = -0.5*b*rad*k*cos(k*var(3))*sin(phi) bz = b*sin(k*var(3))+bz0 gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.20) then c exact solenoid, two adjacent coils with unequal polarity c b is in Tesla, k in 1/meter scalel = 15. b = 0.005 k = 2.*pi/2./scalel rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) c bx = -0.5*b*rad*k*cos(k*var(3))*cos(phi) c by = -0.5*b*rad*k*cos(k*var(3))*sin(phi) arg = k*rad br = 0. bz = 0. solrad = 0.07 soll = 0.4*scalel coefs = b*4*k*solrad/pi do ks = 0, 0 km = real(ks*2+1) s1 = sin(km*k*soll) sz1 = sin(km*k*var(3)) cz1 = cos(km*k*var(3)) bk1 = dbesk1(km*k*solrad) br = br + s1*bk1*dbesi1(km*solrad*rad)*sz1 bz = bz + s1*bk1*dbesi0(km*solrad*rad)*cz1 end do br = br*coefs bz = bz*coefs bx = br*cos(phi) by = br*sin(phi) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.21) then c exact solenoid, two adjacent coils with equal polarity c b is in Tesla, k in 1/meter scalel = 15. b = 0.005 c bz0 = 0.0030 k = 2.*pi/1./scalel rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) arg = k*rad solrad = 0.07 soll = 0.4*scalel coefs = 2*k*solrad/pi br = 0. bz = soll/Pi*k do ks = 1, 1 km = real(ks) s1 = sin(km*k*soll) sz1 = sin(km*k*var(3)) cz1 = cos(km*k*var(3)) bk1 = dbesk1(km*k*solrad) br = br + coefs*s1*bk1*dbesi1(km*solrad*rad)*sz1 bz = bz + coefs*s1*bk1*dbesi0(km*solrad*rad)*cz1 end do br = br*b bz = bz*b bx = br*cos(phi) by = br*sin(phi) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.22) then c kekb symmetric c yoke, more exact c a and b are in Tesla/meter, k in 1/meter a = 0.3 b = 0.2 k=2.*pi/0.1 bx = a*var(2)+b*cos(k*var(3))*(var(2)+1./4.*k*k*( & var(1)*var(1)+var(2)*var(2)/3.)) by = a*var(1)+b*cos(k*var(3))*(var(1)+1./4.*k*k*( & var(2)*var(2)+var(1)*var(1)/3.)) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.23) then c kekb asymmetric c yoke, more exact c a and b are in Tesla/meter, k in 1/meter a = 0.0 b = 0.5 k=2.*pi/0.2 bx = a*var(2)+b*cos(k*var(3))*(var(2)+1./4.*k*k*( & var(1)*var(1)+var(2)*var(2)/3.)) by = a*var(1)+b*cos(k*var(3))*(var(1)+1./4.*k*k*( & var(2)*var(2)+var(1)*var(1)/3.)) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.24) then c combined function magnet c b is bfield c g is bgradient bx = + bgradient*var(2) by = bfield - bgradient*var(1) bz = 0. gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.25) then c H_1,1 wave c 5 GHz, 100 kV/m c c for debugging c var(1) = 0.0001 c var(2) = 0.0001 c var(3) = 0. c f0 = 6.3e9 c efield = 1.e4 c amplfield = efield/(3.7)*xbound domegaw = 2*pi*f0 dlambda0 = 2*pi*vl/domegaw dlambda11 = 1.71*2.*xbound dmu0 = 4.*pi*1.e-7 z0 = 377 zf = z0/sqrt(1-(dlambda0/dlambda11)**2) dlambdah = dlambda0/sqrt(1.-(dlambda0/dlambda11)**2) dbeta0 = 2.*pi/dlambdah rad = sqrt(var(1)*var(1)+var(2)*var(2)) arg = rad*3.7/(2*xbound) bj0 = s17aef(arg,ifail) bj1 = s17aff(arg,ifail) bj1p = bj0-1.d0/arg*bj1 ampl = amplfield*cos(dbeta0*var(3)-domegaw*t) ampl1 = amplfield*sin(dbeta0*var(3)-domegaw*t) ex = ampl*(bj1-arg*bj1p)*var(1)*var(2)/rad**3 ey = ampl*(bj1*var(2)**2+arg*bj1p*var(1)**2)/rad**3 ez = 0. bx = ampl/zf*dmu0*(arg*bj1p*var(1)**2+bj1*var(2)**2)/rad**3 by = bfield+ampl/zf*dmu0*(arg*bj1p-bj1)*var(1)*var(2)/rad**3 bz = ampl1/zf*dmu0*arg**2*dlambdah/(2.*pi)*bj1*var(2)/rad**3 c write(*,*) ' ibend = 25 ' c write(*,*) ' coordinates ',var(1),var(2),var(3) c write(*,*) ' time ',t c write(*,*) ' dlambda0 ',dlambda0 c write(*,*) ' dlambda11 ',dlambda11 c write(*,*) ' domegaw ',domegaw c write(*,*) ' f0 ',f0 c write(*,*) ' ex,ey,ez',ex,ey,ez c write(*,*) ' bx,by,bz',bz,by,vz gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by + ex) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz + ey) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx + ez) endif if (ibend.eq.38) then c strong dipole with vertical e field 20 kV/m for IPM c ef is in V/m ef = 20.e3 c b is in Tesla, k in 1/meter b = bfield k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = 0. by = b bz = 0. gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)/gamma*bz & -var(6)/gamma*by) f(5) = dpy - el/elmass*(var(6)/gamma*bx & -var(4)/gamma*bz) - el/elmass/gamma*ef f(6) = dpz - el/elmass*(var(4)/gamma*by & -var(5)/gamma*bx) endif return end subroutine out(tsol,var) c purpose: output of intermediate data implicit real*8 (a-h,o-z) c implicit integer (a-z) integer n, isel, ibend parameter(n=6) real*8 dpx, dpy, dpz real*8 tend, tsol, deltat, var(n) common / nagv / ibend, isel, tend, dpx, dpy, dpz if(isel.eq.1) WRITE (33,99999) tsol*1.0d12, (var(J),J=1,6) deltat = tend/20 tsol = tsol + deltat return 99999 FORMAT (1X,e20.12,6e20.12) end * * $Id: deqmr64.F,v 1.1.1.1 1996/04/01 15:02:17 mclareni Exp $ * * $Log: deqmr64.F,v $ * Revision 1.1.1.1 1996/04/01 15:02:17 mclareni * Mathlib gen * * SUBROUTINE DDEQMR(N,XA,XZ,Y,H0,EPS,SUB,W) IMPLICIT real*8 (A-H,O-Z) integer n * * $Id: imp64.inc,v 1.1.1.1 1996/04/01 15:02:59 mclareni Exp $ * * $Log: imp64.inc,v $ * Revision 1.1.1.1 1996/04/01 15:02:59 mclareni * Mathlib gen * * imp64.inc * C Based on a modification of the Runge-Kutta method suggested C by Merson. See G.N. Lance, Numerical Methods for High speed C Computers, Iliffe & Sons, London 1960, pp. 56-57 CHARACTER NAME*(*) CHARACTER*80 ERRTXT PARAMETER (NAME = 'DDEQMR') LOGICAL LER,LFN DIMENSION Y(*),W(N,*) PARAMETER (DELTA = 1D-14) PARAMETER (Z1 = 1, R2 = Z1/2, R3 = Z1/3) PARAMETER (R4 = 3*Z1/8, R5 = 3*Z1/2, R6 = 9*Z1/2) PARAMETER (R7 = 4*Z1/3, R0 = Z1/32) IF(N .LT. 1 .OR. XA .EQ. XZ .OR. H0 .EQ. 0) RETURN DELTAX=DELTA*ABS(XZ-XA) EPS5=5*ABS(EPS) EPS0=R0*EPS5 X=XA H1=SIGN(ABS(H0),XZ-XA) SGH=SIGN(Z1,H1) 12 IF(SGH*(X+H1-XZ) .LT. 0) THEN HH=H1 H0=H1 LFN=.FALSE. ELSE HH=XZ-X IF(ABS(HH) .LT. DELTAX) THEN DO 10 I = 1,N 10 Y(I)=W(I,6) RETURN END IF LFN=.TRUE. END IF S2=R2*HH S3=R3*HH S7=R7*HH X1=X+HH X2=X+S2 X3=X+S3 CALL SUB(X,Y,W(1,1)) DO 1 I = 1,N W(I,1)=S3*W(I,1) 1 W(I,6)=Y(I)+W(I,1) CALL SUB(X3,W(1,6),W(1,2)) DO 2 I = 1,N W(I,2)=S3*W(I,2) 2 W(I,6)=Y(I)+R2*(W(I,1)+W(I,2)) CALL SUB(X3,W(1,6),W(1,3)) DO 3 I = 1,N W(I,3)=S3*W(I,3) W(I,2)=3*W(I,3) 3 W(I,6)=Y(I)+R4*(W(I,1)+W(I,2)) CALL SUB(X2,W(1,6),W(1,4)) DO 4 I = 1,N W(I,4)=S7*W(I,4) 4 W(I,6)=Y(I)+R5*(W(I,1)-W(I,2)+W(I,4)) CALL SUB(X1,W(1,6),W(1,5)) DO 5 I = 1,N W(I,5)=S3*W(I,5) 5 W(I,6)=Y(I)+R2*(W(I,1)+W(I,4)+W(I,5)) DO 8 I = 1,N W(I,2)=ABS(W(I,1)-R6*W(I,3)+W(I,4)-R2*W(I,5)) W(I,1)=ABS(W(I,6)) IF(W(I,2) .GT. EPS5*W(I,1)) THEN H1=R2*HH IF(ABS(H1) .LT. DELTAX) THEN WRITE(ERRTXT,101) X c CALL MTLPRT(NAME,'D202.1',ERRTXT) RETURN END IF GO TO 12 END IF 8 CONTINUE LER=.TRUE. DO 7 I = 1,N 7 LER=LER .AND. W(I,2) .LT. EPS0*W(I,1) DO 9 I = 1,N 9 Y(I)=W(I,6) IF(LER) THEN H0=H1+H1 H1=HH+HH END IF IF(LFN) RETURN X=X1 GO TO 12 101 FORMAT('TOO HIGH ACCURACY REQUIRED NEAR X = ',1P,D15.8) END