program ecloud *----------------------------------------------------------------------* * * * CERN * * * * European Organization for Nuclear Research * * * * Program name: ECLOUD Version 4.0 * * * * Authors and contact: G. BELLODI, O. BRUNING, J. CRITTENDEN, * * G. RUMOLO, D. SCHULTE, X. ZHANG, * * F. ZIMMERMANN * * (formerly) AB SL Division * * (presently) BE-ABP * * CERN * * CH-1211 GENEVA 23 * * SWITZERLAND * * Tel. [041] (022) 767 9054 * * frank.zimmermann@cern.ch * * [041] (022) 767 3264 * * giovanni.rumolo@cern.ch * * * * Affiliation of J. Crittenden: Wilson Synchrotron Laboratory * * Cornell University * * Ithaca, New York 14853-8001 * * Tel. [1] (607) 255-9424 * * crittenden@cornell.edu * * * * 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 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) c c January 2002, improvements in speed for space charge calculations c and new solvers for the euqations of motion to improve c performance c c 2007, difference wrt ecloud2.f is that here, when particles are c generated by gas ionization, 90% are within the beam cross c section and 10% are random across the full pipe section c c 2007, see line 1485, it creates a file with the electron phase c space at the beginning of a bunch passage when the electron clous c is at saturation. To be used as input for HEADTAIL c c 2009 J. Crittenden has corrected the clean routine by rescaling the cloud c charges after cleaning, such as to preserve the sum of the Q array. c Also the arrays of zero-charge entries are purged. The former clean c routine, while generally well behaved, would occasionally create c negative array charges or artificial charge plateaus for a decaying c cloud by not conserving the total cloud charge when doing the cleaning. 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 = 1500) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) integer iycount(0:iybin) integer index(npelm), ik, iabort, igap, irepout 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 qaccc, xbc, ybc 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) real*8 webincut(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 webinny(0:500) real*8 denscenter real*4 timecpu 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, qaccc, xbc, ybc 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 /colli1/ press,crse,plpppm,pleff 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,webinny common / wavgui17 / webinx, webinx2, webinx3 common / wavgui18 / webincut 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, nbwake c cccccccccccccccccccccccccccccccccccccccccccc common / def1 / rbound, xbound, ybound, zbound, energy, belen common / test1 / itest common / test2 / test common / space2 / efxa, efya, qgrid common / center / denscenter common / time / timelimit common / b_numm / ident_bunch, ib_edi one = 1.0d0 etemp = 0.0d0 yksum = 0.0d0 yk2 = 0.0d0 xksum = 0.0d0 xk2 = 0.0d0 isemax = 1 c open(14,file="garbage.out",status='unknown') 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(61,file="cd.data",status='unknown') open(44,file="edistr.data",status='unknown') c changes 4444 to 91 open(91,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(47,file="bunch.movie.data",status='unknown') open(48,file="boundary.movie.data",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(55,file="cmnCylindrical.TESLA.dat",status='unknown') open(56,file="av.yield.data",status='unknown') open(57,file="wigglerfieldmaurotest.dat",status='unknown') open(58,file="wigglerfieldhanstest.dat",status='unknown') open(59,file="seilertest.dat",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(75,file="onwall.energy.distrc.data",status='unknown') c 1176 seems not to be needed c open(1176,file="onwall.energyn.distr.data",status='unknown') c was 174 open(79,file="onwall.azimuth.distr.data",status='unknown') c was 176 - energy flux on wall open(76,file="onwall.x.distr.data",status='unknown') c seems not needed c open(1741,file="onwall.azimuth1.distr.data",status='unknown') c was 1761 - charge flux on wall open(77,file="onwall.x1.distr.data",status='unknown') c was 1762 - charge flux on wall from e- with energy > 30 eV open(78,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') c was 188 open(71,file="qlosswh.data",status='unknown') c was 144 open(72,file="traj.test.data",status='unknown') c was 145 open(73,file="trapping.data",status='unknown') c was 149 open(82,file="ioniz.data",status='unknown') c added for hits open(51,file='hit.data') open(52,file='hit.sum') open(35,file='wake.data') open(37,file='wfield.data') c open(53,file='hit.hist') call init write(46,*) "set xrange [",-1.1*xbound,":",1.1*xbound,"]" write(46,*) "set yrange [",-1.1*ybound,":",1.1*ybound,"]" write(46,*) "set nokey" 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 ident_bunch = j call timex(timecpu) c write(*,*) ' timecpu = ',timecpu if (timecpu.gt.(timelimit-300.)) then write(*,*) ' time : ', timecpu write(*,*) ' exceeds limit: ', timelimit write(*,*) ' start passage ', j goto 917 endif 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 c if (iwake.eq.2.and.j.eq.nbwake) then c xt = x1 + xwto c yt = y1 + ywto c endif iflagg=0 if (indexb(j).eq.1) then write(*,*) ' call generate ' write(61,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc 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) qdensc = qaccc/belen/pi/(xbc*ybc) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc if (indexb(j).eq.1) then write(42,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=0 write(*,*) ' call interbunch ', j,' ', t 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 c write(61,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc 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) qdensc = qaccc/belen/pi/(xbc*ybc) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens c write(43,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc write(43,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc if (indexb(j).eq.1) then write(42,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc 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 c write(61,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc call generate(j,iseed,yt,xt,iflagg) qdens = qacc/belen/pi/(xbound*ybound) qdensc = qaccc/belen/pi/(xbc*ybc) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens c write(43,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc write(43,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc if (indexb(j).eq.1) then write(42,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc 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 call scdtrig(eloss*el/deltatime/belen,elossq) 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 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 call timex(timecpu) if (timecpu.gt.(timelimit-300.)) then write(*,*) ' time : ', timecpu write(*,*) ' exceeds limit: ', timelimit write(*,*) ' abort gap: ', j goto 917 endif qdens = qacc/belen/pi/(xbound*ybound) qdensc = qaccc/belen/pi/(xbc*ybc) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens c write(43,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc write(43,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc c write(42,'(e25.5,e25.5,e25.5)') t, denscenter,qdensc 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) write(61,'(e25.5,2(1x,e15.5))') t, denscenter,qdensc end do c compute trapping condition c for quadrupole fields c c if (ibend.eq.2) then c do j =1, icount c vtot2 = xp(j)**2+yp(j)**2+zp(j)**2 c vtrans2 = (x(j)*xp(j)-y(j)*yp(j))**2/(x(j)**2+y(j)**2) c trap = vtot2*Sqrt(x(j)**2+y(j)**2)/vtrans2/xbound-1. c was 145 c write(73,'(i4,3(1x,e12.4))') j, trap, x(j), y(j), q(j) c end do c endif c frank, nov 99 if (iwake.ne.1) 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.ne.1) 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.d0)) xksum = xksum / real(isemax) xk2 = xk2 / real(isemax) xrms = dsqrt(dmax1(xk2-xksum*xksum,0.d0)) write(23,*) ' ' write(23,*) yksum, yrms, xksum, xrms close(23) write(*,*) dkickx, dkicky, dkickn write(*,*) dkickx, dkicky, dkickn endif 917 continue 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 723 endif if (etemp2.eq.0) then write(*,*) ' WARNING - etemp2=0 ' goto 722 endif do 322 ik=0,500 dik=ik*2. c was 1174 write(83,*) dik, webinn(ik)/etemp2 322 continue 722 continue do 323 ik=0,500 dik=real(ik)*800/500. write(74,*) dik, webin(ik)/etemp write(75,*) dik, webincut(ik)/etemp 323 continue 723 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) c was 174 write(79,*) real(ik)*pi/250.,webinphi(ik)/deltatime/ & belen/real(nbunch)*el*500./(pi*(xbound+ymbound)),j c was 174 write(79,*) real(ik)*pi/250.,webinph2(ik)/deltatime/ & belen/real(nbunch)*el*500./(pi*(xbound+ymbound)),j c heat load c was 176 write(76,*) (xstep*real(ik)),webinx(ik)/ & deltatime/belen/real(nbunch)*el*500./(2*xbound),j c charge c was 1761 write(77,*) (xstep*real(ik)),webinx2(ik)/ & deltatime/belen/real(nbunch)*el*500./(2*xbound),j c charge with e energies above 30 eV c was 1762 write(78,*) (xstep*real(ik)),webinx3(ik)/ & deltatime/belen/real(nbunch)*el*500./(2*xbound),j 329 continue c was 174 close(79) c seems not needed c 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(26) close(88) close(45) close(44) close(46) close(47) close(91) close(26) close(87) close(24) close(43) close(45) close(48) c was 144 close(72) c was 149 close(82) 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 = 1500) integer iycount(0:iybin) integer index(npelm), i, ik, iabort real*8 webinny(0:500) 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, press, crse real*8 rhorg, dnelion 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 qaccc, xbc, ybc 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) double precision varscd(100) 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 real*8 maurocoef (1:40,1:40) real*8 bzfield 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,efieldrfmult 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/ colli1 / press, crse,plpppm,pleff 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, qaccc, xbc, ybc 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 / 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 / rann / iseed, idumy common / movie / boundix, boundiy, boundox, boundoy common / beam / rg, rm1 common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn,webinny 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, nbwake common / byield1 / iycount common / loss2 / qlosswh, qlosstot, qlosstot2 common / delay / iscatter ccccccccccccccccccccccccccccccccccccccccccccccccccc c frank 23/06/03 common / time / timelimit common / seilerflag / iflagem common /daniel/ yex(-100:100),yldx(-100:100),escdf,nscdf,ifload common / mauro / maurocoef common / ibend2 / ibend2 common / defcb / bzfield common / b_numm / ident_bunch, ib_edi c write(*,*) ' in init ' do i=-ngrid2,ngrid2 do j=-ngrid2,ngrid2 efxa(i,j) = 0.0d0 efya(i,j) = 0.0d0 end do end do 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 ifload=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 c if (ibend.eq.0) then c bfield = 0.0d0 c else c bfield = 8.39d0 c 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! do km = 1, 40 do kn = 1, 40 maurocoef(km,kn )= 0. end do end do c 20.06.1997 Oliver: Read input from file: open(11,file="ecloud.input",status='unknown') read(11,'(a64)') dummy read(11,*) isemax,idumy idumy=-idumy write(*,*) dummy write(*,*) isemax,idumy 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 nscdf=0 if (yim.lt.0.0) then call varld endif 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 write (*,*) 'ifload=',ifload c write(*,*) dummy c write(*,*) ybound read(11,'(a64)') dummy read(11,*) zbound if (zbound.lt.0.0) then zbound=-zbound ifload=1 else ifload=0 endif 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 write(*,*) volt c if (zbound.ne.0.0) volt = volt /2.0d0/zbound read(11,'(a64)') dummy read(11,*) ibend write(*,*) dummy write(*,*) ibend if (ibend.eq.2) then read(11,*) ibend2 write(*,*) ibend2 if (ibend2.ge.6) then read(11,*) bzfield endif endif if (ibend.eq.24.or.ibend.eq.50) then read(11,*) bgradient endif if (ibend.eq.25) then read(11,*) f0,efieldrf endif if (ibend.eq.26) then do ki26 = 1,10000 read(55,*,end=91) km,kn,maurocoef(km,kn) write(*,*) km,kn,maurocoef(km,kn) end do c stop endif 91 continue if (ibend.eq.26) then write(*,*) ' here ' c call fcntest c call seilertest c stop 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 if (icoll.eq.2) then read(11,*) press,crse write(*,*) ' icoll=2: ',press,crse else if (icoll.eq.3) then read(11,*) plpppm,pleff write(*,*) ' icoll=3: ',plpppm,pleff endif c frank, november 99, flag for inelastic scattering read(11,'(a64)') dummy read(11,*) inel,escdf write(*,*) dummy write(*,*) inel,escdf c c c call seilertest c stop 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,*) idis1,idis2,idis3,idis4 read(11,*) ditn1, ditn2, ditn3, ditn4 read(11,*) ifscd if (ifscd.gt.0) then if (ifscd.lt.100) then read(11,*) (varscd(k),k=1,ifscd) else stop 'too many bunch charges' endif endif 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, nbwake write(*,*) dummy write(*,*) iwake write(*,*) xwto, ywto, nbwake c frank, june 03 c may want to add back monitor later read(11,'(a64)') dummy read(11,*) em1, em2 write(*,*) dummy write(*,*) em1, em2 c read(11,'(a64)') dummy read(11,*) timelimit write(*,*) dummy write(*,*) timelimit close(11) write(*,*) ' input complete ' c here we define the bunch at which the electron distribution must be saved c to the edistr.data to be later used in HEADTAIL. We select five bunches c before the end of the last batch (defined by the total number of bunches c minus the number of abort bunches minus the empty bunches at the end of c a batch!) ib_edi=nbunch-iabort-ito2-5 indbx = 0 do i = 1, irep do j = 1, ito1 indbx = indbx+1 indexb (indbx) = 1 dntr (indbx) = ditn1 do k=2,idis1 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = 0 end do end do do j = 1, ito2 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = ditn2 do k=2,idis2 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = 0 end do end do do j = 1, ito3 indbx = indbx+1 indexb (indbx) = 1 dntr (indbx) = ditn3 do k=2,idis3 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = 0 end do end do do j = 1, ito4 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = ditn4 do k=2,idis4 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = 0 end do end do end do c Daniel to add charge modulation if (ifscd.gt.0) then kscd=1 do k=1,indbx if (indexb(k).gt.0) then dntr(k)=dntr(k)*varscd(kscd) kscd=kscd+1 if (kscd.gt.ifscd) then kscd=1 endif endif enddo endif 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(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) = 2*sx*cos(2*pi*i/40.0d0) boundiy(i) = 2*sy*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.eq.0) 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 else if (icoll.eq.2) then rhorg=press*(1.333d-7)/(1.38d-23)/300 dnelion=crse*(1d-22)*rhorg*belen*ppb q(i) = dnelion/real(npepb) index(i) = 0 else if (icoll.eq.3) then q(i)= belen*ppb*pleff*plpppm/real(npepb) index(i) = 0 endif 12 continue bnorm = 0.0 if (idistr.eq.3) * write(*,*) "Using a parabolic charge distribution " 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.ge.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(nbstep)+real(i))/(real(ibmax)- & real(nbstep)) 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-1)/real(nbstep-1)) endif if (idistr.eq.3) then bweight(i)=real(i-1)*bl*bl*real(nbstep-i)/real((nbstep-1)**2) 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. iflagem = 0 c used for ILC definition of central density xbc = 0.001 ybc = 0.001 end subroutine generate(jb,is,yoff0,xoff0,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 = 1500) c parameter (nbstep = 5) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,ngrid2=10) parameter (np=8000,np1=8000) real*8 webinlarge(0:500) integer iycount(0:iybin) integer index(npelm) integer kw, nw, iflag integer iazi, IFAIL, iirefl, iscatter integer iwake, nbwake real*8 ayield(0:iybin), avcos(0:iybin),webinny(0:500) 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 qaccc, xbc, ybc 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 webincut(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 real*4 timecpu real*8 xwto, ywto 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, qaccc, xbc, ybc 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,webinny common / wavgui17 / webinx, webinx2, webinx3 common / wavgui18 / webincut common / wavgui19 / webinlarge common / refl / refl common / swrefl / iirefl common / indb2 / dntr common / caso / uni common / delay / iscatter common / time / timelimit common / wake / iwake common / wake2 / xwto, ywto, nbwake common / b_numm / ident_bunch, ib_edi external C05ADF external CDF external solenx,soleny,solenz c c Daniel: some quick hack to find out if the field has changed c integer isold data isold /0/ save isold xoff=xoff0 yoff=yoff0 if (jb.eq.50) then c yoff=0.002 c xoff=0.004 endif if (jb.eq.nbwake.and.iwake.eq.2) then yoff=ywto xoff=xwto endif one = 1.0d0 write(*,*) ' in subroutine generate ', xoff,yoff,jb,nbwake 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 if(ib.eq.1) then if(ident_bunch.ge.ib_edi.and.ident_bunch.le.ib_edi) then write(*,*) 'bunch number =',ident_bunch do 465 i = 1, icount write(44,9444) x(i), y(i), xp(i), yp(i), q(i) 9444 format(5(1x,e12.4)) 465 continue write(44,*) ' ' write(44,*) ' ' endif endif call timex(timecpu) c write(*,*) ' timecpu = ',timecpu, ib if (timecpu.gt.(timelimit-300.)) then write(*,*) ' time : ', timecpu write(*,*) ' exceeds limit in generate: ', timelimit write(*,*) ' start step ', ib return endif if (icount.gt.npelm/3) call clean bunchtm=(jb-1)*(sb+bl)/vl+(ib-1)*dtex if ((ib.eq.1).or.(ib.eq.nbstep)) then write(47,*) bunchtm, 0d0 else write(47,*) bunchtm, bweight(ib)*ppb endif 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 icountfrozen = icount do 11 i = 1, icountfrozen 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 c was 144 write(72,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) c c Daniel: indx should correspond to a point below the actual particle position c if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indx.ge.ngrid2.or.indx.lt.-ngrid2.or. * indy.ge.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.and.igeom.ne.4) * call foliver(xt,yt,xoff,yoff,sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xt-xoff)/xta dpy = dpy - pre * factor c * (yt-yoff)/yta c + el*volt/ elmass eebeamx = pim * factor c * (xt-xoff)/xta eebeamy = pre * factor c * (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 gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl cc11 = pxt*dtex/gamma cc12 = (-eebeamx+eespacex * + el/elmass*pzt*bfield/gamma)*dtex cc13 = pyt*dtex/gamma cc14 = (-eebeamy+eespacey)*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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta endif 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta endif cc 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.30.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt c write(*,*) ' ebinw =' call ebinw(webin,webincut,engt,qt,xt) c if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) call ebinwlarge(webinlarge,engt,qt,xt) engty = 0.5*yp(i)*yp(i)*elmass/el if (abs(xt).lt.(0.7*xbound).and.engty.gt.30.) & call ebinwnew(webinny,webinn,engty,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. c if (jb.eq.jebin.and.ib.eq.iebin.and.q(i).gt.0.0d0) then c write(44,9444) x(i), y(i), q(i), z(i) c 9444 format(4(1x,e12.4)) c channel was 4444 c write(91,9444) xp(i), yp(i), q(i), zp(i) c endif if (imovie.eq.1.and.mod(ib,iseq).eq.0.and. * q(i).gt.0.0d0.and.mod(i,10).eq.0.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,iseq).eq.0) then do 112 id=1,40 write(48,*) boundix(id), boundiy(id) 112 continue do 113 id=1,80 write(48,*) boundox(id), boundoy(id) 113 continue write(45,*) " " write(45,*) " " write(48,*) " " write(48,*) " " 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" write(46,*) * "replot 'boundary.movie.data' index ",mcount," with points 4 6" 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... c 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.lt.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 c for uniform distribution outside antechamber c (a.c. half height 3 mm, half chamber width 16 mm) c 4 mm 22 mm if(iirefl.eq.6) then rsign=ran2(idumy) if (rsign.gt.0.5) then tsign=+1.d0 else tsign=-1.d0 endif acut = 0.182 r2 = tsign*((pi-2*acut)*(ran2(idumy))+acut) 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 * 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.or.icoll.eq.2) 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 if(ran2(idumy)<0.9) then 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 else x(icount) = xbound*ran2(idumy)*cos(2.d0*pi*ran2(idumy)) y(icount) = ybound*ran2(idumy)*sin(2.d0*pi*ran2(idumy)) endif 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) else if (icoll.eq.3) then **** uniform distribution for electrons by proton losses x(icount) = xbound*cos(2.d0*pi*ran2(idumy)) y(icount) = ybound*sin(2.d0*pi*ran2(idumy)) z(icount) = (ran2(idumy)-0.5)*belen ****** find orthonormal vectors xtpl = x(icount) ytpl = y(icount) dn1pl = -xtpl/xbound**2/ + sqrt(xtpl**2/xbound**4+ytpl**2/ybound**4) dn2pl = -ytpl/ybound**2/ + sqrt(xtpl**2/xbound**4+ytpl**2/ybound**4) dn3pl = 0.0d0 dm1pl = -dn2pl dm2pl = dn1pl dm3pl = 0.0d0 do1pl = 0.0d0 do2pl = 0.0d0 do3pl = 1.0d0 ***** uniform energy distribution c emax0elpl = 25.0d0 c enelpl = ran2(idumy)*emax0elpl*el c velpl = sqrt(2.0d0*enelpl/elmass) **** gaussian energy distribution emax0elpl = 10.0d0 sigmaelpl = 5.0d0 enelpl = sqrt(-2*log(ran2(idum1)))*cos(2*pi*ran2(idum2)) enelpl = enelpl*sigmaelpl+emax0elpl if (enelpl.lt.0.d0) enelpl=-enelpl c write(6,*) 'nrg;', enelpl velpl = sqrt(2.0d0*enelpl*el/elmass) c*** angle distribution sinel = sqrt(ran2(idumy)) cosel = sqrt(1.0d0 - sinel**2) dphiel = 2.0d0*pi*ran2(idumy) xp(icount) = dn1pl*cosel+sinel*(dm1pl*cos(dphiel)+ + do1pl*sin(dphiel)) yp(icount) = dn2pl*cosel+sinel*(dm2pl*cos(dphiel)+ + do2pl*sin(dphiel)) zp(icount) = dn3pl*cosel+sinel*(dm3pl*cos(dphiel)+ + do3pl*sin(dphiel)) xp(icount) = xp(icount)*velpl yp(icount) = yp(icount)*velpl zp(icount) = zp(icount)*velpl endif c was 149 write(82,*) x(icount),y(icount),q(icount) 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) c was 144 write(72,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) c c Daniel: changed to get proper field calculation c if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 c if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 c 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.and.igeom.ne.4) * call foliver(xt,yt,xoff,yoff,sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xt-xoff)/xta dpy = dpy - pre * factor c * (yt-yoff)/yta c+ el*volt/ elmass c * dti eebeamx = pim * factor c * (xt-xoff)/xta eebeamy = pre * factor c * (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 gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta endif cc 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.and.igeom.ne.4) * call foliver(xtn,ytn,xoff,yoff, * sx,sy,rg,rm1,pre,pim) if(iimageb.eq.1.and.igeom.eq.4) * call frect(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 c * (xtn-xoff)/xta eebeamy = pre * factor c * (ytn-yoff)/yta 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.30.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt call ebinw(webin,webincut,engt,qt,xt) c if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) call ebinwlarge(webinlarge,engt,qt,xt) engty = 0.5*yp(icount)*yp(icount)*elmass/el c engttest = 0.5*(yp(i)*yp(i)+xp(icount)*xp(icount)+zp(i)*zp(i)) c & *elmass/el c write(*,*) ' engttest = ',engttest, engt if (abs(xt).lt.(0.7*xbound).and.engty.gt.30.) & call ebinwnew(webinny,webinn,engty,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 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. c if (jb.eq.jebin.and.ib.eq.iebin.and.q(icount).gt.0.0) then c write(44,9444) x(icount), y(icount), q(icount), z(icount) c channel was 4444 c write(91,9444) xp(icount), yp(icount), q(icount), zp(icount) c endif 13 continue endif qdens = qacc/belen/pi/(xbound*ybound) qdensc = qaccc/belen/pi/(xbc*ybc) 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 c was 188 write(71,'(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 INTEGER 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 INTEGER 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 INTEGER 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 webinny(0:500),webinlarge(0:500) 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 qaccc, xbc, ybc 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 real*8 webincut(0:500) real*4 timecpu 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, qaccc, xbc, ybc 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,webinny common / wavgui17 / webinx, webinx2,webinx3 common / wavgui18 / webincut common / wavgui19 / webinlarge c frank, nov 99, for azimuth common / azi / iazi common / center / denscenter common / time / timelimit common / b_numm / ident_bunch, ib_edi 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 call timex(timecpu) c write(*,*) ' timecpu = ',timecpu, ib,' interbunch' if (timecpu.gt.(timelimit-300.)) then write(*,*) ' time : ', timecpu write(*,*) ' exceeds limit in interbunch: ', timelimit write(*,*) ' start step ', ib return endif if (icount.gt.npelm/3) call clean 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 `1 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 icountfrozen = icount do 11 i = 1, icountfrozen 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 c was 144 write(72,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) c c Daniel: changed to get proper field calculation c if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 c if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 c 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 gammai = vl/sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2) c gamma = sqrt(1.0d0+(py(i)/vl)**2) xp(i) = px(i)*gammai yp(i) = py(i)*gammai zp(i) = pz(i)*gammai 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 gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl 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 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 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 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 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 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 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.30.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt call ebinw(webin,webincut,engt,qt,xt) c if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) call ebinwlarge(webinlarge,engt,qt,xt) engty = 0.5*yp(i)*yp(i)*elmass/el c engttest = 0.5*(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) c & *elmass/el c write(*,*) ' engttest = ',engttest, engt if (abs(xt).lt.(0.7*xbound).and.engty.gt.30.) & call ebinwnew(webinny,webinn,engty,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(48,*) boundox(id), boundoy(id) 213 continue write(45,*) " " write(45,*) " " write(48,*) " " write(48,*) " " write(46,*) * "plot 'edistr.movie.data' index ",mcount," with points 3" write(46,*) * "replot 'boundary.movie.data' index ",mcount," with lines 4" c if (ib.eq.1) write(46,*) c * "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) qdensc = qaccc/belen/pi/(xbc*ybc) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,2(1x,e15.5))') t, denscenter, qdensc c write(88,'(2e25.5)') t, elossq c was 188 write(71,'(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, qaccc, xbc, ybc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinny(0:500), webinlarge(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 webincut(0:500) 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, qaccc, xbc, ybc 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, webinny common / wavgui17 / webinx, webinx2, webinx3 common / wavgui18 / webincut common / wavgui19 / webinlarge 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),webinny(0:500) 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, qaccc, xbc, ybc 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 webincut(0:500) 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, qaccc, xbc, ybc 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,webinny common / wavgui17 / webinx, webinx2, webinx3 common / wavgui18 / webincut 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 block data scddat common / qlimit / qlimit double precision qlimit data qlimit /10d0/ end subroutine clean c c Randomly remove cloud macroparticles to reduce computing time c and limit cloud array usage to NACCEPT elements. c Also remove the zero-charge macroparticles. c c Rescale the remaining cloud charges so that c the sum variable QACC remains correct. c c Restore the NPELM array entries of the removed macroparticles to c their original values. Most importantly, restore the c primary charge values Q originally defined in routine INIT. c c Note that CLEAN is called inside the time slice loops c if the number of macroparticles ICOUNT exceeds 1/3 NPELM. c But CLEAN exits without doing anything if c the number of macroparticles is less than NACCEPT. c So it doesn't make sense to have NACCEPT > 1/3 NPELM. c 3 Sep 2009 J.A.Crittenden c Force this condition on NACCEPT in the parameter statement c 28 Oct 2009 jac c implicit real*8 (a-h,o-z) parameter (npelm=600000) parameter (naccept=npelm/3) 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), test(npelm) real*8 dele(npelm), qele(npelm) real*8 ran2 integer iseed, idumy real*8 qacc,qaccc, xbc, ybc real*8 qtot,qtotnew common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / test2 / test common / part / qacc, qaccc, xbc, ybc common / part2 / icount, icountact, iadele common / egain / dele, qele common / rann / iseed, idumy write(*,*)' Enter Rtn CLEAN. t,icount,qacc,naccept,npelm= ', & t,icount,qacc,naccept,npelm if(icount.eq.0)return incount = 0 qtot = 0. c Remove zero-charge macroparticles do i=1,icount qtot = qtot + q(i) if (q(i).gt.0.) then incount = incount + 1 q(incount) = q(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) index(incount) = index(i) esign(incount) = esign(i) test(incount) = test(i) dele(incount) = dele(i) qele(incount) = qele(i) endif enddo write(*,*)' Rtn CLEAN removes ',icount-incount, & ' small charges of ',icount, & ' total, carrying total charge fraction ', & (qtot-qtotnew)/qtot icount = incount if(icount.eq.0)return c If ICOUNT still greater than NACCEPT, remove c macroparticles randomly if (icount.gt.naccept) then ratio=real(naccept)/real(icount) qtot = 0. qtotnew = 0. incount = 0 do i=1,icount qtot = qtot + q(i) if (ran2(idum).lt.ratio) then incount = incount + 1 q(incount) = q(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) index(incount) = index(i) esign(incount) = esign(i) test(incount) = test(i) dele(incount) = dele(i) qele(incount) = qele(i) qtotnew=qtotnew+q(incount) endif enddo write(*,*)' Rtn CLEAN removing macroparticle fraction ', & 1.-ratio, 'carrying total charge fraction', & (qtot-qtotnew)/qtot icount = incount c Restore total cloud charge if(qtotnew.gt.0.)then do i=1,icount q(i) = q(i)*qtot/qtotnew enddo endif endif c Reinitialize Q and INDEX originally defined in routine INIT do i = icount+1,npelm-1 q(i) = q(npelm) index(i) = 0 enddo write(*,*) & ' Exit Rtn CLEAN with nr cloud charges, total cloud charge:', & icount,qtot end subroutine oldclean c purpose: eliminate indices for electrons with vanishing charge. implicit real*8 (a-h,o-z) c implicit integer (a-z) parameter (npelm=600000) parameter (naccept=50000) 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 common / qlimit / qlimit save write(*,*)' in clean ' incount = 0 c qlimit = 10.d0 if (icount.gt.naccept) then qsum=0.d0 do i=1,icount qsum=qsum+q(i) end do qlimit=max(10.d0,qsum/real(naccept)) c qlimit=qsum/real(naccept) endif do 101 i=1,icount if (q(i).lt.qlimit) then rtest=ran2(idum) if (q(i).ge.rtest*qlimit) 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 c c should simply be zero, no? Daniel. c 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 webinny(0:500), webinlarge(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 qacc, qaccc, xbc, ybc common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / part / qacc, qaccc, xbc, ybc 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, webinny common / wavgui17 / webinx, webinx2, webinx3 common / wavgui19 / webinlarge 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, qaccc, xbc, ybc common / part / qacc, qaccc, xbc, ybc 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, qaccc, xbc, ybc real*8 bfield, el, vl, fom, pi, re, elmass common / part / qacc, qaccc, xbc, ybc 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 webinny(0:500), webinlarge(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, qaccc, xbc, ybc real*8 rboundl common / part / qacc, qaccc, xbc, ybc 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, webinny common / wavgui17 / webinx, webinx2, webinx3 common / wavgui19 / webinlarge 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 webinny(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, webinny 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, binwecut, wen, qw, x) 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, x real*8 binwecut(0:500) real*8 rbound, xbound, ybound, zbound, energy, belen ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 common / def1 / rbound, xbound, ybound, zbound, energy, belen cccccccccccccccccccccccccccccccccccccccccccc vmax = 1000.0d0 vmin = 0.0d0 xcut = xbound*0.7 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 if (abs(x).lt.xcut) then binwecut(k) = binwecut(k)+qw endif endif 101 continue end subroutine ebinwnew(binwey, binwe, weny, 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 real*8 binwey(0:500), weny ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc vmax = 1000.0d0 vmin = 0.0d0 estep = (vmax-vmin)/(nbin-1) 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 k=nint(weny/estep) if (weny.lt.vmax) then if(k.gt.nbin.or.k.lt.0) then goto 201 endif binwey(k) = binwey(k) + qw endif 201 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) parameter(eta=8.8542d-12) integer ifirst 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) c c Daniel: c significant increase in speed (some factor) by keeping track of old forces c double complex force(-ngrid2:ngrid2,-ngrid2:ngrid2,-ngrid2:ngrid2, . -ngrid2:ngrid2) integer iff(-ngrid2:ngrid2,-ngrid2:ngrid2) C data ff /((2*ngrid2+1)*(2*ngrid2+1))*0/ save ff,force real*8 r1x(0:nimage2),r1y(0:nimage2),r2x(0:nimage2),r2y(0:nimage2) real*8 rg, rm1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc, qaccc, xbc, ybc 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 real*4 timecpu 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 real*8 webinny(0:500) 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, qaccc, xbc, ybc 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,webinny common / wavgui17 / webinx, webinx2, webinx3 common / center / denscenter common / time / timelimit common /daniel/ yex(-100:100),yldx(-100:100),escdf,nscdf,ifload data first /1/ save first call timex(timecpu) c write(*,*) ' s.c. timecpu = ',timecpu if (timecpu.gt.(timelimit-300.)) then write(*,*) ' time : ', timecpu write(*,*) ' exceeds limit: ', timelimit write(*,*) ' start passage ', j return endif qaccc=0.d0 do i = 1, icount radtest = sqrt(x(i)*x(i)+y(i)*y(i)) if (radtest.lt.xbc) then qaccc = qaccc+q(i) endif end do do i=1,ngridffts do j=1,ngridffts qgridfft(j,i)=0.d0 end do end do do i=-ngrid2,ngrid2 do j=-ngrid2,ngrid2 qgrid(j,i)=0.d0 end do end do c scd c write (*,*) 'hello' if (first.eq.1) then if (ifload.eq.0) then do i=-ngrid2,ngrid2 do j=-ngrid2,ngrid2 iff(j,i)=0 end do end do else open(54,file='space.force') write (*,*) 'reading space.force' do i=-ngrid2,ngrid2 write (*,*) i do j=-ngrid2,ngrid2 iff(j,i)=2 read(54,*) efxa(i,j),efya(i,j) end do end do close(54) endif first=0 endif ccccccccccccccccccccccccccccccccccccccccccccccc c c parameter for avoiding zero charge and grid points epsi=1.d-5 write(*,*) ' in spacecharge2 ' c seems not to be not needed c 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: c scd c write (*,*) 'hello' c do i=1,1000 c x(i)=0.98*xbound*cos(2.0*acos(-1.0)*(i-0.5)*0.001) c y(i)=0.98*xbound*sin(2.0*acos(-1.0)*(i-0.5)*0.001) c q(i)=100.0 c write (*,*) x(i),y(i) c end do c icount=1000 if (igeom.ne.4) then do 103 i=1,icount c c frank: i do not understand the abs( ) - correct for quads? c 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 c scd c Daniel: modifed to contain abs(linx), abs(liny) c this should give symmetric behaviour c c 331 rl2 = (dble(linx-1)/dble(ngrid2))**2 + c * (dble(liny)/dble(ngrid2))**2 c rl3 = (dble(linx)/dble(ngrid2))**2 + c * (dble(liny-1)/dble(ngrid2))**2 c rl4 = (dble(linx-1)/dble(ngrid2))**2 + c * (dble(liny-1)/dble(ngrid2))**2 331 rl2 = (dble(abs(linx)-1)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 rl3 = (dble(linx)/dble(ngrid2))**2 + * (dble(abs(liny)-1)/dble(ngrid2))**2 rl4 = (dble(abs(linx)-1)/dble(ngrid2))**2 + * (dble(abs(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 c write(*,*) " to : ",linx,liny, x(i),y(i) if(rl1.gt.rolimit) goto 331 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 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 c scd do i=-ngrid2,ngrid2 do j=-ngrid2,ngrid2 c write (95,*) i,j,efxa(i,j),efya(i,j),qgrid(i,j) end do c write (95,*) end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c compute 2-D FFT of charge distribution c if (igeom.eq.4) then c do 1031 i=1,icount c note right/top border are outside the range c c Daniel Schulte: only half a cell is outside of boundary c linx = nint((ngridffts/2)*(xbound+x(i))/(2.*xbound)+1.0) liny = nint((ngridffts/2)*(ymbound+y(i))/(2.*ymbound)+1.0) c c Daniel Schulte: corrected the test whether the particle is inside the c beam chamber c c was the following c if (linx.ge.1.and.linx.le.ngridffts.and.liny.ge.1.and. c & liny.le.ngridffts) then if (linx.gt.1.and.linx.le.ngridffts/2.and.liny.gt.1.and. & liny.le.ngridffts/2) then qgridfft(linx,liny) = qgridfft(linx,liny) + q(i) endif 1031 continue ishift=2 do 1034 ifft2=1,ngridffts/2 do 1033 ifft1=ngridffts/2+ishift,ngridffts qgridfft(ifft1,ifft2) = -qgridfft(ngridffts+ishift-ifft1,ifft2) 1033 continue 1034 continue do 1036 ifft2=ngridffts/2+ishift,ngridffts do 1035 ifft1=1,ngridffts/2 qgridfft(ifft1,ifft2) = -qgridfft(ifft1,ngridffts+ishift-ifft2) 1035 continue 1036 continue do 1038 ifft2=ngridffts/2+ishift,ngridffts do 1037 ifft1=ngridffts/2+ishift,ngridffts qgridfft(ifft1,ifft2) = & +qgridfft(ngridffts+ishift-ifft1,ngridffts+ishift-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 c scd acoef (ifft1,ifft2) = 2./(nnfft1*nnfft2) & *(dble(datafft(ifft1,ifft2,1))- & dble(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: c write (*,*) 'constructing field' 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 c Daniel: Check whether the Green function for the force between cell (k,l) c and (i,j) has already been calculated c if (iff(k,l).ne.2) then c write (*,*) 'one' 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+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 c c Daniel: store the Green function of the force from cell (k,l) onto (i,j) c force(k,l,i,j)=efz efz=efz*charge*const tx=dreal(efz) ty=dreal(-efz*zi) iff(k,l)=1 else c c Daniel: use the stored value of the force c c write (*,*) 'two' charge=1.d0 tx=dreal(force(k,l,i,j))*charge*const ty=dimag(force(k,l,i,j))*charge*const endif efxa(i,j)=efxa(i,j)+tx efya(i,j)=efya(i,j)+ty 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 c was closed here c 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 ' c scd c c Daniel: Check for all cells if the Green function has been calculated c it has then been calculated for all other cells c so set flag to memorise this c do i=-ngrid2,ngrid2 do j=-ngrid2,ngrid2 if (iff(i,j).eq.1) then iff(i,j)=2 endif c write (95,*) i,j,efxa(i,j),efya(i,j),qgrid(i,j) end do c write (95,*) end do write (*,*) 'hier - exit s.c. ' c stop write (35,400) t,efxa(0,0),efya(0,0),efya(0,1),efya(0,2) 400 format(5(1x,e14.6)) 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 = 1500) 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, qaccc, xbc, ybc 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, qaccc, xbc, ybc 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.or.ibend.eq.40) 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) c c Daniel: changed to get porper field calculation c if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 c if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 c 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.or.ibend.eq.40) 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 (abs(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.and.igeom.ne.4) & call foliver(xt,yt,xoff,yoff,sx,sy,rg,rm1, & pre,pim) if(iimageb.eq.1.and.igeom.eq.4) & call frect(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 > .or.ibend.eq.40) 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 (abs(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 > .or.ibend.eq.40) 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 (abs(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 > .or.ibend.eq.40) 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 (y(i).gt.zbound) amp = 2.0d0 if (y(i).lt.-zbound) amp = 2.0d0 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, qaccc, xbc, ybc 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 real*8 webinny(0:500) 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, qaccc, xbc, ybc 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,webinny common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c c parameter for avoiding zero charge and grid points epsi=1.d-5 write(*,*) ' enter sc 3 ' c file is not used c 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) c was 990 open(90,file="density.dat") write(90,*) density close(90) 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: c was 1090 open(90,file="efxy.dat") c was 1092 open(92,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) c c Daniel: changed to get proper field calculation c if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 c if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 c 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 c was 1090 write(90,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 c was 1090 close(90) c file is not used c close(444) c was 1092 write (92,*) ' ey gradient = ', efgrad , ' V/m' close(92) 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 complex 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 c c Daniel June 2003, new version of the routine c error of the field in the centre of the elyptical chamber has been corrected c the routine is much faster now 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 (pi=3.141592653589793d0) parameter(nimage=30) double precision xt,yt real*8 x,y,sx,sy,rg,rm1,fr,fi, efx, efy, r2 common /daniel/ yex(-100:100),yldx(-100:100),escdf,nscdf,ifload complex*16 zone, zi, z1, z2, z3, z4, efz complex*16 z1b, z2b, z3b, z4b,scale4,ds4,fact isxsyflag = 0 if (sy.gt.sx) then syold=sy sxold=sx xold=x yold=y isxsyflag = 1 endif charge = 1.0d0 zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) c new variables if (isxsyflag.eq.0) then dx = x-xof dy = y-yof else dy = -x+xof dx = y-yof sx = syold sy = sxold endif 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 rg resmod = 2.d0/sqrt(2.d0*pi) res = resmod/r2 sx1 = sx sy1 = sy if (abs((sx/sy)-1.0d0).lt.1.0d-2) then co = (1.0d0-exp(-r2/(2.0d0*sx*sy))) fr = res*co*yt*(dy/yt) fi = res*co*xt*(dx/xt) if(r2.le.sx*sy/100.) then if (isxsyflag.eq.1) then sx = sxold sy = syold fitemp = fi fi = fr c Fx = (-)Fy fr = fitemp c Fy = Fx endif return endif c co1 = (1.0d0-exp(-r2/(2.0d0*sx*sy/100.))) c frc = res*co1*yt*(dy/yt) c fic = res*co1*xt*(dx/xt) if(r2.gt.sx*sy/100.) then c change round beam case as for flat beam c efx = dx/ r2 c efy = dy/ r2 c efz = efx * zone + efy * zi efz = (0.d0,0.d0) 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 = fi+efx*2.0d0/sqrt(2.0d0*pi) fr = fr+efy*2.0d0/sqrt(2.0d0*pi) if (isxsyflag.eq.1) then sx = sxold sy = syold fitemp = fi fi = fr c Fx = (-)Fy fr = fitemp c Fy = Fx endif return endif else c flat beam co = (1.0d0-exp(-r2/(2.0d0*sx*sy))) c fr2 = resmod * yt/r * co *(dy/yt) c fi2 = resmod * xt/r * co *(dx/xt) fr2 = resmod * dy/r * co fi2 = resmod * dx/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)*(dy/yt) fi1 = ( pim1 - expon * pim2 ) / sqrt(sx*sx-sy*sy)*(dx/xt) fr = fr2 fi = fi2 c den = sqrt((40.*sx)**2+r*r) w1 = 40.*sx/den w2 = sx/den c scd the above seems stupid w1=1.0 w2=0.0 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/100.) then if (ifload.eq.0) then efz = (0.d0,0.d0) 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 charge = 1.0d0 fact=1.d0/(cdexp((rmi*zone-rphi*zi)) - * cdexp(-(rmi*zone-rphi*zi)))/ rg if ((xof.eq.0.0).and.(yof.eq.0.0)) then ds=dexp(4.d0*rm1) scale=1.d0 ds4=cdexp(2.d0*(rmi*zone-rphi*zi)) scale4=(1.d0,0.d0) do 101 i=1,nimage scale=scale*ds scale4=scale4*ds4 efz = efz+((-1)**i)* * 8.0d0*charge/(scale+1.0d0) * * (scale4-1.d0/scale4)*fact 101 continue else ds=dexp(-rm1) scale=1.d0 ds2=dexp(rm1) scale2=1.d0 ds3=dexp(rmib) scale3=1.d0 ds4=cdexp(rmi*zone-rphi*zi) scale4=(1.d0,0.d0) ddsin=sin(rphib) ddcos=cos(rphib) c=1.d0 s=0.d0 do 201 i=1,nimage scale=scale*ds scale2=scale2*ds2 scale3=scale3*ds3 scale4=scale4*ds4 tmp=ddcos*s+ddsin*c c=ddcos*c-ddsin*s s=tmp efz = efz+2.d0*charge*scale*( * (scale3+1.d0/scale3)* * c/(scale2+scale)+ * zi*(scale3-1.d0/scale3)* * s/(scale2-scale))* * (scale4-1.d0/scale4)*fact 201 continue endif efx = dreal(efz) efy = dreal(-efz*zi) else call sumlhc(xof,yof,x,y,efx,efy) endif fic = efx*2.0d0/sqrt(2.0d0*pi) frc = efy*2.0d0/sqrt(2.0d0*pi) endif fr = w1 * fr1 + w2 * fr2 + frc fi = w1 * fi1 + w2 * fi2 + fic if (isxsyflag.eq.1) then sx = sxold sy = syold fitemp = fi fi = fr c Fx = (-)Fy fr = fitemp c Fy = Fx endif return endif c write(*,*) "Message from foliver: The beams are not round!" 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 c January 2003 - attempt to write a routine which correctly represents c the beam image charges for rectangular bondaries c subroutine frect(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 real*8 rbound, xbound, ybound, zbound, energy, belen, ymbound common / def1 / rbound, xbound, ybound, zbound, energy, belen ymbound = min(ybound,zbound) isxsyflag = 0 if (sy.gt.sx) then syold=sy sxold=sx xold=x yold=y ymboundold=ymbound xboundold=xbound isxsyflag = 1 endif c new variables if (isxsyflag.eq.0) then dx = x-xof dy = y-yof else dy = -x+xof dx = y-yof sx = syold sy = sxold ymbound=xbound xbound=ymbound endif 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 rg pi = acos(-1.0d0) res = 2.0d0/sqrt(2.0d0*pi)/r2 resmod = 2./sqrt(2.*pi) sx1 = sx sy1 = sy c round beam if (abs((sx/sy)-1.0d0).lt.1.0d-2) then co = (1.0d0-exp(-r2/(2.0d0*sx*sy))) fr = res*co*yt *(dy/yt) fi = res*co*xt *(dx/xt) call sumf(xbound,ymbound,xof,yof,x,y,efx,efy) fi = fi+efx*2.0d0/sqrt(2.0d0*pi) fr = fr+efy*2.0d0/sqrt(2.0d0*pi) if (isxsyflag.eq.1) then sx = sxold sy = syold ymbound=ymboundold xbound=xboundold fitemp = fi fi = -fr c Fx = (-)Fy fr = fitemp c Fy = Fx endif return else c flat beam co = (1.0d0-exp(-r2/(2.0d0*sx*sy))) fr2 = resmod * yt/r * co*(dy/yt) fi2 = resmod * xt/r * co*(dx/xt) 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)*(dy/yt) fi1 = ( pim1 - expon * pim2 ) / sqrt(sx*sx-sy*sy)*(dx/xt) fr = fr2 fi = fi2 c c den = sqrt((40.*sx)**2+r*r) c w1 = 40.*sx/den c w2 = sx/den c image charge: use oliver's routine and subtract round-beam kick c and add flat beam kick instead frc = 0. fic = 0. call sumf(xbound,ymbound,xof,yof,x,y,efx,efy) c if(r2.gt.sx*sy/100.) then c dya = y-(2.*ymbound-yof) c dyb = y-(-2*ymbound-yof) cc dyc = y-(4.*ymbound+yof) cc dyd = y-(-4*ymbound+yof) c ra = (xt*xt+dya*dya) c rb = (xt*xt+dyb*dyb) cc efx = dx/ r2 cc efy = dy/ r2 - dya/ra - dyb/rb c efx=0.d0 c efy=- dya/ra - dyb/rb firs = efx*2.0d0/sqrt(2.0d0*pi) frrs = efy*2.0d0/sqrt(2.0d0*pi) c co1 = (1.0d0-exp(-r2/(2.0d0*sx*sy/100.))) c c Daniel: hopefully corrected the formula c c co1=1.d0 co1=0.d0 frr = res*co1*dy fir = res*co1*dx c end of correction frc = frrs-frr fic = firs-fir c endif c arg = sqrt(sx*sy)/5. c if (r.lt.arg) then c fr = fr1 c fi = fi1 c else c fr = w1 * fr1 + w2 * fr2 + frc c fi = w1 * fi1 + w2 * fi2 + fic fr = fr1 + frc fi = fi1 + fic c endif if (isxsyflag.eq.1) then sx = sxold sy = syold ymbound=ymboundold xbound=xboundold fitemp = fi fi = -fr c Fx = (-)Fy fr = fitemp c Fy = Fx 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 isxsyflag = 0 if (sy.gt.sx) then syold=sy sxold=sx xold=x yold=y isxsyflag = 1 endif c new variables if (isxsyflag.eq.0) then dx = x-xof dy = y-yof else dy = -x+xof dx = y-yof sx = syold sy = sxold endif pi = 4.*datan(1.0d0) xt = abs(dx) yt = abs(dy) 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*dy fi = res*co*dx if (isxsyflag.eq.1) then sx = sxold sy = syold fitemp = fi fi = -fr c check with Frank c Fx = (-)Fy fr = fitemp c Fy = Fx endif return else c flat beam call bbkick(pre1,pre2,pim1,pim2,xt,yt,sx1,sy1) expon = dexp(-xt**2/(2.d0*sx1**2)-yt**2/(2.d0*sy1**2)) fr = ( pre1 - expon * pre2 )/ sqrt(sx*sx-sy*sy)*(dy/yt) fi = ( pim1 - expon * pim2 ) / sqrt(sx*sx-sy*sy)*(dx/xt) if (isxsyflag.eq.1) then sx = sxold sy = syold fitemp = fi fi = -fr c Fx = (-)Fy fr = fitemp c Fy = Fx endif 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), webinn(0:500) real*8 webinny(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 rin, rout, pi, vcosi(6), vsini(6) common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn, webinny common / wavgui17 / webinx, webinx2, webinx3 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 isxsyflag = 0 if (sy.gt.sx) then syold=sy sxold=sx xold=x yold=y isxsyflag = 1 endif xt = abs(x) yt = abs(y) if (isxsyflag.eq.1) then xt = abs(y) yt = abs(x) endif 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 if (isxsyflag.eq.1) then sx = sxold sy = syold fitemp = fi fi = -fr c Fx = (-)Fy fr = fitemp c Fy = Fx endif 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),webinny(0:500) 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 qaccc, xbc, ybc 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, qaccc, xbc, ybc 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 common / def11/ icoll common / colli1/ press,crse,plpppm,pleff 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,webinny 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 common / qlimit / qlimit common / seilerflag / iflagem common /daniel/ yex(-100:100),yldx(-100:100),escdf,nscdf,ifload save daniel costheta0=1.0 if (nscdf.eq.1) then i=int(xt/xbound*100.0) if (i.lt.-100) i=-100 if (i.gt.100) i=100 yemax=yex(i) yim=yldx(i) endif c write(*,*) ' in seiler ',xt,yt,zt, qt if (iflagem.eq.0) then enem=yemax if (inel.eq.1.or.inel.eq.2) then if(enem.le.300) then qtelast = frac1(enem)/(1-frac1(enem)) else qtelast = frac2(enem)/(1-frac2(enem)) endif if (inel.eq.2) then ene0=0.1d0 qtene0 = yield(ene0,costheta0,yim,yemax) qtelast = dexp(-enem/4.d0)*(1.-qtene0* & frac1(ene0)/(1-frac1(ene0)))+qtelast endif else if (inel.eq.3) then qtelast = ((sqrt(enem)-sqrt(enem+150))**2/(sqrt(enem)+ & sqrt(enem+150))**2) endif c c rescale delta_max only for inel=2,3, not for inel=1, c to be consistent with Noel's fitting c if (inel.eq.2.or.inel.eq.3) then yim=yim*yim/(yim+qtelast) endif iflagem = 1 write(*,*) ' rescaled yim: ', yimold, yim, qtelast endif 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 if (ibend.eq.2.and.igeom.ne.4) then c write(*,*) ' here ' c for LHC quadrupoles with elliptical boundary Bcoef = (xt*xt*ybound*ybound+yt*yt*xbound*xbound- & xbound*xbound*ybound*ybound) / & (xt*xt*xbound*xbound+ybound*ybound*yt*yt) Ccoef = xt*yt*(xbound*xbound+ybound*ybound)/ & (xt*xt*xbound*xbound+ybound*ybound*yt*yt) Ccoef2 = Ccoef**2 if ((Ccoef2-Bcoef).lt.0.d0) then c write(*,*) ' Ccoef2-Bcoef < 0 ! ' c write(*,*) Ccoef2, Bcoef, Ccoef c write(*,*) xt, yt, xbound, ybound if(abs(xt).gt.abs(yt)) then xt = sign(1.d0,xt)*xbound*sqrt(1.d0-yt**2/ybound**2) yt = yt else yt = sign(1.d0,yt)*ybound*sqrt(1.d0-xt**2/xbound**2) xt = xt endif goto 500 endif csol1 = Ccoef - sqrt(Ccoef2-Bcoef) csol2 = Ccoef + sqrt(Ccoef2-Bcoef) xt1 = xt - csol1 * yt yt1 = yt - csol1 * xt xt2 = xt - csol2 * yt yt2 = yt - csol2 * xt c Choose closest solution del1 = (xt1-xt)**2+(yt1-yt)**2 del2 = (xt2-xt)**2+(yt2-yt)**2 if(del1.lt.del2)then xt=xt1 yt=yt1 else xt=xt2 yt=yt2 endif 500 continue test1 = xtold**2/xbound**2+ytold**2/ybound**2 test2 = xt**2/xbound**2+yt**2/ybound**2+1.d-15 xt=xt/sqrt(test2) yt=yt/sqrt(test2) c test1 = xtold**2/xbound**2+ytold**2/ybound**2 test3 = xt**2/xbound**2+yt**2/ybound**2 aresidual = test3-1.d0 c if (aresidual.gt.0d0) then c write(*,*) ' test3 > 1 ! ' c write(*,*) aresidual c write(*,*) test1, test2, test3 c write(*,*) Ccoef2, Bcoef, Ccoef c write(*,*) xt, yt, xbound, ybound c stop c endif c if (aresidual.lt.0d0) then c write(*,*) ' test3 < 1 ! ' c write(*,*) aresidual c write(*,*) test1, test2, test3 c write(*,*) Ccoef2, Bcoef, Ccoef c write(*,*) xt, yt, xbound, ybound c stop c endif c write(*,*) ' here - 2 ', test1, test2, test3, xt,yt,csol1, c & ccoef, bcoef, xtold, ytold c endif c if (yt.gt.zbound) yt = zbound c if (yt.lt.-zbound) yt = -zbound c if (igeom.eq.4.and.abs(xt).ge.xbound) then c xt = xt/abs(xt)*(xbound-1.d-7) c endif else c if (ibend.ne.1) then if (igeom.ne.4) then c c Daniel: This is wrong for elliptic geometry with flat upper and lower c part c c scale = 1.0d0/sqrt((xt/xbound)**2+(yt/ybound)**2) c c replaced by (but still not satisfactory) c if (abs(yt).gt.zbound) then scale1 = zbound/abs(yt) else scale1 =1.d0 endif scale = 1.0d0/sqrt((xt/xbound)**2+(yt/ybound)**2) if (scale1.lt.scale) scale=scale1 c c end of change c xt = xt * scale yt = yt * scale if (yt.gt.zbound) yt = zbound if (yt.lt.-zbound) yt = -zbound else c c Daniel: this was wrong c c if (abs(x(i)/y(i)).gt.xbound/zbound) then c c and has been replaced by c Still a problem for correct treatment of boundaries remains c currently cheating by moving particle from the surface horizontally c if (abs(xt/yt).gt.xbound/zbound) then c scale = xbound/abs(xt) c Daniel: Test smaller distance from wall for scale scale = xbound/abs(xt)*0.99 else scale = zbound/abs(yt) endif xt = xt * scale yt = yt * scale c write (*,*) 'new ',xt,yt, c . ((abs(xt).le.xbound).and.(abs(yt).le.ybound)) 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) cscdtest if (abs(yt).eq.zbound) dn1 = 0.0d0 c if (igeom.eq.4) then c if (abs(yt).ge.zbound) then c dn1=0.d0 c else c dn2=0.d0 c endif c else c if (abs(yt).eq.zbound) dn1 = 0.0d0 c endif c scdendtest 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 costhetareal = abs(dn1*xpt+dn2*ypt)/ * sqrt(xpt**2+ypt**2+zpt**2) costheta = max(costhetareal,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 scdwrite c write(51,*) real(ene),real(qt),int(xt*1e3) call scdhit(ene,qt,xt,yt,zt,ypt/vl) 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 costheta0=1.0 qtntheta0 = yield(ene,costheta0,yim,yemax)*qt c if (inel.eq.1.or.inel.eq.2.or.inel.eq.3) 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 ftheta = dexp(0.5*(1.-costheta)) if (qtnew.gt.0.0) then if(ene.le.300) then if (inel.eq.1.or.inel.eq.2) then qtelast = qtntheta0*frac1(ene)/(1-frac1(ene)) if (inel.eq.2) then cccccc ene0=0.1d0 qtene0 = yield(ene0,costheta0,yim,yemax)*qt qtelast = dexp(-ene/4.d0)*(qt-qtene0* & frac1(ene0)/(1-frac1(ene0)))+qtelast cccccc endif else if (inel.eq.3) then qtelast = escdf . *((sqrt(ene)-sqrt(ene+150))**2/(sqrt(ene)+ & sqrt(ene+150))**2)*qt endif qtnew1 = qtelast+qtnew ratio = 1-qtnew/qtnew1 qtnew = qtnew1 qtold = qt else if (inel.eq.1.or.inel.eq.2) then qtelast = qtntheta0*frac2(ene)/(1-frac2(ene)) if (inel.eq.2) then cccccc ene0=0.1d0 qtene0 = yield(ene0,costheta0,yim,yemax)*qt qtelast = dexp(-ene/4.d0)*(qt-qtene0* & frac2(ene0)/(1-frac2(ene0)))+qtelast endif cccccc else if (inel.eq.3) then qtelast = escdf . *((sqrt(ene)-sqrt(ene+150))**2/(sqrt(ene)+ & sqrt(ene+150))**2)*qt endif qtnew1 = qtelast+qtnew ratio = 1-qtnew/qtnew1 qtnew = qtnew1 qtold = qt endif else return endif c if (qtnew.gt.0.0.and.ene.le.300) then c ratio = frac1(ene) c else if (qtnew.gt.0.0.and.ene.gt.300) then c ratio = frac2(ene) c else if (qtnew.le.0.0) then c return c 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 continue if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else if (icoll.le.2) then rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/real(npepb) else if (icoll.le.3) then qtref = ppb*pleff*plpppm*belen/real(npepb) endif c frank, change this number, 22 May 2002 c if (peeff.lt.1.e-5) then if (peeff.lt.1.e2) then qtref=dmax1(qtref*1.d4,1.d3) endif c c Daniel try to avoid production of too many secondary particles c if (qtref.lt.0.2*qt) qtref=0.2*qt c frankz - new, 13.06.2003 trying to follow Daniel if (icount.gt.npelm/3) qtref=dmax1(qtref,3*qlimit) 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 c scdwrite c write(51,*) real(-eneemit),real(qt) c call scdhit(eneemit,-qt,xt) 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 if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else if (icoll.le.2) then rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/real(npepb) else if (icoll.le.3) then qtref = ppb*pleff*plpppm*belen/real(npepb) endif endif endif c frank, change this number, 22 May 2002 c if (peeff.lt.1.e-5) then if (peeff.lt.1.e2) then qtref=dmax1(qtref*1.d4,1.d3) endif c c Daniel try to avoid production of too many secondary particles c if (qtref.lt.0.2*qt) qtref=0.2*qt c frankz - new, 13.06.2003 trying to follow Daniel if (icount.gt.npelm/3) qtref=dmax1(qtref,3*qlimit) 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 scdwrite c call scdhit(eneemit,-qtnew,xt) c write(51,*) real(-eneemit),real(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 ',icount return end subroutine seilerm(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,ibd,iw) c purpose: computes secondary emitted electron a la miguel 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 real*8 qtelast,qtred,qtsec,qtnewtot,ratio1,ratio2 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 qaccc, xbc, ybc 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 webinny(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, qaccc, xbc, ybc common / partgiulia / qwall, ewall, wallcount common / part2 / icount, icountact, iadele c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy,belen common / defgiulia / betap 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 common / def11/ icoll common / colli1/ press,crse,plpppm,pleff 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, webinny 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 common / qlimit / qlimit common / seilerflag / iflagem c write(*,*) 'iflagem', iflagem c write(*,*) 'old', xt,yt if (iflagem.eq.0) then if (inel.eq.1) then enem=yemax qtelast = 0.07+0.33*dexp(-enem/100.d0) endif iflagem = 1 c write(*,*) ' rescaled yim: ', yimold, yim, qtelast endif 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.ge.zbound) yt = zbound-2.d-7 if (yt.le.-zbound) yt = -zbound+1.d-7 if (igeom.eq.4.and.abs(xt).ge.xbound) then xt = xt/abs(xt)*(xbound-1.d-7) endif else c (ibend.ne.1) case if (igeom.ne.4) then c c Daniel: This is wrong for elliptic geometry with flat upper and lower c part c c scale = 1.0d0/sqrt((xt/xbound)**2+(yt/ybound)**2) c c replaced by (but still not satisfactory) c if (abs(yt).gt.zbound) then scale1 = zbound/abs(yt) else scale1 =1.d0 endif scale = 1.0d0/sqrt((xt/xbound)**2+(yt/ybound)**2) if (scale1.lt.scale) scale=scale1 c c end of change c c write(6,*) 'scale', scale xt = xt * scale yt = yt * scale if (yt.gt.zbound) yt = zbound-1.d-7 if (yt.lt.-zbound) yt = -zbound+1.d-7 else c geom = 4 c c Daniel: this was wrong c c if (abs(x(i)/y(i)).gt.xbound/zbound) then c c and has been replaced by c Still a problem for correct treatment of boundaries remains c currently cheating by moving particle from the surface horizontally c if (abs(xt).ge.xbound) then xt = xt/abs(xt)*(xbound-1.d-7) c if (abs(yt).ge.ybound) then c yt = yt/abs(yt)*(ybound-1.d-7) c endif endif if (abs(yt).gt.ybound) then yt = yt/abs(yt)*(ybound-1.d-7) endif c write (*,*) 'new ',xt,yt c . ((abs(xt).le.xbound).and.(abs(yt).le.ybound)) 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 if (igeom.eq.4) then if (dabs(xt).ge.(xbound-2.d-7)) then dn1 = -xt/dabs(xt) dn2 = 0. elseif (dabs(yt).ge.(ybound-2.d-7)) then dn1 = 0. dn2 = -yt/dabs(yt) if (dabs(xt).ge.(xbound-2.d-7)) then dn1 = -xt/dabs(xt)/sqrt(2.d0) dn2 = -yt/dabs(yt)/sqrt(2.d0) endif endif else 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 endif 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 charge of emitted secondary e- c ecloud sey c qtsec = 1.5d0*(1.35d0*ene/yemax)/(0.35d0+(ene/yemax)**1.35d0) qtsec = 0.89d0*(1.7d0*ene/yemax)/(0.7d0+(ene/yemax)**1.7d0) & *(1.d0+0.6d0*(1.d0-costheta**0.8)) c & *dexp(0.5d0*(1-costheta)) ftheta = dexp(0.5*(1.-costheta)) if (qtsec.gt.0.0) then if (inel.eq.1) then qtelast = (0.07d0+0.33d0*dexp(-ene/100.d0)) & *(1.d0+0.26d0*(1-costheta**2)) c ecloud qtelast = (0.01d0+0.34d0*dexp(-ene/75.d0)) qtred = 0.53d0*(1d0-dexp(-ene/40.d0)) & *(1.d0+0.26d0*(1-costheta**2)) c ec qtred = 0.d0 endif qtnewtot = qtelast+qtsec+qtred ratio1 = 1.d0-qtsec/qtnewtot ratio2 = ratio1 - (qtred/qtnewtot) cc c ec ratio1 = 0.d0 qtnew = qtnewtot*qt qtold = qt else return endif c write(*,*) qtelast/qtnewtot, (qtred)/qtnewtot, qtsec/qtnewtot c write(1184,11841) ene, costheta, qtelast, qtred, qtsec, qtnewtot, c & ratio1, ratio2 11841 format(8(e16.4)) which = ran2(idumy) if (which.lt.ratio2) then c elastically reflected if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else if (icoll.le.2) then rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/real(npepb) else if (icoll.le.3) then qtref = ppb*pleff*plpppm*belen/real(npepb) endif endif endif if (peeff.lt.1.e2) then qtref=dmax1(qtref*1.d4,1.d3) endif if (qtref.lt.0.2*qt) qtref=0.2*qt c frankz - new, 13.06.2003 trying to follow Daniel if (icount.gt.npelm/3) qtref=dmax1(qtref,3*qlimit) 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 g = sqrt(-2*log(ran2(idum1)))*cos(2*pi*ran2(idum2)) c write(1184,*) g eneemit=ene -dabs(g)*1.9d0 if (eneemit.lt.0.d0) then eneemit = - eneemit c eneemit = ene eloss = eloss - eneemit*qt 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)) 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) x(icount) = xt if (abs(x(icount)).gt.xbound) then x(icount) = x(icount)/abs(x(icount))*(xbound-2.d-7) endif if (qtnew.eq.0.0) then xpt = 0.0d0 ypt = 0.0d0 zpt = 0.0d0 endif x(icount) = xt y(icount) = yt z(icount) = zt xp(icount) = xpt yp(icount) = ypt zp(icount) = zpt endif 110 continue elseif (which.lt.ratio1) then c rediffused if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else if (icoll.le.2) then rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/real(npepb) else if (icoll.le.3) then qtref = ppb*pleff*plpppm*belen/real(npepb) endif endif endif if (peeff.lt.1.e2) then qtref=dmax1(qtref*1.d4,1.d3) endif if (qtref.lt.0.2*qt) qtref=0.2*qt c frankz - new, 13.06.2003 trying to follow Daniel if (icount.gt.npelm/3) qtref=dmax1(qtref,3*qlimit) 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 do 117 i = 1, iq qt = abs(qtnew / real(iq)) isectot = isectot + 1 avq = avq + qt eneemit=ene*(ran2(idumy)**0.714) eloss = eloss - eneemit*qt c write(*,*) ene, eneemit c next determine angular distribution c c scale with energy energyscale = eneemit * el velo = sqrt(2.0d0*energyscale/elmass) 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 if (igeom.ne.4) then x(icount) = xt + (ran2(idumy)-0.5d0)*2.0d0*xwid else x(icount) = xt endif if (abs(x(icount)).gt.xbound) then x(icount) = x(icount)/abs(x(icount))*(xbound-2.d-7) endif 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 117 continue else c true secondaries c nindhg=nint(iybin*xt/xbound+iybin)/2 c if (nindhg.gt.iybin.or.nindhg.lt.0) goto 123 c iycount(nindhg) = c * iycount(nindhg) + 1 c if(ene.le.300) then c ayield(nindhg) = c * ayield(nindhg)+yield(ene,costheta,yim,yemax)/(1-frac1(ene)) c else c ayield(nindhg) = c * ayield(nindhg)+yield(ene,costheta,yim,yemax)/(1-frac2(ene)) c endif c avcos(nindhg) = c * avcos(nindhg) + c * costheta cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 123 continue if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else if (icoll.le.2) then rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/real(npepb) else if (icoll.le.3) then qtref = ppb*pleff*plpppm*belen/real(npepb) endif if (peeff.lt.1.e2) then qtref=dmax1(qtref*1.d4,1.d3) endif if (qtref.lt.0.2*qt) qtref=0.2*qt if (icount.gt.npelm/3) qtref=dmax1(qtref,3*qlimit) 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 do 10 i = 1, iq qt = abs(qtnew / real(iq)) isectot = isectot + 1 avq = avq + qt c 30 eneemit = ran2(idumy)*emax0 30 g2 = sqrt(-2*log(ran2(idum1)))*cos(2*pi*ran2(idum2)) eneemit = g2*5.d0+10.d0 if (eneemit.lt.0) eneemit= - eneemit if (eneemit.gt.ene) eneemit = ene c write(*,*) eneemit c 30 eneemit = (ene**(0.6d0))*dexp(-(ene/3.9d0)) c write(*,*) ene,eneemit c if (abs(ene-100.d0).lt.2.d0) then c write(1185,*) eneemit c endif 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 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 if (igeom.ne.4) then x(icount) = xt + (ran2(idumy)-0.5d0)*2.0d0*xwid else x(icount) = xt endif if (abs(x(icount)).gt.xbound) then x(icount) = x(icount)/abs(x(icount))*(xbound-2.d-7) endif 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 betai = (xpt*xpt+ypt*ypt+zpt*zpt)/vl/vl gammai = 1.0d0/sqrt(1.0d0-betai) enei = (gammai-1.0d0)*elmass*vl*vl/el 10 continue c return endif if (abs(ene-200.d0).lt.1.d0) then write(1189,*) eneemit elseif (abs(ene-100.d0).lt.1.d0) then write(1188,*) eneemit elseif (abs(ene-50.d0).lt.1.d0) then write(1187,*) eneemit elseif (abs(ene-10.d0).lt.1.d0) then write(1186,*) eneemit elseif (abs(ene-5.d0).lt.1.d0) then write(1185,*) eneemit endif return end subroutine seilertest 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),webinny(0:500) 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 qaccc, xbc, ybc 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, qaccc, xbc, ybc 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 common / def11/ icoll common / colli1/ press,crse,plpppm,pleff 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,webinny 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 common / qlimit / qlimit common / seilerflag / iflagem common /daniel/ yex(-100:100),yldx(-100:100),escdf,nscdf,ifload save daniel write (*,*) ' enter seilertest ' , inel, iflagem do iloop = 1, 1500 ene = real(iloop) costheta0=1.0 qt = 1.d0 do k = 1, 2 if (k.eq.1) costheta = 1. if (k.eq.2) costheta = 0.5 if (iflagem.eq.0) then if (inel.eq.1.or.inel.eq.2) then enem=yemax if(enem.le.300) then qtelast = frac1(enem)/(1-frac1(enem)) else qtelast = frac2(enem)/(1-frac2(enem)) endif if (inel.eq.2) then ene0=0.1d0 qtene0 = yield(ene0,costheta0,yim,yemax) qtelast = dexp(-enem/4.d0)*(1.-qtene0* & frac1(ene0)/(1-frac1(ene0)))+qtelast endif endif if (inel.eq.3) then qtelast = ((sqrt(enem)-sqrt(enem+150))**2/(sqrt(enem)+ & sqrt(enem+150))**2) endif endif c c rescale delta_max only for inel=2,3, not for inel=1, c to be consistent with Noel's fitting c if (inel.eq.2.or.inel.eq.3) then yimt=yim*yim/(yim+qtelast) endif qtnew = yield(ene,costheta,yimt,yemax)*qt write(*,*) ' k loop ', k , costheta, qtnew costheta0=1.0 qtntheta0 = yield(ene,costheta0,yimt,yemax)*qt c if (inel.eq.1.or.inel.eq.2.or.inel.eq.3) 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 ftheta = dexp(0.5*(1.-costheta)) write (*,*) 'in seilertest ' , qtnew, ene if (qtnew.gt.0.0) then if (inel.eq.3) then cccccc qtelast = escdf . *((sqrt(ene)-sqrt(ene+150))**2/(sqrt(ene)+ & sqrt(ene+150))**2)*qt cccccc qtnewt = qtelast+qtnew ratio = 1-qtnew/qtnewt qtnew = qtnewt qtold = qt endif if(ene.le.300) then if (inel.eq.1.or.inel.eq.2) then qtelast = qtntheta0*frac1(ene)/(1-frac1(ene)) if (inel.eq.2) then cccccc ene0=0.1d0 qtene0 = yield(ene0,costheta0,yimt,yemax)*qt qtelast = dexp(-ene/4.d0)*(qt-qtene0* & frac1(ene0)/(1-frac1(ene0)))+qtelast cccccc endif qtnew1 = qtelast+qtnew ratio = 1-qtnew/qtnew1 qtnew = qtnew1 qtold = qt endif else if (inel.eq.1.or.inel.eq.2) then qtelast = qtntheta0*frac2(ene)/(1-frac2(ene)) if (inel.eq.2) then cccccc ene0=0.1d0 qtene0 = yield(ene0,costheta0,yim,yemax)*qt qtelast = dexp(-ene/4.d0)*(qt-qtene0* & frac2(ene0)/(1-frac2(ene0)))+qtelast endif cccccc qtnew1 = qtelast+qtnew ratio = 1-qtnew/qtnew1 qtnew = qtnew1 qtold = qt endif endif else write (*,*) ' surprisingly here ' return endif endif if (k.eq.1) then enem1 = ene qtnew1 = qtnew else enem2 = ene qtnew2 = qtnew endif end do write (59,910) enem1, qtnew1, enem2, qtnew2 910 format (4(1x,e9.3)) end do 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 c 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)) c 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 rbound, xbound, ybound, zbound, energy, belen double precision varx(6) c real*8 D02CJW, D02CJX c EXTERNAL D02CJW, D02CJX, out, fcn, fcn2, bsstep, gfcn2 EXTERNAL D02CJW, D02CJX EXTERNAL out, fcn, fcn2, bsstep, gfcn2,fld, fld2, fld3 EXTERNAL fld26,fld27,fldib26,fldsext, fld20, fld21 common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / nagv / ibend, isel, tend, dpx, dpy, dpz common / pel52 / time0 common / ibend2 / ibend2 common / image / iimage, iimageb, interspace, igeom common / def1 / rbound, xbound, ybound, zbound, energy, belen 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 c Daniel: from test odeint2 is faster by more than a factor two compared c to the other methods c next choice would be ode (which uses the slatec package) c c scd if (ibend2.eq.1) then call ddeqmr(n,t,tend,var,dt0,tol,fcn2,w) else if (ibend2.eq.2) then call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn2,bsstep) else if (ibend2.eq.3) then call move(var,var(4),tend,fld) else if (ibend2.eq.4) then call ode(gfcn2,var,n,t,tend,tol) else if (ibend2.eq.5) then CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) else if (ibend2.eq.6) then call move(var,var(4),tend,fldib26) else if (ibend2.eq.7) then call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn2,bsstep) else if (ibend2.eq.8) then CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) else write (*,*) ' ibend2 not defined ',ibend2 stop endif 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.127) 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 c Daniel: from test odeint2 is faster by more than a factor two compared c to the other methods c next choice would be ode (which uses the slatec package) c c scd cc call ddeqmr(n,t,tend,var,dt0,tol,fcn2,w) c call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn,bsstep) call move(var,var(4),tend,fld2) c call ode(gfcn2,var,n,t,tend,tol) cc 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.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. cc call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) cc call ddeqmr(n,t,tend,var,dt0,tol,fcn2,w) call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn2,bsstep) c call ode(gfcn2,var,n,t,tend,tol) 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 gammai=1.0/gammaf gammai=1.0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz c c Daniel: to be changed c c omega=el/emass*bfield c bscd=el*bfield/elmass bscdi=1.0/bscd s=sin(tend*bscd*gammai) c=cos(tend*bscd*gammai) c write(*,*) 'phase ',tend*bscd*gammai ascd=dpx varx(2)=var(2)+tend*(0.5*tend*dpy+var(5))*gammai varx(5)=var(5)+dpy*tend varx(1)=var(1) . +(ascd*bscdi*(1.0-c)+var(4)*s-var(6)*(c-1.0))* . bscdi*gammai varx(3)=var(3)+(ascd*(bscdi*s-dt)-var(4)*(1.0-c)+ . var(6)*s) . *bscdi*gammai tmp=var(4) varx(4)=var(4)*c+var(6)*s+ascd*bscdi*s varx(6)=var(6)*c-tmp*s+ascd*bscdi*(c-1.0) c varx(4)=var(4)*c+var(6)*s c varx(6)=var(6)*c-tmp*s tol = 1.0d-6 ifail = 0 dt0=dt/500. cc call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn2,bsstep) cc call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) cc 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) c if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = varx(1) y = varx(2) z = varx(3) vx = varx(4) vy = varx(5) vz = varx(6) c x = var(1) c y = var(2) c z = var(3) c vx = var(4) c vy = var(5) c vz = var(6) c write (*,*) 'test' c write (*,*) tend,s,c,bscd c write (*,*) (var(i),i=1,6) c write (*,*) (varx(i),i=1,6) c write (*,*) ((var(i)-varx(i)),i=1,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-4 ifail = 0 dt0 = dt/500. call move(var,var(4),tend,fld20) cc 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) cc 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-4 ifail = 0 dt0 = dt/500. call move(var,var(4),tend,fld21) cc 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) cc 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. 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) 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 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. 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) 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 TESLA wiggler - Mauro Pivi's expression if(ibend.eq.26) 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-4 ifail = 0 dt0 = dt/500. amp=0.0 if (igeom.eq.4) then amp = dmax1(dabs(x)/xbound,dabs(y)/zbound) endif if (amp.le.1.0d0) then c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn,bsstep) call move(var,var(4),tend,fld26) 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) endif 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 TESLA wiggler - Hans Braun's expression if(ibend.eq.27) 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-4 ifail = 0 dt0 = dt/500. amp=0.0 if (igeom.eq.4) then amp = dmax1(dabs(x)/xbound,dabs(y)/zbound) endif if (amp.le.1.0d0) then c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) call move(var,var(4),tend,fld27) c call odeint2(var,n,t,tend,tol,dt0,0.d0,nok,nbad,fcn,bsstep) 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) endif 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 CLIC wiggler - Hans Braun's expression if(ibend.eq.28) 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-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 TESLA linac if(ibend.eq.29) 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. 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) 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 GLC/JLC linac if(ibend.eq.30) 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. 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) 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 CLIC linac if(ibend.eq.31) 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. 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) 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 DAFNE wiggler - Cristina's parametrization if(ibend.eq.32) 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-4 ifail = 0 dt0 = dt/500. amp=0.0 if (igeom.eq.4) then amp = dmax1(dabs(x)/xbound,dabs(y)/zbound) endif if (amp.le.1.0d0) then c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c write(*,*) ' bmap, before move ' call move(var,var(4),tend,fld3) c write(*,*) ' bmap, after move ' 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) endif 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.33) 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 move(var,var(4),tend,fldsext) 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, efieldrfmult real*8 k real*8 bzfield real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail, ibend2 real*8 function s17aff, s17aef real*8 maurocoef(1:40,1:40) common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf,efieldrfmult common / def1 / rbound, xbound, ybound, zbound, energy, belen common / mauro / maurocoef common / ibend2 / ibend2 common / defcb / bzfield 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 bf=el*bfield/elmass if (ibend2.le.5) then f(4) = (dpx - var(6)*bf*var(1)) f(5) = (dpy + var(6)*bf*var(2)) f(6) = (dpz + bf * (var(4)*var(1) - var(5)*var(2))) else if (ibend2.eq.8) then bzf = el*bzfield/elmass f(4) = (dpx - var(6)*bf*var(1)-bzf*var(5)) f(5) = (dpy + var(6)*bf*var(2)+bzf*var(4)) f(6) = (dpz + bf * (var(4)*var(1) - var(5)*var(2))) endif 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 = bfield 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 c scd test f(1) = 0.0 f(2) = var(5)/gamma f(3) = 0.0 f(4) = 0.0 f(5) = dpy f(6) = 0.0 c f(1) = var(4)/gamma c f(2) = var(5)/gamma c f(3) = var(6)/gamma c f(4) = dpx - el/elmass*(var(5)/gamma*bz c & -var(6)/gamma*by) c f(5) = dpy - el/elmass*(var(6)/gamma*bx c & -var(4)/gamma*bz) c f(6) = dpz - el/elmass*(var(4)/gamma*by c & -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 = 0.15 b = 0.005 b = bfield 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, 5 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*k*rad)*sz1 bz = bz + s1*bk1*dbesi0(km*k*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 = 0.15 b = 0.005 b = bfield 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, 5 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*k*rad)*sz1 bz = bz + coefs*s1*bk1*dbesi0(km*k*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.26) then c wiggler for TESLA - Mauro Pivi's expression c b is in Tesla, k in 1/meter scalel = 0.40 b = 1.6 c bz0 = 0.0030 var(1)=0.002 var(2)=0.001 nzloop = 200 dzstep = 0.1/real(nzloop) do i=1,nzloop var(3)=real(i)*dzstep dkz = 2.*pi/1./scalel rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) arg = k*rad gaprad = 0.025 br = 0. bz = 0. bphi = 0. do knn = 1, 39, 2 do kmm = 1, 13, 2 dkm = real(kmm) dkn = real(knn) sz1 = sin(dkn*dkz*var(3)) cz1 = cos(dkn*dkz*var(3)) sphi = sin(dkm*phi) cphi = cos(dkm*phi) bk1 = dbesi1(dkn*dkz*rad) depsbes = 1.e-4 bk1p = (-dbesi1(dkn*dkz*rad)+ & dbesi1(dkn*dkz*rad+depsbes))/depsbes c 0.5*(dbesi0(dkn*kz*rad)+dbesi2(dkn*dkz*rad)) b = maurocoef(kmm,knn) br = br + b*bk1p*sphi*cz1 bphi = bphi + b*dkm/(dkz*rad*dkn)*bk1*cphi*cz1 bz = bz - b*bk1*sphi*sz1 end do end do bx = br*cphi-bphi*sphi by = br*sphi+bphi*cphi 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) write(37,919) var(1), var(2), var(3), bx, by, bz 919 format(6(1x,f12.5)) end do stop endif if (ibend.eq.27) then c wiggler for TESLA - Hans Braun's expression c b is in Tesla, k in 1/meter scalel = 0.40 dkz = 2.*pi/1./scalel c bz0 = 1.68/cosh(0.0125*dkz) bz0 = 1.6 bx = 0. by = bz0*cosh(dkz*var(2))*cos(dkz*var(3)) bz = -bz0*sinh(dkz*var(2))*sin(dkz*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) c write(35,919) var(1), var(2), var(3), bx, by, bz c 919 format(6(1x,f12.5)) c end do c stop endif if (ibend.eq.28) then c wiggler for CLIC - Hans Braun's expression c b is in Tesla, k in 1/meter scalel = 0.20 dkz = 2.*pi/1./scalel bz0 = 1.76/cosh(0.0125*dkz) bx = 0. by = bz0*cosh(dkz*var(2))*cos(dkz*var(3)) bz = bz0*sinh(dkz*var(2))*sin(dkz*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) c write(35,919) var(1), var(2), var(3), bx, by, bz c 919 format(6(1x,f12.5)) c end do c stop endif if (ibend.eq.29) then c TESLA linac c efield = 23.4e6*efieldrfmult f0=1.3e9 domegaw = 2*pi*f0 dmu0 = 4.*pi*1.e-7 z0 = 377 bfieldp = efield/vl rad = sqrt(var(1)*var(1)+var(2)*var(2)) arg = rad*2.405/(2*xbound) bj0 = s17aef(arg,ifail) bj1 = s17aff(arg,ifail) bj1p = bj0-1.d0/arg*bj1 efieldr = efield*bj0*cos(-domegaw*t) bfieldphi = -bfieldp*bj1*sin(-domegaw*t) phi = datan2(var(2),var(1)) sphi = sin(phi) cphi = cos(phi) bx = -bfieldphi*sphi by = bfieldphi*cphi bz = 0. ex = efieldr*cphi ey = efieldr*sphi ez = 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 + 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.30) then c GLC/JLC linac c efield = 45.1e6*efieldrfmult f0=11.42e9 domegaw = 2*pi*f0 dmu0 = 4.*pi*1.e-7 z0 = 377 bfieldp = efield/vl rad = sqrt(var(1)*var(1)+var(2)*var(2)) arg = rad*2.405/(2*xbound) bj0 = s17aef(arg,ifail) bj1 = s17aff(arg,ifail) bj1p = bj0-1.d0/arg*bj1 efieldr = efield*bj0*cos(-domegaw*t) bfieldphi = -bfieldp*bj1*sin(-domegaw*t) phi = datan2(var(2),var(1)) sphi = sin(phi) cphi = cos(phi) bx = -bfieldphi*sphi by = bfieldphi*cphi bz = 0. ex = efieldr*cphi ey = efieldr*sphi ez = 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 + 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.31) then c CLIC linac c efield = 150.e6*efieldrfmult f0=30.e9 domegaw = 2*pi*f0 dmu0 = 4.*pi*1.e-7 z0 = 377 bfieldp = efield/vl rad = sqrt(var(1)*var(1)+var(2)*var(2)) arg = rad*2.405/(2*xbound) bj0 = s17aef(arg,ifail) bj1 = s17aff(arg,ifail) bj1p = bj0-1.d0/arg*bj1 efieldr = efield*bj0*cos(-domegaw*t) bfieldphi = -bfieldp*bj1*sin(-domegaw*t) phi = datan2(var(2),var(1)) sphi = sin(phi) cphi = cos(phi) bx = -bfieldphi*sphi by = bfieldphi*cphi bz = 0. ex = efieldr*cphi ey = efieldr*sphi ez = 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 + 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 fcntest 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, efieldrfmult real*8 k real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail real*8 function s17aff, s17aef real*8 maurocoef(1:40,1:40) common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf,efieldrfmult common / def1 / rbound, xbound, ybound, zbound, energy, belen common / mauro / maurocoef var(1) = 0.001 var(2) = 0.001 do i = 1, 100 var(3) = real(i)*0.01 c wiggler for TESLA - Mauro Pivi's expression c b is in Tesla, k in 1/meter scalel = 0.40 b = 1.6 c bz0 = 0.0030 dkz = 2.*pi/1./scalel rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) arg = k*rad gaprad = 0.025 br = 0. bz = 0. bphi = 0. do knn = 1, 39, 2 do kmm = 1, 13, 2 dkm = real(kmm) dkn = real(knn) sz1 = sin(dkn*dkz*var(3)) cz1 = cos(dkn*dkz*var(3)) sphi = sin(dkm*phi) cphi = cos(dkm*phi) bk1 = dbesi1(dkn*dkz*rad) depsbes = 1.e-4 bk1p = (-dbesi1(dkn*dkz*rad)+ & dbesi1(dkn*dkz*rad+depsbes))/depsbes c 0.5*(dbesi0(dkn*kz*rad)+dbesi2(dkn*dkz*rad)) b = maurocoef(kmm,knn) br = br + b*bk1p*sphi*cz1 bphi = bphi + b*dkm/(dkz*rad*dkn)*bk1*cphi*cz1 bz = bz - b*bk1*sphi*sz1 end do end do bx = br*cphi-bphi*sphi by = br*sphi+bphi*cphi write(57,910) var(1), var(2), var(3), bx,by,bz 910 format (6(1x,e12.3)) end do do i = 1, 100 var(3) = real(i)*0.01 scalel = 0.40 dkz = 2.*pi/1./scalel c bz0 = 1.68/cosh(0.0125*dkz) bz0 = 1.6 bx = 0. by = bz0*cosh(dkz*var(2))*cos(dkz*var(3)) bz = bz0*sinh(dkz*var(2))*sin(dkz*var(3)) write(58,910) var(1), var(2), var(3), bx,by,bz end do return end subroutine fcn2(t,var,f) c purpose: defines the system of differential equations. c Daniel: separated out from old fcn c this version is limited to quadrupoles only but is much faster c 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, efieldrfmult real*8 k, bzfield real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail, ibend2 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,efieldrfmult common / def1 / rbound, xbound, ybound, zbound, energy, belen common / ibend2 / ibend2 common / defcb / bzfield gammai = vl/sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2) if (ibend.eq.2) then f(1) = var(4)*gammai f(2) = var(5)*gammai f(3) = var(6)*gammai bf=el*bfield/elmass if (ibend2.le.5) then f(4) = (dpx - var(6)*bf*var(1)) f(5) = (dpy + var(6)*bf*var(2)) f(6) = (dpz + bf * (var(4)*var(1) - var(5)*var(2))) else bzf = el*bzfield/elmass f(4) = (dpx - var(6)*bf*var(1)-bzf*var(5)) f(5) = (dpy + var(6)*bf*var(2)+bzf*var(4)) f(6) = (dpz + bf * (var(4)*var(1) - var(5)*var(2))) endif else if (ibend.eq.17) then c uniform weak solenoid bf = el*bfield/elmass f(1) = var(4)*gammai f(2) = var(5)*gammai f(3) = var(6)*gammai f(4) = (dpx - bf*var(5)) f(5) = (dpy + bf*var(4)) f(6) = dpz else if (ibend.eq.18) then c uniform bend bf = el*bfield/elmass f(1) = var(4)*gammai f(2) = var(5)*gammai f(3) = var(6)*gammai f(4) = dpx - bf*var(6) f(5) = dpy f(6) = dpz + bf*var(4) 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 c c Daniel: The following routines are taken from Numerical Recipies c and transformed to double precision c SUBROUTINE ODEINT(YSTART,NVAR,X1,X2,EPS,H1,HMIN,NOK,NBAD,DERIVS,RK *QC) implicit double precision (a-h,o-z) PARAMETER (MAXSTP=10000,NMAX=10,TWO=2.0,ZERO=0.0,TINY=1.E-30) COMMON /PATH/ KMAX,KOUNT,DXSAV,XP(200),YP(10,200) DIMENSION YSTART(NVAR),YSCAL(NMAX),Y(NMAX),DYDX(NMAX) external derivs X=X1 H=SIGN(H1,X2-X1) NOK=0 NBAD=0 KOUNT=0 DO 11 I=1,NVAR Y(I)=YSTART(I) 11 CONTINUE XSAV=X-DXSAV*TWO DO 16 NSTP=1,MAXSTP CALL DERIVS(X,Y,DYDX) DO 12 I=1,NVAR YSCAL(I)=ABS(Y(I))+ABS(H*DYDX(I))+TINY 12 CONTINUE IF(KMAX.GT.0)THEN IF(ABS(X-XSAV).GT.ABS(DXSAV)) THEN IF(KOUNT.LT.KMAX-1)THEN KOUNT=KOUNT+1 XP(KOUNT)=X DO 13 I=1,NVAR YP(I,KOUNT)=Y(I) 13 CONTINUE XSAV=X ENDIF ENDIF ENDIF IF((X+H-X2)*(X+H-X1).GT.ZERO) H=X2-X CALL RKQC(Y,DYDX,NVAR,X,H,EPS,YSCAL,HDID,HNEXT,DERIVS) IF(HDID.EQ.H)THEN NOK=NOK+1 ELSE NBAD=NBAD+1 ENDIF IF((X-X2)*(X2-X1).GE.ZERO)THEN DO 14 I=1,NVAR YSTART(I)=Y(I) 14 CONTINUE IF(KMAX.NE.0)THEN KOUNT=KOUNT+1 XP(KOUNT)=X DO 15 I=1,NVAR YP(I,KOUNT)=Y(I) 15 CONTINUE ENDIF RETURN ENDIF IF(ABS(HNEXT).LT.HMIN) PAUSE 'Stepsize smaller than minimum.' H=HNEXT 16 CONTINUE PAUSE 'Too many steps.' RETURN END SUBROUTINE ODEINT2(YSTART,NVAR,X1,X2,EPS,H1,HMIN,NOK,NBAD,DERIVS, . RKQC) implicit double precision (a-h,o-z) PARAMETER (MAXSTP=10000,NMAX=10,TWO=2.0d0,ZERO=0.0d0, . TINY=1.d-30) DIMENSION YSTART(NVAR),YSCAL(NMAX),Y(NMAX),DYDX(NMAX) external derivs X=X1 H=SIGN(H1,X2-X1) NOK=0 NBAD=0 KOUNT=0 DO 11 I=1,NVAR Y(I)=YSTART(I) 11 CONTINUE XSAV=X-DXSAV*TWO DO 16 NSTP=1,MAXSTP CALL DERIVS(X,Y,DYDX) DO 12 I=1,NVAR YSCAL(I)=ABS(Y(I))+ABS(H*DYDX(I))+TINY 12 CONTINUE IF((X+H-X2)*(X+H-X1).GT.ZERO) H=X2-X CALL RKQC(Y,DYDX,NVAR,X,H,EPS,YSCAL,HDID,HNEXT,DERIVS) IF(HDID.EQ.H)THEN NOK=NOK+1 ELSE NBAD=NBAD+1 ENDIF IF((X-X2)*(X2-X1).GE.ZERO)THEN DO 14 I=1,NVAR YSTART(I)=Y(I) 14 CONTINUE RETURN ENDIF IF(ABS(HNEXT).LT.HMIN) PAUSE 'Stepsize smaller than minimum.' H=HNEXT 16 CONTINUE PAUSE 'Too many steps.' RETURN END SUBROUTINE BSSTEP(Y,DYDX,NV,X,HTRY,EPS,YSCAL,HDID,HNEXT,DERIVS) implicit double precision (a-h,o-z) external derivs PARAMETER (NMAX=10,IMAX=11,NUSE=7,ONE=1.E0,SHRINK=.95d0,GROW=1.2d0 *) DIMENSION Y(NV),DYDX(NV),YSCAL(NV),YERR(NMAX), * YSAV(NMAX),DYSAV(NMAX),YSEQ(NMAX),NSEQ(IMAX) DATA NSEQ /2,4,6,8,12,16,24,32,48,64,96/ H=HTRY XSAV=X DO 11 I=1,NV YSAV(I)=Y(I) DYSAV(I)=DYDX(I) 11 CONTINUE 1 DO 10 I=1,IMAX CALL MMID(YSAV,DYSAV,NV,XSAV,H,NSEQ(I),YSEQ,DERIVS) XEST=(H/NSEQ(I))**2 c CALL RZEXTR(I,XEST,YSEQ,Y,YERR,NV,NUSE) CALL PZEXTR(I,XEST,YSEQ,Y,YERR,NV,NUSE) ERRMAX=0. DO 12 J=1,NV ERRMAX=MAX(ERRMAX,ABS(YERR(J)/YSCAL(J))) 12 CONTINUE ERRMAX=ERRMAX/EPS IF(ERRMAX.LT.ONE) THEN X=X+H HDID=H IF(I.EQ.NUSE)THEN HNEXT=H*SHRINK ELSE IF(I.EQ.NUSE-1)THEN HNEXT=H*GROW ELSE HNEXT=(H*NSEQ(NUSE-1))/NSEQ(I) ENDIF RETURN ENDIF 10 CONTINUE H=0.25d0*H/2**((IMAX-NUSE)/2) IF(X+H.EQ.X)PAUSE 'Step size underflow.' GOTO 1 END SUBROUTINE MMID(Y,DYDX,NVAR,XS,HTOT,NSTEP,YOUT,DERIVS) implicit double precision (a-h,o-z) PARAMETER (NMAX=10) DIMENSION Y(NVAR),DYDX(NVAR),YOUT(NVAR),YM(NMAX),YN(NMAX) H=HTOT/NSTEP DO 11 I=1,NVAR YM(I)=Y(I) YN(I)=Y(I)+H*DYDX(I) 11 CONTINUE X=XS+H CALL DERIVS(X,YN,YOUT) H2=2.d0*H DO 13 N=2,NSTEP DO 12 I=1,NVAR SWAP=YM(I)+H2*YOUT(I) YM(I)=YN(I) YN(I)=SWAP 12 CONTINUE X=X+H CALL DERIVS(X,YN,YOUT) 13 CONTINUE DO 14 I=1,NVAR YOUT(I)=0.5d0*(YM(I)+YN(I)+H*YOUT(I)) 14 CONTINUE RETURN END SUBROUTINE RZEXTR(IEST,XEST,YEST,YZ,DY,NV,NUSE) implicit double precision (a-h,o-z) PARAMETER (IMAX=11,NMAX=10,NCOL=7) DIMENSION X(IMAX),YEST(NV),YZ(NV),DY(NV),D(NMAX,NCOL),FX(NCOL) X(IEST)=XEST IF(IEST.EQ.1) THEN DO 11 J=1,NV YZ(J)=YEST(J) D(J,1)=YEST(J) DY(J)=YEST(J) 11 CONTINUE ELSE M1=MIN(IEST,NUSE) DO 12 K=1,M1-1 FX(K+1)=X(IEST-K)/XEST 12 CONTINUE DO 14 J=1,NV YY=YEST(J) V=D(J,1) C=YY D(J,1)=YY DO 13 K=2,M1 B1=FX(K)*V B=B1-C IF(B.NE.0.) THEN B=(C-V)/B DDY=C*B C=B1*B ELSE DDY=V ENDIF V=D(J,K) D(J,K)=DDY YY=YY+DDY 13 CONTINUE DY(J)=DDY YZ(J)=YY 14 CONTINUE ENDIF RETURN END SUBROUTINE PZEXTR(IEST,XEST,YEST,YZ,DY,NV,NUSE) implicit double precision (a-h,o-z) PARAMETER (IMAX=11,NCOL=7,NMAX=10) DIMENSION X(IMAX),YEST(NV),YZ(NV),DY(NV),QCOL(NMAX,NCOL),D(NMAX) X(IEST)=XEST DO 11 J=1,NV DY(J)=YEST(J) YZ(J)=YEST(J) 11 CONTINUE IF(IEST.EQ.1) THEN DO 12 J=1,NV QCOL(J,1)=YEST(J) 12 CONTINUE ELSE M1=MIN(IEST,NUSE) DO 13 J=1,NV D(J)=YEST(J) 13 CONTINUE DO 15 K1=1,M1-1 DELTA=1./(X(IEST-K1)-XEST) F1=XEST*DELTA F2=X(IEST-K1)*DELTA DO 14 J=1,NV Q=QCOL(J,K1) QCOL(J,K1)=DY(J) DELTA=D(J)-Q DY(J)=F1*DELTA D(J)=F2*DELTA YZ(J)=YZ(J)+DY(J) 14 CONTINUE 15 CONTINUE DO 16 J=1,NV QCOL(J,M1)=DY(J) 16 CONTINUE ENDIF RETURN END c c Daniel: the following routine is a small driver to use the differential c equation solver of the slatec package c subroutine ode(f,x0,n,t0,t1,tol) implicit double precision (a-h,o-z) dimension w(10000),iw(10000),info(15) external f info(1)=0 info(2)=0 info(3)=0 info(4)=0 t=t0 rtol=tol atol=tol 1 call deabm(f,n,t,x0,t1,info,rtol,atol,idid,w,10000,iw,10000, . rpar,ipar) c write (*,*) 'idid=',idid if (idid.eq.-1) then info(1)=1 goto 1 endif end subroutine gfcn2(t,var,f,rxx,irxx) c c Daniel: Subroutine to evaluate fcn2 c this is used by the slatec differential equation solver c c 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, efieldrfmult 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,efieldrfmult common / def1 / rbound, xbound, ybound, zbound, energy, belen gammai = vl/sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2) f(1) = var(4)*gammai f(2) = var(5)*gammai f(3) = var(6)*gammai bf=el*bfield/elmass f(4) = (dpx - var(6)*bf*var(1)) f(5) = (dpy + var(6)*bf*var(2)) f(6) = (dpz + bf * (var(4)*var(1) - var(5)*var(2))) return end c c Daniel: the following routines are taken from the slatec package c they have been converted to double precision c c *DECK DEABM SUBROUTINE DEABM (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + RWORK, LRW, IWORK, LIW, RPAR, IPAR) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE DEABM C***PURPOSE Solve an initial value problem in ordinary differential C equations using an Adams-Bashforth method. C***LIBRARY SLATEC (DEPAC) C***CATEGORY I1A1B C***TYPE SINGLE PRECISION (DEABM-S, DDEABM-D) C***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, C ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR C***AUTHOR Shampine, L. F., (SNLA) C Watts, H. A., (SNLA) C***DESCRIPTION C C This is the Adams code in the package of differential equation C solvers DEPAC, consisting of the codes DERKF, DEABM, and DEBDF. C Design of the package was by L. F. Shampine and H. A. Watts. C It is documented in C SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE C Solvers. C DEABM is a driver for a modification of the code ODE written by C L. F. Shampine and M. K. Gordon C Sandia Laboratories C Albuquerque, New Mexico 87185 C C ********************************************************************** C ** DEPAC PACKAGE OVERVIEW ** C ************************************************** C C You have a choice of three differential equation solvers from C DEPAC. The following brief descriptions are meant to aid you C in choosing the most appropriate code for your problem. C C DERKF is a fifth order Runge-Kutta code. It is the simplest of C the three choices, both algorithmically and in the use of the C code. DERKF is primarily designed to solve non-stiff and mild- C ly stiff differential equations when derivative evaluations are C not expensive. It should generally not be used to get high C accuracy results nor answers at a great many specific points. C Because DERKF has very low overhead costs, it will usually C result in the least expensive integration when solving C problems requiring a modest amount of accuracy and having C equations that are not costly to evaluate. DERKF attempts to C discover when it is not suitable for the task posed. C C DEABM is a variable order (one through twelve) Adams code. C Its complexity lies somewhere between that of DERKF and DEBDF. C DEABM is primarily designed to solve non-stiff and mildly stiff C differential equations when derivative evaluations are C expensive, high accuracy results are needed or answers at C many specific points are required. DEABM attempts to discover C when it is not suitable for the task posed. C C DEBDF is a variable order (one through five) backward C differentiation formula code. It is the most complicated of C the three choices. DEBDF is primarily designed to solve stiff C differential equations at crude to moderate tolerances. C If the problem is very stiff at all, DERKF and DEABM will be C quite inefficient compared to DEBDF. However, DEBDF will be C inefficient compared to DERKF and DEABM on non-stiff problems C because it uses much more storage, has a much larger overhead, C and the low order formulas will not give high accuracies C efficiently. C C The concept of stiffness cannot be described in a few words. C If you do not know the problem to be stiff, try either DERKF C or DEABM. Both of these codes will inform you of stiffness C when the cost of solving such problems becomes important. C C ********************************************************************** C ** ABSTRACT ** C ************** C C Subroutine DEABM uses the Adams-Bashforth-Moulton predictor- C corrector formulas of orders one through twelve to integrate a C system of NEQ first order ordinary differential equations of the C form C DU/DX = F(X,U) C when the vector Y(*) of initial values for U(*) at X=T is given. The C subroutine integrates from T to TOUT. It is easy to continue the C integration to get results at additional TOUT. This is the interval C mode of operation. It is also easy for the routine to return with C the solution at each intermediate step on the way to TOUT. This is C the intermediate-output mode of operation. C C DEABM uses subprograms DES, STEPS, SINTRP, HSTART, HVNRM, R1MACH and C the error handling routine XERMSG. The only machine dependent C parameters to be assigned appear in R1MACH. C C ********************************************************************** C ** DESCRIPTION OF THE ARGUMENTS TO DEABM (AN OVERVIEW) ** C ********************************************************* C C The parameters are C C F -- This is the name of a subroutine which you provide to C define the differential equations. C C NEQ -- This is the number of (first order) differential C equations to be integrated. C C T -- This is a value of the independent variable. C C Y(*) -- This array contains the solution components at T. C C TOUT -- This is a point at which a solution is desired. C C INFO(*) -- The basic task of the code is to integrate the C differential equations from T to TOUT and return an C answer at TOUT. INFO(*) is an integer array which is used C to communicate exactly how you want this task to be C carried out. C C RTOL, ATOL -- These quantities represent relative and absolute C error tolerances which you provide to indicate how C accurately you wish the solution to be computed. You may C choose them to be both scalars or else both vectors. C C IDID -- This scalar quantity is an indicator reporting what C the code did. You must monitor this integer variable to C decide what action to take next. C C RWORK(*), LRW -- RWORK(*) is a real work array of length LRW C which provides the code with needed storage space. C C IWORK(*), LIW -- IWORK(*) is an integer work array of length LIW C which provides the code with needed storage space and an C across call flag. C C RPAR, IPAR -- These are real and integer parameter arrays which C you can use for communication between your calling C program and the F subroutine. C C Quantities which are used as input items are C NEQ, T, Y(*), TOUT, INFO(*), C RTOL, ATOL, RWORK(1), LRW and LIW. C C Quantities which may be altered by the code are C T, Y(*), INFO(1), RTOL, ATOL, C IDID, RWORK(*) and IWORK(*). C C ********************************************************************** C ** INPUT -- WHAT TO DO ON THE FIRST CALL TO DEABM ** C **************************************************** C C The first call of the code is defined to be the start of each new C problem. Read through the descriptions of all the following items, C provide sufficient storage space for designated arrays, set C appropriate variables for the initialization of the problem, and C give information about how you want the problem to be solved. C C C F -- Provide a subroutine of the form C F(X,U,UPRIME,RPAR,IPAR) C to define the system of first order differential equations C which is to be solved. For the given values of X and the C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must C evaluate the NEQ components of the system of differential C equations DU/DX = F(X,U) and store the derivatives in C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for C equations I=1,...,NEQ. C C Subroutine F must not alter X or U(*). You must declare C the name F in an external statement in your program that C calls DEABM. You must dimension U and UPRIME in F. C C RPAR and IPAR are real and integer parameter arrays which C you can use for communication between your calling program C and subroutine F. They are not used or altered by DEABM. C If you do not need RPAR or IPAR, ignore these parameters C by treating them as dummy arguments. If you do choose to C use them, dimension them in your calling program and in F C as arrays of appropriate length. C C NEQ -- Set it to the number of differential equations. C (NEQ .GE. 1) C C T -- Set it to the initial point of the integration. C You must use a program variable for T because the code C changes its value. C C Y(*) -- Set this vector to the initial values of the NEQ solution C components at the initial point. You must dimension Y at C least NEQ in your calling program. C C TOUT -- Set it to the first point at which a solution C is desired. You can take TOUT = T, in which case the code C will evaluate the derivative of the solution at T and C return. Integration either forward in T (TOUT .GT. T) C or backward in T (TOUT .LT. T) is permitted. C C The code advances the solution from T to TOUT using C step sizes which are automatically selected so as to C achieve the desired accuracy. If you wish, the code will C return with the solution and its derivative following C each intermediate step (intermediate-output mode) so that C you can monitor them, but you still must provide TOUT in C accord with the basic aim of the code. C C The first step taken by the code is a critical one C because it must reflect how fast the solution changes near C the initial point. The code automatically selects an C initial step size which is practically always suitable for C the problem. By using the fact that the code will not C step past TOUT in the first step, you could, if necessary, C restrict the length of the initial step size. C C For some problems it may not be permissible to integrate C past a point TSTOP because a discontinuity occurs there C or the solution or its derivative is not defined beyond C TSTOP. When you have declared a TSTOP point (see INFO(4) C and RWORK(1)), you have told the code not to integrate C past TSTOP. In this case any TOUT beyond TSTOP is invalid C input. C C INFO(*) -- Use the INFO array to give the code more details about C how you want your problem solved. This array should be C dimensioned of length 15 to accommodate other members of C DEPAC or possible future extensions, though DEABM uses C only the first four entries. You must respond to all of C the following items which are arranged as questions. The C simplest use of the code corresponds to answering all C questions as YES ,i.e. setting all entries of INFO to 0. C C INFO(1) -- This parameter enables the code to initialize C itself. You must set it to indicate the start of every C new problem. C C **** Is this the first call for this problem ... C YES -- Set INFO(1) = 0 C NO -- Not applicable here. C See below for continuation calls. **** C C INFO(2) -- How much accuracy you want of your solution C is specified by the error tolerances RTOL and ATOL. C The simplest use is to take them both to be scalars. C To obtain more flexibility, they can both be vectors. C The code must be told your choice. C C **** Are both error tolerances RTOL, ATOL scalars ... C YES -- Set INFO(2) = 0 C and input scalars for both RTOL and ATOL C NO -- Set INFO(2) = 1 C and input arrays for both RTOL and ATOL **** C C INFO(3) -- The code integrates from T in the direction C of TOUT by steps. If you wish, it will return the C computed solution and derivative at the next C intermediate step (the intermediate-output mode) or C TOUT, whichever comes first. This is a good way to C proceed if you want to see the behavior of the solution. C If you must have solutions at a great many specific C TOUT points, this code will compute them efficiently. C C **** Do you want the solution only at C TOUT (and not at the next intermediate step) ... C YES -- Set INFO(3) = 0 C NO -- Set INFO(3) = 1 **** C C INFO(4) -- To handle solutions at a great many specific C values TOUT efficiently, this code may integrate past C TOUT and interpolate to obtain the result at TOUT. C Sometimes it is not possible to integrate beyond some C point TSTOP because the equation changes there or it is C not defined past TSTOP. Then you must tell the code C not to go past. C C **** Can the integration be carried out without any C restrictions on the independent variable T ... C YES -- Set INFO(4)=0 C NO -- Set INFO(4)=1 C and define the stopping point TSTOP by C setting RWORK(1)=TSTOP **** C C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) C error tolerances to tell the code how accurately you want C the solution to be computed. They must be defined as C program variables because the code may change them. You C have two choices -- C both RTOL and ATOL are scalars. (INFO(2)=0) C both RTOL and ATOL are vectors. (INFO(2)=1) C In either case all components must be non-negative. C C The tolerances are used by the code in a local error test C at each step which requires roughly that C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL C for each vector component. C (More specifically, a Euclidean norm is used to measure C the size of vectors, and the error test uses the magnitude C of the solution at the beginning of the step.) C C The true (global) error is the difference between the true C solution of the initial value problem and the computed C approximation. Practically all present day codes, C including this one, control the local error at each step C and do not even attempt to control the global error C directly. Roughly speaking, they produce a solution Y(T) C which satisfies the differential equations with a C residual R(T), DY(T)/DT = F(T,Y(T)) + R(T) , C and, almost always, R(T) is bounded by the error C tolerances. Usually, but not always, the true accuracy of C the computed Y is comparable to the error tolerances. This C code will usually, but not always, deliver a more accurate C solution if you reduce the tolerances and integrate again. C By comparing two such solutions you can get a fairly C reliable idea of the true error in the solution at the C bigger tolerances. C C Setting ATOL=0.0 results in a pure relative error test on C that component. Setting RTOL=0.0 results in a pure abso- C lute error test on that component. A mixed test with non- C zero RTOL and ATOL corresponds roughly to a relative error C test when the solution component is much bigger than ATOL C and to an absolute error test when the solution component C is smaller than the threshold ATOL. C C Proper selection of the absolute error control parameters C ATOL requires you to have some idea of the scale of the C solution components. To acquire this information may mean C that you will have to solve the problem more than once. C In the absence of scale information, you should ask for C some relative accuracy in all the components (by setting C RTOL values non-zero) and perhaps impose extremely small C absolute error tolerances to protect against the danger of C a solution component becoming zero. C C The code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. It will C advise you if you ask for too much accuracy and inform C you as to the maximum accuracy it believes possible. C C RWORK(*) -- Dimension this real work array of length LRW in your C calling program. C C RWORK(1) -- If you have set INFO(4)=0, you can ignore this C optional input parameter. Otherwise you must define a C stopping point TSTOP by setting RWORK(1) = TSTOP. C (for some problems it may not be permissible to integrate C past a point TSTOP because a discontinuity occurs there C or the solution or its derivative is not defined beyond C TSTOP.) C C LRW -- Set it to the declared length of the RWORK array. C You must have LRW .GE. 130+21*NEQ C C IWORK(*) -- Dimension this integer work array of length LIW in C your calling program. C C LIW -- Set it to the declared length of the IWORK array. C You must have LIW .GE. 51 C C RPAR, IPAR -- These are parameter arrays, of real and integer C type, respectively. You can use them for communication C between your program that calls DEABM and the F C subroutine. They are not used or altered by DEABM. If C you do not need RPAR or IPAR, ignore these parameters by C treating them as dummy arguments. If you do choose to use C them, dimension them in your calling program and in F as C arrays of appropriate length. C C ********************************************************************** C ** OUTPUT -- AFTER ANY RETURN FROM DEABM ** C ******************************************* C C The principal aim of the code is to return a computed solution at C TOUT, although it is also possible to obtain intermediate results C along the way. To find out whether the code achieved its goal C or if the integration process was interrupted before the task was C completed, you must check the IDID parameter. C C C T -- The solution was successfully advanced to the C output value of T. C C Y(*) -- Contains the computed solution approximation at T. C You may also be interested in the approximate derivative C of the solution at T. It is contained in C RWORK(21),...,RWORK(20+NEQ). C C IDID -- Reports what the code did C C *** Task Completed *** C reported by positive values of IDID C C IDID = 1 -- A step was successfully taken in the C intermediate-output mode. The code has not C yet reached TOUT. C C IDID = 2 -- The integration to TOUT was successfully C completed (T=TOUT) by stepping exactly to TOUT. C C IDID = 3 -- The integration to TOUT was successfully C completed (T=TOUT) by stepping past TOUT. C Y(*) is obtained by interpolation. C C *** Task Interrupted *** C reported by negative values of IDID C C IDID = -1 -- A large amount of work has been expended. C (500 steps attempted) C C IDID = -2 -- The error tolerances are too stringent. C C IDID = -3 -- The local error test cannot be satisfied C because you specified a zero component in ATOL C and the corresponding computed solution C component is zero. Thus, a pure relative error C test is impossible for this component. C C IDID = -4 -- The problem appears to be stiff. C C IDID = -5,-6,-7,..,-32 -- Not applicable for this code C but used by other members of DEPAC or possible C future extensions. C C *** Task Terminated *** C reported by the value of IDID=-33 C C IDID = -33 -- The code has encountered trouble from which C it cannot recover. A message is printed C explaining the trouble and control is returned C to the calling program. For example, this C occurs when invalid input is detected. C C RTOL, ATOL -- These quantities remain unchanged except when C IDID = -2. In this case, the error tolerances have been C increased by the code to values which are estimated to be C appropriate for continuing the integration. However, the C reported solution at T was obtained using the input values C of RTOL and ATOL. C C RWORK, IWORK -- Contain information which is usually of no C interest to the user but necessary for subsequent calls. C However, you may find use for C C RWORK(11)--Which contains the step size H to be C attempted on the next step. C C RWORK(12)--If the tolerances have been increased by the C code (IDID = -2) , they were multiplied by the C value in RWORK(12). C C RWORK(13)--Which contains the current value of the C independent variable, i.e. the farthest point C integration has reached. This will be dif- C ferent from T only when interpolation has been C performed (IDID=3). C C RWORK(20+I)--Which contains the approximate derivative of C the solution component Y(I). In DEABM, it is C obtained by calling subroutine F to evaluate C the differential equation using T and Y(*) when C IDID=1 or 2, and by interpolation when IDID=3. C C ********************************************************************** C ** INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ** C ** (CALLS AFTER THE FIRST) ** C ***************************************************** C C This code is organized so that subsequent calls to continue the C integration involve little (if any) additional effort on your C part. You must monitor the IDID parameter in order to C determine what to do next. C C Recalling that the principal task of the code is to integrate C from T to TOUT (the interval mode), usually all you will need C to do is specify a new TOUT upon reaching the current TOUT. C C Do not alter any quantity not specifically permitted below, C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or C the differential equation in subroutine F. Any such alteration C constitutes a new problem and must be treated as such, i.e. C you must start afresh. C C You cannot change from vector to scalar error control or vice C versa (INFO(2)) but you can change the size of the entries of C RTOL, ATOL. Increasing a tolerance makes the equation easier C to integrate. Decreasing a tolerance will make the equation C harder to integrate and should generally be avoided. C C You can switch from the intermediate-output mode to the C interval mode (INFO(3)) or vice versa at any time. C C If it has been necessary to prevent the integration from going C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the C code will not integrate to any TOUT beyond the currently C specified TSTOP. Once TSTOP has been reached you must change C the value of TSTOP or set INFO(4)=0. You may change INFO(4) C or TSTOP at any time but you must supply the value of TSTOP in C RWORK(1) whenever you set INFO(4)=1. C C The parameter INFO(1) is used by the code to indicate the C beginning of a new problem and to indicate whether integration C is to be continued. You must input the value INFO(1) = 0 C when starting a new problem. You must input the value C INFO(1) = 1 if you wish to continue after an interrupted task. C Do not set INFO(1) = 0 on a continuation call unless you C want the code to restart at the current T. C C *** Following a Completed Task *** C If C IDID = 1, call the code again to continue the integration C another step in the direction of TOUT. C C IDID = 2 or 3, define a new TOUT and call the code again. C TOUT must be different from T. You cannot change C the direction of integration without restarting. C C *** Following an Interrupted Task *** C To show the code that you realize the task was C interrupted and that you want to continue, you C must take appropriate action and reset INFO(1) = 1 C If C IDID = -1, the code has attempted 500 steps. C If you want to continue, set INFO(1) = 1 and C call the code again. An additional 500 steps C will be allowed. C C IDID = -2, the error tolerances RTOL, ATOL have been C increased to values the code estimates appropriate C for continuing. You may want to change them C yourself. If you are sure you want to continue C with relaxed error tolerances, set INFO(1)=1 and C call the code again. C C IDID = -3, a solution component is zero and you set the C corresponding component of ATOL to zero. If you C are sure you want to continue, you must first C alter the error criterion to use positive values C for those components of ATOL corresponding to zero C solution components, then set INFO(1)=1 and call C the code again. C C IDID = -4, the problem appears to be stiff. It is very C inefficient to solve such problems with DEABM. The C code DEBDF in DEPAC handles this task efficiently. C If you are absolutely sure you want to continue C with DEABM, set INFO(1)=1 and call the code again. C C IDID = -5,-6,-7,..,-32 --- cannot occur with this code C but used by other members of DEPAC or possible C future extensions. C C *** Following a Terminated Task *** C If C IDID = -33, you cannot continue the solution of this C problem. An attempt to do so will result in your C run being terminated. C C ********************************************************************** C C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user C oriented package of ODE solvers, Report SAND79-2374, C Sandia Laboratories, 1979. C***ROUTINES CALLED DES, XERMSG C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 891024 Changed references from VNORM to HVNRM. (WRB) C 891024 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900510 Convert XERRWV calls to XERMSG calls. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DEABM C LOGICAL START,PHASE1,NORND,STIFF,INTOUT C DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), 1 RPAR(*),IPAR(*) C CHARACTER*8 XERN1 CHARACTER*16 XERN3 C EXTERNAL F C C CHECK FOR AN APPARENT INFINITE LOOP C C***FIRST EXECUTABLE STATEMENT DEABM IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0 IF (IWORK(LIW) .GE. 5) THEN IF (T .EQ. RWORK(21 + NEQ)) THEN WRITE (XERN3, '(1PE15.6)') T CALL XERMSG ('SLATEC', 'DEABM', * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // * 'CODE, PARTICULARLY INFO(1).', 13, 2) RETURN ENDIF ENDIF C C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION C IDID=0 IF (LRW .LT. 130+21*NEQ) THEN WRITE (XERN1, '(I8)') LRW CALL XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE RWORK ' // * 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) IDID=-33 ENDIF C IF (LIW .LT. 51) THEN WRITE (XERN1, '(I8)') LIW CALL XERMSG ('SLATEC', 'DEABM', 'THE LENGTH OF THE IWORK ' // * 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // * 'WITH LIW = ' // XERN1, 2, 1) IDID=-33 ENDIF C C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY C IYPOUT = 21 ITSTAR = NEQ + 21 IYP = 1 + ITSTAR IYY = NEQ + IYP IWT = NEQ + IYY IP = NEQ + IWT IPHI = NEQ + IP IALPHA = (NEQ*16) + IPHI IBETA = 12 + IALPHA IPSI = 12 + IBETA IV = 12 + IPSI IW = 12 + IV ISIG = 12 + IW IG = 13 + ISIG IGI = 13 + IG IXOLD = 11 + IGI IHOLD = 1 + IXOLD ITOLD = 1 + IHOLD IDELSN = 1 + ITOLD ITWOU = 1 + IDELSN IFOURU = 1 + ITWOU C RWORK(ITSTAR) = T IF (INFO(1) .EQ. 0) GO TO 50 START = IWORK(21) .NE. (-1) PHASE1 = IWORK(22) .NE. (-1) NORND = IWORK(23) .NE. (-1) STIFF = IWORK(24) .NE. (-1) INTOUT = IWORK(25) .NE. (-1) C 50 CALL DES(F,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), 1 RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), 2 RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), 3 RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), 4 RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), 5 RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), 5 RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), 6 IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), 7 IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), 8 RPAR,IPAR) C IWORK(21) = -1 IF (START) IWORK(21) = 1 IWORK(22) = -1 IF (PHASE1) IWORK(22) = 1 IWORK(23) = -1 IF (NORND) IWORK(23) = 1 IWORK(24) = -1 IF (STIFF) IWORK(24) = 1 IWORK(25) = -1 IF (INTOUT) IWORK(25) = 1 C IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 C RETURN END *DECK STEPS SUBROUTINE STEPS (F, NEQN, Y, X, H, EPS, WT, START, HOLD, K, KOLD, + CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, PHASE1, NS, + NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, KGI, GI, + RPAR, IPAR) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE STEPS C***PURPOSE Integrate a system of first order ordinary differential C equations one step. C***LIBRARY SLATEC (DEPAC) C***CATEGORY I1A1B C***TYPE SINGLE PRECISION (STEPS-S, DSTEPS-D) C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR C***AUTHOR Shampine, L. F., (SNLA) C Gordon, M. K., (SNLA) C MODIFIED BY H.A. WATTS C***DESCRIPTION C C Written by L. F. Shampine and M. K. Gordon C C Abstract C C Subroutine STEPS is normally used indirectly through subroutine C DEABM . Because DEABM suffices for most problems and is much C easier to use, using it should be considered before using STEPS C alone. C C Subroutine STEPS integrates a system of NEQN first order ordinary C differential equations one step, normally from X to X+H, using a C modified divided difference form of the Adams Pece formulas. Local C extrapolation is used to improve absolute stability and accuracy. C The code adjusts its order and step size to control the local error C per unit step in a generalized sense. Special devices are included C to control roundoff error and to detect when the user is requesting C too much accuracy. C C This code is completely explained and documented in the text, C Computer Solution of Ordinary Differential Equations, The Initial C Value Problem by L. F. Shampine and M. K. Gordon. C Further details on use of this code are available in "Solving C Ordinary Differential Equations with ODE, STEP, and INTRP", C by L. F. Shampine and M. K. Gordon, SLA-73-1060. C C C The parameters represent -- C F -- subroutine to evaluate derivatives C NEQN -- number of equations to be integrated C Y(*) -- solution vector at X C X -- independent variable C H -- appropriate step size for next step. Normally determined by C code C EPS -- local error tolerance C WT(*) -- vector of weights for error criterion C START -- logical variable set .TRUE. for first step, .FALSE. C otherwise C HOLD -- step size used for last successful step C K -- appropriate order for next step (determined by code) C KOLD -- order used for last successful step C CRASH -- logical variable set .TRUE. when no step can be taken, C .FALSE. otherwise. C YP(*) -- derivative of solution vector at X after successful C step C KSTEPS -- counter on attempted steps C TWOU -- 2.*U where U is machine unit roundoff quantity C FOURU -- 4.*U where U is machine unit roundoff quantity C RPAR,IPAR -- parameter arrays which you may choose to use C for communication between your program and subroutine F. C They are not altered or used by STEPS. C The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, C W,P,IV and GI are required for the interpolation subroutine SINTRP. C The remaining variables and arrays are included in the call list C only to eliminate local retention of variables between calls. C C Input to STEPS C C First call -- C C The user must provide storage in his calling program for all arrays C in the call list, namely C C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), C 2 RPAR(*),IPAR(*) C C **Note** C C The user must also declare START , CRASH , PHASE1 and NORND C logical variables and F an EXTERNAL subroutine, supply the C subroutine F(X,Y,YP) to evaluate C DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN)) C and initialize only the following parameters. C NEQN -- number of equations to be integrated C Y(*) -- vector of initial values of dependent variables C X -- initial value of the independent variable C H -- nominal step size indicating direction of integration C and maximum size of step. Must be variable C EPS -- local error tolerance per step. Must be variable C WT(*) -- vector of non-zero weights for error criterion C START -- .TRUE. C YP(*) -- vector of initial derivative values C KSTEPS -- set KSTEPS to zero C TWOU -- 2.*U where U is machine unit roundoff quantity C FOURU -- 4.*U where U is machine unit roundoff quantity C Define U to be the machine unit roundoff quantity by calling C the function routine R1MACH, U = R1MACH(4), or by C computing U so that U is the smallest positive number such C that 1.0+U .GT. 1.0. C C STEPS requires that the L2 norm of the vector with components C LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The C array WT allows the user to specify an error test appropriate C for his problem. For example, C WT(L) = 1.0 specifies absolute error, C = ABS(Y(L)) error relative to the most recent value of the C L-th component of the solution, C = ABS(YP(L)) error relative to the most recent value of C the L-th component of the derivative, C = MAX(WT(L),ABS(Y(L))) error relative to the largest C magnitude of L-th component obtained so far, C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed C relative-absolute test where RELERR is relative C error, ABSERR is absolute error and EPS = C MAX(RELERR,ABSERR) . C C Subsequent calls -- C C Subroutine STEPS is designed so that all information needed to C continue the integration, including the step size H and the order C K , is returned with each step. With the exception of the step C size, the error tolerance, and the weights, none of the parameters C should be altered. The array WT must be updated after each step C to maintain relative error tests like those above. Normally the C integration is continued just beyond the desired endpoint and the C solution interpolated there with subroutine SINTRP . If it is C impossible to integrate beyond the endpoint, the step size may be C reduced to hit the endpoint since the code will not take a step C larger than the H input. Changing the direction of integration, C i.e., the sign of H , requires the user set START = .TRUE. before C calling STEPS again. This is the only situation in which START C should be altered. C C Output from STEPS C C Successful Step -- C C The subroutine returns after each successful step with START and C CRASH set .FALSE. . X represents the independent variable C advanced one step of length HOLD from its value on input and Y C the solution vector at the new value of X . All other parameters C represent information corresponding to the new X needed to C continue the integration. C C Unsuccessful Step -- C C When the error tolerance is too small for the machine precision, C the subroutine returns without taking a step and CRASH = .TRUE. . C An appropriate step size and error tolerance for continuing are C estimated and all other information is restored as upon input C before returning. To continue with the larger tolerance, the user C just calls the code again. A restart is neither required nor C desirable. C C***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary C differential equations with ODE, STEP, and INTRP, C Report SLA-73-1060, Sandia Laboratories, 1973. C***ROUTINES CALLED HSTART, R1MACH C***REVISION HISTORY (YYMMDD) C 740101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE STEPS C LOGICAL START,CRASH,PHASE1,NORND DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), 2 RPAR(*),IPAR(*) DIMENSION TWO(13),GSTR(13) EXTERNAL F SAVE TWO, GSTR C DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), 1 TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) /2.0,4.0,8.0,16.0, 2 32.0,64.0,128.0,256.0,512.0,1024.0,2048.0,4096.0,8192.0/ DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), 1 GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13)/0.500, 2 0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936,0.00789, 3 0.00679,0.00592,0.00524,0.00468/ C C C *** BEGIN BLOCK 0 *** C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A C STARTING STEP SIZE. C *** C C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE C C***FIRST EXECUTABLE STATEMENT STEPS CRASH = .TRUE. IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 H = SIGN(FOURU*ABS(X),H) RETURN 5 P5EPS = 0.5*EPS C C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE C ROUND = 0.0 DO 10 L = 1,NEQN 10 ROUND = ROUND + (Y(L)/WT(L))**2 ROUND = TWOU*SQRT(ROUND) IF(P5EPS .GE. ROUND) GO TO 15 EPS = 2.0*ROUND*(1.0 + FOURU) RETURN 15 CRASH = .FALSE. G(1) = 1.0 G(2) = 0.5 SIG(1) = 1.0 IF(.NOT.START) GO TO 99 C C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP C C CALL F(X,Y,YP,RPAR,IPAR) C SUM = 0.0 DO 20 L = 1,NEQN PHI(L,1) = YP(L) 20 PHI(L,2) = 0.0 C20 SUM = SUM + (YP(L)/WT(L))**2 C SUM = SQRT(SUM) C ABSH = ABS(H) C IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) C H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) C U = R1MACH(4) BIG = SQRT(R1MACH(2)) CALL HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG, 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) C HOLD = 0.0 K = 1 KOLD = 0 KPREV = 0 START = .FALSE. PHASE1 = .TRUE. NORND = .TRUE. IF(P5EPS .GT. 100.0*ROUND) GO TO 99 NORND = .FALSE. DO 25 L = 1,NEQN 25 PHI(L,15) = 0.0 99 IFAIL = 0 C *** END BLOCK 0 *** C C *** BEGIN BLOCK 1 *** C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. C *** C 100 KP1 = K+1 KP2 = K+2 KM1 = K-1 KM2 = K-2 C C NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE C IF(H .NE. HOLD) NS = 0 IF (NS.LE.KOLD) NS = NS+1 NSP1 = NS+1 IF (K .LT. NS) GO TO 199 C C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH C ARE CHANGED C BETA(NS) = 1.0 REALNS = NS ALPHA(NS) = 1.0/REALNS TEMP1 = H*REALNS SIG(NSP1) = 1.0 IF(K .LT. NSP1) GO TO 110 DO 105 I = NSP1,K IM1 = I-1 TEMP2 = PSI(IM1) PSI(IM1) = TEMP1 BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 TEMP1 = TEMP2 + H ALPHA(I) = H/TEMP1 REALI = I 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) 110 PSI(K) = TEMP1 C C COMPUTE COEFFICIENTS G(*) C C INITIALIZE V(*) AND SET W(*). C IF(NS .GT. 1) GO TO 120 DO 115 IQ = 1,K TEMP3 = IQ*(IQ+1) V(IQ) = 1.0/TEMP3 115 W(IQ) = V(IQ) IVC = 0 KGI = 0 IF (K .EQ. 1) GO TO 140 KGI = 1 GI(1) = W(2) GO TO 140 C C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) C 120 IF(K .LE. KPREV) GO TO 130 IF (IVC .EQ. 0) GO TO 122 JV = KP1 - IV(IVC) IVC = IVC - 1 GO TO 123 122 JV = 1 TEMP4 = K*KP1 V(K) = 1.0/TEMP4 W(K) = V(K) IF (K .NE. 2) GO TO 123 KGI = 1 GI(1) = W(2) 123 NSM2 = NS-2 IF(NSM2 .LT. JV) GO TO 130 DO 125 J = JV,NSM2 I = K-J V(I) = V(I) - ALPHA(J+1)*V(I+1) 125 W(I) = V(I) IF (I .NE. 2) GO TO 130 KGI = NS - 1 GI(KGI) = W(2) C C UPDATE V(*) AND SET W(*) C 130 LIMIT1 = KP1 - NS TEMP5 = ALPHA(NS) DO 135 IQ = 1,LIMIT1 V(IQ) = V(IQ) - TEMP5*V(IQ+1) 135 W(IQ) = V(IQ) G(NSP1) = W(1) IF (LIMIT1 .EQ. 1) GO TO 137 KGI = NS GI(KGI) = W(2) 137 W(LIMIT1+1) = V(LIMIT1+1) IF (K .GE. KOLD) GO TO 140 IVC = IVC + 1 IV(IVC) = LIMIT1 + 2 C C COMPUTE THE G(*) IN THE WORK VECTOR W(*) C 140 NSP2 = NS + 2 KPREV = K IF(KP1 .LT. NSP2) GO TO 199 DO 150 I = NSP2,KP1 LIMIT2 = KP2 - I TEMP6 = ALPHA(I-1) DO 145 IQ = 1,LIMIT2 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) 150 G(I) = W(1) 199 CONTINUE C *** END BLOCK 1 *** C C *** BEGIN BLOCK 2 *** C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. C *** C C INCREMENT COUNTER ON ATTEMPTED STEPS C KSTEPS = KSTEPS + 1 C C CHANGE PHI TO PHI STAR C IF(K .LT. NSP1) GO TO 215 DO 210 I = NSP1,K TEMP1 = BETA(I) DO 205 L = 1,NEQN 205 PHI(L,I) = TEMP1*PHI(L,I) 210 CONTINUE C C PREDICT SOLUTION AND DIFFERENCES C 215 DO 220 L = 1,NEQN PHI(L,KP2) = PHI(L,KP1) PHI(L,KP1) = 0.0 220 P(L) = 0.0 DO 230 J = 1,K I = KP1 - J IP1 = I+1 TEMP2 = G(I) DO 225 L = 1,NEQN P(L) = P(L) + TEMP2*PHI(L,I) 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) 230 CONTINUE IF(NORND) GO TO 240 DO 235 L = 1,NEQN TAU = H*P(L) - PHI(L,15) P(L) = Y(L) + TAU 235 PHI(L,16) = (P(L) - Y(L)) - TAU GO TO 250 240 DO 245 L = 1,NEQN 245 P(L) = Y(L) + H*P(L) 250 XOLD = X X = X + H ABSH = ABS(H) CALL F(X,P,YP,RPAR,IPAR) C C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 C ERKM2 = 0.0 ERKM1 = 0.0 ERK = 0.0 DO 265 L = 1,NEQN TEMP3 = 1.0/WT(L) TEMP4 = YP(L) - PHI(L,1) IF(KM2)265,260,255 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 265 ERK = ERK + (TEMP4*TEMP3)**2 IF(KM2)280,275,270 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) 280 TEMP5 = ABSH*SQRT(ERK) ERR = TEMP5*(G(K)-G(KP1)) ERK = TEMP5*SIG(KP1)*GSTR(K) KNEW = K C C TEST IF ORDER SHOULD BE LOWERED C IF(KM2)299,290,285 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 GO TO 299 290 IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 C C TEST IF STEP SUCCESSFUL C 299 IF(ERR .LE. EPS) GO TO 400 C *** END BLOCK 2 *** C C *** BEGIN BLOCK 3 *** C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE C PRECISION. C *** C C RESTORE X, PHI(*,*) AND PSI(*) C PHASE1 = .FALSE. X = XOLD DO 310 I = 1,K TEMP1 = 1.0/BETA(I) IP1 = I+1 DO 305 L = 1,NEQN 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) 310 CONTINUE IF(K .LT. 2) GO TO 320 DO 315 I = 2,K 315 PSI(I-1) = PSI(I) - H C C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP C SIZE C 320 IFAIL = IFAIL + 1 TEMP2 = 0.5 IF(IFAIL - 3) 335,330,325 325 IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 330 KNEW = 1 335 H = TEMP2*H K = KNEW NS = 0 IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 CRASH = .TRUE. H = SIGN(FOURU*ABS(X),H) EPS = EPS + EPS RETURN 340 GO TO 100 C *** END BLOCK 3 *** C C *** BEGIN BLOCK 4 *** C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. C *** 400 KOLD = K HOLD = H C C CORRECT AND EVALUATE C TEMP1 = H*G(KP1) IF(NORND) GO TO 410 DO 405 L = 1,NEQN TEMP3 = Y(L) RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) Y(L) = P(L) + RHO PHI(L,15) = (Y(L) - P(L)) - RHO 405 P(L) = TEMP3 GO TO 420 410 DO 415 L = 1,NEQN TEMP3 = Y(L) Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) 415 P(L) = TEMP3 420 CALL F(X,Y,YP,RPAR,IPAR) C C UPDATE DIFFERENCES FOR NEXT STEP C DO 425 L = 1,NEQN PHI(L,KP1) = YP(L) - PHI(L,1) 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) DO 435 I = 1,K DO 430 L = 1,NEQN 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) 435 CONTINUE C C ESTIMATE ERROR AT ORDER K+1 UNLESS: C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, C ALREADY DECIDED TO LOWER ORDER, C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE C ERKP1 = 0.0 IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. IF(PHASE1) GO TO 450 IF(KNEW .EQ. KM1) GO TO 455 IF(KP1 .GT. NS) GO TO 460 DO 440 L = 1,NEQN 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) C C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER C FOR NEXT STEP C IF(K .GT. 1) GO TO 445 IF(ERKP1 .GE. 0.5*ERK) GO TO 460 GO TO 450 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 C C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED C C RAISE ORDER C 450 K = KP1 ERK = ERKP1 GO TO 460 C C LOWER ORDER C 455 K = KM1 ERK = ERKM1 C C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP C 460 HNEW = H + H IF(PHASE1) GO TO 465 IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 HNEW = H IF(P5EPS .GE. ERK) GO TO 465 TEMP2 = K+1 R = (P5EPS/ERK)**(1.0/TEMP2) HNEW = ABSH*MAX(0.5,MIN(0.9,R)) HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 465 H = HNEW RETURN C *** END BLOCK 4 *** END *DECK HVNRM double precision FUNCTION HVNRM (V, NCOMP) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE HVNRM C***SUBSIDIARY C***PURPOSE Subsidiary to DEABM, DEBDF and DERKF C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (HVNRM-S, DHVNRM-D) C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C Compute the maximum norm of the vector V(*) of length NCOMP and C return the result as HVNRM. C C***SEE ALSO DEABM, DEBDF, DERKF C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891024 Changed routine name from VNORM to HVNRM. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910722 Updated AUTHOR section. (ALS) C***END PROLOGUE HVNRM DIMENSION V(*) C***FIRST EXECUTABLE STATEMENT HVNRM HVNRM=0. DO 10 K=1,NCOMP 10 HVNRM=MAX(HVNRM,ABS(V(K))) RETURN END *DECK HSTART SUBROUTINE HSTART (F, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE HSTART C***SUBSIDIARY C***PURPOSE Subsidiary to DEABM, DEBDF and DERKF C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (HSTART-S, DHSTRT-D) C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C HSTART computes a starting step size to be used in solving initial C value problems in ordinary differential equations. C ********************************************************************** C Abstract C C Subroutine HSTART computes a starting step size to be used by an C initial value method in solving ordinary differential equations. C It is based on an estimate of the local Lipschitz constant for the C differential equation (lower bound on a norm of the Jacobian), C a bound on the differential equation (first derivative), and C a bound on the partial derivative of the equation with respect to C the independent variable. C (All approximated near the initial point A.) C C Subroutine HSTART uses a function subprogram HVNRM for computing C a vector norm. The maximum norm is presently utilized though it C can easily be replaced by any other vector norm. It is presumed C that any replacement norm routine would be carefully coded to C prevent unnecessary underflows or overflows from occurring, and C also, would not alter the vector or number of components. C C ********************************************************************** C On Input you must provide the following C C F -- This is a subroutine of the form C F(X,U,UPRIME,RPAR,IPAR) C which defines the system of first order differential C equations to be solved. For the given values of X and the C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must C evaluate the NEQ components of the system of differential C equations dU/DX=F(X,U) and store the derivatives in the C array UPRIME(*), that is, UPRIME(I) = * dU(I)/DX * for C equations I=1,...,NEQ. C C Subroutine F must not alter X or U(*). You must declare C the name F in an EXTERNAL statement in your program that C calls HSTART. You must dimension U and UPRIME in F. C C RPAR and IPAR are real and integer parameter arrays which C you can use for communication between your program and C subroutine F. They are not used or altered by HSTART. If C you do not need RPAR or IPAR, ignore these parameters by C treating them as dummy arguments. If you do choose to use C them, dimension them in your program and in F as arrays C of appropriate length. C C NEQ -- This is the number of (first order) differential equations C to be integrated. C C A -- This is the initial point of integration. C C B -- This is a value of the independent variable used to define C the direction of integration. A reasonable choice is to C set B to the first point at which a solution is desired. C You can also use B, if necessary, to restrict the length C of the first integration step because the algorithm will C not compute a starting step length which is bigger than C ABS(B-A), unless B has been chosen too close to A. C (It is presumed that HSTART has been called with B C different from A on the machine being used. Also see C the discussion about the parameter SMALL.) C C Y(*) -- This is the vector of initial values of the NEQ solution C components at the initial point A. C C YPRIME(*) -- This is the vector of derivatives of the NEQ C solution components at the initial point A. C (defined by the differential equations in subroutine F) C C ETOL -- This is the vector of error tolerances corresponding to C the NEQ solution components. It is assumed that all C elements are positive. Following the first integration C step, the tolerances are expected to be used by the C integrator in an error test which roughly requires that C ABS(local error) .LE. ETOL C for each vector component. C C MORDER -- This is the order of the formula which will be used by C the initial value method for taking the first integration C step. C C SMALL -- This is a small positive machine dependent constant C which is used for protecting against computations with C numbers which are too small relative to the precision of C floating point arithmetic. SMALL should be set to C (approximately) the smallest positive real number such C that (1.+SMALL) .GT. 1. on the machine being used. the C quantity SMALL**(3/8) is used in computing increments of C variables for approximating derivatives by differences. C also the algorithm will not compute a starting step length C which is smaller than 100*SMALL*ABS(A). C C BIG -- This is a large positive machine dependent constant which C is used for preventing machine overflows. A reasonable C choice is to set big to (approximately) the square root of C the largest real number which can be held in the machine. C C SPY(*),PV(*),YP(*),SF(*) -- These are real work arrays of length C NEQ which provide the routine with needed storage space. C C RPAR,IPAR -- These are parameter arrays, of real and integer C type, respectively, which can be used for communication C between your program and the F subroutine. They are not C used or altered by HSTART. C C ********************************************************************** C On Output (after the return from HSTART), C C H -- Is an appropriate starting step size to be attempted by the C differential equation method. C C All parameters in the call list remain unchanged except for C the working arrays SPY(*),PV(*),YP(*) and SF(*). C C ********************************************************************** C C***SEE ALSO DEABM, DEBDF, DERKF C***ROUTINES CALLED HVNRM C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891024 Changed references from VNORM to HVNRM. (WRB) C 891024 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910722 Updated AUTHOR section. (ALS) C***END PROLOGUE HSTART C DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*),SF(*), 1 RPAR(*),IPAR(*) EXTERNAL F C C....................................................................... C C***FIRST EXECUTABLE STATEMENT HSTART DX = B - A ABSDX = ABS(DX) RELPER = SMALL**0.375 YNORM = HVNRM(Y,NEQ) C C....................................................................... C C COMPUTE A WEIGHTED APPROXIMATE BOUND (DFDXB) ON THE PARTIAL C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. ALSO C COMPUTE A WEIGHTED BOUND (FBND) ON THE FIRST DERIVATIVE LOCALLY. C DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX),100.*SMALL*ABS(A)),DX) IF (DA .EQ. 0.) DA = RELPER*DX CALL F(A+DA,Y,SF,RPAR,IPAR) C IF (MORDER .EQ. 1) GO TO 20 POWER = 2./(MORDER+1) DO 10 J=1,NEQ WTJ = ETOL(J)**POWER SPY(J) = SF(J)/WTJ YP(J) = YPRIME(J)/WTJ 10 PV(J) = SPY(J) - YP(J) GO TO 40 C 20 DO 30 J=1,NEQ SPY(J) = SF(J)/ETOL(J) YP(J) = YPRIME(J)/ETOL(J) 30 PV(J) = SPY(J) - YP(J) C 40 DELF = HVNRM(PV,NEQ) DFDXB = BIG IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) YPNORM = HVNRM(YP,NEQ) FBND = MAX(HVNRM(SPY,NEQ),YPNORM) C C....................................................................... C C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ CONSTANT FOR C THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ALSO REPRESENTS AN C ESTIMATE OF THE NORM OF THE JACOBIAN LOCALLY. C THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ESTIMATE THE C LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. THE FIRST C PERTURBATION VECTOR IS BASED ON THE INITIAL DERIVATIVES AND C DIRECTION OF INTEGRATION. THE SECOND PERTURBATION VECTOR IS C FORMED USING ANOTHER EVALUATION OF THE DIFFERENTIAL EQUATION. C THE THIRD PERTURBATION VECTOR IS FORMED USING PERTURBATIONS BASED C ONLY ON THE INITIAL VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS C CHANGED TO NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT COMPONENTS C OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE CONSISTENT WITH C THE SLOPES OF LOCAL SOLUTION CURVES. C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST DERIVATIVE. C NO ATTEMPT IS MADE TO KEEP THE PERTURBATION VECTOR SIZE CONSTANT. C IF (YPNORM .EQ. 0.) GO TO 60 C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION ICASE = 1 DO 50 J=1,NEQ SPY(J) = YPRIME(J) 50 YP(J) = YPRIME(J) GO TO 80 C CANNOT HAVE A NULL PERTURBATION VECTOR 60 ICASE = 2 DO 70 J=1,NEQ SPY(J) = YPRIME(J) 70 YP(J) = ETOL(J) C 80 DFDUB = 0. LK = MIN(NEQ+1,3) DO 260 K=1,LK C SET YPNORM AND DELX YPNORM = HVNRM(YP,NEQ) IF (ICASE .EQ. 1 .OR. ICASE .EQ. 3) GO TO 90 DELX = SIGN(1.0,DX) GO TO 120 C TRY TO ENFORCE MEANINGFUL PERTURBATION VALUES 90 DELX = DX IF (ABS(DELX)*YPNORM .GE. RELPER*YNORM) GO TO 100 DELXB = BIG IF (RELPER*YNORM .LT. BIG*YPNORM) DELXB = RELPER*YNORM/YPNORM DELX = SIGN(DELXB,DX) 100 DO 110 J=1,NEQ IF (ABS(DELX*YP(J)) .GT. ETOL(J)) DELX=SIGN(ETOL(J)/YP(J),DX) 110 CONTINUE C DEFINE PERTURBED VECTOR OF INITIAL VALUES 120 DO 130 J=1,NEQ 130 PV(J) = Y(J) + DELX*YP(J) IF (K .EQ. 2) GO TO 150 C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES CALL F(A,PV,YP,RPAR,IPAR) DO 140 J=1,NEQ 140 PV(J) = YP(J) - YPRIME(J) GO TO 170 C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE C IN COMPUTING ONE ESTIMATE 150 CALL F(A+DA,PV,YP,RPAR,IPAR) DO 160 J=1,NEQ 160 PV(J) = YP(J) - SF(J) C CHOOSE LARGEST BOUND ON THE WEIGHTED FIRST C DERIVATIVE 170 IF (MORDER .EQ. 1) GO TO 190 DO 180 J=1,NEQ 180 YP(J) = YP(J)/ETOL(J)**POWER GO TO 210 190 DO 200 J=1,NEQ 200 YP(J) = YP(J)/ETOL(J) 210 FBND = MAX(FBND,HVNRM(YP,NEQ)) C COMPUTE BOUND ON A LOCAL LIPSCHITZ CONSTANT DELF = HVNRM(PV,NEQ) IF (DELF .EQ. 0.) GO TO 220 DELY = ABS(DELX)*YPNORM IF (DELF .GE. BIG*DELY) GO TO 270 DFDUB = MAX(DFDUB,DELF/DELY) C 220 IF (K .EQ. LK) GO TO 280 C CHOOSE NEXT PERTURBATION VECTOR DO 250 J=1,NEQ IF (K .EQ. LK-1) GO TO 230 ICASE = 3 DY = ABS(PV(J)) IF (DY .EQ. 0.) DY = MAX(DELF,ETOL(J)) GO TO 240 230 ICASE = 4 DY = MAX(RELPER*ABS(Y(J)),ETOL(J)) 240 IF (SPY(J) .EQ. 0.) SPY(J) = YP(J) IF (SPY(J) .NE. 0.) DY = SIGN(DY,SPY(J)) 250 YP(J) = DY 260 CONTINUE C C PROTECT AGAINST AN OVERFLOW 270 DFDUB = BIG C C....................................................................... C C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE C 280 YDPB = DFDXB + DFDUB*FBND C C....................................................................... C C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND SECOND C DERIVATIVE INFORMATION C C RESTRICT THE STEP LENGTH TO BE NOT BIGGER THAN C ABS(B-A). (UNLESS B IS TOO CLOSE TO A) H = ABSDX C IF (YDPB .NE. 0. .OR. FBND .NE. 0.) GO TO 290 C C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND C DERIVATIVE TERM (YDPB) ARE ZERO GO TO 310 C 290 IF (YDPB .NE. 0.) GO TO 300 C C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO IF (1.0 .LT. FBND*ABSDX) H = 1./FBND GO TO 310 C C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO 300 SRYDPB = SQRT(0.5*YDPB) IF (1.0 .LT. SRYDPB*ABSDX) H = 1./SRYDPB C C FURTHER RESTRICT THE STEP LENGTH TO BE NOT C BIGGER THAN 1/DFDUB 310 IF (H*DFDUB .GT. 1.) H = 1./DFDUB C C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE C STEP LENGTH. H = MAX(H,100.*SMALL*ABS(A)) IF (H .EQ. 0.) H = SMALL*ABS(B) C C NOW SET DIRECTION OF INTEGRATION H = SIGN(H,DX) C RETURN END *DECK XGETUA SUBROUTINE XGETUA (IUNITA, N) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE XGETUA C***PURPOSE Return unit number(s) to which error messages are being C sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XGETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C XGETUA may be called to determine the unit number or numbers C to which error messages are being sent. C These unit numbers may have been set by a call to XSETUN, C or a call to XSETUA, or may be a default value. C C Description of Parameters C --Output-- C IUNIT - an array of one to five unit numbers, depending C on the value of N. A value of zero refers to the C default unit, as defined by the I1MACH machine C constant routine. Only IUNIT(1),...,IUNIT(N) are C defined by XGETUA. The values of IUNIT(N+1),..., C IUNIT(5) are not defined (for N .LT. 5) or altered C in any way by XGETUA. C N - the number of units to which copies of the C error messages are being sent. N will be in the C range from 1 to 5. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED J4SAVE C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XGETUA DIMENSION IUNITA(5) C***FIRST EXECUTABLE STATEMENT XGETUA N = J4SAVE(5,0,.FALSE.) DO 30 I=1,N INDEX = I+4 IF (I.EQ.1) INDEX = 3 IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) 30 CONTINUE RETURN END *DECK XERHLT SUBROUTINE XERHLT (MESSG) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE XERHLT C***SUBSIDIARY C***PURPOSE Abort program execution and print error message. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERHLT-A) C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C ***Note*** machine dependent routine C XERHLT aborts the execution of the program. C The error message causing the abort is given in the calling C sequence, in case one needs it for printing on a dayfile, C for example. C C Description of Parameters C MESSG is as in XERMSG. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to delete length of character C and changed routine name from XERABT to XERHLT. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERHLT CHARACTER*(*) MESSG C***FIRST EXECUTABLE STATEMENT XERHLT STOP END *DECK I1MACH INTEGER FUNCTION I1MACH (I) C***BEGIN PROLOGUE I1MACH C***PURPOSE Return integer machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 C***TYPE INTEGER (I1MACH-I) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) C Schryer, N. L., (Bell Labs) C***DESCRIPTION C C I1MACH can be used to obtain machine-dependent parameters for the C local machine environment. It is a function subprogram with one C (input) argument and can be referenced as follows: C C K = I1MACH(I) C C where I=1,...,16. The (output) value of K above is determined by C the (input) value of I. The results for various values of I are C discussed below. C C I/O unit numbers: C I1MACH( 1) = the standard input unit. C I1MACH( 2) = the standard output unit. C I1MACH( 3) = the standard punch unit. C I1MACH( 4) = the standard error message unit. C C Words: C I1MACH( 5) = the number of bits per integer storage unit. C I1MACH( 6) = the number of characters per integer storage unit. C C Integers: C assume integers are represented in the S-digit, base-A form C C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C C where 0 .LE. X(I) .LT. A for I=0,...,S-1. C I1MACH( 7) = A, the base. C I1MACH( 8) = S, the number of base-A digits. C I1MACH( 9) = A**S - 1, the largest magnitude. C C Floating-Point Numbers: C Assume floating-point numbers are represented in the T-digit, C base-B form C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. C I1MACH(10) = B, the base. C C Single-Precision: C I1MACH(11) = T, the number of base-B digits. C I1MACH(12) = EMIN, the smallest exponent E. C I1MACH(13) = EMAX, the largest exponent E. C C Double-Precision: C I1MACH(14) = T, the number of base-B digits. C I1MACH(15) = EMIN, the smallest exponent E. C I1MACH(16) = EMAX, the largest exponent E. C C To alter this function for a particular environment, the desired C set of DATA statements should be activated by removing the C from C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be C checked for consistency with the local operating system. C C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for C a portable library, ACM Transactions on Mathematical C Software 4, 2 (June 1978), pp. 177-188. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 891012 Added VAX G-floating constants. (WRB) C 891012 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900618 Added DEC RISC constants. (WRB) C 900723 Added IBM RS 6000 constants. (WRB) C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. C (RWC) C 910710 Added HP 730 constants. (SMR) C 911114 Added Convex IEEE constants. (WRB) C 920121 Added SUN -r8 compiler option constants. (WRB) C 920229 Added Touchstone Delta i860 constants. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920625 Added Convex -p8 and -pd8 compiler option constants. C (BKS, WRB) C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler C options. (DWL, RWC and WRB). C***END PROLOGUE I1MACH C INTEGER IMACH(16),OUTPUT SAVE IMACH EQUIVALENCE (IMACH(4),OUTPUT) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT COMPILER C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 129 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1025 / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA IMACH( 1) / 7 / C DATA IMACH( 2) / 2 / C DATA IMACH( 3) / 2 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 33 / C DATA IMACH( 9) / Z1FFFFFFFF / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -256 / C DATA IMACH(13) / 255 / C DATA IMACH(14) / 60 / C DATA IMACH(15) / -256 / C DATA IMACH(16) / 255 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -50 / C DATA IMACH(16) / 76 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -32754 / C DATA IMACH(16) / 32780 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -4095 / C DATA IMACH(13) / 4094 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -4095 / C DATA IMACH(16) / 4094 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6LOUTPUT/ C DATA IMACH( 5) / 60 / C DATA IMACH( 6) / 10 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 48 / C DATA IMACH( 9) / 00007777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -929 / C DATA IMACH(13) / 1070 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -929 / C DATA IMACH(16) / 1069 / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z'7FFFFFFF' / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fn COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fi COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -p8 COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 53 / C DATA IMACH(12) / -1023 / C DATA IMACH(13) / 1023 / C DATA IMACH(14) / 113 / C DATA IMACH(15) / -16383 / C DATA IMACH(16) / 16383 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -pd8 COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 53 / C DATA IMACH(12) / -1023 / C DATA IMACH(13) / 1023 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE CRAY C USING THE 46 BIT INTEGER COMPILER OPTION C C DATA IMACH( 1) / 100 / C DATA IMACH( 2) / 101 / C DATA IMACH( 3) / 102 / C DATA IMACH( 4) / 101 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 46 / C DATA IMACH( 9) / 1777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -8189 / C DATA IMACH(13) / 8190 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -8099 / C DATA IMACH(16) / 8190 / C C MACHINE CONSTANTS FOR THE CRAY C USING THE 64 BIT INTEGER COMPILER OPTION C C DATA IMACH( 1) / 100 / C DATA IMACH( 2) / 101 / C DATA IMACH( 3) / 102 / C DATA IMACH( 4) / 101 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 777777777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -8189 / C DATA IMACH(13) / 8190 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -8099 / C DATA IMACH(16) / 8190 / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C DATA IMACH( 1) / 11 / C DATA IMACH( 2) / 12 / C DATA IMACH( 3) / 8 / C DATA IMACH( 4) / 10 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING G_FLOAT C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING IEEE_FLOAT C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE DEC RISC C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE DEC VAX C USING D_FLOATING C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE DEC VAX C USING G_FLOATING C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 32 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / 3 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 23 / C DATA IMACH( 9) / 8388607 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 38 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 43 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 63 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 730 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 4 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 39 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 4 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 55 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 7 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 32 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1015 / C DATA IMACH(16) / 1017 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z7FFFFFFF / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 / C C MACHINE CONSTANTS FOR THE IBM PC C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE INTEL i860 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 54 / C DATA IMACH(15) / -101 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 62 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE SUN C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE SUN C USING THE -r8 COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 53 / C DATA IMACH(12) / -1021 / C DATA IMACH(13) / 1024 / C DATA IMACH(14) / 113 / C DATA IMACH(15) / -16381 / C DATA IMACH(16) / 16384 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 1 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 60 / C DATA IMACH(15) / -1024 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR C C DATA IMACH( 1) / 1 / C DATA IMACH( 2) / 1 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C***FIRST EXECUTABLE STATEMENT I1MACH IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 C I1MACH = IMACH(I) RETURN C 10 CONTINUE WRITE (UNIT = OUTPUT, FMT = 9000) 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') C C CALL FDUMP C STOP END *DECK XERCNT SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE XERCNT C***SUBSIDIARY C***PURPOSE Allow user control over handling of errors. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERCNT-A) C***KEYWORDS ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C Allows user control over handling of individual errors. C Just after each message is recorded, but before it is C processed any further (i.e., before it is printed or C a decision to abort is made), a call is made to XERCNT. C If the user has provided his own version of XERCNT, he C can then override the value of KONTROL used in processing C this message by redefining its value. C KONTRL may be set to any value from -2 to 2. C The meanings for KONTRL are the same as in XSETF, except C that the value of KONTRL changes only for this message. C If KONTRL is set to a value outside the range from -2 to 2, C it will be moved back into that range. C C Description of Parameters C C --Input-- C LIBRAR - the library that the routine is in. C SUBROU - the subroutine that XERMSG is being called from C MESSG - the first 20 characters of the error message. C NERR - same as in the call to XERMSG. C LEVEL - same as in the call to XERMSG. C KONTRL - the current value of the control flag as set C by a call to XSETF. C C --Output-- C KONTRL - the new value of KONTRL. If KONTRL is not C defined, it will remain at its original value. C This changed value of control affects only C the current occurrence of the current message. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE C names, changed routine name from XERCTL to XERCNT. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERCNT CHARACTER*(*) LIBRAR, SUBROU, MESSG C***FIRST EXECUTABLE STATEMENT XERCNT RETURN END *DECK XERSVE SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + ICOUNT) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE XERSVE C***SUBSIDIARY C***PURPOSE Record that an error has occurred. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3 C***TYPE ALL (XERSVE-A) C***KEYWORDS ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C *Usage: C C INTEGER KFLAG, NERR, LEVEL, ICOUNT C CHARACTER * (len) LIBRAR, SUBROU, MESSG C C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) C C *Arguments: C C LIBRAR :IN is the library that the message is from. C SUBROU :IN is the subroutine that the message is from. C MESSG :IN is the message to be saved. C KFLAG :IN indicates the action to be performed. C when KFLAG > 0, the message in MESSG is saved. C when KFLAG=0 the tables will be dumped and C cleared. C when KFLAG < 0, the tables will be dumped and C not cleared. C NERR :IN is the error number. C LEVEL :IN is the error severity. C ICOUNT :OUT the number of times this message has been seen, C or zero if the table has overflowed and does not C contain this message specifically. When KFLAG=0, C ICOUNT will not be altered. C C *Description: C C Record that this error occurred and possibly dump and clear the C tables. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 800319 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900413 Routine modified to remove reference to KFLAG. (WRB) C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling C sequence, use IF-THEN-ELSE, make number of saved entries C easily changeable, changed routine name from XERSAV to C XERSVE. (RWC) C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERSVE PARAMETER (LENTAB=10) INTEGER LUN(5) CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB CHARACTER*20 MESTAB(LENTAB), MES DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG DATA KOUNTX/0/, NMSG/0/ C***FIRST EXECUTABLE STATEMENT XERSVE C IF (KFLAG.LE.0) THEN C C Dump the table. C IF (NMSG.EQ.0) RETURN C C Print to each unit. C CALL XGETUA (LUN, NUNIT) DO 20 KUNIT = 1,NUNIT IUNIT = LUN(KUNIT) IF (IUNIT.EQ.0) IUNIT = I1MACH(4) C C Print the table header. C WRITE (IUNIT,9000) C C Print body of table. C DO 10 I = 1,NMSG WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), * NERTAB(I),LEVTAB(I),KOUNT(I) 10 CONTINUE C C Print number of other errors. C IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX WRITE (IUNIT,9030) 20 CONTINUE C C Clear the error tables. C IF (KFLAG.EQ.0) THEN NMSG = 0 KOUNTX = 0 ENDIF ELSE C C PROCESS A MESSAGE... C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. C LIB = LIBRAR SUB = SUBROU MES = MESSG DO 30 I = 1,NMSG IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. * LEVEL.EQ.LEVTAB(I)) THEN KOUNT(I) = KOUNT(I) + 1 ICOUNT = KOUNT(I) RETURN ENDIF 30 CONTINUE C IF (NMSG.LT.LENTAB) THEN C C Empty slot found for new message. C NMSG = NMSG + 1 LIBTAB(I) = LIB SUBTAB(I) = SUB MESTAB(I) = MES NERTAB(I) = NERR LEVTAB(I) = LEVEL KOUNT (I) = 1 ICOUNT = 1 ELSE C C Table is full. C KOUNTX = KOUNTX+1 ICOUNT = 0 ENDIF ENDIF RETURN C C Formats. C 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + ' LIBRARY SUBROUTINE MESSAGE START NERR', + ' LEVEL COUNT') 9010 FORMAT (1X,A,3X,A,3X,A,3I10) 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) 9030 FORMAT (1X) END *DECK J4SAVE FUNCTION J4SAVE (IWHICH, IVALUE, ISET) C***BEGIN PROLOGUE J4SAVE C***SUBSIDIARY C***PURPOSE Save or recall global variables needed by error C handling routines. C***LIBRARY SLATEC (XERROR) C***TYPE INTEGER (J4SAVE-I) C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C J4SAVE saves and recalls several global variables needed C by the library error handling routines. C C Description of Parameters C --Input-- C IWHICH - Index of item desired. C = 1 Refers to current error number. C = 2 Refers to current error control flag. C = 3 Refers to current unit number to which error C messages are to be sent. (0 means use standard.) C = 4 Refers to the maximum number of times any C message is to be printed (as set by XERMAX). C = 5 Refers to the total number of units to which C each error message is to be written. C = 6 Refers to the 2nd unit for error messages C = 7 Refers to the 3rd unit for error messages C = 8 Refers to the 4th unit for error messages C = 9 Refers to the 5th unit for error messages C IVALUE - The value to be set for the IWHICH-th parameter, C if ISET is .TRUE. . C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE C given the value, IVALUE. If ISET=.FALSE., the C IWHICH-th parameter will be unchanged, and IVALUE C is a dummy parameter. C --Output-- C The (old) value of the IWHICH-th parameter will be returned C in the function value, J4SAVE. C C***SEE ALSO XERMSG C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900205 Minor modifications to prologue. (WRB) C 900402 Added TYPE section. (WRB) C 910411 Added KEYWORDS section. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE J4SAVE LOGICAL ISET INTEGER IPARAM(9) SAVE IPARAM DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ DATA IPARAM(5)/1/ DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ C***FIRST EXECUTABLE STATEMENT J4SAVE J4SAVE = IPARAM(IWHICH) IF (ISET) IPARAM(IWHICH) = IVALUE RETURN END *DECK FDUMP SUBROUTINE FDUMP implicit double precision (a-h,o-z) C***BEGIN PROLOGUE FDUMP C***PURPOSE Symbolic dump (should be locally written). C***LIBRARY SLATEC (XERROR) C***CATEGORY R3 C***TYPE ALL (FDUMP-A) C***KEYWORDS ERROR, XERMSG C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C ***Note*** Machine Dependent Routine C FDUMP is intended to be replaced by a locally written C version which produces a symbolic dump. Failing this, C it should be replaced by a version which prints the C subprogram nesting list. Note that this dump must be C printed on each of up to five files, as indicated by the C XGETUA routine. See XSETUA and XGETUA for details. C C Written by Ron Jones, with SLATEC Common Math Library Subcommittee C C***REFERENCES (NONE) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FDUMP C***FIRST EXECUTABLE STATEMENT FDUMP RETURN END *DECK SINTRP SUBROUTINE SINTRP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, + IV, KGI, GI, ALPHA, OG, OW, OX, OY) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE SINTRP C***PURPOSE Approximate the solution at XOUT by evaluating the C polynomial computed in STEPS at XOUT. Must be used in C conjunction with STEPS. C***LIBRARY SLATEC (DEPAC) C***CATEGORY I1A1B C***TYPE SINGLE PRECISION (SINTRP-S, DINTP-D) C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, C SMOOTH INTERPOLANT C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C The methods in subroutine STEPS approximate the solution near X C by a polynomial. Subroutine SINTRP approximates the solution at C XOUT by evaluating the polynomial there. Information defining this C polynomial is passed from STEPS so SINTRP cannot be used alone. C C Subroutine STEPS is completely explained and documented in the text, C "Computer Solution of Ordinary Differential Equations, the Initial C Value Problem" by L. F. Shampine and M. K. Gordon. C C Input to SINTRP -- C C The user provides storage in the calling program for the arrays in C the call list C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) C AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) C and defines C XOUT -- point at which solution is desired. C The remaining parameters are defined in STEPS and passed to C SINTRP from that subroutine C C Output from SINTRP -- C C YOUT(*) -- solution at XOUT C YPOUT(*) -- derivative of solution at XOUT C The remaining parameters are returned unaltered from their input C values. Integration with STEPS may be continued. C C***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP C II, Report SAND84-0293, Sandia Laboratories, 1984. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 840201 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SINTRP C DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) C C***FIRST EXECUTABLE STATEMENT SINTRP KP1 = KOLD + 1 KP2 = KOLD + 2 C HI = XOUT - OX H = X - OX XI = HI/H XIM1 = XI - 1. C C INITIALIZE W(*) FOR COMPUTING G(*) C XIQ = XI DO 10 IQ = 1,KP1 XIQ = XI*XIQ TEMP1 = IQ*(IQ+1) 10 W(IQ) = XIQ/TEMP1 C C COMPUTE THE DOUBLE INTEGRAL TERM GDI C IF (KOLD .LE. KGI) GO TO 50 IF (IVC .GT. 0) GO TO 20 GDI = 1.0/TEMP1 M = 2 GO TO 30 20 IW = IV(IVC) GDI = OW(IW) M = KOLD - IW + 3 30 IF (M .GT. KOLD) GO TO 60 DO 40 I = M,KOLD 40 GDI = OW(KP2-I) - ALPHA(I)*GDI GO TO 60 50 GDI = GI(KOLD) C C COMPUTE G(*) AND C(*) C 60 G(1) = XI G(2) = 0.5*XI*XI C(1) = 1.0 C(2) = XI IF (KOLD .LT. 2) GO TO 90 DO 80 I = 2,KOLD ALP = ALPHA(I) GAMMA = 1.0 + XIM1*ALP L = KP2 - I DO 70 JQ = 1,L 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) G(I+1) = W(1) 80 C(I+1) = GAMMA*C(I) C C DEFINE INTERPOLATION PARAMETERS C 90 SIGMA = (W(2) - XIM1*W(1))/GDI RMU = XIM1*C(KP1)/GDI HMU = RMU/H C C INTERPOLATE FOR THE SOLUTION -- YOUT C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT C DO 100 L = 1,NEQN YOUT(L) = 0.0 100 YPOUT(L) = 0.0 DO 120 J = 1,KOLD I = KP2 - J GDIF = OG(I) - OG(I-1) TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF TEMP3 = (C(I) - C(I-1)) + RMU*GDIF DO 110 L = 1,NEQN YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) 120 CONTINUE DO 130 L = 1,NEQN YOUT(L) = ((1.0 - SIGMA)*OY(L) + SIGMA*Y(L)) + 1 H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + 1 (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) C RETURN END *DECK XERPRN SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE XERPRN C***SUBSIDIARY C***PURPOSE Print error messages processed by XERMSG. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERPRN-A) C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR C***AUTHOR Fong, Kirby, (NMFECC at LLNL) C***DESCRIPTION C C This routine sends one or more lines to each of the (up to five) C logical units to which error messages are to be sent. This routine C is called several times by XERMSG, sometimes with a single line to C print and sometimes with a (potentially very long) message that may C wrap around into multiple lines. C C PREFIX Input argument of type CHARACTER. This argument contains C characters to be put at the beginning of each line before C the body of the message. No more than 16 characters of C PREFIX will be used. C C NPREF Input argument of type INTEGER. This argument is the number C of characters to use from PREFIX. If it is negative, the C intrinsic function LEN is used to determine its length. If C it is zero, PREFIX is not used. If it exceeds 16 or if C LEN(PREFIX) exceeds 16, only the first 16 characters will be C used. If NPREF is positive and the length of PREFIX is less C than NPREF, a copy of PREFIX extended with blanks to length C NPREF will be used. C C MESSG Input argument of type CHARACTER. This is the text of a C message to be printed. If it is a long message, it will be C broken into pieces for printing on multiple lines. Each line C will start with the appropriate prefix and be followed by a C piece of the message. NWRAP is the number of characters per C piece; that is, after each NWRAP characters, we break and C start a new line. In addition the characters '$$' embedded C in MESSG are a sentinel for a new line. The counting of C characters up to NWRAP starts over for each new line. The C value of NWRAP typically used by XERMSG is 72 since many C older error messages in the SLATEC Library are laid out to C rely on wrap-around every 72 characters. C C NWRAP Input argument of type INTEGER. This gives the maximum size C piece into which to break MESSG for printing on multiple C lines. An embedded '$$' ends a line, and the count restarts C at the following character. If a line break does not occur C on a blank (it would split a word) that word is moved to the C next line. Values of NWRAP less than 16 will be treated as C 16. Values of NWRAP greater than 132 will be treated as 132. C The actual line length will be NPREF + NWRAP after NPREF has C been adjusted to fall between 0 and 16 and NWRAP has been C adjusted to fall between 16 and 132. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 880621 DATE WRITTEN C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE C SLASH CHARACTER IN FORMAT STATEMENTS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK C LINES TO BE PRINTED. C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Added code to break messages between words. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERPRN CHARACTER*(*) PREFIX, MESSG INTEGER NPREF, NWRAP CHARACTER*148 CBUFF INTEGER IU(5), NUNIT CHARACTER*2 NEWLIN PARAMETER (NEWLIN = '$$') C***FIRST EXECUTABLE STATEMENT XERPRN CALL XGETUA(IU,NUNIT) C C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD C ERROR MESSAGE UNIT. C N = I1MACH(4) DO 10 I=1,NUNIT IF (IU(I) .EQ. 0) IU(I) = N 10 CONTINUE C C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING C THE REST OF THIS ROUTINE. C IF ( NPREF .LT. 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF ENDIF LPREF = MIN(16, LPREF) IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX C C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE C TIME FROM MESSG TO PRINT ON ONE LINE. C LWRAP = MAX(16, MIN(132, NWRAP)) C C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. C LENMSG = LEN(MESSG) N = LENMSG DO 20 I=1,N IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 LENMSG = LENMSG - 1 20 CONTINUE 30 CONTINUE C C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. C IF (LENMSG .EQ. 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO 40 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 40 CONTINUE RETURN ENDIF C C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. C C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH C OF THE SECOND ARGUMENT. C C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT C POSITION NEXTC. C C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE C REMAINDER OF THE CHARACTER STRING. LPIECE C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, C WHICHEVER IS LESS. C C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY C BLANK LINES. THIS TAKES CARE OF THE SITUATION C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC C SHOULD BE INCREMENTED BY 2. C C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. C C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 C RESET LPIECE = LPIECE-1. NOTE THAT THIS C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY C AT THE END OF A LINE. C NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) IF (LPIECE .EQ. 0) THEN C C THERE WAS NO NEW LINE SENTINEL FOUND. C IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) IF (LPIECE .LT. LENMSG+1-NEXTC) THEN DO 52 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF 52 CONTINUE ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE IF (LPIECE .EQ. 1) THEN C C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). C DON'T PRINT A BLANK LINE. C NEXTC = NEXTC + 2 GO TO 50 ELSE IF (LPIECE .GT. LWRAP+1) THEN C C LPIECE SHOULD BE SET DOWN TO LWRAP. C IDELTA = 0 LPIECE = LWRAP DO 56 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF 56 CONTINUE 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE C C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. C WE SHOULD DECREMENT LPIECE BY ONE. C LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 ENDIF C C PRINT C DO 60 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 60 CONTINUE C IF (NEXTC .LE. LENMSG) GO TO 50 RETURN END *DECK R1MACH double precision FUNCTION R1MACH (I) C***BEGIN PROLOGUE R1MACH C***PURPOSE Return floating point machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 C***TYPE SINGLE PRECISION (R1MACH-S, D1MACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) C Schryer, N. L., (Bell Labs) C***DESCRIPTION C C R1MACH can be used to obtain machine-dependent parameters for the C local machine environment. It is a function subprogram with one C (input) argument, and can be referenced as follows: C C A = R1MACH(I) C C where I=1,...,5. The (output) value of A above is determined by C the (input) value of I. The results for various values of I are C discussed below. C C R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. C R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. C R1MACH(3) = B**(-T), the smallest relative spacing. C R1MACH(4) = B**(1-T), the largest relative spacing. C R1MACH(5) = LOG10(B) C C Assume single precision numbers are represented in the T-digit, C base-B form C C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and C EMIN .LE. E .LE. EMAX. C C The values of B, T, EMIN and EMAX are provided in I1MACH as C follows: C I1MACH(10) = B, the base. C I1MACH(11) = T, the number of base-B digits. C I1MACH(12) = EMIN, the smallest exponent E. C I1MACH(13) = EMAX, the largest exponent E. C C To alter this function for a particular environment, the desired C set of DATA statements should be activated by removing the C from C column 1. Also, the values of R1MACH(1) - R1MACH(4) should be C checked for consistency with the local operating system. C C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for C a portable library, ACM Transactions on Mathematical C Software 4, 2 (June 1978), pp. 177-188. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 790101 DATE WRITTEN C 890213 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900618 Added DEC RISC constants. (WRB) C 900723 Added IBM RS 6000 constants. (WRB) C 910710 Added HP 730 constants. (SMR) C 911114 Added Convex IEEE constants. (WRB) C 920121 Added SUN -r8 compiler option constants. (WRB) C 920229 Added Touchstone Delta i860 constants. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920625 Added CONVEX -p8 and -pd8 compiler option constants. C (BKS, WRB) C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) C***END PROLOGUE R1MACH C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) C double precision RMACH(5) SAVE RMACH C EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7EFFFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA SMALL(1) / 16#00800000 / C DATA LARGE(1) / 16#7FFFFFFF / C DATA RIGHT(1) / 16#33800000 / C DATA DIVER(1) / 16#34000000 / C DATA LOG10(1) / 16#3E9A209B / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA RMACH(1) / Z400800000 / C DATA RMACH(2) / Z5FFFFFFFF / C DATA RMACH(3) / Z4E9800000 / C DATA RMACH(4) / Z4EA800000 / C DATA RMACH(5) / Z500E730E8 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS C C DATA RMACH(1) / O1771000000000000 / C DATA RMACH(2) / O0777777777777777 / C DATA RMACH(3) / O1311000000000000 / C DATA RMACH(4) / O1301000000000000 / C DATA RMACH(5) / O1157163034761675 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA RMACH(1) / Z"3001800000000000" / C DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / C DATA RMACH(3) / Z"3FD2800000000000" / C DATA RMACH(4) / Z"3FD3800000000000" / C DATA RMACH(5) / Z"3FFF9A209A84FBCF" / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA RMACH(1) / 00564000000000000000B / C DATA RMACH(2) / 37767777777777777776B / C DATA RMACH(3) / 16414000000000000000B / C DATA RMACH(4) / 16424000000000000000B / C DATA RMACH(5) / 17164642023241175720B / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fn COMPILER OPTION C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7FFFFFFF' / C DATA RMACH(3) / Z'34800000' / C DATA RMACH(4) / Z'35000000' / C DATA RMACH(5) / Z'3F9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fi COMPILER OPTION C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -p8 OR -pd8 COMPILER OPTION C C DATA RMACH(1) / Z'0010000000000000' / C DATA RMACH(2) / Z'7FFFFFFFFFFFFFFF' / C DATA RMACH(3) / Z'3CC0000000000000' / C DATA RMACH(4) / Z'3CD0000000000000' / C DATA RMACH(5) / Z'3FF34413509F79FF' / C C MACHINE CONSTANTS FOR THE CRAY C C DATA RMACH(1) / 200034000000000000000B / C DATA RMACH(2) / 577767777777777777776B / C DATA RMACH(3) / 377224000000000000000B / C DATA RMACH(4) / 377234000000000000000B / C DATA RMACH(5) / 377774642023241175720B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC RMACH(5) C C DATA SMALL / 20K, 0 / C DATA LARGE / 77777K, 177777K / C DATA RIGHT / 35420K, 0 / C DATA DIVER / 36020K, 0 / C DATA LOG10 / 40423K, 42023K / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING G_FLOAT C C DATA RMACH(1) / '00000080'X / C DATA RMACH(2) / 'FFFF7FFF'X / C DATA RMACH(3) / '00003480'X / C DATA RMACH(4) / '00003500'X / C DATA RMACH(5) / '209B3F9A'X / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING IEEE_FLOAT C C DATA RMACH(1) / '00800000'X / C DATA RMACH(2) / '7F7FFFFF'X / C DATA RMACH(3) / '33800000'X / C DATA RMACH(4) / '34000000'X / C DATA RMACH(5) / '3E9A209B'X / C C MACHINE CONSTANTS FOR THE DEC RISC C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE DEC VAX C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1) / 128 / C DATA LARGE(1) / -32769 / C DATA RIGHT(1) / 13440 / C DATA DIVER(1) / 13568 / C DATA LOG10(1) / 547045274 / C C DATA SMALL(1) / Z00000080 / C DATA LARGE(1) / ZFFFF7FFF / C DATA RIGHT(1) / Z00003480 / C DATA DIVER(1) / Z00003500 / C DATA LOG10(1) / Z209B3F9A / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C (ASSUMING REAL*4 IS THE DEFAULT REAL) C C DATA SMALL(1) / '00800000'X / C DATA LARGE(1) / '7F7FFFFF'X / C DATA RIGHT(1) / '33800000'X / C DATA DIVER(1) / '34000000'X / C DATA LOG10(1) / '3E9A209B'X / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / C DATA LARGE(1), LARGE(2) / '37777777, '00000177 / C DATA RIGHT(1), RIGHT(2) / '20000000, '00000352 / C DATA DIVER(1), DIVER(2) / '20000000, '00000353 / C DATA LOG10(1), LOG10(2) / '23210115, '00000377 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 / C C MACHINE CONSTANTS FOR THE HP 730 C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA SMALL(1) / 00004000000B / C DATA LARGE(1) / 17677777777B / C DATA RIGHT(1) / 06340000000B / C DATA DIVER(1) / 06400000000B / C DATA LOG10(1) / 07646420233B / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA RMACH(1) / Z00100000 / C DATA RMACH(2) / Z7FFFFFFF / C DATA RMACH(3) / Z3B100000 / C DATA RMACH(4) / Z3C100000 / C DATA RMACH(5) / Z41134413 / C C MACHINE CONSTANTS FOR THE IBM PC C C DATA SMALL(1) / 1.18E-38 / C DATA LARGE(1) / 3.40E+38 / C DATA RIGHT(1) / 0.595E-07 / C DATA DIVER(1) / 1.19E-07 / C DATA LOG10(1) / 0.30102999566 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE INTEL i860 C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR) C C DATA RMACH(1) / "000400000000 / C DATA RMACH(2) / "377777777777 / C DATA RMACH(3) / "146400000000 / C DATA RMACH(4) / "147400000000 / C DATA RMACH(5) / "177464202324 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 / C C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA LARGE(1), LARGE(2) / 32767, -1 / C DATA RIGHT(1), RIGHT(2) / 13440, 0 / C DATA DIVER(1), DIVER(2) / 13568, 0 / C DATA LOG10(1), LOG10(2) / 16282, 8347 / C C DATA SMALL(1), SMALL(2) / O000200, O000000 / C DATA LARGE(1), LARGE(2) / O077777, O177777 / C DATA RIGHT(1), RIGHT(2) / O032200, O000000 / C DATA DIVER(1), DIVER(2) / O032400, O000000 / C DATA LOG10(1), LOG10(2) / O037632, O020233 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE SUN C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE SUN C USING THE -r8 COMPILER OPTION C C DATA RMACH(1) / Z'0010000000000000' / C DATA RMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA RMACH(3) / Z'3CA0000000000000' / C DATA RMACH(4) / Z'3CB0000000000000' / C DATA RMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES C C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 / C C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR C C DATA SMALL(1), SMALL(2) / 0, 256/ C DATA LARGE(1), LARGE(2) / -1, -129/ C DATA RIGHT(1), RIGHT(2) / 0, 26880/ C DATA DIVER(1), DIVER(2) / 0, 27136/ C DATA LOG10(1), LOG10(2) / 8347, 32538/ C C***FIRST EXECUTABLE STATEMENT R1MACH IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'R1MACH', + 'I OUT OF BOUNDS', 1, 2) C R1MACH = RMACH(I) RETURN C END *DECK XERMSG SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE XERMSG C***PURPOSE Process error messages for SLATEC and other libraries. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERMSG-A) C***KEYWORDS ERROR MESSAGE, XERROR C***AUTHOR Fong, Kirby, (NMFECC at LLNL) C***DESCRIPTION C C XERMSG processes a diagnostic message in a manner determined by the C value of LEVEL and the current value of the library error control C flag, KONTRL. See subroutine XSETF for details. C C LIBRAR A character constant (or character variable) with the name C of the library. This will be 'SLATEC' for the SLATEC C Common Math Library. The error handling package is C general enough to be used by many libraries C simultaneously, so it is desirable for the routine that C detects and reports an error to identify the library name C as well as the routine name. C C SUBROU A character constant (or character variable) with the name C of the routine that detected the error. Usually it is the C name of the routine that is calling XERMSG. There are C some instances where a user callable library routine calls C lower level subsidiary routines where the error is C detected. In such cases it may be more informative to C supply the name of the routine the user called rather than C the name of the subsidiary routine that detected the C error. C C MESSG A character constant (or character variable) with the text C of the error or warning message. In the example below, C the message is a character constant that contains a C generic message. C C CALL XERMSG ('SLATEC', 'MMPY', C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', C *3, 1) C C It is possible (and is sometimes desirable) to generate a C specific message--e.g., one that contains actual numeric C values. Specific numeric values can be converted into C character strings using formatted WRITE statements into C character variables. This is called standard Fortran C internal file I/O and is exemplified in the first three C lines of the following example. You can also catenate C substrings of characters to construct the error message. C Here is an example showing the use of both writing to C an internal file and catenating character strings. C C CHARACTER*5 CHARN, CHARL C WRITE (CHARN,10) N C WRITE (CHARL,10) LDA C 10 FORMAT(I5) C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// C * CHARL, 3, 1) C C There are two subtleties worth mentioning. One is that C the // for character catenation is used to construct the C error message so that no single character constant is C continued to the next line. This avoids confusion as to C whether there are trailing blanks at the end of the line. C The second is that by catenating the parts of the message C as an actual argument rather than encoding the entire C message into one large character variable, we avoid C having to know how long the message will be in order to C declare an adequate length for that large character C variable. XERMSG calls XERPRN to print the message using C multiple lines if necessary. If the message is very long, C XERPRN will break it into pieces of 72 characters (as C requested by XERMSG) for printing on multiple lines. C Also, XERMSG asks XERPRN to prefix each line with ' * ' C so that the total line length could be 76 characters. C Note also that XERPRN scans the error message backwards C to ignore trailing blanks. Another feature is that C the substring '$$' is treated as a new line sentinel C by XERPRN. If you want to construct a multiline C message without having to count out multiples of 72 C characters, just use '$$' as a separator. '$$' C obviously must occur within 72 characters of the C start of each line to have its intended effect since C XERPRN is asked to wrap around at 72 characters in C addition to looking for '$$'. C C NERR An integer value that is chosen by the library routine's C author. It must be in the range -99 to 999 (three C printable digits). Each distinct error should have its C own error number. These error numbers should be described C in the machine readable documentation for the routine. C The error numbers need be unique only within each routine, C so it is reasonable for each routine to start enumerating C errors from 1 and proceeding to the next integer. C C LEVEL An integer value in the range 0 to 2 that indicates the C level (severity) of the error. Their meanings are C C -1 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. An attempt is made to only print this C message once. C C 0 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. C C 1 A recoverable error. This is used even if the error is C so serious that the routine cannot return any useful C answer. If the user has told the error package to C return after recoverable errors, then XERMSG will C return to the Library routine which can then return to C the user's routine. The user may also permit the error C package to terminate the program upon encountering a C recoverable error. C C 2 A fatal error. XERMSG will not return to its caller C after it receives a fatal error. This level should C hardly ever be used; it is much better to allow the C user a chance to recover. An example of one of the few C cases in which it is permissible to declare a level 2 C error is a reverse communication Library routine that C is likely to be called repeatedly until it integrates C across some interval. If there is a serious error in C the input such that another step cannot be taken and C the Library routine is called again without the input C error having been corrected by the caller, the Library C routine will probably be called forever with improper C input. In this case, it is reasonable to declare the C error to be fatal. C C Each of the arguments to XERMSG is input; none will be modified by C XERMSG. A routine may make multiple calls to XERMSG with warning C level messages; however, after a call to XERMSG with a recoverable C error, the routine should return to the user. Do not try to call C XERMSG with a second recoverable error after the first recoverable C error because the error package saves the error number. The user C can retrieve this error number by calling another entry point in C the error handling package and then clear the error number when C recovering from the error. Calling XERMSG in succession causes the C old error number to be overwritten by the latest error number. C This is considered harmless for error numbers associated with C warning messages but must not be done for error numbers of serious C errors. After a call to XERMSG with a recoverable error, the user C must be given a chance to call NUMXER or XERCLR to retrieve or C clear the error number. C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE C***REVISION HISTORY (YYMMDD) C 880101 DATE WRITTEN C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. C THERE ARE TWO BASIC CHANGES. C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE C OF LOWER CASE. C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. C THE PRINCIPAL CHANGES ARE C 1. CLARIFY COMMENTS IN THE PROLOGUES C 2. RENAME XRPRNT TO XERPRN C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / C CHARACTER FOR NEW RECORDS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C CLEAN UP THE CODING. C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN C PREFIX. C 891013 REVISED TO CORRECT COMMENTS. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and C XERCTL to XERCNT. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERMSG CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*8 XLIBR, XSUBR CHARACTER*72 TEMP CHARACTER*20 LFIRST C***FIRST EXECUTABLE STATEMENT XERMSG LKNTRL = J4SAVE (2, 0, .FALSE.) MAXMES = J4SAVE (4, 0, .FALSE.) C C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE C SHOULD BE PRINTED. C C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. C IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// * 'JOB ABORT DUE TO FATAL ERROR.', 72) CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) CALL XERHLT (' ***XERMSG -- INVALID INPUT') RETURN ENDIF C C RECORD THE MESSAGE. C I = J4SAVE (1, NERR, .TRUE.) CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) C C HANDLE PRINT-ONCE WARNING MESSAGES. C IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN C C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. C XLIBR = LIBRAR XSUBR = SUBROU LFIRST = MESSG LERR = NERR LLEVEL = LEVEL CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) C LKNTRL = MAX(-2, MIN(2,LKNTRL)) MKNTRL = ABS(LKNTRL) C C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS C ZERO AND THE ERROR IS NOT FATAL. C IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 C C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG C IS NOT ZERO. C IF (LKNTRL .NE. 0) THEN TEMP(1:21) = 'MESSAGE FROM ROUTINE ' I = MIN(LEN(SUBROU), 16) TEMP(22:21+I) = SUBROU(1:I) TEMP(22+I:33+I) = ' IN LIBRARY ' LTEMP = 33 + I I = MIN(LEN(LIBRAR), 16) TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) TEMP(LTEMP+I+1:LTEMP+I+1) = '.' LTEMP = LTEMP + I + 1 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE C FROM EACH OF THE FOLLOWING THREE OPTIONS. C 1. LEVEL OF THE MESSAGE C 'INFORMATIVE MESSAGE' C 'POTENTIALLY RECOVERABLE ERROR' C 'FATAL ERROR' C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE C 'PROG CONTINUES' C 'PROG ABORTED' C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) C 'TRACEBACK REQUESTED' C 'TRACEBACK NOT REQUESTED' C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT C EXCEED 74 CHARACTERS. C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. C IF (LKNTRL .GT. 0) THEN C C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. C IF (LEVEL .LE. 0) THEN TEMP(1:20) = 'INFORMATIVE MESSAGE,' LTEMP = 20 ELSEIF (LEVEL .EQ. 1) THEN TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' LTEMP = 30 ELSE TEMP(1:12) = 'FATAL ERROR,' LTEMP = 12 ENDIF C C THEN WHETHER THE PROGRAM WILL CONTINUE. C IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' LTEMP = LTEMP + 14 ELSE TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' LTEMP = LTEMP + 16 ENDIF C C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. C IF (LKNTRL .GT. 0) THEN TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' LTEMP = LTEMP + 20 ELSE TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' LTEMP = LTEMP + 24 ENDIF CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C NOW SEND OUT THE MESSAGE. C CALL XERPRN (' * ', -1, MESSG, 72) C C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A C TRACEBACK. C IF (LKNTRL .GT. 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO 10 I=16,22 IF (TEMP(I:I) .NE. ' ') GO TO 20 10 CONTINUE C 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) CALL FDUMP ENDIF C C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. C IF (LKNTRL .NE. 0) THEN CALL XERPRN (' * ', -1, ' ', 72) CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) CALL XERPRN (' ', 0, ' ', 72) ENDIF C C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. C 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN C C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. C IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN IF (LEVEL .EQ. 1) THEN CALL XERPRN * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) ELSE CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) ENDIF CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) CALL XERHLT (' ') ELSE CALL XERHLT (MESSG) ENDIF RETURN END *DECK DES SUBROUTINE DES (F, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, YPOUT, + YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, H, EPS, + X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, PHASE1, + NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, KLE4, + IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) implicit double precision (a-h,o-z) C***BEGIN PROLOGUE DES C***SUBSIDIARY C***PURPOSE Subsidiary to DEABM C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (DES-S, DDES-D) C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C DEABM merely allocates storage for DES to relieve the user of the C inconvenience of a long call list. Consequently DES is used as C described in the comments for DEABM . C C***SEE ALSO DEABM C***ROUTINES CALLED R1MACH, SINTRP, STEPS, XERMSG C***REVISION HISTORY (YYMMDD) C 800501 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 900510 Convert XERRWV calls to XERMSG calls, replace GOTOs with C IF-THEN-ELSEs. (RWC) C 910722 Updated AUTHOR section. (ALS) C***END PROLOGUE DES C LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT C DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), 1 YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), 2 GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) CHARACTER*8 XERN1 CHARACTER*16 XERN3, XERN4 C EXTERNAL F C C....................................................................... C C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE C WORK. C SAVE MAXNUM DATA MAXNUM/500/ C C....................................................................... C C***FIRST EXECUTABLE STATEMENT DES IF (INFO(1) .EQ. 0) THEN C C ON THE FIRST CALL , PERFORM INITIALIZATION -- C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE C FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE C VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. C U=R1MACH(4) C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS TWOU=2.*U FOURU=4.*U C -- SET TERMINATION FLAG IQUIT=0 C -- SET INITIALIZATION INDICATOR INIT=0 C -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS=0 C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT INTOUT= .FALSE. C -- SET INDICATOR FOR STIFFNESS DETECTION STIFF= .FALSE. C -- SET STEP COUNTER FOR STIFFNESS DETECTION KLE4=0 C -- SET INDICATORS FOR STEPS CODE START= .TRUE. PHASE1= .TRUE. NORND= .TRUE. C -- RESET INFO(1) FOR SUBSEQUENT CALLS INFO(1)=1 ENDIF C C....................................................................... C C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY C IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN WRITE (XERN1, '(I8)') INFO(1) CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, INFO(1) MUST BE ' // * 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // * 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // * 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // * 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) IDID=-33 ENDIF C IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN WRITE (XERN1, '(I8)') INFO(2) CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, INFO(2) MUST BE 0 OR 1 ' // * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // * XERN1, 4, 1) IDID=-33 ENDIF C IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN WRITE (XERN1, '(I8)') INFO(3) CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, INFO(3) MUST BE 0 OR 1 ' // * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // * 'WITH INFO(3) = ' // XERN1, 5, 1) IDID=-33 ENDIF C IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN WRITE (XERN1, '(I8)') INFO(4) CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, INFO(4) MUST BE 0 OR 1 ' // * 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // * 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // * 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) IDID=-33 ENDIF C IF (NEQ .LT. 1) THEN WRITE (XERN1, '(I8)') NEQ CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, THE NUMBER OF EQUATIONS ' // * 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // * 'CODE WITH NEQ = ' // XERN1, 6, 1) IDID=-33 ENDIF C NRTOLP = 0 NATOLP = 0 DO 90 K=1,NEQ IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') RTOL(K) CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, THE RELATIVE ERROR ' // * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) IDID = -33 NRTOLP = 1 ENDIF C IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.) THEN WRITE (XERN1, '(I8)') K WRITE (XERN3, '(1PE15.6)') ATOL(K) CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, THE ABSOLUTE ERROR ' // * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) IDID = -33 NATOLP = 1 ENDIF C IF (INFO(2) .EQ. 0) GO TO 100 IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 100 90 CONTINUE C 100 IF (INFO(4) .EQ. 1) THEN IF (SIGN(1.,TOUT-T) .NE. SIGN(1.,TSTOP-T) 1 .OR. ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN WRITE (XERN3, '(1PE15.6)') TOUT WRITE (XERN4, '(1PE15.6)') TSTOP CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, YOU HAVE CALLED THE ' // * 'CODE WITH TOUT = ' // XERN3 // ' BUT YOU HAVE ' // * 'ALSO TOLD THE CODE (INFO(4) = 1) NOT TO INTEGRATE ' // * 'PAST THE POINT TSTOP = ' // XERN4 // ' THESE ' // * 'INSTRUCTIONS CONFLICT.', 14, 1) IDID=-33 ENDIF ENDIF C C CHECK SOME CONTINUATION POSSIBILITIES C IF (INIT .NE. 0) THEN IF (T .EQ. TOUT) THEN WRITE (XERN3, '(1PE15.6)') T CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, YOU HAVE CALLED THE ' // * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) IDID=-33 ENDIF C IF (T .NE. TOLD) THEN WRITE (XERN3, '(1PE15.6)') TOLD WRITE (XERN4, '(1PE15.6)') T CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, YOU HAVE CHANGED THE ' // * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // * ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) IDID=-33 ENDIF C IF (INIT .NE. 1) THEN IF (DELSGN*(TOUT-T) .LT. 0.) THEN WRITE (XERN3, '(1PE15.6)') TOUT CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, BY CALLING THE ' // * 'CODE WITH TOUT = ' // XERN3 // ' YOU ARE ' // * 'ATTEMPTING TO CHANGE THE DIRECTION OF ' // * 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // * 'RESTARTING.', 11, 1) IDID=-33 ENDIF ENDIF ENDIF C C INVALID INPUT DETECTED C IF (IDID .EQ. (-33)) THEN IF (IQUIT .NE. (-33)) THEN IQUIT = -33 INFO(1) = -1 ELSE CALL XERMSG ('SLATEC', 'DES', * 'IN DEABM, INVALID INPUT WAS ' // * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) ENDIF RETURN ENDIF C C....................................................................... C C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE C FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE C DO 180 K=1,NEQ IF (RTOL(K)+ATOL(K) .GT. 0.) GO TO 170 RTOL(K)=FOURU IDID=-2 170 IF (INFO(2) .EQ. 0) GO TO 190 180 CONTINUE C 190 IF (IDID .NE. (-2)) GO TO 200 C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A C SMALL POSITIVE VALUE INFO(1)=-1 RETURN C C BRANCH ON STATUS OF INITIALIZATION INDICATOR C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE C AND DIRECTION NOT YET SET C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED C 200 IF (INIT .EQ. 0) GO TO 210 IF (INIT .EQ. 1) GO TO 220 GO TO 240 C C....................................................................... C C MORE INITIALIZATION -- C -- EVALUATE INITIAL DERIVATIVES C 210 INIT=1 A=T CALL F(A,Y,YP,RPAR,IPAR) IF (T .NE. TOUT) GO TO 220 IDID=2 DO 215 L = 1,NEQ 215 YPOUT(L) = YP(L) TOLD=T RETURN C C -- SET INDEPENDENT AND DEPENDENT VARIABLES C X AND YY(*) FOR STEPS C -- SET SIGN OF INTEGRATION DIRECTION C -- INITIALIZE THE STEP SIZE C 220 INIT = 2 X = T DO 230 L = 1,NEQ 230 YY(L) = Y(L) DELSGN = SIGN(1.0,TOUT-T) H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) C C....................................................................... C C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT C 240 DEL = TOUT - T ABSDEL = ABS(DEL) C C....................................................................... C C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN C 250 IF(ABS(X-T) .LT. ABSDEL) GO TO 260 CALL SINTRP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, 1 ALPHA,G,W,XOLD,P) IDID = 3 IF (X .NE. TOUT) GO TO 255 IDID = 2 INTOUT = .FALSE. 255 T = TOUT TOLD = T RETURN C C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, C EXTRAPOLATE AND RETURN C 260 IF (INFO(4) .NE. 1) GO TO 280 IF (ABS(TSTOP-X) .GE. FOURU*ABS(X)) GO TO 280 DT = TOUT - X DO 270 L = 1,NEQ 270 Y(L) = YY(L) + DT*YP(L) CALL F(TOUT,Y,YPOUT,RPAR,IPAR) IDID = 3 T = TOUT TOLD = T RETURN C 280 IF (INFO(3) .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 C C INTERMEDIATE-OUTPUT MODE C IDID = 1 DO 290 L = 1,NEQ Y(L)=YY(L) 290 YPOUT(L) = YP(L) T = X TOLD = T INTOUT = .FALSE. RETURN C C....................................................................... C C MONITOR NUMBER OF STEPS ATTEMPTED C 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 C C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED IDID=-1 KSTEPS=0 IF (.NOT. STIFF) GO TO 310 C C PROBLEM APPEARS TO BE STIFF IDID=-4 STIFF= .FALSE. KLE4=0 C 310 DO 320 L = 1,NEQ Y(L) = YY(L) 320 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. RETURN C C....................................................................... C C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP C 330 HA = ABS(H) IF (INFO(4) .NE. 1) GO TO 340 HA = MIN(HA,ABS(TSTOP-X)) 340 H = SIGN(HA,H) EPS = 1.0 LTOL = 1 DO 350 L = 1,NEQ IF (INFO(2) .EQ. 1) LTOL = L WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) IF (WT(L) .LE. 0.0) GO TO 360 350 CONTINUE GO TO 380 C C RELATIVE ERROR CRITERION INAPPROPRIATE 360 IDID = -3 DO 370 L = 1,NEQ Y(L) = YY(L) 370 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. RETURN C 380 CALL STEPS(F,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, 1 YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, 2 TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) C C....................................................................... C IF(.NOT.CRASH) GO TO 420 C C TOLERANCES TOO SMALL IDID = -2 RTOL(1) = EPS*RTOL(1) ATOL(1) = EPS*ATOL(1) IF (INFO(2) .EQ. 0) GO TO 400 DO 390 L = 2,NEQ RTOL(L) = EPS*RTOL(L) 390 ATOL(L) = EPS*ATOL(L) 400 DO 410 L = 1,NEQ Y(L) = YY(L) 410 YPOUT(L) = YP(L) T = X TOLD = T INFO(1) = -1 INTOUT = .FALSE. RETURN C C (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE C ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR C 420 KLE4 = KLE4 + 1 IF(KOLD .GT. 4) KLE4 = 0 IF(KLE4 .GE. 50) STIFF = .TRUE. INTOUT = .TRUE. GO TO 250 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 subroutine timex(t) real t t=0.d0 end subroutine oldscdhit(e,q,x,vy) double precision e,q,x,vy parameter(nc=10) double precision d(100,-77:77) double precision charge,energy,sum double precision qold(nc) character buffer(100) integer it data d /15500*0.0d0/ data qold /nc*0.0d0/ data charge /0.d0/ data energy /0.d0/ data it /0/ save charge save energy save it save d save qold if (q.lt.0.0) return if (vy*vy.lt.4.0d-6*20d0) return charge=charge+q energy=energy+q*e i3=int(x*1e3) if ((i3.lt.-77) .or.(i3.gt.77)) then write (51,*) e,q,x return endif i2=int(abs(e*0.5)+1) if (i2.gt.20) then i2=int((i2-20)/3)+21 endif if ((i2.lt.1).or.(i2.gt.100)) then write (51,*) it,e,q,x return endif d(i2,i3)=d(i2,i3)+q return entry oldscdtrig write (52,*) it,charge,energy ifl=1 do i=nc,2,-1 qold(i)=qold(i-1) enddo qold(1)=charge qmin=1d300 qmax=-1d300 do i=1,nc qmin=min(qold(i),qmin) qmax=max(qold(i),qmax) enddo c if (qmin.gt.0.d0) then c if ((qmax-qmin)/qmin.lt.0.05) then c close(52) c stop c endif c endif c write (buffer,*) 'scd.',it c open (53,file=buffer) write (53,*) 'STEP',it write (53,*) d c close(53) c write (buffer,*) 'scdx.',it c open (53,file=buffer) c do i=-77,77 c sum=0.d0 c do j=1,100 c sum=sum+d(j,i) c end do c write (53,*) sum c end do c close(53) c write (buffer,*) 'scde.',it c open (53,file=buffer) c do i=1,100 c sum=0.d0 c do j=-77,77 c sum=sum+d(i,j) c end do c write (53,*) sum c end do c close(53) it=it+1 charge=0.d0 energy=0.d0 c do j=-77,77 c do i=1,100 c d(i,j)=0.d0 c end do c end do end subroutine scdhit(e,q,x,y,z,vy) double precision e,q,x,y,z,vy double precision x1,x2 parameter(nc=10) double precision d(1000,2),scrub(-100:100) double precision zq(2000) double precision charge,energy,sum double precision qold(nc),s1,s2 character buffer(100) integer it double precision rbound, xbound, ybound, zbound, eng0, belen common / def1 / rbound, xbound, ybound, zbound, eng0, belen double precision mem(10000,10) data d /2000*0.0d0/ data zq /2000*0.0d0/ data scrub /201*0.0d0/ data qold /nc*0.0d0/ data charge /0.d0/ data energy /0.d0/ data it /0/ save charge save energy save it save d save qold c charge=charge+q c energy=energy+q*e c if (q.lt.0.0) return c if (e.gt.30.0) then c i=int((x+xbound)/xbound*100.0)-100 c if (i.gt.100) i=100 c if (i.lt.-100) i=-100 c scrub(i)=scrub(i)+q c endif i=z*1000.0+1000 if (i.gt.0.and.i.le.2000) then zq(i)=zq(i)+q endif c write (96,*) z,e,q c return if (vy*vy.lt.4.0d-6*20d0) return if (y.gt.0.0) return c call ttscd(z,x,ifl) c if (ifl.eq.0) return charge=charge+q energy=energy+q*e return if (abs(x).lt.20d-3) then c i2=int(abs(0.5*vy*vy*511d3*0.5)+1) i2=int(abs(e)+1) if (i2.gt.1000) then i2=1000 endif d(i2,1)=d(i2,1)+q d(i2,2)=d(i2,2)+q*e endif q=0.d0 return entry scdtrig(x1,x2) write (52,*) it,charge,energy open(96,file='test') it=it+1 mem(it,1)=x1 mem(it,2)=x2 mem(it,3)=charge mem(it,4)=energy charge=0.d0 energy=0.d0 do i=1,it write(96,*) i,mem(i,1),mem(i,2),mem(i,3),mem(i,4) enddo close (96) return do i=1,1000 write (96,*) (i-1000)*0.001,zq(i) enddo close(96) return write (52,*) it,charge,energy ifl=1 do i=nc,2,-1 qold(i)=qold(i-1) enddo qold(1)=charge qmin=1d300 qmax=-1d300 do i=1,nc qmin=min(qold(i),qmin) qmax=max(qold(i),qmax) enddo c if (qmin.gt.0.d0) then c if ((qmax-qmin)/qmin.lt.0.05) then c close(52) c stop c endif c endif c open (53,file='hitnew') c write (53,*) '# STEP',it c s1=0.d0 c s2=0.d0 c do i=1,1000 c s1=s1+d(i,1) c s2=s2+d(i,2) c write (53,*) 2*(i-1),d(i,1),d(i,2),s1,s2 c enddo c close(53) open (53,file='hit.x') write (53,*) '# STEP',it do i=-100,100 write (53,*) i,real(scrub(i)) enddo close(53) it=it+1 charge=0.d0 energy=0.d0 end subroutine ttscd(z,x,iflag) double precision z,x za=z*1e3 xa=x*1e3 if (za.gt.0.0) then iz=int(za) za=za-int(iz/36)*36.0 else iz=-(int(abs(za))+1) za=za-(int(iz/36)-1)*36.0 endif if (za.gt.36.0) za=za-36.0 if (za.lt.0.0) za=za+36.0 iz=int(za) if (mod(iz,6).gt.1) then iflag=0 return endif xa=xa+int(iz/6) za=za-int(iz/6)*6.0-1.0 if (xa.gt.0.0) then ix=int(xa) xa=xa-int(ix/6)*6.0 else ix=-(int(abs(xa))+1) xa=xa-(int(ix/6)-1)*6.0 endif if (xa.gt.6.0) xa=xa-6.0 if (xa.lt.0.0) xa=xa+6.0 xa=xa-1.0 if ((xa*xa+za*za).gt.1.0) then iflag=0 return endif iflag=1 end subroutine sumf(xw,yw,xoff,yoff,x,y,xf,yf) implicit double precision(a-h,o-z) parameter(n=5) xf=0.0 yf=0.0 x0=xoff y0=yoff if (mod(n,2).eq.1) then x0=-x0 y0=-y0 endif charge=1.d0 do i=-n,n dx=x-2*i*xw do j=-n,n dy=y-2*j*yw tmp=charge/(dx*dx+dy*dy) if((i.eq.0).and.(j.eq.0)) tmp=0.d0 xf=xf+dx*tmp yf=yf+dy*tmp charge=-charge y0=-y0 enddo x0=-x0 enddo end subroutine varld implicit double precision (a-h,o-z) common /daniel/ yex(-100:100),yldx(-100:100),escdf,nscdf,ifload open(53,file='yield.x') do i=-100,100 read(53,*) yex(i),yldx(i) enddo close(53) nscdf=1 end subroutine sumlhc(xoff,yoff,x,y,xf,yf) implicit double precision(a-h,o-z) parameter (xsize=22e-3,ysize=22e-3,eps=1e-5,nl=200) integer first data first /1/ save first real efx(nl,nl),efy(nl,nl) save efx,efy xf0=xf yf0=yf if ((abs(xoff).ge.eps).or.(abs(yoff).ge.eps)) then write (*,*) 'error in sumlhc ',xoff,yoff stop endif if (first.eq.1) then write (*,*) 'reading boundary.force' open(54,file='boundary.force') do ix=1,nl do iy=1,nl read(54,*) d1,d2,efx(ix,iy),efy(ix,iy) enddo read(54,*) enddo close(54) write (*,*) 'done' first=0 endif ix=nl*(0.5*((x+xsize)/xsize))+1 iy=nl*(0.5*((y+ysize)/ysize))+1 if (ix.gt.nl) ix=nl if (iy.gt.nl) iy=nl if (ix.lt.1) ix=1 if (iy.lt.1) iy=1 xf=efx(ix,iy) yf=efy(ix,iy) c write (*,*) x,y,xf,xf0,yf,yf0 end subroutine move(x0,v0,tend,fldc) implicit double precision (a-h,o-z) double precision x(3),v(3),b(3),f(3),x0(3),v0(3) double precision xf(6) equivalence(xf,x) equivalence(xf(4),v) parameter (nmax=11) double precision yz(6),dy(6),t,xa(3),va(3) integer nstep(nmax) integer nc logical ready external fldc data nstep /2,4,6,8,12,16,24,32,48,64,96/ data nc /0/ save c write(*,*) ' enter move ',x0(1),x0(1),v0(1),v0(2) tbest=tend*1.0 c write (*,*) 'tbest x ',tbest t0=0.d0 ntake=7 x(1)=x0(1) x(2)=x0(2) x(3)=x0(3) v(1)=v0(1) v(2)=v0(2) v(3)=v0(3) 1 t=tbest if (t0.ge.tend) goto 999 if (t0+t.gt.tend) t=tend-t0 do i=1,nmax x(1)=x0(1) x(2)=x0(2) x(3)=x0(3) v(1)=v0(1) v(2)=v0(2) v(3)=v0(3) call smidp(x,v,fldc,t,nstep(i)) c write(*,*) ' move ',x,v call pzextr(i,(t/nstep(i))**2,xf,yz,dy,6,ntake) err=(dy(1)**2+dy(2)**2+dy(3)**2)*1e12 . +(dy(4)**2+dy(5)**2+dy(6)**2) c err=max(abs(dy(1)),abs(dy(2)),abs(dy(3))) c err=max(err*1e6,abs(dy(4)),abs(dy(5)),abs(dy(6))) if (err.lt.1.d0) then nc=nc+1 c write (*,*) nc,i,t0,t,x(1),x(2),x(3),v(1),v(2),v(3) t0=t0+t if (i.eq.ntake) then tbest=t*0.95d0 else if (i.eq.ntake-1) then tbest=t*1.2d0 c write (*,*) 'tbest a ',tbest else tbest=tbest*dble(nstep(ntake-1)) tbest=tbest/dble(nstep(i)) tdummy=tbest tbest=tdummy c write (14,*) 'tbest b ',tbest if (tbest.lt.1.d-13) then tbest=2d-13 c write (*,*) 'tbest b ',tbest c stop endif endif endif x0(1)=yz(1) x0(2)=yz(2) x0(3)=yz(3) v0(1)=yz(4) v0(2)=yz(5) v0(3)=yz(6) goto 1 endif end do tbest=0.25*t/2**((nmax-ntake)/2) c c write (*,*) 'tbest c',tbest goto 1 999 continue c write (*,*) xf c write (*,*) sqrt(xf(4)**2+xf(5)**2+xf(6)**2) c write(*,*) ' exit move ',x0(1),x0(1),v0(1),v0(2) end subroutine fld(x,b,f) implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3) f(1)=dpx f(2)=dpy f(3)=0.d0 b(1)=x(2)*bfield b(2)=x(1)*bfield b(3)=0.d0 end subroutine fldsext(x,b,f) implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3) f(1)=dpx f(2)=dpy f(3)=0.d0 b(1)=x(1)*x(2)*bfield b(2)=(x(1)*x(1)-x(2)*x(2))*bfield/2.d0 b(3)=0.d0 end subroutine fld2(x,b,f) implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3),dkz,b0 f(1)=dpx f(2)=dpy f(3)=0.d0 dkz=2.d0*pi/0.4d0 b0=1.68d0/cosh(0.0125d0*dkz) b(1)=0.d0 b(2)=b0*cosh(dkz*x(2))*cos(dkz*x(3)) b(3)=b0*sinh(dkz*x(2))*sin(dkz*x(3)) end subroutine fld20(x,b,f) implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz double precision scalel, rad, bh, k, arg, br, bz, solrad double precision s1, sz1, cz1, bk1, by, coefs, phi, soll integer ks common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3),dkz,b0, km double precision dbesi1, dbesi0, dbesk1 c external dbesi1, dbesi0, dbesk1 f(1)=dpx f(2)=dpy f(3)=0.d0 scalel = 0.15 bh = 0.005 bh = bfield k = 2.*pi/2./scalel rad = sqrt(x(1)*x(1)+x(2)*x(2)) phi = datan2(x(2),x(1)) arg = k*rad br = 0. bz = 0. solrad = 0.07 soll = 0.4*scalel coefs = bh*4*k*solrad/pi do ks = 0, 5 km = real(ks*2+1) s1 = sin(km*k*soll) sz1 = sin(km*k*x(3)) cz1 = cos(km*k*x(3)) bk1 = dbesk1(km*k*solrad) br = br + s1*bk1*dbesi1(km*k*rad)*sz1 bz = bz + s1*bk1*dbesi0(km*k*rad)*cz1 end do br = br*coefs b(3) = bz*coefs b(1) = br*cos(phi) b(2) = br*sin(phi) end subroutine fld21(x,b,f) implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz double precision scalel, rad, bh, k, arg, br, bz, solrad double precision s1, sz1, cz1, bk1, by, coefs, phi, soll integer ks common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3),dkz, km double precision dbesi1, dbesi0, dbesk1 c external dbesi1, dbesi0, dbesk1 f(1)=dpx f(2)=dpy f(3)=0.d0 scalel = 0.15 bh = 0.005 bh = bfield k = 2.*pi/1./scalel rad = sqrt(x(1)*x(1)+x(2)*x(2)) phi = datan2(x(2),x(1)) arg = k*rad solrad = 0.07 soll = 0.4*scalel coefs = 2*k*solrad/pi br = 0. bz = soll/scalel*2.d0 do ks = 1, 5 km = real(ks) s1 = sin(km*k*soll) sz1 = sin(km*k*x(3)) cz1 = cos(km*k*x(3)) bk1 = dbesk1(km*k*solrad) br = br + coefs*s1*bk1*dbesi1(km*k*rad)*sz1 bz = bz + coefs*s1*bk1*dbesi0(km*k*rad)*cz1 end do br = br*bh b(3) = bz*bh b(1) = br*cos(phi) b(2) = br*sin(phi) end subroutine fldib26(x,b,f) implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz, bzfield common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / defcb / bzfield double precision x(3),b(3),f(3),dkz,b0 f(1)=dpx f(2)=dpy f(3)=0.d0 b(1)=x(2)*bfield b(2)=x(1)*bfield b(3)=bzfield c write(*,*) ' fldib26 ', b(1),b(2),b(3),bfield,bzfield end subroutine fld3(x,b,f) c for DAFNE wiggler implicit none integer ibend,isel, iflag double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3),dkz,b0,x1,x2,x3 double precision bx,by,bz double precision atest iflag = 0 f(1)=dpx f(2)=dpy f(3)=0.d0 x1 = x(1) x2 = x(2) x3 = x(3) if (x3.lt.-1.2d0) then x3=x3+2.4 iflag = 1 else if (x3.gt.1.2d0) then x3=x3-2.4 iflag = 1 endif c write(*,*) ' fld3, b4 fieldmap ', x1,x2,x3 c atest = abs(x2+2.099477D-6) c write(*,*) atest c if (atest.lt.1.d-8) then c x3 = 1.3 c write(*,*) ' changed!, b4 fieldmap ', x1,x2,x3 c endif call Field_map(x1,x2,x3,Bx,By,Bz) c write(*,*) ' fld3, after fieldmap ', bx,by,bz b(1) = bx b(2) = by b(3) = bz if (iflag.eq.1) then b(3) = -bz endif end subroutine fld26(x,b,f) c for Mauro Pivi's ILC wiggler implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3),dkz,b0,x1,x2,x3 double precision bx,by,bz complex*16 cdbesseli(1:15) real*8 dbesseli(1:15) complex*16 zarg integer nmax real*8 maurocoef (1:40,1:40) common / mauro / maurocoef real*8 scalel, bz0, rad, phi, arg, br, bphi real*8 depsbes, sz1, cz1, bk1, bk1p, gaprad real*8 cphi, sphi, bt, dkn, dkm, cphi1, sphi1 real*8 dbesi0, dbesi1, dbesi2 real*8 dzstep, bk, bkp, bkminus, bkplus integer kmm, knn, nzloop, i, ifail, fnu , nz c external dbesi0, dbesi1, dbesi2 external s18def character*1 scale x1 = x(1) x2 = x(2) x3 = x(3) c wiggler for TESLA - Mauro Pivi's expression c b is in Tesla, k in 1/meter scalel = 0.40 c x1=0.002d0 c x2=0.001d0 c nzloop = 200 c dzstep = 0.1/real(nzloop) c do i=1,nzloop c x3=real(i)*dzstep cc x3 = 0.02 scale='U' nmax=16 bt = 1.6 c bz0 = 0.0030 dkz = 2.*pi/1./scalel rad = sqrt(x1*x1+x2*x2) phi = datan2(x2,x1) sphi1 = sin(phi) cphi1 = cos(phi) c arg = k*rad c gaprad = 0.025 br = 0. bz = 0. bphi = 0. do knn = 1, 39, 2 dkn = real(knn) fnu = 0 zarg = complex(dkn*rad*dkz,0.d0) ifail = 0 c write(*,*) fnu, zarg, nmax, scale c write(*,*) nz, ifail c write(*,*) cdbesseli call s18def(fnu,zarg,nmax,scale,cdbesseli,nz,ifail) do kmm = 1, 13, 2 dbesseli(kmm) = realpart(cdbesseli(kmm+1)) if (kmm.eq.1) then dbesseli(kmm-1) = realpart(cdbesseli(kmm)) endif dbesseli(kmm+1) = realpart(cdbesseli(kmm+2)) dkm = real(kmm) sz1 = sin(dkn*dkz*x3) cz1 = cos(dkn*dkz*x3) sphi = sin(dkm*phi) cphi = cos(dkm*phi) bk = dbesseli(kmm) c write(*,*) knn,kmm,bk bkminus = dbesseli(kmm-1) bkplus = dbesseli(kmm+1) depsbes = 1.e-4 bkp = 0.5*(bkminus+bkplus) bt = maurocoef(kmm,knn) br = br + bt*bkp*sphi*cz1 bphi = bphi + bt*dkm/(dkz*rad*dkn)*bk*cphi*cz1 bz = bz - bt*bk*sphi*sz1 c write(*,*) knn,kmm,bt c r,bphi,bz,sphi,cz1,bkp c write(*,*) knn,kmm,br,bphi,bz,bkp, bkminus,bkplus,bk end do end do bx = br*cphi1-bphi*sphi1 by = br*sphi1+bphi*cphi1 c write(*,*) cphi,sphi,phi c write(*,*) x1,x2,x3,bx,by,bz,br,bphi f(1) = dpx f(2) = dpy f(3) = 0.d0 b(1) = bx b(2) = by b(3) = bz c write(37,919) x1, x2, x3, bx, by, bz 919 format(6(1x,f12.5)) c end do c stop end subroutine fld27(x,b,f) c for Hans Braun'swiggler implicit none integer ibend,isel double precision bfield,el,vl,fom,pi,re,elmass double precision tend,dpx,dpy,dpz common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass double precision x(3),b(3),f(3),dkz,b0,x1,x2,x3 double precision bx,by,bz real*8 maurocoef (1:40,1:40) real*8 scalel, bz0 common / mauro / maurocoef integer i, nzloop real*8 dzstep x1 = x(1) x2 = x(2) x3 = x(3) c x1=0.002d0 c x2=0.001d0 c nzloop = 200 c dzstep = 0.1/real(nzloop) c do i=1,nzloop c x3=real(i)*dzstep c wiggler for TESLA - Hans Braun's expression c b is in Tesla, k in 1/meter scalel = 0.40 dkz = 2.*pi/1./scalel c bz0 = 1.68/cosh(0.0125*dkz) bz0 = 1.6 bx = 0. by = bz0*cosh(dkz*x2)*cos(dkz*x3) bz = -bz0*sinh(dkz*x2)*sin(dkz*x3) f(1)=dpx f(2)=dpy f(3)=0.d0 b(1) = bx b(2) = by b(3) = bz c write(37,919) x1, x2, x3, bx, by, bz c 919 format(6(1x,f12.5)) c end do c stop end subroutine scstep(x,v,b,f0,dt) implicit none double precision eps,freq,clight,escal parameter (eps=1d-10,freq=177777777777.778d0) c parameter (clight=3d8,escal=3.d8*3d8/0.511d6) parameter (clight=3d8,escal=1.d0) double precision x(3),v(3),b(3),f(3),f0(3),dt double precision be(3),fe(3),re(3),fpar,fsenk,vt(3),dx(3) double precision tmp,ascd,bscd,bscdi,gammai,c,s c f(1)=escal*f0(1) f(2)=escal*f0(2) f(3)=escal*f0(3) c f(1)=f0(1) c f(2)=f0(2) c f(3)=f0(3) bscd=sqrt(b(1)*b(1)+b(2)*b(2)+b(3)*b(3)) if (bscd.le.1d-9) then gammai=clight/sqrt(clight**2+v(1)**2+v(2)**2+v(3)**2) x(1)=x(1)+gammai*(dt*(v(1)+0.5*dt*f(1))) x(2)=x(2)+gammai*(dt*(v(2)+0.5*dt*f(2))) x(3)=x(3)+gammai*(dt*(v(3)+0.5*dt*f(3))) v(1)=v(1)+dt*f(1) v(2)=v(2)+dt*f(2) v(3)=v(3)+dt*f(3) return endif bscdi=1.d0/bscd be(1)=b(1)*bscdi be(2)=b(2)*bscdi be(3)=b(3)*bscdi fpar=(f(1)*be(1)+f(2)*be(2)+f(3)*be(3)) fe(1)=f(1)-fpar*be(1) fe(2)=f(2)-fpar*be(2) fe(3)=f(3)-fpar*be(3) fsenk=sqrt(fe(1)*fe(1)+fe(2)*fe(2)+fe(3)*fe(3)) if (fsenk.gt.eps) then fe(1)=fe(1)/fsenk fe(2)=fe(2)/fsenk fe(3)=fe(3)/fsenk else if (abs(be(1)).gt.0.d0) then if (abs(be(2)).gt.0.d0) then tmp=1.0/sqrt(be(1)*be(1)+be(2)*be(2)) fe(1)=-be(2)*tmp fe(2)=be(1)*tmp fe(3)=0.d0 else fe(1)=0.d0 fe(2)=1.d0 fe(3)=0.d0 endif else fe(1)=1.d0 fe(2)=0.d0 fe(3)=0.d0 endif endif re(1)=-(fe(2)*be(3)-fe(3)*be(2)) re(2)=-(fe(3)*be(1)-fe(1)*be(3)) re(3)=-(fe(1)*be(2)-fe(2)*be(1)) vt(1)=(v(1)*fe(1)+v(2)*fe(2)+v(3)*fe(3)) vt(2)=(v(1)*be(1)+v(2)*be(2)+v(3)*be(3)) vt(3)=(v(1)*re(1)+v(2)*re(2)+v(3)*re(3)) c write (*,*) 'x0',vt,v c write (*,*) fe c write (*,*) be c write (*,*) re c stop c write (*,*) 'fpar',fpar c c gammai=1.d0 gammai=clight/sqrt(clight**2+v(1)**2+v(2)**2+v(3)**2) bscd=freq*bscd bscdi=1.d0/bscd ascd=fsenk s=sin(dt*bscd*gammai) c=cos(dt*bscd*gammai) c write (*,*) dt*bscd*gammai dx(2)=dt*(0.5*dt*fpar+vt(2))*gammai vt(2)=vt(2)+dt*fpar dx(1)=(ascd*bscdi*(1.0-c)+vt(1)*s-vt(3)*(c-1.0))* . bscdi c*gammai c dx(3)=(ascd*(bscdi*s-dt*gammai)-vt(1)*(1.0-c)+vt(3)*s) dx(3)=(ascd*(bscdi*s-gammai*dt)-vt(1)*(1.0-c)+vt(3)*s) . *bscdi c*gammai tmp=vt(1) vt(1)=vt(1)*c+vt(3)*s+ascd*bscdi*s vt(3)=vt(3)*c-tmp*s+ascd*bscdi*(c-1.0) x(1)=x(1)+be(1)*dx(2)+fe(1)*dx(1)+re(1)*dx(3) x(2)=x(2)+be(2)*dx(2)+fe(2)*dx(1)+re(2)*dx(3) x(3)=x(3)+be(3)*dx(2)+fe(3)*dx(1)+re(3)*dx(3) v(1)=be(1)*vt(2)+fe(1)*vt(1)+re(1)*vt(3) v(2)=be(2)*vt(2)+fe(2)*vt(1)+re(2)*vt(3) v(3)=be(3)*vt(2)+fe(3)*vt(1)+re(3)*vt(3) c write (*,*) 'dx',dx c write (*,*) vt,v c write (*,*) 'x1',dx,vt c write (*,*) 'x',x,v end subroutine smidp(x,v,sub,t,n) implicit none double precision x(3),v(3),t integer n external sub integer i double precision dt,b(3),f(3),xold(3),vold(3),tmp save dt=t/n xold(1)=x(1) xold(2)=x(2) xold(3)=x(3) vold(1)=v(1) vold(2)=v(2) vold(3)=v(3) call sub(x,b,f) call scstep(x,v,b,f,dt) do i=2,n call sub(x,b,f) call scstep(xold,vold,b,f,2.d0*dt) tmp=x(1) x(1)=xold(1) xold(1)=tmp tmp=x(2) x(2)=xold(2) xold(2)=tmp tmp=x(3) x(3)=xold(3) xold(3)=tmp tmp=v(1) v(1)=vold(1) vold(1)=tmp tmp=v(2) v(2)=vold(2) vold(2)=tmp tmp=v(3) v(3)=vold(3) vold(3)=tmp end do call sub(x,b,f) call scstep(xold,vold,b,f,dt) x(1)=0.5d0*(x(1)+xold(1)) x(2)=0.5d0*(x(2)+xold(2)) x(3)=0.5d0*(x(3)+xold(3)) v(1)=0.5d0*(v(1)+vold(1)) v(2)=0.5d0*(v(2)+vold(2)) v(3)=0.5d0*(v(3)+vold(3)) end subroutine ebinwlarge(binwe, wen, qw, x) 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, x real*8 binwecut(0:500) real*8 rbound, xbound, ybound, zbound, energy, belen ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 common / def1 / rbound, xbound, ybound, zbound, energy, belen cccccccccccccccccccccccccccccccccccccccccccc vmax = 100000.0d0 vmin = 0.0d0 xcut = xbound*0.7 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 if (abs(x).lt.xcut) then binwecut(k) = binwecut(k)+qw endif endif 101 continue end SUBROUTINE Field_map(X,Y,Z,Bx,By,Bz) IMPLICIT NONE DOUBLE PRECISION DUMMY_X(1500),DUMMY_Y(1500),WRK(8000) DOUBLE PRECISION DX(1500),DY(1500),DX2(1500),DY2(1500) DOUBLE PRECISION C_X(1410),C_Z(1410) DOUBLE PRECISION LA_X(98),MU_X(19) DOUBLE PRECISION SX(4),SXX(4),SXX2(4) DOUBLE PRECISION LA_Z(19),MU_Z(98) DOUBLE PRECISION SY(4),SYY(4),SYY2(4) DOUBLE PRECISION XV(1),ZV(1),BY_0(1) DOUBLE PRECISION X,Y,Z,BX,BY,BZ c for old data set ccccccccccccccccccccccccccccccccccc c DOUBLE PRECISION C_X(1529),C_Z(1590) c DOUBLE PRECISION LA_X(106),MU_X(19) c DOUBLE PRECISION LA_Z(19),MU_Z(110) cccccccccccccccccccccccccccccccccccccccccccccc DATA BY_0/0.0D00/ INTEGER NX_X,NY_X,NX_Y,NY_Y,IFAIL INTEGER I,J,IWRK DATA IWRK/8000/ c INCLUDE "DATA_BASE.f" c INCLUDE "DATA_BASE_Old.f" c INCLUDE "DATA_BASE_OLD_rev.f" c INCLUDE "DATA_BASE_New.f" XV(1)=X ZV(1)=Z DO I=1,NY_X-4 DO J=1,NX_X-4 DUMMY_X(J)=C_X((NX_X-4)*(I-1)+J) ENDDO CALL E02BCF(NX_X,MU_X,DUMMY_X,X,1,SX,IFAIL) DX(I)=SX(2) DX2(I)=SX(3) ENDDO CALL E02BCF(NY_X,LA_X,DX,Z,1,SXX,IFAIL) CALL E02BCF(NY_X,LA_X,DX2,Z,1,SXX2,IFAIL) ! CALL E02DEF(1,NY_X,NX_X,XV,ZV,LA_X,MU_X,C_X,BY_0,WRK,IWRK,IFAIL) DO I=1,NX_Y-4 DO J=1,NY_Y-4 DUMMY_Y(J)=C_Z((NY_Y-4)*(I-1)+J) ENDDO CALL E02BCF(NY_Y,MU_Z,DUMMY_Y,Z,1,SY,IFAIL) DY(I)=SY(2) DY2(I)=SY(3) ENDDO CALL E02BCF(NX_X,LA_Z,DY,X,1,SYY,IFAIL) CALL E02BCF(NX_X,LA_Z,DY2,X,1,SYY2,IFAIL) CALL E02DEF(1,NX_Y,NY_Y,XV,ZV,LA_Z,MU_Z,C_Z,BY_0,WRK,IWRK,IFAIL) Bx=SXX(1)*Y Bz=SYY(1)*Y ! WRITE(*,*)'SXX(3),SYY(3)',SXX(3),SYY(3) By=BY_0(1)-(SXX2(1)+SYY2(1))*Y*Y/2. RETURN END