program ecloud *----------------------------------------------------------------------* * * * CERN * * * * European Organization for Nuclear Research * * * * Program name: ECLOUD Version 2.0 * * * * Authors and contact: O. BRUNING, G. RUMOLO, D. SCHULTE, * * X. ZHANG, F. ZIMMERMANN * * AB (formerly) SL Division * * CERN * * CH-1211 GENEVA 23 * * SWITZERLAND * * Tel. [041] (022) 767 9054 * * frank.zimmermann@cern.ch * * * * Copyright CERN, Geneva 2003 - Copyright and any other * * appropriate legal protection of this computer program and * * associated documentation reserved in all countries of the * * world. * * * * Organizations collaborating with CERN may receive this program * * and documentation freely and without charge. * * * * CERN undertakes no obligation for the maintenance of this * * program, nor responsibility for its correctness, and accepts * * no liability whatsoever resulting from its use. * * * * Program and documentation are provided solely for the use of * * the organization to which they are distributed. * * * * This program may not be copied or otherwise distributed * * without permission. This message must be retained on this and * * any other authorized copies. * * * * The material cannot be sold. CERN should be given credit in * * all references. * * * *----------------------------------------------------------------------* c c purpose: calculations for ohmi effect c c Modification with respect to 'ohmilhc.eric': c introduction of a new module for the particle motion in the c presence of a magnetic field. c c Oct. 1998. Add a common block for six-wire waveguide geometry c and an input parameter rbound6 for wire radius. Add also two c output files of electron numbers and energy distribution for c electrons that hit the wall. c c Nov. 1998. Add Parameters of ppb1, sb1, ppb2, sb2 for simulating c the effect of the satellite bunches. c c Jul. 1999. Add electrons from collisional ionization c c Aug. 1999. Remove obscure offset problem (xoff,yoff) in c this version of the code. c c 2000-2001 lots of undocumented changes (e.g., new parametrization c of secondary emission including elastic reflection, debugged formulae c for image charges, eliminated problems related to longitudinal c profile and bunch length, inconsistencies in time accounting,...) c c Giovanni (July 2001): c c 'clean' routine modified and activated. c c As the new switch 'iirefl' for the distribution of the reflected c light has been introduced, in the input file for this version of c the code one has to put 3 numbers after the line c 'Primary photoelectron emission yield (peeff):' c of the input file. The first is the photoelectric yield, the c second is the percent of reflected radiation, and the third is c an integer that sets the angular distribution of the reflected c light -> c [1] uniform [2] cos [3] cos^2 [4] smooth parabolic [5] cos^3 c c An "on line" Runge-Kutta integration for a dipole and a finite c length solenoid field is introduced. To activate it, use as switch c 'ibend': 40 [dipole], or 41 [solenoid] c Please, when you set 'ibend' to be 40 or 41, let 'ibeam' be 1 and c 'ispace' be 2. c c c August 30, add idistr=2: flat charge distribution with edges c and new input c c November 4, 2001, add iseldis=5 (Noel's distribution) implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: parameter (npelm=600000,iybin=500,ngrid=500,ngrid2=10) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) integer iycount(0:iybin) integer index(npelm), ik, iabort real*8 ayield(0:iybin), avcos(0:iybin) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), * pz(npelm), py(npelm), px(npelm) real*8 ptime(npelm), esign(npelm), test(npelm) c charge of lost electrons in fine time steps real*8 qlosswh, qlosstot, qlosstot2 c oliver 6.6.197:cccccccccccccccccc real*8 eloss, elossq, ephoto, adele, qadele, alimit real*8 dele(npelm), qele(npelm) real*8 bweight(50000) real*8 peeff, yim, yemax real*8 xwto, ywto real*8 epesig, epemax, ecut real*8 wgl, wk, vtem, vtem0 real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 factor, dt real*8 xt, yt real*8 one, etemp real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) c real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) ccccccccccccccccccccccccccccccccccccccc c frank nov 99, index field for empty buckets integer indexb (1:nbmax), iazi, iwake real*8 dntr(1:nbmax) real*8 denscenter ccccccccccccccccccccccccccccccccccccccc common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def6 / peeff, yim, yemax common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def8 / alimit common / def9 / wgl, wk, vtem, vtem0 c 01.08.1999 Frank: adding transverse offsets in input file common / def10 / x1, y1, x2, y2, x3, y3 common / def11 / icoll common /colli1/ press,crse common / bunch / bweight ccccccccccccccccccccccccccccccccccccccccccccccc common / help / factor, dt common / rann / iseed, idumy common / loss2 / qlosswh, qlosstot, qlosstot2 c oliver 6.6.197:cccccccccccccccccc common / loss / eloss, elossq, ephoto, adele, qadele common / egain / dele, qele common / eini / epemax,ecut common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig cccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax,wen1,wen2,wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c frank 13/11/1999 common / indb / indexb common / indb2 / dntr common / indb3 / iabort common / azi / iazi common / wake / iwake common / wake2 / xwto, ywto c cccccccccccccccccccccccccccccccccccccccccccc common / def1 / rbound, xbound, ybound, zbound, energy, belen common / test1 / itest common / test2 / test common / space2 / efxa, efya, qgrid common / center / denscenter one = 1.0d0 etemp = 0.0d0 yksum = 0.0d0 yk2 = 0.0d0 xksum = 0.0d0 xk2 = 0.0d0 isemax = 1 open(23,file="kick.dat",status='unknown') open(9,file="tr.dat",status='unknown') open(42,file="cdbunch.data",status='unknown') open(43,file="centerdensity.data",status='unknown') open(44,file="edistr.data",status='unknown') 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(56,file="av.yield.data",status='unknown') open(66,file="photoel.energy.distr.data",status='unknown') open(67,file="secel.energy.distr.data",status='unknown') open(74,file="onwall.energy.distr.data",status='unknown') 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') 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 eloss = 0.0d0 ephoto = 0.0d0 adele = 0.0d0 qadele = 0.0d0 iadele = 0 elossq = 0.0d0 sbtot = sb+bl if(ppb1.gt.1.0d0) then sbtot = sb+sb1+bl+bl endif if(ppb2.gt.1.0d0) then sbtot = sb+sb2+bl+bl endif if(ppb1.gt.1.0d0.and.ppb2.gt.1.0d0) then sbtot = sb+sb1+sb2+bl+bl+bl endif write(*,*) ' sb1 is distance between 1st satellite and 2nd s.' write(*,*) ' sb2 is distance between second satellite and m.b.' write(*,*) ' sb is distance after main bunch ' write(*,*) ' sbtot = ',sbtot write(*,*) ' sb1, sb2, sb = ',sb1, sb2, sb yt = y1 xt = x1 c yt = 5.0d-3 c xt = 5.0d-3 iflagg=0 if (indexb(j).eq.1) then write(*,*) ' call generate ' call generate(j,iseed,yt,xt,iflagg) else if (indexb(j).eq.0) then iflagi=4 call interbunch(iflagi) endif qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter if (indexb(j).eq.1) then write(42,'(e25.5,e25.5)') t, denscenter endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=0 write(*,*) ' call interbunch ' if (iwave.eq.0) call interbunch(iflagi) c X. Zhang Nov. 1998 c For satellite bunch if(ppb1.gt.1.0d0) then yt = y2 xt = x2 c yt = -5.0d-3 c xt = -5.0d-3 iflagg=1 c frank, 13/11/99, new branch to simulate fill patterns if (indexb(j).eq.1) then call generate(j,iseed,yt,xt,iflagg) else if (indexb(j).eq.0) then iflagi=4 call interbunch(iflagi) endif c --------------------------------------------- c write(21,'(i3,1x,i3,e25.5,i8,1e25.5)') j,0,t,icount,qacc qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter if (indexb(j).eq.1) then write(42,'(e25.5,e25.5)') t, denscenter endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=1 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif if(ppb2.gt.1.0d0) then yt = y3 xt = x3 iflagg=2 call generate(j,iseed,yt,xt,iflagg) qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter if (indexb(j).eq.1) then write(42,'(e25.5,e25.5)') t, denscenter endif if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=2 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif c---End of X. Zhang c oliver 6.6.197:cccccccccccccccccc c output is given as: 'energy[eV]*total charge of macroparticle/ c bunch spacing/magnet length' if(mod(j,10).eq.0.or.iwave.eq.0) then write(*,*) write(*,*) "Bunch Passage: ",j if (iwave.eq.1) then call tem(xbound/2.0,xbound/2.0,wk,t,wgl,pre,pim) write(*,*) "Kick polarity: ",vtem*pim/abs(vtem) endif if (iwave.eq.2) then call tem6(xbound/2.0,xbound/2.0,wk,t,wgl,xbound,pre,pim,0d0) write(*,*) "Kick polarity: ",vtem*pim/abs(vtem) endif c frankz 05/08/99 normalize with the actual bunch spacing deltatime = sbtot/vl write(*,*) "Electron loss",j, eloss*el/deltatime/belen, * "Watts/meter" write(*,*) "Photon loss",j, ephoto*el/deltatime/belen, * "Watts/meter" if(qadele.ne.0.0) * write(*,*) "Average energy: ",adele/el/qadele, "eV" if(qadele.eq.0.0.and.adele.eq.0.0) * write(*,*) "Average energy: ",0.0, "eV" if(qadele.eq.0.0.and.adele.ne.0.0) * write(*,*) "Average energy: ",Inf, "eV" c * adele, el, qadele write(*,*) "Number of electrons per bend: ",qacc endif write(26,*) j, eloss*el/deltatime/belen write(88,*) j, elossq ccccccccccccccccccccccccccccccccccccccc call clean 12 continue c end loop over bunch passages c start if over qacc if (qacc.gt.1.e-8) then c write(*,*) ' koko ' c write(*,*) qgrid call spacecharge3 c write(*,*) ' after spacecharge 3' c write(*,*) qgrid c ------------------------------------------ c print out charge distribution on grid ymbound = min(ybound,zbound) write(*,*) ' qgrid output - ngrid2 =',ngrid2 do ig1 = -ngrid2,ngrid2 do ig2 = -ngrid2,ngrid2 xga = ig1*xbound/ngrid2 yga = ig2*ymbound/ngrid2 write(49,9441) xga,yga,qgrid(ig1,ig2) 9441 format(3(1x,e14.6)) end do end do close(49) c ------------------------------------------ write(*,*) ' binning e distribution ' c open(44,file="edistr.data",status='unknown') c 4.08.1997 Oliver: Bining the electron distribution: call binx c 4.08.1997 Oliver: Bining the yield: do 210 iy=0,iybin if(iycount(iy).ne.0) * write(56,*) (2.0d0*iy/iybin-1.0d0)*xbound, * ayield(iy)/iycount(iy),avcos(iy)/iycount(iy) c if(iycount(iy).eq.0) c * write(56,*) (2.0d0*iy/iybin-1.0d0)*xbound, c * 0.0,0.0 210 continue close(56) c write(*,*) ' call spacecharge ' ix = 1 if (ispace.eq.1) then call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c frank, 26 april 2000. c add abort gap c temporarily set space charge and image force to zero c frank, 23 March 2002 c ispace=0 c iimage=0 do j = 1, iabort qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter c write(42,'(e25.5,e25.5)') t, denscenter if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) call spacecharge2 iflagi=0 if (iwave.eq.0) call interbunch(iflagi) end do c compute trapping condition c for quadrupole fields c if (ibend.eq.2) then do j =1, icount vtot2 = xp(j)**2+yp(j)**2+zp(j)**2 vtrans2 = (x(j)*xp(j)-y(j)*yp(j))**2/(x(j)**2+y(j)**2) trap = vtot2*Sqrt(x(j)**2+y(j)**2)/vtrans2/xbound-1. c was 145 write(73,'(i4,3(1x,e12.4))') j, trap, x(j), y(j), q(j) end do endif c frank, nov 99 if (iwake.eq.0) then yt = 0.00d0 * sign xt = 0.00d0 * sign else if (iwake.eq.1) then yt = ywto * sign xt = xwto * sign endif ytoffs = yt xtoffs = xt if (iwake.eq.0) goto 444 c goto 444 c do not go through the following loop iflagg=0 call generate(nbunch+1,iseed,yt,xt,iflagg) if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c if (iwave.ne.1) call interbunch iflagi=0 if (iwave.eq.0) call interbunch(iflagi) c call interbunch c X. Zhang Nov. 1998 c For satellite bunch if(ppb1.gt.1.0d0) then yt = y2 c 0.00d0 * sign xt = x2 c 0.00d0 * sign c yt = -5.00d-3 * sign c xt = -5.00d-3 * sign ytoff = yt xtoff = xt iflagg=1 call generate(nbunch+1,iseed,yt,xt,iflagg) if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c if (iwave.ne.1) call interbunch iflagi=1 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif if(ppb2.gt.1.0d0) then yt = y3 xt = x3 ytoff = yt xtoff = xt iflagg=2 call generate(nbunch+1,iseed,yt,xt,iflagg) if (ispace.eq.1) then ix = 0 call spacecharge(ix) endif if (ispace.eq.2) then call spacecharge2 endif c if (iwave.ne.1) call interbunch iflagi=2 if (iwave.eq.0) call interbunch(iflagi) c call interbunch endif 444 continue iseed = 201 yto = 0.0 xto = 0.0 if (iwake.eq.1) then c 10.07.1997 Oliver c call bin dkickyn = 0. dkickxn = 0. call offsetkick(iseed,dkickx,dkicky,yto,xto) if (abs(ytoffs).gt.1.e-20) then dkickyn = dkicky/ytoffs endif if (abs(xtoffs).gt.1.e-20) then dkickxn = dkickx/xtoffs endif if (isign.eq.1) then ykick1 = dkickyn xkick1 = dkickxn else if (isign.eq.2) then ykick2 = dkickyn xkick2 = dkickxn endif endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c end if over qacc 11 continue if (iwake.eq.1) then ykickav = (ykick1+ykick2)/2. xkickav = (xkick1+xkick2)/2. write(23,*) ise, ykick1, ykick2, ykickav, xkick1, & xkick2, xkickav yksum = yksum + ykickav xksum = xksum + xkickav yk2 = yk2 + ykickav*ykickav xk2 = xk2 + xkickav*xkickav endif 10 continue if (iwake.eq.1) then write(23,*) ' ' c write(23,*) ' 1. attempt ' c write(23,*) yksum, yrms, xksum, xrms, isemax yksum = yksum / real(isemax) yk2 = yk2 / real(isemax) yrms = dsqrt(dmax1(yk2-yksum*yksum,0.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 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=ik*2. write(74,*) dik, webin(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(jx)*el*500./(pi*(xbound+ymbound)),j c was 174 write(79,*) real(ik)*pi/250.,webinph2(ik)/deltatime/ & belen/real(jx)*el*500./(pi*(xbound+ymbound)),j c heat load c was 176 write(76,*) (xstep*real(ik)),webinx(ik)/ & deltatime/belen/real(jx)*el*500./(2*xbound),j c charge c was 1761 write(77,*) (xstep*real(ik)),webinx2(ik)/ & deltatime/belen/real(jx)*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(jx)*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(88) close(45) close(26) close(87) close(24) close(43) 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 = 1000) integer iycount(0:iybin) integer index(npelm), i, ik, iabort real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), py(npelm) real*8 px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 mec2 real*8 peeff, yim, yemax, 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 bfield, el, vl, fom, pi, re, elmass real*8 bgradient, f0, efieldrf real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 rmax, rmin, circum c frank nov 99, index field for empty buckets integer indexb (1:nbmax), iazi, iwake real*8 dntr(1:nbmax) character*64 dummy c oliver 27.10.1997: variables for miguel: integer intn, iirefl, iscatter parameter (intn=1000) real*8 limit(intn), lcount(intn) real*8 avq, isectot, ltest real*8 xwto, ywto real*8 qlosstot, qlosswh, qlosstot2 common / miguel1 / isectot, ltest, avq common / miguel2 / lcount, limit ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / def4 / circum common / def10 / x1, y1, x2, y2, x3, y3 common / def11 / icoll common/ colli1 / press, crse common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / rann / iseed, idumy common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def6 / peeff, yim, yemax common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def8 / alimit common / def9 / wgl, wk, vtem, vtem0 common / def20 / inel common / bunch / bweight common / eini / epemax,ecut common / epe / epemax2, epesig2, ratio common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig common / movie / boundix, boundiy, boundox, boundoy common / beam / rg, rm1 common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c oliver 24.7.197:cccccccccccccccccc common / emax / semax, emax0 common / image / iimage, iimageb, interspace, igeom ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax, sigmal, rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc c frank 13/11/1999 common / indb / indexb common / indb2 / dntr common / indb3 / iabort common / refl / refl common / swrefl / iirefl common / azi / iazi common / wake / iwake common / wake2 / xwto, ywto common / byield1 / iycount common / loss2 / qlosswh, qlosstot, qlosstot2 common / delay / iscatter c write(*,*) ' in init ' icount = 0 icountact = 0 itest = 0 qacc = 0.0d0 idumy = 1 iscatter = 0 mcount = 0 qouter = 0.0d0 qinner = 0.0d0 c pi = 4.*atan(1.) pi = acos(-1.0d0) c photo electron emission efficiency c (number of emitted electrons/photon): peeff = 0.02d0 c IBEND - switch to 0 for drift / 1 for bend ibend = 0 xbound = 0.022d0 ybound = 0.018d0 belen = 14.2d0 circum = 27000.0d0 el = 1.6d-19 vl = 3.0d8 re = 2.8d-15 elmass = 9.0d-31 ppb = 1.05d11 ppb1 = 0d0 ppb2 = 0d0 c bunch spacing sb = 7.48d0 sb1 = 0d0 sb2 = 0d0 mec2 = 511000.0d0 c FINAL ENERGY energy = 7.0d12 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! c 20.06.1997 Oliver: Read input from file: open(11,file="ecloud.input",status='unknown') read(11,'(a64)') dummy read(11,*) isemax write(*,*) dummy write(*,*) isemax read(11,'(a64)') dummy read(11,*) npepb c write(*,*) dummy c write(*,*) npepb read(11,'(a64)') dummy read(11,*) nbunch c write(*,*) dummy c write(*,*) nbunch read(11,'(a64)') dummy read(11,*) nbstep c write(*,*) dummy c write(*,*) nbstep read(11,'(a64)') dummy read(11,*) nistep c write(*,*) dummy c write(*,*) nistep read(11,'(a64)') dummy read(11,*) nostep c write(*,*) dummy c write(*,*) nostep read(11,'(a64)') dummy read(11,*) jebin c write(*,*) dummy c write(*,*) jebin read(11,'(a64)') dummy read(11,*) iebin if(iebin.gt.nbstep) iebin = nbstep c write(*,*) dummy c write(*,*) iebin read(11,'(a64)') dummy read(11,*) imovie c write(*,*) dummy c write(*,*) imovie read(11,'(a64)') dummy read(11,*) iseq c write(*,*) dummy c write(*,*) iseq read(11,'(a64)') dummy read(11,*) ppb c write(*,*) dummy c write(*,*) ppb read(11,'(a64)') dummy read(11,*) sb c write(*,*) dummy c write(*,*) sb read(11,'(a64)') dummy read(11,*) bl c write(*,*) dummy c write(*,*) bl read(11,'(a64)') dummy read(11,*) belen c write(*,*) dummy c write(*,*) belen read(11,'(a64)') dummy read(11,*) energy c write(*,*) dummy c write(*,*) energy read(11,'(a64)') dummy read(11,*) circum c write(*,*) dummy c write(*,*) circum read(11,'(a64)') dummy read(11,*) peeff, refl, iirefl c write(*,*) dummy c write(*,*) peeff, refl read(11,'(a64)') dummy read(11,*) nbini c write(*,*) dummy c write(*,*) nbini read(11,'(a64)') dummy read(11,*) nsini c write(*,*) dummy c write(*,*) nsini if (nbini.lt.0.or.nsini.lt.0) then nbini = nbunch nsini = nbstep endif read(11,'(a64)') dummy read(11,*) imodo c write(*,*) dummy c write(*,*) imodo read(11,'(a64)') dummy read(11,*) alimit c write(*,*) dummy c write(*,*) alimit read(11,'(a64)') dummy read(11,*) epemax, epemax2, ratio write(*,*) dummy write(*,*) epemax, epemax2, ratio read(11,'(a64)') dummy read(11,*) epesig, epesig2 write(*,*) dummy write(*,*) epesig, epesig2 read(11,'(a64)') dummy read(11,*) semax c write(*,*) dummy c write(*,*) semax read(11,'(a64)') dummy read(11,*) iseldis c write(*,*) dummy c write(*,*) iseldis read(11,'(a64)') dummy read(11,*) ecut c write(*,*) dummy c write(*,*) ecut read(11,'(a64)') dummy read(11,*) yim c write(*,*) dummy c write(*,*) yim read(11,'(a64)') dummy read(11,*) yemax c write(*,*) dummy c write(*,*) yemax read(11,'(a64)') dummy read(11,*) interspace c write(*,*) dummy c write(*,*) interspace read(11,'(a64)') dummy read(11,*) iimage c write(*,*) dummy c write(*,*) iimage read(11,'(a64)') dummy read(11,*) iimageb c write(*,*) dummy c write(*,*) iimageb read(11,'(a64)') dummy read(11,*) sx c write(*,*) dummy c write(*,*) sx read(11,'(a64)') dummy read(11,*) sy c write(*,*) dummy c write(*,*) sy read(11,'(a64)') dummy read(11,*) xbound c write(*,*) dummy c write(*,*) xbound read(11,'(a64)') dummy read(11,*) ybound c write(*,*) dummy c write(*,*) ybound read(11,'(a64)') dummy read(11,*) zbound c write(*,*) dummy c write(*,*) zbound read(11,'(a64)') dummy read(11,*) bfield c write(*,*) dummy c write(*,*) bfield read(11,'(a64)') dummy read(11,*) volt c write(*,*) dummy c write(*,*) volt c if (zbound.ne.0.0) volt = volt /2.0d0/zbound read(11,'(a64)') dummy read(11,*) ibend c write(*,*) dummy c write(*,*) ibend if (ibend.eq.24.or.ibend.eq.50) then read(11,*) bgradient endif if (ibend.eq.25) then read(11,*) f0,efieldrf endif read(11,'(a64)') dummy read(11,*) iloss c write(*,*) dummy c write(*,*) iloss read(11,'(a64)') dummy read(11,*) ispace write(*,*) dummy write(*,*) ispace read(11,'(a64)') dummy read(11,*) idistr write(*,*) dummy write(*,*) idistr if (idistr.eq.2) then read(11,*) edgefraction write(*,*) edgefraction endif c write(*,*) dummy read(11,'(a64)') dummy read(11,*) ibeam if (ibeam.eq.2) then write(*,*) ' ibeam set to 1, iscatter activated ' write(*,*) ' (iscatter=1 represents e- beam) ' iscatter=1 ibeam=1 endif write(*,*) dummy write(*,*) ibeam, iscatter read(11,'(a64)') dummy read(11,*) iwave write(*,*) dummy write(*,*) iwave if (iwave.ne.0) idistr = 0 read(11,'(a64)') dummy read(11,*) rbound c write(*,*) dummy c write(*,*) rbound read(11,'(a64)') dummy read(11,*) wgl c write(*,*) dummy c write(*,*) wgl read(11,'(a64)') dummy read(11,*) wk c write(*,*) dummy c write(*,*) wk read(11,'(a64)') dummy read(11,*) vtem c write(*,*) dummy c write(*,*) vtem read(11,'(a64)') dummy read(11,*) vtem0 c write(*,*) dummy c write(*,*) vtem0 c vtem0 = vtem0 * log(sqrt(xbound**2+ybound**2)/rbound) read(11,'(a64)') dummy read(11,*) rbound6 read(11,'(a64)') dummy read(11,*) ppb1 c write(*,*) dummy c write(*,*) ppb1 read(11,'(a64)') dummy read(11,*) sb1 c write(*,*) dummy c write(*,*) sb1 read(11,'(a64)') dummy read(11,*) ppb2 c write(*,*) dummy c write(*,*) ppb2 read(11,'(a64)') dummy read(11,*) sb2 c write(*,*) dummy c write(*,*) sb2 read(11,'(a64)') dummy read(11,*) x1,y1 write(*,*) dummy write(*,*) x1,y1 read(11,'(a64)') dummy read(11,*) x2,y2 write(*,*) dummy write(*,*) x2,y2 read(11,'(a64)') dummy read(11,*) x3,y3 write(*,*) dummy write(*,*) x3,y3 read(11,'(a64)') dummy read(11,*) icoll write(*,*) dummy write(*,*) icoll if (icoll.eq.2) then read(11,*) press,crse endif c frank, november 99, flag for inelastic scattering read(11,'(a64)') dummy read(11,*) inel write(*,*) dummy write(*,*) inel c c frank, november 99, for bunch fill pattern read(11,'(a64)') dummy read(11,*) irep, iabort read(11,*) ito1, ito2, ito3, ito4 read(11,*) ditn1, ditn2, ditn3, ditn4 write(*,*) dummy write(*,*) irep, iabort write(*,*) ito1, ito2, ito3, ito4 write(*,*) ditn1, ditn2, ditn3, ditn4 c frank, november 99, switch for azimuthal heat load read(11,'(a64)') dummy read(11,*) iazi write(*,*) dummy write(*,*) iazi c frank, november 99, switch for wake read(11,'(a64)') dummy read(11,*) iwake read(11,*) xwto, ywto write(*,*) dummy write(*,*) iwake write(*,*) xwto, ywto close(11) write(*,*) ' input complete ' indbx = 0 do i = 1, irep do j = 1, ito1 indbx = indbx+1 indexb (indbx) = 1 dntr (indbx) = ditn1 end do do j = 1, ito2 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = ditn2 end do do j = 1, ito3 indbx = indbx+1 indexb (indbx) = 1 dntr (indbx) = ditn3 end do do j = 1, ito4 indbx = indbx+1 indexb (indbx) = 0 dntr (indbx) = ditn4 end do end do c frank, summer 99 c note sign reversal for offset c of first satellite! x10 = x1/1000. x1=x10 x20 = -x2/1000. x2=x20 x30 = x3/1000. x3=x30 y10 = y1/1000. y1=y10 y20 = -y2/1000. y2=y20 y30 = y3/1000. y3=y30 if (idistr.eq.1) then c CORRECT bl = bl * 4. * sqrt(3.) c bl = bl * 4. c NEW c bl = bl * 2. * sqrt(4.) c OLD AND POSSIBLY WRONG c bl = bl * 2. * sqrt(2.0d0) endif sb = sb-bl if(ppb1.gt.1.0d0.and.ppb2.lt.1.d0) then sb0 = sb sb = sb1-bl sb1 = sb0-sb-1.*bl endif c if(ppb2.gt.1.0d0.and.ppb1.le.0) then if(ppb2.gt.1.0d0.and.ppb1.gt.1.d0) then sb0 = sb+bl sb10 = sb1 sb20 = sb2 sb1 = sb20-sb10-bl sb2 = sb0-sb20-bl sb = sb10-bl else if(ppb2.gt.1.0d0) then sb0 = sb sb = sb2-bl sb2 = sb0-sb-1.*bl endif c Round vacuum chamber: if(xbound.eq.ybound.and.zbound.eq.ybound) igeom = 1 c Elliptical vacuum chamber: if(xbound.ne.ybound.or.zbound.lt.ybound) igeom = 2 c Rectangular vacuum chamber: if(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 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(ibmin) endif endif endif c uniform charge distribution: if (idistr.eq.0) then bweight(i) = 1.0d0 endif c Gaussian charge distribution: if (idistr.eq.1) then cc CORRECT with bunch length = sqrt(3)*4*sz: bweight(i) = exp(-6*real(2*(i-1)-(nbstep-1))* cc bweight(i) = exp(-2*real(2*(i-1)-(nbstep-1))* c bweight(i) = exp(-5*real(2*(i-1)-(nbstep-1))* c bweight(i) = exp(-2*real(2*(i-1)-(nbstep-1))* * real(2*(i-1)-(nbstep-1))/ real(nbstep-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. end subroutine generate(jb,is,yoff,xoff,iflag) c purpose: generates photoelectrons and propagates them c during bunch passage implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,iybin=500) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) c parameter (nbstep = 5) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,ngrid2=10) parameter (np=8000,np1=8000) integer iycount(0:iybin) integer index(npelm) integer kw, nw, iflag integer iazi, IFAIL, iirefl, iscatter real*8 ayield(0:iybin), avcos(0:iybin) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm),zp(npelm),py(npelm),pz(npelm) real*8 px(npelm), dele(npelm), qele(npelm), test(npelm) real*8 xpt, ypt, zpt, pxt, pyt, pzt real*8 ptime(npelm), esign(npelm) real*8 arrayr2(npelm) c real*8 rn(np), rn1(np1) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 uni, XX, CDF c oliver 17.6.1997:cccccccccccccccccc real*8 eloss, elossq, ephoto, adele, qadele, alimit real*8 bweight(50000) real*8 boundix(40), boundiy(40), boundox(80), boundoy(80) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccc real*8 rg, rm1 real*8 epesig, epemax, ecut real*8 wgl, wk, vtem, vtem0 real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppbt, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 factor, dt real*8 radi real*8 xt, yt, zt real*8 volt, qouter, qinner real*8 ran2 real*8 r2, r3, rnorm, rnx, rny, avar, sigmr, avar1, avar2 real*8 enhelp, voltx, volty real*8 one real*8 dpx, dpy, dpz, dpxm, dpym, dpzm real*8 epemax2, epesig2, ratio real*8 dntr(1:nbmax) real*8 qlosswh, qlosstot, qlosstot2 real*8 eespacex, eespacey, eebeamx, eebeamy, gamman real*8 xtn,ytn,xta,yta,frasol real*8 c11,c12,c13,c14,c15,c16,c21,c22,c23,c24,c25,c26 real*8 c31,c32,c33,c34,c35,c36,c41,c42,c43,c44,c45,c46 real*8 bgradient c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / def10 / x1, y1, x2, y2, x3, y3 common / def11 / icoll common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / help / factor, dt common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid common / rann / iseed, idumy c oliver 17.6.1997:cccccccccccccccccc common / loss / eloss, elossq, ephoto, adele, qadele common / egain / dele, qele common / bunch / bweight common / loss2 / qlosswh, qlosstot, qlosstot2 cccccccccccccccccccccccccccccccccccccc c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def8 / alimit common / def9 / wgl, wk, vtem, vtem0 common / eini / epemax,ecut common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig common / epe / epemax2, epesig2, ratio common / movie / boundix, boundiy, boundox, boundoy ccccccccccccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos ccccccccccccccccccccccccccccccccccccccc c frank, nov 99 for azimuth common / azi / iazi cccccccccccccccccccccccccccccccccccccccccccccc common / test1 / itest common / test2 / test common / beam / rg, rm1 common / image / iimage, iimageb, interspace, igeom common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 common / refl / refl common / swrefl / iirefl common / indb2 / dntr common / caso / uni common / delay / iscatter external C05ADF external CDF external solenx,soleny,solenz one = 1.0d0 write(*,*) ' in subroutine generate ' c X. Zhang Oct. 1998:cccccccccccccccc c Introduce a parameter sigmr to modify the initial electron c distribution when alimit<0 c sigmr = 1.0d0*sy/xbound if (iwave.eq.2) sigmr = 1.0d0 iseed = iseed+12349 ppbt = ppb if(iflag.eq.1) ppbt = ppb1 if(iflag.eq.2) ppbt = ppb2 factor = ppbt * re * vl & * sqrt(2.0d0*pi) if (iscatter.eq.1) then factor = - factor endif dt = bl/vl dtex = bl/vl/real(nbstep) c t = t + dt c frankz introduce intensity variation, 25/01/01 c cfac = (ran2(idumy)-0.5) * 0.4 cfac = 1.d0 c first propagate existing particles... if(interspace.ne.0) ismod = nbstep/interspace if(interspace.eq.0) ismod = nbstep + 1 do 10 ib = 1, nbstep 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 do 11 i = 1, icount c write(*,*) ' 11 loop', i, ib if ((index(i).eq.0).and.(q(i).gt.0.0d0)) then dpx = 0.0 dpy = 0.0 dpz = 0.0 xt = x(i) yt = y(i) zt = z(i) xpt = xp(i) ypt = yp(i) zpt = zp(i) c Oliver 12.8.1998: c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = 1.0d0*gammaf(velt)*ypt pxt = 1.0d0*gammaf(velt)*xpt pzt = 1.0d0*gammaf(velt)*zpt if (i.eq.1) then ti=1.e9*t gf=gammaf(velt) c write(144,900) ti,x(i),y(i),xp(i),yp(i),gf 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) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1201 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif dpx = dpx + sign(efx3,xt) dpy = dpy + sign(efy3,yt) eespacex = sign(efx3,xt) eespacey = sign(efy3,yt) endif 1201 continue c end space charge cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' before bb kick ' ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Beam-Beam Kick: yt = yt xt = xt xta = abs(xt-xoff) yta = abs(yt-yoff) c Normal beam-beam kick: if (ibeam.eq.1.and.iwave.eq.0) then if(iimageb.ne.1) * call ffrank(xt,yt,xoff,yoff,sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1210 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1210 continue endif cc cc21 = (pxt+cc12/2)/gamman*dtex cc22 = (-eebeamx + eespacex + el/elmass*(pzt+ * cc16/2)/gamman*bfield)*dtex cc23 = (pyt+cc14/2)/gamman*dtex cc24 = (-eebeamy + eespacey)*dtex cc25 = (pzt+cc16/2)/gamman*dtex cc26 = - el/elmass*(pxt+cc12/2)* * bfield/gamman*dtex c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1211 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1211 continue endif cc31 = (pxt+cc22/2)/gamman*dtex cc32 = (-eebeamx +eespacex + el/elmass*(pzt * +cc26/2)/gamman*bfield)*dtex cc33 = (pyt+cc24/2)/gamman*dtex cc34 = (-eebeamy + eespacey)*dtex cc35 = (pzt+cc26/2)/gamman*dtex cc36 = - el/elmass*(pxt+cc22/2)* * bfield/gamman*dtex c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1212 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1212 continue endif cc41 = (pxt+cc32)/gamman*dtex cc42 = (-eebeamx + eespacex + el/elmass*(pzt * +cc36)/gamman*bfield)*dtex cc43 = (pyt+cc34)/gamman*dtex cc44 = (-eebeamy + eespacey)*dtex cc45 = (pzt+cc36)/gamman*dtex cc46 = - el/elmass*(pxt+cc32)* * bfield/gamman*dtex c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl endif c Giovanni: an "on line" Runge-Kutta for the solution of the electron c motion in a finite length solenoid field. if(ibend.eq.41) then frasol = 0.8 cc11 = pxt*dtex/gamma cc12 = (-eebeamx + eespacex - el/elmass*pyt*solenz * (frasol,xt,yt,zt)/gamma + el/elmass* * pzt*soleny(frasol,xt,yt,zt)/gamma)*dtex cc13 = pyt*dtex/gamma cc14 = (-eebeamy + eespacey - el/elmass*pzt*solenx * (frasol,xt,yt,zt)/gamma + el/elmass* * pxt*solenz(frasol,xt,yt,zt)/gamma)*dtex cc15 = pzt*dtex/gamma cc16 = (- el/elmass*pxt*soleny(frasol,xt,yt,zt) * /gamma + el/elmass*pyt*solenx(frasol,xt,yt, * zt)/gamma)*dtex c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 ztn = zt + cc15/2 pxtn = pxt + cc12/2 pytn = pyt + cc14/2 pztn = pzt + cc16/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1220 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1220 continue endif cc21 = pxtn/gamman*dtex cc22 = (-eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dtex cc23 = pytn/gamman*dtex cc24 = (-eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dtex cc25 = pztn/gamman*dtex cc26 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass * pytn*solenx(frasol,xtn, * ytn,ztn)/gamman)*dtex c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 ztn = zt + cc25/2 pxtn = pxt + cc22/2 pytn = pyt + cc24/2 pztn = pzt + cc26/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1221 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1221 continue endif cc31 = pxtn/gamman*dtex cc32 = (-eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dtex cc33 = pytn/gamman*dtex cc34 = (-eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dtex cc35 = pztn/gamman*dtex cc36 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dtex c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 ztn = zt + cc35 pxtn = pxt + cc32 pytn = pyt + cc34 pztn = pzt + cc36 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1222 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1222 continue endif cc41 = pxtn/gamman*dtex cc42 = (-eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dtex cc43 = pytn/gamman*dtex cc44 = (-eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dtex cc45 = pztn/gamman*dtex cc46 = (- el/elmass*pxtn*soleny(frasol,xt,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dtex c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl c write(*,*) ionene(iio) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c Oliver 17.6.1997 (calculate energy and storing it in an array): iadele = iadele + 1 c vel2 = (xp(i)*xp(i)+yp(i)*yp(i)+zp(i)*zp(i)) c beta2 = vel2/vl/vl c beta2 = 1.0d0 - 1.0d0/gamma**2 dele(iadele) = (gamma-1.0d0)*elmass*vl*vl qele(iadele) = q(i) if (ib.eq.nbstep) then adele = adele + qele(iadele)*(gamma-1.0d0)*elmass*vl*vl qadele = qadele + qele(iadele) endif cccccccccccccccccccccccccccccccccccccccccccccccccc c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(i)/xbound)**2+(y(i)/ybound)**2 if (y(i).gt.zbound) amp = 2.0d0 if (y(i).lt.-zbound) amp = 2.0d0 if (iwave.eq.1) then amp2 = (x(i)**2+y(i)**2)/ rbound**2 else if (iwave.eq.2) then call dist(amp2, x(i), y(i), kw) endif if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif if (amp.gt.1.and.iloss.eq.1) then ptime(i) = t - ptime(i) if (ptime(i).gt.0.0.and.dele(iadele)/el.gt.ecut) then write(24,*) x(i), ptime(i)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).ge.0.0d0) c * write(27,*) x(i), ptime(i)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).lt.0.0d0) c * write(28,*) x(i), ptime(i)*1.0d9,dele(iadele)/el endif esign(i) = y(i) ptime(i) = t xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) engt=dele(iadele)/el qlosswh = qlosswh + qt/dtex if (engt.ge.1.0d0) then qlosstot = qlosstot + qt if (engt.ge.20.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt c write(*,*) ' ebinw =' call ebinw(webin,engt,qt) if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) if (iazi.eq.1) then c write(*,*) ' ebinwphi =' call ebinwphi(webinphi,webinph2,engt,qt,xt,yt) c write(*,*) ' ebinwx =' call ebinwx(webinx,webinx2,webinx3,engt,qt,xt,yt) endif endif qacc = qacc - qt qouter = qouter - qt c write(*,*) ' before seiler ' call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) c write(*,*) ' after seiler ' xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qouter = qouter + qtnew c qlosswh = qlosswh - qtnew/dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.ne.0) then ptime(i) = t - ptime(i) if (ptime(i).gt.0.0.and.dele(iadele)/el.gt.ecut) * write(25,*) x(i),ptime(i)*1.0d9,dele(iadele)/el ptime(i) = t esign(i) = y(i) xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qinner = qinner - qt c if (ib.eq.58) then c write(*,*) ' before seiler ', qt c endif call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,2,kw) c if (ib.eq.58) then c write(*,*) ' after seiler ', qt c endif xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qinner = qinner + qtnew endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif c 23.06.1997 Oliver: Writing the electron distribution to a file. if (jb.eq.jebin.and.ib.eq.iebin.and.q(i).gt.0.0d0) then write(44,9444) x(i), y(i), q(i), z(i) 9444 format(4(1x,e12.4)) c channel was 4444 write(91,9444) xp(i), yp(i), q(i), zp(i) 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... 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 end if c 90 Percent of the photo electrons are limited by 'alimit': if (reflrandom.ge.(refl/100.).and. * abs(alimit).ne.2.0d0) cc 98 Percent of the photo electrons are limited by 'alimit': c if (dble(i).ge.dble(npepbx)/50.0d0.and.abs(alimit).ne.2.0d0) * r2 = sqrt(-2*log(ran2(idumy)))*cos(2*pi*ran2(idumy)) * * abs(alimit)*pi/2. c *(ran2(idumy)-0.5d0) c 100 Percent of the photo electrons are limited by 'alimit': c r2 = sqrt(-2*log(ran2(idumy)))*cos(2*pi*ran2(idumy)) * c * abs(alimit)*pi*(ran2(idumy)-0.5d0) if (reflrandom.ge.(refl/100.).and.abs(alimit) * .eq.2.0d0) then c FRANK 22/05/2000 cos theta distribution a la Oleg Malyshev c * r2 = pi-2.*asin((2.*ran2(idumy)-1)) c * r2 = abs(alimit)*pi*(ran2(idumy)-0.5d0) c r2 = abs(alimit)*pi*(rn(i)-0.5d0) c Giovanni 6/2000 different distributions if(iirefl.eq.1) * r2 = abs(alimit)*pi*(ran2(idumy)-0.5d0) if(iirefl.eq.2) * r2 = pi-2.*asin((2.*ran2(idumy)-1)) if(iirefl.eq.3.or.iirefl.eq.4) then uni = ran2(idumy) IFAIL = 1 CALL C05ADF(-pi/2,pi/2,1.0d-5,0.0d0,CDF,XX,IFAIL) r2 = pi - 2.0d0*XX endif c for cos^3 distribution if(iirefl.eq.5) then uni = ran2(idumy) IFAIL = 1 CALL C05ADF(-1.0d0,1.0d0,1.0d-5,0.0d0,CDF,XX,IFAIL) r2 = pi - 2.0d0*asin(XX) endif end if c Bining the angle distribution: vmin = 0.0d0 vmax = 2.0d0 iunit = 87 if(jb.eq.1) arrayr2(icount) = (r2 + pi)/ pi if(jb.eq.1.and.ib.eq.nbstep) * call ebin2(arrayr2,icount,iunit,vmax,vmin) avar = 1.0d0 if(alimit.lt.0.0) then 888 avar1 = (2.0 * ran2(idumy) - 1.0) avar2 = (2.0 * ran2(idumy) - 1.0) avar = sqrt(avar1 * avar1 + avar2 * avar2) if(avar.gt.1.0d0) goto 888 x(icount) = avar1*xbound*sigmr y(icount) = avar2*ybound*sigmr z(icount) = (ran2(idumy)-0.5d0)*belen if(iwave.eq.2) then do 678 nw=1,6 ddw=sqrt((x(icount)-x0r(nw))**2+(y(icount)-y0r(nw))**2) if(ddw.lt.rbound6) goto 888 678 enddo endif else x(icount) = avar*xbound*cos(r2) y(icount) = avar*ybound*sin(r2) z(icount) = (ran2(idumy)-0.5d0)*belen endif c 23.july.1998; oliver. c !Achtung: testing the initial photoelectron distribution: c write(71,*) x(icount), y(icount) c Calculate the angle of the surface normal. c The angle is used for the angular distribution of the momentum vector. if (abs(y(icount)).le.zbound) then rnorm = 1.0d0/ * sqrt(x(icount)**2/xbound**4+y(icount)**2/ybound**4) rnx = rnorm * x(icount)/ xbound**2 rny = rnorm * y(icount)/ ybound**2 angle = atan2(rny,rnx) + pi endif if (y(icount).gt.zbound) then y(icount) = zbound angle = -pi/2.0d0 endif if (y(icount).lt.-zbound) then y(icount) = -zbound angle = pi/2.0d0 endif esign(icount) = y(icount) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c energy 5 eV +/- 5 eV c write(*,*) epemax, epesig c enhelp = ((rn(i+2*npepbx)-0.5d0)*epemax+epemax)*el*2.d0/3.d0/elmass c Oliver 31.07.1997: c Gaussian energy distribution for the photo electrons: c double Gaussian with weight determined by 'ratio' if (ran2(idum).gt.ratio) then 123 continue enhelp = (epesig*sqrt(-2*log(ran2(idumy)))* * cos(2*pi*ran2(idumy)) + epemax) * * 2*el/elmass if (enhelp.lt.0.0d0) goto 123 else 124 continue enhelp = (epesig2*sqrt(-2*log(ran2(idumy)))* * cos(2*pi*ran2(idumy)) + epemax2) * * 2*el/elmass if (enhelp.lt.0.0d0) goto 124 endif c Oliver 17. 6. 1997 ephoto = ephoto + enhelp*q(icount)*elmass/el/2 cccccccccccccccccccccccccccccc c Oliver 10.9.1997: introducing a new routine for calculating the impulse c distribution: c aplimit limits the opening angle of the momentum distribution. aplimit = 1.0d0 r2 = angle + aplimit * pi * (ran2(idumy)-0.5d0) r3 = 2.0d0 * pi * (ran2(idumy)-0.5d0) xp(icount) = sqrt(4.0d0/3.0d0)*sqrt(enhelp)*cos(r2)*abs(sin(r3)) yp(icount) = sqrt(4.0d0/3.0d0)*sqrt(enhelp)*sin(r2)*abs(sin(r3)) zp(icount) = sqrt(2.0d0/3.0d0)*sqrt(enhelp)*cos(r3) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) ' after generating new electrons ' c c frank, 01.08.1999 c branch for collisional ionization else if (icoll.eq.1.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 x(icount) = sx*sqrt(-2*log(ran2(idumy))) & *cos(2*pi*ran2(idumy)) + xof y(icount) = sy*sqrt(-2*log(ran2(idumy))) & *cos(2*pi*ran2(idumy)) + yof z(icount) = (ran2(idumy)-0.5)*belen xp(icount) = 1.d-10*(ran2(idumy)-0.5) yp(icount) = 1.d-10*(ran2(idumy)-0.5) zp(icount) = 1.d-10*(ran2(idumy)-0.5) endif c 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) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1202 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dpx = dpx + sign(efx3,xt) c * dti dpy = dpy + sign(efy3,yt) c * dti eespacex = sign(efx3,xt) eespacey = sign(efy3,yt) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1202 continue endif c end space charge yt = yt xt = xt xta = abs(xt-xoff) yta = abs(yt-yoff) if (iscatter.eq.1) goto 1121 if (ibeam.eq.1.and.iwave.eq.0) then if(iimageb.ne.1) * call ffrank(xt,yt,xoff,yoff,sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1207 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1207 continue endif cc cc21 = (pxt+cc12/2)/gamman*dti cc22 = (-eebeamx + eespacex + el/elmass*(pzt+ * cc16/2)/gamman*bfield)*dti cc23 = (pyt+cc14/2)/gamman*dti cc24 = (-eebeamy + eespacey)*dti cc25 = (pzt+cc16/2)/gamman*dti cc26 = - el/elmass*(pxt+cc12/2)* * bfield/gamman*dti c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1208 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1208 continue endif cc cc31 = (pxt+cc22/2)/gamman*dti cc32 = (-eebeamx + eespacex + el/elmass*(pzt * +cc26/2)/gamman*bfield)*dti cc33 = (pyt+cc24/2)/gamman*dti cc34 = (-eebeamy + eespacey)*dti cc35 = (pzt+cc26/2)/gamman*dti cc36 = - el/elmass*(pxt+cc22/2)* * bfield/gamman*dti c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1209 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1209 continue endif cc41 = (pxt+cc32)/gamman*dti cc42 = (- eebeamx + eespacex + el/elmass*(pzt * +cc36)/gamman*bfield)*dti cc43 = (pyt+cc34)/gamman*dti cc44 = (- eebeamy + eespacey)*dti cc45 = (pzt+cc36)/gamman*dti cc46 = - el/elmass*(pxt+cc32)* * bfield/gamman*dti c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(icount) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(icount) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(icount) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(icount) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(icount) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(icount) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(icount)**2+py(icount)**2 * + pz(icount)**2)/vl xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma c ene(icount) = (gamma-1.0d0)*elmass*vl*vl endif c Giovanni: an "on line" Runge-Kutta for the solution of the electron c motion in a finite length solenoid field. if(ibend.eq.41) then frasol = 0.8 cc11 = pxt*dti/gamma cc12 = (-eebeamx + eespacex - el/elmass*pyt*solenz * (frasol,xt,yt,zt)/gamma + el/elmass* * pzt*soleny(frasol,xt,yt,zt)/gamma)*dti cc13 = pyt*dti/gamma cc14 = (-eebeamy + eespacey - el/elmass*pzt*solenx * (frasol,xt,yt,zt)/gamma + el/elmass* * pxt*solenz(frasol,xt,yt,zt)/gamma)*dti cc15 = pzt*dti/gamma cc16 = (- el/elmass*pxt*soleny(frasol,xt,yt,zt) * /gamma + el/elmass*pyt*solenx(frasol,xt,yt, * zt)/gamma)*dti c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 ztn = zt + cc15/2 pxtn = pxt + cc12/2 pytn = pyt + cc14/2 pztn = pzt + cc16/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1240 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1240 continue endif cc21 = pxtn/gamman*dti cc22 = (-eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dti cc23 = pytn/gamman*dti cc24 = (-eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dti cc25 = pztn/gamman*dti cc26 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass * pytn*solenx(frasol,xtn, * ytn,ztn)/gamman)*dti c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 ztn = zt + cc25/2 pxtn = pxt + cc22/2 pytn = pyt + cc24/2 pztn = pzt + cc26/2 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1241 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1241 continue endif cc31 = pxtn/gamman*dti cc32 = (-eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dti cc33 = pytn/gamman*dti cc34 = (-eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dti cc35 = pztn/gamman*dti cc36 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dti c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 ztn = zt + cc35 pxtn = pxt + cc32 pytn = pyt + cc34 pztn = pzt + cc36 xta = abs(xtn - xoff) yta = abs(ytn - yoff) if(ibeam.eq.1) then if(iimageb.ne.1) * call ffrank(xtn,ytn,xoff,yoff, * sx,sy,pre,pim) if(iimageb.eq.1.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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(icount)=0. goto 1242 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1242 continue endif cc41 = pxtn/gamman*dti cc42 = (-eebeamx + eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dti cc43 = pytn/gamman*dti cc44 = (-eebeamy + eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dti cc45 = pztn/gamman*dti cc46 = (- el/elmass*pxtn*soleny(frasol,xt,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dti c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(icount) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(icount) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(icount) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(icount) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(icount) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(icount) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(icount)**2+py(icount)**2 * + pz(icount)**2)/vl xp(icount) = px(icount)/gamma yp(icount) = py(icount)/gamma zp(icount) = pz(icount)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl c write(*,*) ionene(iio) endif c end bmap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c Oliver 17.6.1997 (calculate energy and storing it in an array): iadele = iadele + 1 c Oliver: 12.7.1998 (gamma is already defined above!) c vel2 = (xp(icount)*xp(icount)+yp(icount)*yp(icount) c * +zp(icount)*zp(icount)) c beta2 = vel2/vl/vl c gamma = 1.0d0/sqrt(1.0d0-beta2) dele(iadele) = (gamma-1.0d0)*elmass*vl*vl qele(iadele) = q(icount) if (ib.eq.nbstep) then adele = adele + qele(iadele)*(gamma-1.0d0)*elmass*vl*vl qadele = qadele + qele(iadele) endif cccccccccccccccccccccccccccccccccccccccccccccccccc c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(icount)/xbound)**2+(y(icount)/ybound)**2 if (y(icount).gt.zbound) amp = 2.0d0 if (y(icount).lt.-zbound) amp = 2.0d0 if (iwave.eq.1) then amp2 = (x(icount)**2+y(icount)**2)/ rbound**2 else if (iwave.eq.2) then call dist(amp2, x(icount), y(icount), kw) endif if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif if (amp.gt.1.and.iloss.eq.1) then ptime(icount) = t - ptime(icount) if (ptime(icount).gt.0.0.and.dele(iadele)/el.gt.ecut) then write(24,*) x(icount),ptime(icount)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).ge.0.0) c * write(27,*) x(i), ptime(i)*1.0d9,dele(iadele)/el c if (esign(i)*y(i).lt.0.0) c * write(28,*) x(i), ptime(i)*1.0d9,dele(iadele)/el endif ptime(icount) = t esign(icount) = y(icount) xt = x(icount) yt = y(icount) xpt = xp(icount) ypt = yp(icount) zt = z(icount) zpt = zp(icount) qt = q(icount) engt=dele(iadele)/el qlosswh = qlosswh + qt/dtex if (engt.ge.1.0d0) then qlosstot = qlosstot + qt if (engt.ge.20.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt call ebinw(webin,engt,qt) if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) if (iazi.eq.1) then call ebinwphi(webinphi,webinph2,engt,qt,xt,yt) call ebinwx(webinx,webinx2,webinx3,engt,qt,xt,yt) endif endif qacc = qacc - qt qouter = qouter - qt icold = icount call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(icold) = xpt yp(icold) = ypt zp(icold) = zpt x(icold) = xt y(icold) = yt z(icold) = zt q(icold) = qt qacc = qacc + qt qouter = qouter + qtnew c qlosswh = qlosswh - qtnew/dtex endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.ne.0) then ptime(icount) = t - ptime(icount) if (ptime(icount).gt.0.0.and.dele(iadele)/el.gt.ecut) * write(25,*) x(icount),ptime(icount)*1.0d9,dele(iadele)/el ptime(icount) = t esign(icount) = y(icount) xt = x(icount) yt = y(icount) xpt = xp(icount) ypt = yp(icount) zt = z(icount) zpt = zp(icount) qt = q(icount) qacc = qacc - qt qinner = qinner - qt icold = icount c write(*,*) ' seiler again =' call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,2,kw) xp(icold) = xpt yp(icold) = ypt zp(icold) = zpt x(icold) = xt y(icold) = yt z(icold) = zt q(icold) = qt qacc = qacc + qt qinner = qinner + qtnew endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 23.06.1997 Oliver: Writing the electron distribution to a file. if (jb.eq.jebin.and.ib.eq.iebin.and.q(icount).gt.0.0) then write(44,9444) x(icount), y(icount), q(icount), z(icount) c channel was 4444 write(91,9444) xp(icount), yp(icount), q(icount), zp(icount) endif 13 continue endif qdens = qacc/belen/pi/(xbound*ybound) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') > jb,ib,t,icount,qacc,qdens c x(1),y(1),q(1) c write(21,'(i3,i3,e25.5,i8,2e25.5)') j,0,t,icount,qacc c Bin the energy distribution and write the result to an external file: if (jb.eq.jebin.and.ib.eq.iebin) then c close(24) c close(26) close(29) write(*,*) "jebin = ",jebin, "iebin = ",iebin call ebin endif c write(88,'(2e25.5)') t, elossq 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, IFAIL REAL*8 bfield, el, vl, fom, pi, re, elmass REAL*8 rbound, xbound, ybound, zbound, energy, belen REAL*8 S18ADF REAL*8 S18AFF external S18ADF external S18AFF parz = 0.0 onda = 2*pi/belen wind = dmax1(xbound,ybound) rad = sqrt(posx**2 + posy**2) do 137 is = 1, 100 parz = parz + 4/belen*wind*sin(is*onda*frac*belen/2)* * S18ADF(is*onda*wind,IFAIL)*S18AFF(is*onda*rad,IFAIL)* * sin(is*onda*posz) 137 continue solenx = parz*bfield*posx/rad RETURN END REAL*8 FUNCTION soleny(frac,posx,posy,posz) COMMON / def1 / rbound, xbound, ybound, zbound, energy, belen COMMON / def2 / bfield, el, vl, fom, pi, re, elmass INTEGER is REAL*8 posx, posy, posz, parz, onda, wind, rad, frac, IFAIL REAL*8 bfield, el, vl, fom, pi, re, elmass REAL*8 rbound, xbound, ybound, zbound, energy, belen REAL*8 S18ADF REAL*8 S18AFF external S18ADF external S18AFF parz = 0.0 onda = 2*pi/belen wind = dmax1(xbound,ybound) rad = sqrt(posx**2 + posy**2) do 138 is = 1, 100 parz = parz + 4/belen*wind*sin(is*onda*frac*belen/2)* * S18ADF(is*onda*wind,IFAIL)*S18AFF(is*onda*rad,IFAIL)* * sin(is*onda*posz) 138 continue soleny = parz*bfield*posy/rad RETURN END REAL*8 FUNCTION solenz(frac,posx,posy,posz) COMMON / def1 / rbound, xbound, ybound, zbound, energy, belen COMMON / def2 / bfield, el, vl, fom, pi, re, elmass INTEGER is REAL*8 posx, posy, posz, parz, onda, wind, rad, frac, IFAIL REAL*8 bfield, el, vl, fom, pi, re, elmass REAL*8 rbound, xbound, ybound, zbound, energy, belen REAL*8 S18ADF REAL*8 S18AEF external S18ADF external S18AEF parz = frac onda = 2*pi/belen wind = dmax1(xbound,ybound) rad = sqrt(posx**2 + posy**2) do 139 is = 1, 100 parz = parz + 4/belen*wind*sin(is*onda*frac*belen/2)* * S18ADF(is*onda*wind,IFAIL)*S18AEF(is*onda*rad,IFAIL)* * cos(is*onda*posz) 139 continue solenz = parz*bfield RETURN END subroutine interbunch(iflag) c purpose: propagates through interbunch gap c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,iybin=500) c parameter (nistep = 20) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500,ngrid2=10) integer iycount(0:iybin) integer kw, iflag real*8 ayield(0:iybin), avcos(0:iybin) real*8 boundix(40), boundiy(40), boundox(80), boundoy(80) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm),yp(npelm),zp(npelm),py(npelm),pz(npelm) real*8 px(npelm), dele(npelm), qele(npelm), dele2(npelm) real*8 xpt, ypt, zpt, pxt, pyt, pzt real*8 ptime(npelm), esign(npelm) integer index(npelm) integer iazi real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 eloss, elossq, ephoto, adele, qadele, alimit real*8 epesig, epemax, ecut real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, sbt, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 dt real*8 radi real*8 xt, yt, zt real*8 volt, qouter, qinner real*8 dpx, dpy, dpz, dpxm, dpym, dpzm real*8 qlosswh, qlosstot, qlosstot2 real*8 denscenter real*8 eespacex, eespacey, eebeamx, eebeamy, gamman real*8 xtn,ytn,xta,yta,frasol real*8 c11,c12,c13,c14,c15,c16,c21,c22,c23,c24,c25,c26 real*8 c31,c32,c33,c34,c35,c36,c41,c42,c43,c44,c45,c46 real*8 bgradient c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / loss / eloss, elossq, ephoto, adele, qadele common / loss2 / qlosswh, qlosstot, qlosstot2 common / part / qacc common / part2 / icount, icountact, iadele common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c Oliver 18.06.1997 common / egain / dele, qele ccccccccccccccccccccccccccccc c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / eini / epemax,ecut common / eini2 / nbini,nsini,imovie,iseq,mcount,imodo common / eino / epesig common / movie / boundix, boundiy, boundox, boundoy ccccccccccccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos common / image / iimage, iimageb, interspace, igeom ccccccccccccccccccccccccccccccccccccccc common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2,webinx3 c frank, nov 99, for azimuth common / azi / iazi common / center / denscenter external solenx,soleny,solenz if(interspace.ne.0) ismod = nistep/interspace if(interspace.eq.0) ismod = nistep + 1 sbt = sb if(iflag.eq.1) sbt = sb1 if(iflag.eq.2) sbt = sb2 if(iflag.eq.4) sbt = bl do 10 ib = 1, nistep qlosswh = 0. if(mod(ib,ismod).eq.0) then if(ispace.eq.2) call spacecharge2 c if(ispace.eq.2) then c write(*,*) "Calculating E-field:" c do 123 it=0,ngrid2 c do 124 jt =0,ngrid2 c if(efxa(it,jt).ne.0.0) c * write(*,*) it,jt,efxa(it,jt) c 124 continue c 123 continue c endif if(ispace.eq.1) call spacecharge(0) endif dt = sbt/vl/real(nistep) t = t + dt c c write(*,*) ' heureka!' c write(*,*) dt, sbt, iflag c elossq = 0.0d0 if (icount.gt.0) then if (ibend.eq.5) then a1 = (dt-1.0d0/fom*sin(fom*dt))/fom a2 = 1.0d0 a3 = (1.0d0-cos(fom*dt))/fom a4 = sin(fom*dt)/fom b1 = (1.0d0-cos(fom*dt))/fom**2 b2 = 1.0d0 b3 = sin(fom*dt)/fom b4 = (cos(fom*dt)-1.0d0)/fom c1 = (1.0d0-cos(fom*dt))/fom c2 = sin(fom*dt) c3 = cos(fom*dt) d1 = sin(fom*dt)/fom d2 = cos(fom*dt) d3 = -sin(fom*dt) endif endif if (icount.gt.0) then iadele2 = 0 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 24.06.1997 Oliver: Writing the particle positions to a file for a movie: c if (imovie.eq.1.and.mod(ib,iseq).eq.0) then c do 213 id=1,80 c write(45,*) boundox(id), boundoy(id) c 213 continue c write(45,*) " " c write(45,*) " " c if (ib.ne.1) c write(46,*) c * "plot 'edistr.movie.data' index ",mcount," with points 3" c if (ib.eq.1) write(46,*) c * "plot 'edistr.movie.data' index ",mcount," with points 1" c mcount = mcount + 1 c write(46,*) "pause 0.3" c endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do 11 i = 1, icount if(i.eq.1) then ihelp = index(i) qhelp = q(i) c write(*,*) ' ihelp = ',ihelp, qhelp endif if (index(i).eq.0.and.(q(i).gt.0)) then ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 24.06.1997 Oliver: Writing the particle positions to a file for a movie: if (imovie.eq.1.and.mod(ib,iseq).eq.0.and.q(i).gt.0.0d0.and. * abs(x(i)).lt.xbound.and.abs(y(i)).lt.ybound) * write(45,*) x(i), y(i) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 3.8.1997 (calculate energy and storing it in an array): iadele2 = iadele2 + 1 c Oliver: 12.8.1998 New definition for Gamma: c vel2 = (xp(i)*xp(i)+yp(i)*yp(i)+zp(i)*zp(i)) c beta2 = vel2/vl/vl c gamma = 1.0001d0/sqrt(1.0d0-beta2) c gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl c c dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dpx = 0.0 dpy = 0.0 dpz = 0.0 xt = x(i) yt = y(i) zt = z(i) xpt = xp(i) ypt = yp(i) zpt = zp(i) c Oliver 12.8.1998: c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = 1.0d0*gammaf(velt)*ypt pxt = 1.0d0*gammaf(velt)*xpt pzt = 1.0d0*gammaf(velt)*zpt c frank 12/11/99 c recalculate gamma after updating px, py etc... gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl if (i.eq.1) then ti=1.e9*t 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) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1201 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dpx = dpx + sign(efx3,xt) c*dt dpy = dpy + sign(efy3,yt) c*dt 1201 continue eespacex = sign(efx3,xt) eespacey = sign(efy3,yt) endif c end space charge c Oliver 31.07.1997: introducing the force of an additional c voltage across the vacuum chamber. c deltay = el*volt/ elmass c write(*,*) "space=",ispace,xp(i),yp(i) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 11.8.1998 Oliver: New module for case without magnetic field. if(ibend.eq.0) then px(i) = pxt + dpx*dt py(i) = pyt + dpy*dt pz(i) = pzt gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2+pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma x(i) = xt + (xp(i)+xpt)/2.0d0 * dt y(i) = yt + (yp(i)+ypt)/2.0d0 * dt z(i) = zt + (zp(i)+zpt)/2.0d0 * dt endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c 17.11.1998 X. Zhang: For case with field of horizontal bend magnet. if(ibend.eq.1) then px(i) = pxt py(i) = pyt + dpy*dt pz(i) = pzt 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 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1213 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1213 continue endif cc cc21 = (pxt+cc12/2)/gamman*dt cc22 = (eespacex + el/elmass*(pzt+ * cc16/2)/gamman*bfield)*dt cc23 = (pyt+cc14/2)/gamman*dt cc24 = eespacey*dt cc25 = (pzt+cc16/2)/gamman*dt cc26 = - el/elmass*(pxt+cc12/2)* * bfield/gamman*dt c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1214 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1214 continue endif cc cc31 = (pxt+cc22/2)/gamman*dt cc32 = (eespacex + el/elmass*(pzt * +cc26/2)/gamman*bfield)*dt cc33 = (pyt+cc24/2)/gamman*dt cc34 = eespacey*dt cc35 = (pzt+cc26/2)/gamman*dt cc36 = - el/elmass*(pxt+cc22/2)* * bfield/gamman*dt c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1215 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1215 continue endif cc41 = (pxt+cc32)/gamman*dt cc42 = (eespacex + el/elmass*(pzt * +cc36)/gamman*bfield)*dt cc43 = (pyt+cc34)/gamman*dt cc44 = eespacey*dt cc45 = (pzt+cc36)/gamman*dt cc46 = - el/elmass*(pxt+cc32)* * bfield/gamman*dt c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl endif c Giovanni: an "on line" Runge-Kutta for the solution of the electron c motion in a finite length solenoid field. if(ibend.eq.41) then frasol = 0.8 cc11 = pxt*dt/gamma cc12 = (eespacex - el/elmass*pyt*solenz * (frasol,xt,yt,zt)/gamma + el/elmass* * pzt*soleny(frasol,xt,yt,zt)/gamma)*dt cc13 = pyt*dt/gamma cc14 = (eespacey - el/elmass*pzt*solenx * (frasol,xt,yt,zt)/gamma + el/elmass* * pxt*solenz(frasol,xt,yt,zt)/gamma)*dt cc15 = pzt*dt/gamma cc16 = (- el/elmass*pxt*soleny(frasol,xt,yt,zt) * /gamma + el/elmass*pyt*solenx(frasol,xt,yt, * zt)/gamma)*dt c write(*,*) 'start generate' c write(*,*) cc12/dtex, ebeamx c write(*,*) cc16 gamman = 1.0d0*sqrt(vl**2+(pxt+cc12/2)**2 + * (pyt + cc14/2)**2 + (pzt + cc16/2)**2)/vl c write(*,*) gamman xtn = xt + cc11/2 ytn = yt + cc13/2 ztn = zt + cc15/2 pxtn = pxt + cc12/2 pytn = pyt + cc14/2 pztn = pzt + cc16/2 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1230 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1230 continue endif cc21 = pxtn/gamman*dt cc22 = (eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dt cc23 = pytn/gamman*dt cc24 = (eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dt cc25 = pztn/gamman*dt cc26 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass * pytn*solenx(frasol,xtn, * ytn,ztn)/gamman)*dt c write(*,*) cc21, cc22, cc23 c write(*,*) cc24, cc25, cc26 gamman = 1.0d0*sqrt(vl**2+(pxt+cc22/2)**2 + * (pyt + cc24/2)**2 + (pzt + cc26/2)**2)/vl c write(*,*) gamman xtn = xt + cc21/2 ytn = yt + cc23/2 ztn = zt + cc25/2 pxtn = pxt + cc22/2 pytn = pyt + cc24/2 pztn = pzt + cc26/2 cc if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1231 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1231 continue endif cc31 = pxtn/gamman*dt cc32 = (eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dt cc33 = pytn/gamman*dt cc34 = (eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dt cc35 = pztn/gamman*dt cc36 = (- el/elmass*pxtn*soleny(frasol,xtn,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dt c write(*,*) cc31, cc32, cc33 c write(*,*) cc34, cc35, cc36 gamman = 1.0d0*sqrt(vl**2+(pxt+cc32)**2 + * (pyt + cc34)**2 + (pzt + cc36)**2)/vl c write(*,*) gamman xtn = xt + cc31 ytn = yt + cc33 ztn = zt + cc35 pxtn = pxt + cc32 pytn = pyt + cc34 pztn = pzt + cc36 if (ispace.eq.2) then ymbound = min(ybound,zbound) indx = nint(ngrid2*xtn/xbound) indy = nint(ngrid2*ytn/ymbound) if(indx*xbound/real(ngrid2).gt.xtn) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xtn) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.ytn) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.ytn) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1232 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xtn-indx*xbound/ngrid2) * efxa(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx, * indy) ) * real(ngrid2)/xbound efx2 = ((xtn-indx*xbound/ngrid2)*efxa(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efxa(indx,indy * +1) ) * real(ngrid2)/xbound efx3 = ((ytn-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-ytn) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xtn-indx*xbound/ngrid2) * efya(indx+1, * indy) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx, * indy) ) * real(ngrid2)/xbound efy2 = ((xtn-indx*xbound/ngrid2)*efya(indx+1,indy * +1) + ((indx+1)*xbound/ngrid2-xtn)*efya(indx,indy * +1) ) * real(ngrid2)/xbound efy3 = ((ytn-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-ytn) * efy1) * * real(ngrid2)/ymbound endif eespacex = sign(efx3,xtn) eespacey = sign(efy3,ytn) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 1232 continue endif cc41 = pxtn/gamman*dt cc42 = (eespacex - el/elmass*pytn*solenz * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pztn*soleny(frasol,xtn,ytn,ztn)/gamman)*dt cc43 = pytn/gamman*dt cc44 = (eespacey - el/elmass*pztn*solenx * (frasol,xtn,ytn,ztn)/gamman + el/elmass* * pxtn*solenz(frasol,xtn,ytn,ztn)/gamman)*dt cc45 = pztn/gamman*dt cc46 = (- el/elmass*pxtn*soleny(frasol,xt,ytn,ztn) * /gamman + el/elmass*pytn*solenx(frasol,xtn,ytn, * ztn)/gamman)*dt c write(*,*) cc41, cc42, cc43 c write(*,*) cc44, cc45, cc46 c write(*,*) 'end generate' x(i) = xt+cc11/6+cc21/3+cc31/3+cc41/6 px(i) = pxt+cc12/6+cc22/3+cc32/3+cc42/6 y(i) = yt+cc13/6+cc23/3+cc33/3+cc43/6 py(i) = pyt+cc14/6+cc24/3+cc34/3+cc44/6 z(i) = zt+cc15/6+cc25/3+cc35/3+cc45/6 pz(i) = pzt+cc16/6+cc26/3+cc36/3+cc46/6 gamma = 1.0d0*sqrt(vl**2+px(i)**2+py(i)**2 * + pz(i)**2)/vl xp(i) = px(i)/gamma yp(i) = py(i)/gamma zp(i) = pz(i)/gamma c ene(i) = (gamma-1.0d0)*elmass*vl*vl c write(*,*) ionene(iio) endif c end bmap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c particle lost when exceeding boundary... c x-y boundary with sec. emission amp = (x(i)/xbound)**2+(y(i)/ybound)**2 if (y(i).gt.zbound) amp = 2.0 if (y(i).lt.-zbound) amp = 2.0 if (iwave.eq.1) then amp2 = (x(i)**2+y(i)**2)/ rbound**2 else if (iwave.eq.2) then call dist(amp2, x(i), y(i), kw) endif if (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif c Oliver 3.8.1997: writing the time of flight to a file. if (amp.gt.1.and.iloss.eq.1) then ptime(i) = t - ptime(i) if (ptime(i).gt.0.0.and.dele2(iadele2)/el.gt.ecut) then write(24,*) x(i), ptime(i)*1.0d9,dele2(iadele2)/el c if (esign(i)*y(i).ge.0.0) c * write(27,*) x(i), ptime(i)*1.0d9,dele2(iadele2)/el c if (esign(i)*y(i).lt.0.0) c * write(28,*) x(i), ptime(i)*1.0d9,dele2(iadele2)/el endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if (amp.gt.1.and.iloss.eq.1) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) engt=dele2(iadele2)/el qlosswh = qlosswh + qt/dt if (engt.ge.1.0d0) then qlosstot = qlosstot + qt if (engt.ge.20.0d0) then qlosstot2 = qlosstot2 + qt endif elossq = elossq + qt call ebinw(webin,engt,qt) if (abs(xt).lt.(0.7*xbound)) call ebinwnew(webinn,engt,qt) if (iazi.eq.1) then call ebinwphi(webinphi,webinph2,engt,qt,xt,yt) call ebinwx(webinx,webinx2,webinx3,engt,qt,xt,yt) endif endif qacc = qacc - qt qouter = qouter - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qouter = qouter + qtnew c qlosswh = qlosswh - qtnew/dt c frank 12/11/99 c recalculate gamma after updating px, py etc... velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) pyt = 1.0d0*gammaf(velt)*yp(i) pxt = 1.0d0*gammaf(velt)*xp(i) pzt = 1.0d0*gammaf(velt)*zp(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.ne.0) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qinner = qinner - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,2,kw) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qinner = qinner + qtnew c frank 12/11/99 c recalculate gamma after updating px, py etc... velt = sqrt(yp(i)*yp(i)+xp(i)*xp(i)+zp(i)*zp(i)) pyt = 1.0d0*gammaf(velt)*yp(i) pxt = 1.0d0*gammaf(velt)*xp(i) pzt = 1.0d0*gammaf(velt)*zp(i) gamma = 1.0d0*sqrt(vl**2+pxt**2+pyt**2+pzt**2)/vl dele2(iadele2) = (gamma-1.0d0)*elmass*vl*vl endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 18.06.1997: setting the energy increase to zero for lost particles. if (q(i).eq.0.0) dele(i) = 0.0 if (q(i).eq.0.0) qele(i) = 0.0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif 11 continue endif if (imovie.eq.1.and.mod(ib,iseq).eq.0) then do 213 id=1,80 write(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) write(21,'(i3,1x,i3,e15.5,i8,e15.5,1x,e15.5)') & j,0,t,icount,qacc,qdens write(43,'(e25.5,e25.5)') t, denscenter c write(88,'(2e25.5)') t, elossq 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 real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 bfield, el, vl, fom, pi, re, elmass common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c grid parameters radstep = xbound/real(ngrid) rad(0) = 0.d0 do 10 j = 1, ngrid crg(j) = 0.0d0 rad(j) = real(j) * radstep 10 continue do 11 i = 1, icount radius = sqrt(x(i)*x(i)+y(i)*y(i)) c write(*,*) ' succ 1 ',i,radius,rad(ngrid),x(i),y(i) do 12 j = ngrid, 1, -1 if (radius.lt.rad(j)) then crg(j) = crg(j) + q(i) cc write(*,*) ' success ',crg(j),q(i),j, i,x(i),y(i) else goto 95 endif 12 continue 95 continue 11 continue mec2 = 511000. coef = 2.d0*re*vl*vl/belen open(22,file="space.dat",status='unknown') write(22,*) "Icount = ",icount efield(0) = 0.d0 do 210 i = 1, ngrid efield(i) = coef * crg(i) / rad(i) c set efield = 0 for no space charge c EFIELD(i) = 0.d0 if (ix.eq.1) then write(22,*) rad(i),efield(i),crg(i),coef,qacc,icount endif 210 continue close(22) end subroutine spacecharge2old c purpose: New space charge routine that uses a two dimensional Mesh c for the field calculation and allows the evaluation of the c effect of image charges on the boundary. c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,ngrid2=10,nimage=50,nimage2=4) parameter(eta=8.8542d-12) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) real*8 rolimit, rilimit parameter(rolimit=0.97d0,rilimit=1.02d0) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 px(npelm), pz(npelm), py(npelm) real*8 ptime(npelm), esign(npelm) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) real*8 r1x(0:nimage2),r1y(0:nimage2),r2x(0:nimage2),r2y(0:nimage2) real*8 rg, rm1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 voltx, volty real*8 rmax, rmin real*8 rm0 real*8 rphi, rphi0, rphi1, rphi2, rphi3 real*8 xl, yl c Complex variables for the calculation of the elliptical coordinates: complex*16 z1, z2, z3, z4, zi, zone complex*16 efz1(-ngrid2:ngrid2,-ngrid2:ngrid2) complex*16 zeric,zdiv,zr,zri,zzr,zzri common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / image / iimage, iimageb, interspace, igeom common / beam / rg, rm1 common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc charge = 1.0d0 coef = 2.0d0*re*vl*vl/belen ymbound = min(ybound,zbound) rmax = max(xbound,ymbound) rmin = min(xbound,ymbound) zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) if(igeom.eq.2) then rg = sqrt(rmax**2 - rmin**2) rm1 = log((rmax+rmin)/(rmax-rmin))/2.0d0 endif c testx = rg*(exp(rm1)+exp(-rm1))/2.0d0 c testy = rg*(exp(rm1)-exp(-rm1))/2.0d0 c write(*,*) "Test1: ",testx, testy c Distributing the charge on the grid: do 103 i=1,icount c c frank: i do not understand the abs( ) - correct for quads? linx = nint(ngrid2*x(i)/xbound) liny = nint(ngrid2*y(i)/ymbound) c Avoiding charges which are outside the boundary for the c image charge calculation: rl1 = (dble(linx)/dble(ngrid2))**2+(dble(liny)/dble(ngrid2))**2 c if(rl1.gt.rolimit.and.iimage.eq.1) then if(rl1.gt.rolimit) then c write(*,*) "Changing the mesh position 1 from: ",linx,liny 331 rl2 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 rl3 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 rl4 = (dble(linx-1)/dble(ngrid2))**2 + * (dble(liny-1)/dble(ngrid2))**2 if(rl2.gt.rolimit) rl2 = 0.0 if(rl3.gt.rolimit) rl3 = 0.0 if(rl4.gt.rolimit) rl4 = 0.0 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).gt.0) * linx = linx - 1 if(rl2.ge.rl3.and.rl2.gt.rl4.and.x(i).lt.0) * linx = linx + 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).gt.0) * liny = liny - 1 if(rl3.ge.rl2.and.rl3.gt.rl4.and.y(i).lt.0) * liny = liny + 1 if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx - 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).gt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx - 1 liny = liny + 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).gt.0) then linx = linx + 1 liny = liny - 1 endif if(rl4.ge.rl2.and.x(i).lt.0. * and.rl4.ge.rl3.and.y(i).lt.0) then linx = linx + 1 liny = liny + 1 endif c if(linx.lt.0) linx = 0 c if(liny.lt.0) liny = 0 rl1 = (dble(linx)/dble(ngrid2))**2 + * (dble(liny)/dble(ngrid2))**2 if(rl1.gt.rolimit) goto 331 c write(*,*) " to : ",linx,liny endif c Avoiding charges which are inside the inner conductor for the c image charge calculation with a wave guide geometry: rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit.and.igeom.eq.3.and.iimage.eq.1) then c write(*,*) "Changing the mesh position 2 from: ",linx,liny 332 if(linx.le.nint(ngrid2*rbound/xbound)) linx = linx + 1 if(liny.le.nint(ngrid2*rbound/ymbound)) liny = liny + 1 if(linx.gt.ngrid2) linx = ngrid2 - 1 if(liny.gt.ngrid2) liny = ngrid2 - 1 rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit) goto 332 c write(*,*) " to : ",linx,liny endif qgrid(linx,liny) = qgrid(linx,liny) + q(i) 103 continue c Achtung! c Introducing a wire with negative charge in the corner of the chamber: c ixq = 14 c iyq = 18 c qgrid(ixq,iyq) = qgrid(ixq,iyq) + volt*1.0e10 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Generating the Field-Mesh: do 104 i=-ngrid2,ngrid2 xg = i*xbound/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.xg.eq.0.0) xg = 1.0d-5 do 105 j=-ngrid2,ngrid2 efxa(i,j) = 0.0d0 efya(i,j) = 0.0d0 yg = j*ymbound/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.yg.eq.0.0) yg = 1.0d-5 c Test lines: c This Test calculates the tangential field on the elliptical boundary. c xg = rbound*cos(2*pi*j/ngrid2) c yg = rbound*sin(2*pi*j/ngrid2) c rnx = xg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rny = yg/ rbound**2/ c * sqrt(xg**2/rbound**4+yg**2/rbound**4) c rtx = rny c rty = -rnx c xg = rmax*cos(2*pi*j/ngrid2) c yg = rmin*sin(2*pi*j/ngrid2) c rnx = xg/ rmax**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rny = yg/ rmin**2/ c * sqrt(xg**2/rmax**4+yg**2/rmin**4) c rtx = rny c rty = -rnx cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Calculate the elliptic coordinates for the image charge calculation: if(iimage.eq.1.and.igeom.eq.2) then z1 = xg/rg * zone + yg/rg * zi z2 = xg/rg * zone - yg/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 if(rphi*yg.lt.0.0d0) rphi = -rphi c testx = rg*(exp(rmi)+exp(-rmi))*cos(rphi)/2.0d0 c testy = rg*(exp(rmi)-exp(-rmi))*sin(rphi)/2.0d0 c write(*,*) "Testi: ",testx, xg, testy, yg endif do 106 k=-ngrid2,ngrid2 xl = k*rmax/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.xl.eq.0.0) c * xl = 1.0d-5 do 107 l=-ngrid2,ngrid2 if(qgrid(k,l).ne.0.0) then charge = 1.0d0 yl = l*rmin/ngrid2 c Avoid a zero charge positions for the image charge calculation with c an elliptical boundary surface: c if(iimage.eq.1.and.igeom.eq.2.and.yl.eq.0.0) c * yl = 1.0d-5 rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 if(xl.ne.xg.or.yl.ne.yg) * rad1 = (xg-xl)**2 + (yg-yl)**2 c if(yl.ne.yg.or.xl.ne.0.0.or.xg.ne.0.0) c * rad2 = (xg+xl)**2 + (yg-yl)**2 c if(xl.ne.xg.or.yl.ne.0.0.or.yg.ne.0.0) c * rad3 = (xg-xl)**2 + (yg+yl)**2 c if(xg.ne.0.0.or.xl.ne.0.0.or.yl.ne.0.0.or.yg.ne.0.0) c * rad4 = (xg+xl)**2 + (yg+yl)**2 efxa(i,j) = * efxa(i,j) + coef * qgrid(k,l) * * (xg-xl)/ rad1 c * + (xg+xl)/ rad2 c * + (xg-xl)/ rad3 c * + (xg+xl)/ rad4 )/ 4.0d0 efya(i,j) = * efya(i,j) + coef * qgrid(k,l) * * (yg-yl)/ rad1 c * + (yg-yl)/ rad2 c * + (yg+yl)/ rad3 c * + (yg+yl)/ rad4 )/ 4.0d0 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for an elliptical vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.2) then c Introducing complex notation for the electric field. c Calculate the elliptical coordinates ('rm' and 'phi') c of the charge on the mesh: z1 = xl/rg * zone + yl/rg * zi z2 = xl/rg * zone - yl/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rm0 = dabs(dreal(z3+z4)/2.0d0) rphi0 = dreal((z4-z3)*zi)/2.0d0 if(rphi0*yl.lt.0.0d0) rphi0 = -rphi0 c testx = rg*(exp(rm0)+exp(-rm0))*cos(rphi0)/2.0d0 c testy = rg*(exp(rm0)-exp(-rm0))*sin(rphi0)/2.0d0 c write(*,*) "Test0: ",testx, xl, testy, yl rphi1 = -rphi0 rphi2 = rphi0 + pi rphi3 = -rphi2 c rphi1 = rphi0 c rphi2 = rphi0 c rphi3 = rphi0 c THIS WAS, SO FAR SO GOOD........ C efz1(i,j) = efz1(i,j)+coef*qgrid(k,l)*2.0d0*exp(-ii*rm1)* C * ( (exp(ii*rm0)+exp(-ii*rm0)) * C * (4d0*cos(ii*rphi0))/ C * (exp(ii*rm1)+exp(-ii*rm1)) * zone ) * C * (cdexp(ii*(rmi*zone-rphi*zi))-cdexp(-ii*(rmi*zone-rphi*zi)))/ C * (cdexp(rmi*zone-rphi*zi)-cdexp(-(rmi*zone-rphi*zi)))/rg/4.0d0 c print *,' ii ',ii,' E ',efz1(i,j) c Adding the contributions from the image charges: c efz1(i,j)=efxa(i,j)*zone+efya(i,j)*zi c zeric=(0d0,0d0) ericreal = 0d0 ericimag = 0d0 const=coef*qgrid(k,l)/rg*2d0 c zr=dcmplx(rmi,-rphi) c zzr=cdexp(zr)-(1d0,0d0)/cdexp(zr) rreal=rmi rimag=-rphi r1real=exp(rreal)*cos(rimag) r1imag=exp(rreal)*sin(rimag) a2b2=r1real*r1real+r1imag*r1imag rzreal=r1real-r1real/a2b2 rzimag=r1imag+r1imag/a2b2 c2d2=rzreal*rzreal+rzimag*rzimag c print *,' init ' c print *,zr,rreal,rimag c print *,cdexp(zr),r1real,r1imag c print *,zzr,rzreal,rzimag do 109 ii=2,nimage,2 c print *,' ii ',ii,' E ',efz1(i,j) c print *,' looping ' erm0=exp(ii*rm0) erm1=exp(ii*rm1) rireal=ii*rreal riimag=ii*rimag c zri=ii*zr c print *,' zri ',zri,rireal,riimag c zzri=cdexp(zri)-(1d0,0d0)/cdexp(zri) rz1real=exp(rireal)*cos(riimag) rz1imag=exp(rireal)*sin(riimag) e2f2=rz1real*rz1real+rz1imag*rz1imag rzireal=rz1real-rz1real/e2f2 rziimag=rz1imag+rz1imag/e2f2 c print *,' rzi ',zzri,rzireal,rziimag eric=(erm0+1d0/erm0)/erm1*cos(ii*rphi0)/(erm1+1d0/erm1) c zeric=zeric + eric * zzri / zzr c a+ib/c+id=ac/(c2+d2)+bd/c2+d2)+( bc/(c2+d2)-ad/(c2+d2) )i ericreal=ericreal+eric*(rzireal*rzreal+rziimag*rzimag)/c2d2 ericimag=ericimag+eric*(rziimag*rzreal-rzireal*rzimag)/c2d2 c print *,' eric ',zeric,ericreal,ericimag 109 continue c efz1(i,j) = efz1(i,j)+const*zeric efxa(i,j) = efxa(i,j)+const*ericreal efya(i,j) = efya(i,j)+const*ericimag c Transforming back to cartesian coordinates: c efxa(i,j) = dreal(efz1(i,j)) c efya(i,j) = dreal(-efz1(i,j)*zi) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for a circular vacuum chamber: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.1) then scale = sqrt(xl**2+yl**2)/xbound if(scale.eq.0.0) goto 108 xim = xl/scale**2 yim = yl/scale**2 rad1 = 1.0d0 rad2 = 1.0d0 rad3 = 1.0d0 rad4 = 1.0d0 if(xim.ne.xg.or.yim.ne.yg) * rad1 = (xg-xim)**2 + (yg-yim)**2 if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.yg) * rad2 = (xg+xim)**2 + (yg-yim)**2 if(xim.ne.xg.or.yim.ne.0.0.or.yg.ne.0.0) * rad3 = (xg-xim)**2 + (yg+yim)**2 if(xim.ne.0.0.or.xg.ne.0.0.or.yim.ne.0.0.or.yg.ne.0.0) * rad4 = (xg+xim)**2 + (yg+yim)**2 efxa(i,j) = efxa(i,j) * - coef * qgrid(k,l)*(xg-xim)/ rad1 c * - coef * qgrid(k,l)*(xg+xim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(xg-xim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(xg+xim)/ rad4/ 4.0d0 efya(i,j) = efya(i,j) * - coef * qgrid(k,l)*(yg-yim)/ rad1 c * - coef * qgrid(k,l)*(yg-yim)/ rad2/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad3/ 4.0d0 c * - coef * qgrid(k,l)*(yg+yim)/ rad4/ 4.0d0 endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Image charges for the wave guide geometry: cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iimage.eq.1.and.igeom.eq.3) then r1x(0) = xl r1y(0) = yl r2x(0) = xl r2y(0) = yl do 110 iw=1,nimage2 charge = -charge c Position of the image charge at the outer boundary (rmax): scale = dsqrt(r2x(iw-1)**2+r2y(iw-1)**2)/rmax if(scale.eq.0.0) goto 208 r1x(iw) = r2x(iw-1)/scale**2 r1y(iw) = r2y(iw-1)/scale**2 c Position of the image charge at the inner boundary (rmin): 208 scale = dsqrt(r1x(iw-1)**2+r1y(iw-1)**2)/rbound if(scale.eq.0.0) goto 108 r2x(iw) = r1x(iw-1)/scale**2 r2y(iw) = r1y(iw-1)/scale**2 rad11 = 1.0d0 rad12 = 1.0d0 rad13 = 1.0d0 rad14 = 1.0d0 rad21 = 1.0d0 rad22 = 1.0d0 rad23 = 1.0d0 rad24 = 1.0d0 if(r1x(iw).ne.xg.or.r1y(iw).ne.yg) * rad11 = (xg-r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.yg) * rad12 = (xg+r1x(iw))**2 + (yg-r1y(iw))**2 if(r1x(iw).ne.xg.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad13 = (xg-r1x(iw))**2 + (yg+r1y(iw))**2 if(r1x(iw).ne.0.0.or.xg.ne.0.0.or.r1y(iw).ne.0.0.or.yg.ne.0.0) * rad14 = (xg+r1x(iw))**2 + (yg+r1y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.yg) * rad21 = (xg-r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.yg) * rad22 = (xg+r2x(iw))**2 + (yg-r2y(iw))**2 if(r2x(iw).ne.xg.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad23 = (xg-r2x(iw))**2 + (yg+r2y(iw))**2 if(r2x(iw).ne.0.0.or.xg.ne.0.0.or.r2y(iw).ne.0.0.or.yg.ne.0.0) * rad24 = (xg+r2x(iw))**2 + (yg+r2y(iw))**2 c Calculate the Field of the image charges: efxa(i,j) = efxa(i,j) + * charge*coef*qgrid(k,l)* * ( * (xg-r1x(iw))/rad11 * + (xg+r1x(iw))/rad12 * + (xg-r1x(iw))/rad13 * + (xg+r1x(iw))/rad14 * + (xg-r2x(iw))/rad21 * + (xg+r2x(iw))/rad22 * + (xg-r2x(iw))/rad23 * + (xg+r2x(iw))/rad24 * )/ 4.0d0 efya(i,j) = efya(i,j) + * charge*coef*qgrid(k,l)* * ( * (yg-r1y(iw))/rad11 * + (yg-r1y(iw))/rad12 * + (yg+r1y(iw))/rad13 * + (yg+r1y(iw))/rad14 * + (yg-r2y(iw))/rad21 * + (yg-r2y(iw))/rad22 * + (yg+r2y(iw))/rad23 * + (yg+r2y(iw))/rad24 * )/4.0d0 110 continue endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 108 if(i.eq.ngrid2.and.j.eq.ngrid2) qgrid(k,l) = 0.0 107 continue 106 continue c Testing the image charge routine for the wave guide mode: c write(*,*) "T-f:",j, c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential field on the elliptical boundary: c write(*,*) "Test-f:", j, c * rtx*efxa(i,j)+rty*efya(i,j), c * rnx*efxa(i,j)+rny*efya(i,j), c * (rtx*efxa(i,j)+rty*efya(i,j))/(rnx*efxa(i,j)+rny*efya(i,j)) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Testing the tangential E-field on the circular boundary: c if(abs(xbound**2-xg**2-yg**2).lt.1.0e-12) then c write(*,*) "Image: ",xg,yg c write(*,*) (yg*efxa(i,j)-xg*efya(i,j))/ c * sqrt(xg**2+yg**2)/coef c endif c if(efya(i,j).ne.0.0) write(*,*) "Test: ", i, j, efya(i,j) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 105 continue 104 continue c Calculating the potential between the two conductors of the c wave guide geometry due to image charges: if(iimage.eq.1.and.igeom.eq.3) then voltx = 0.0d0 volty = 0.0d0 voltz = 0.0d0 do 203 i=0,ngrid2 if(i*xbound/ngrid2.lt.rbound) goto 203 if(i*xbound/ngrid2.gt.xbound) goto 203 voltx = voltx - elmass*xbound*efxa(i,0)/ngrid2/ el volty = volty - elmass*xbound*efya(0,i)/ngrid2/ el c voltz = voltz - c * elmass*xbound*(efxa(i,i)+efya(i,i))/ngrid2/el voltq = -el*qinner*log(xbound/rbound)/ * (2.0d0*pi*eta) 203 continue write(29,fmt='(5e25.5)') t, voltx, volty, voltq c write(*,*) c * "Voltage between boundaries: ",t,voltx,volty,voltq endif c Achtung! c Calculating the potential between the wire and the vacuum chmaber c for electrostatic field: if(iimage.eq.1.and.igeom.ne.3) then voltx = 0.0d0 volty = 0.0d0 voltz = 0.0d0 c Wire in the corner of the liner: do 204 i=ixq,ngrid2 if((sqrt(dble(i)**2+dble(iyq)**2)/ngrid2). * gt.1.0d0) goto 204 voltx = voltx-elmass*xbound*efxa(i,iyq)/ngrid2/el 204 continue do 205 i=iyq,ngrid2 if((sqrt(dble(ixq)**2+dble(i)**2)/ngrid2). * gt.1.0d0) goto 205 if(i*ymbound/ngrid2.gt.ymbound) goto 205 volty = volty-elmass*ymbound*efya(ixq,i)/ngrid2/el 205 continue cc Ploting the electrostatic field: c open(unit=77,file="efield.data",status='unknown') c c do 304 i=0,ngrid2 c do 305 j=0,ngrid2 c if((dble(i)/ngrid2)**2+(dble(j)/ngrid2)**2.gt.1.0d0) c * goto 305 c if(dble(j)*ymbound/ngrid2.gt.ymbound) goto 305 c write(77,*) dble(i)*xbound/ngrid2,dble(j)*ymbound/ngrid2, c * i, j c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17 c c rnorm = sqrt((efxa(i,j)*1.0d-17)**2+ c * (efya(i,j)*1.0d-17)**2) c rlx = 1.0e-4*(efxa(i,j)*1.0d-17)/ rnorm c rly = 1.0e-4*(efya(i,j)*1.0d-17)/ rnorm c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17+rly, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17-rlx c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17+rlx, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17+rly c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17-rly, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17+rlx c write(77,*) dble(i)*xbound/ngrid2 + efxa(i,j)*1.0d-17, c * dble(j)*ymbound/ngrid2 + efya(i,j)*1.0d-17 c write(77,*) c write(77,*) c 305 continue c 304 continue c do 301 i=1,80 c write(77,*) xbound*cos(pi*i/160), ybound*sin(pi*i/160) c 301 continue c close(unit=77) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc write(29,fmt='(5e25.5)') t, voltx, volty, voltq c write(*,*) c * "Voltage between boundaries: ",t,voltx,volty,voltq endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc end subroutine clean c purpose: eliminate indices for electrons with vanishing charge. implicit real*8 (a-h,o-z) c implicit integer (a-z) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer index(npelm) integer icount integer i, incount real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), * pz(npelm), py(npelm), px(npelm) real*8 ptime(npelm), esign(npelm) real*8 rtest common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / part2 / icount, icountact, iadele write(*,*)' in clean ' incount = 0 qlimit = 10.d0 do 101 i=1,icount if (q(i).lt.qlimit) then rtest=ran2(idum) if ((q(i)/qlimit).ge.rtest) q(i)=qlimit endif if (q(i).ge.qlimit) then incount = incount + 1 q(incount) = q(i) index(incount) = index(i) x(incount) = x(i) y(incount) = y(i) z(incount) = z(i) xp(incount) = xp(i) yp(incount) = yp(i) zp(incount) = zp(i) px(incount) = px(i) py(incount) = py(i) pz(incount) = pz(i) ptime(incount) = ptime(i) esign(incount) = esign(i) endif 101 continue do i = incount+1,icount q(i) = q(npelm) index(i) = index(npelm) end do icount = incount end c ---------------------------------------------------------- subroutine bin c purpose: bin charge distribution implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (ngrid = 500) c npelm - total maximum number of macroparticles (> product) real*8 x (npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), py(npelm) real*8 px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) integer index(npelm) real*8 xg(0:ngrid), yg(0:ngrid) real*8 charge(ngrid,ngrid) real*8 cxp(ngrid), cyp(ngrid) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 qacc common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / part / qacc common / part2 / icount, icountact, iadele common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c grid parameters xstep = 2.d0*xbound/real(ngrid) ystep = 2.d0*ybound/real(ngrid) xg(0) = - xbound yg(0) = - ybound do 10 j = 1, ngrid cxp(j) = 0.d0 cyp(j) = 0.d0 xg(j) = -xbound + real(j)*xstep yg(j) = -ybound + real(j)*ystep 10 continue do 11 j1 = 1, ngrid do 12 j2 = 1, ngrid charge(j1,j2) =0.d0 12 continue 11 continue do 13 i = 1, icount do 14 j1 = 1, ngrid if ((x(i).lt.xg(j1)).and.(x(i).ge.xg(j1-1))) then do 15 j2 = 1, ngrid if ((y(i).lt.yg(j2)).and.(y(i).ge.yg(j2-1))) then charge (j1,j2) = charge(j1,j2) + q(i) cxp (j1) = cxp(j1) + q(i) cyp (j2) = cyp(j2) + q(i) goto 90 endif 15 continue endif 14 continue 90 continue 13 continue open(19,file="charge.dat",status='unknown') open(20,file="proj.dat.seed",status='unknown') do 16 j1= 1, ngrid do 17 j2= 1, ngrid write(19,*) xg(j1), yg(j2), charge(j1,j2) 17 continue 16 continue do 18 j = 1, ngrid write(20,*) xg(j),yg(j),cxp(j),cyp(j) 18 continue close(19) close(20) end real*8 function gammaf(v) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 bfield, el, vl, fom, pi, re, elmass, v common / def2 / bfield, el, vl, fom, pi, re, elmass gammaf = 1.d0/sqrt(1.0d0-(v/vl)**2) return end c 18.06.1997 Oliver subroutine ebin c purpose: bin distribution of energy kicks. implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) c npelm - total maximum number of macroparticles (> product) real*8 x (npelm), y(npelm), z(npelm), q(npelm), t real*8 py(npelm), px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 max, min, estepe, estepv, maxv real*8 enbin(0:nbin), vbin(0:nbin) real*8 dele(npelm), qele(npelm) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 bfield, el, vl, fom, pi, re, elmass real*8 qacc common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / egain / dele, qele c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave ccccccccccccccccccccccccccccccccccccccccccccccc avenergy = 0.0d0 avvelocity = 0.0d0 inumetot = 0 inumvtot = 0 c max = 2000.0d0 max = 1000.0d0 min = 0.0 c maxv = maximum velocity/ c maxv = 0.1d0 estepe = (max-min)*el/ (nbin-1) estepv = maxv/ (nbin-1) do 100 i=0,nbin enbin(i) = 0.0d0 vbin(i) = 0.0d0 100 continue c Ploting the energy distribution: if(iadele.gt.npelm) iadele = npelm do 101 i=1,iadele if ((dele(i)/el).lt.max) then enbin(nint(dele(i)/estepe)) = * enbin(nint(dele(i)/estepe)) + * qele(i)/real(npepb) inumetot = inumetot + enbin(nint(dele(i)/estepe)) c write(*,*) "Test",i,sqrt(2*dele(i)/elmass)/1.0d4 endif 101 continue c Ploting the velocity distribution: do 111 i=1,iadele c write(*,*) "Test",i,dele(i),sqrt(2*dele(i)/el/0.511d6) if (sqrt(2*dele(i)/el/0.511d6)/estepv.lt.1.0*nbin) then vbin(nint(sqrt(2*dele(i)/el/0.511d6)/estepv)) = * vbin(nint(sqrt(2*dele(i)/el/0.511d6)/estepv)) + * qele(i)/real(npepb) inumvtot = inumvtot + * vbin(nint(sqrt(2*dele(i)/el/0.511d6)/estepv)) endif 111 continue open(33,file="energy.distr.data",status='unknown') open(34,file="velocity.distr.data",status='unknown') do 102 i=0,nbin write(33,*) i*estepe/el, enbin(i) write(34,*) i*estepv, vbin(i) avenergy = avenergy + enbin(i)*i*estepe/el avvelocity = avvelocity + vbin(i)*i*estepv 102 continue c write(*,*) "Average energy of the photo electrons:", c * avenergy/inumetot c write(*,*) "Average velocity of the photo electrons:", c * avvelocity/inumvtot close(33) close(34) close(44) c close(45) end subroutine ebin2(test,ipec,iunit,vmax,vmin) c purpose: bin an arbitrary distribution. implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) c npelm - total maximum number of macroparticles (> product) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 py(npelm), px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 vmax, vmin, estep real*8 enbin(0:nbin) real*8 dele(npelm), qele(npelm), test(npelm) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / egain / dele, qele c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave ccccccccccccccccccccccccccccccccccccccccccccccc c vmax = 100.0d0 c vmin = 0.0d0 estep = (vmax-vmin)/ (nbin-1) do 100 i=0,nbin enbin(i) = 0.0d0 100 continue c Ploting the energy distribution: if(ipec.gt.npelm) ipec = npelm do 101 i=1,ipec if ((test(i)).lt.vmax) then if(nint(test(i)/estep).gt.nbin) goto 101 enbin(nint(test(i)/estep)) = * enbin(nint(test(i)/estep)) + * qele(i)/real(npepb) c write(*,*) "Test",i,test(i) endif 101 continue do 102 i=0,nbin write(iunit,*) i*estep+vmin, enbin(i) 102 continue c close(iunit) end subroutine binx c purpose: bin the charge distribution and write the density to a file: implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) c npelm - total maximum number of macroparticles (> product) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 py(npelm), px(npelm), pz(npelm) real*8 ptime(npelm), esign(npelm) real*8 xbin(0:nbin), rbin(0:nbin) real*8 dele(npelm), qele(npelm) cccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 bfield, el, vl, fom, pi, re, elmass real*8 qacc real*8 rboundl common / part / qacc common / part2 / icount, icountact, iadele common / def2 / bfield, el, vl, fom, pi, re, elmass common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / egain / dele, qele c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / def1 / rbound, xbound, ybound, zbound, energy, belen common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc open(61,file="horiz.distr.data",status='unknown') open(62,file="radia.distr.data",status='unknown') rboundl = max(xbound,ybound) do 300 i=0,nbin xbin(i) = 0.0 rbin(i) = 0.0 300 continue c Bining the horizontal distribution: do 301 i=1,icount if(nint((nbin*x(i)/xbound+nbin)/2.0d0).gt.nbin) goto 301 xbin(nint((nbin*x(i)/xbound+nbin)/2.0d0)) = * xbin(nint((nbin*x(i)/xbound+nbin)/2)) + * q(i) c frank 12/11/99 remove: /real(npepb) c write(*,*) "Test-x",i,x(i) 301 continue c Bining the radial distribution: do 302 i=1,icount nindhg=nint(nbin*sqrt(x(i)**2+y(i)**2)/rboundl) if(nindhg.gt.nbin) goto 302 rbin(nindhg) = * rbin(nindhg) + * q(i) c frank 12/11/99 remove: /real(npepb) c write(*,*) "Test-r",i,x(i) 302 continue do 303 i=0,nbin if(xbin(i).ne.0.0d0) * write(61,*) (2.0d0*i/nbin-1.0d0)*xbound, xbin(i) if(rbin(i).ne.0.0d0) * write(62,*) i*rboundl/nbin, rbin(i) 303 continue close(61) close(62) end real*8 function ran2(idum) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c The Function Returns a Uniform Random Number between 0.0 and 1.0. c c The Function uses a 'Subtractive Method'!!! c c Set 'idum' to a negative value to initialize or reinitialize the Sequence. c c (Numerical Recipies ran3(idumy), pg. 273.) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer idum integer mbig, mseed, mz real*8 fac parameter(mbig=1000000000,mseed=161803398,mz=0,fac=1.0d0/mbig) integer i, iff, ii, inext, inextp, k integer mj, mk, ma(55) save iff, inext, inextp, ma data iff /0/ c Initialization: if(idum.lt.0.or.iff.eq.0) then iff = 1 mj = mseed-iabs(idum) mj = mod(mj,mbig) mk = 1 do 11 i=1,54 ii = mod(2*i,55) ma(ii) = mk mk = mj - mk if(mk.lt.mz) mk = mk + mbig mj = ma(ii) 11 continue do 13 k=1,4 do 12 i=1,55 ma(i) = ma(i) - ma(1+mod(i+30,55)) if(ma(i).lt.mz) ma(i) = ma(i) + mbig 12 continue 13 continue inext = 0 inextp = 31 idum = 1 end if inext = inext + 1 if(inext.eq.56) inext = 1 inextp = inextp + 1 if(inextp.eq.56) inextp = 1 mj = ma(inext) - ma(inextp) if(mj.lt.mz) mj = mj + mbig ma(inext) = mj ran2 = mj * fac return end subroutine dist(ampl,xx,yy,jw) ********************************************************* * * * Calculate the distance between wire and a particle. * * * ********************************************************* integer k, jw real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 tmp, ampl real*8 xx,yy common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ampl=10.0d0 jw=1 do 111 k=1,6 tmp=((xx-x0r(k))*(xx-x0r(k))+(yy-y0r(k))*(yy-y0r(k))) tmp=tmp/rbound6/rbound6 ampl=min(ampl,tmp) if(tmp.eq.ampl) jw = k 111 continue return end subroutine ebinw(binwe, wen, qw) c purpose: bin energy distribution of the electron that c hit the wall. implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binwe(0:500), wen, qw ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc vmax = 250.0d0 vmin = 0.0d0 estep = (vmax-vmin)/(nbin-1) wenmax = dmax1(wen,wenmax) if (wen.gt.vmax) then if (wen.lt.deltaemax) then wen1 = wen1+qw*wen qne1 = qne1+qw else wen2 = wen2+qw*wen qne2 = qne2 + qw endif endif k=nint(wen/estep) if (wen.lt.vmax) then if(k.gt.nbin.or.k.lt.0) then goto 101 endif binwe(k) = binwe(k) + qw endif 101 continue end subroutine ebinwnew(binwe, wen, qw) c purpose: bin energy distribution of the electron that c hit the wall. implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binwe(0:500), wen, qw ccccccccccccccccccccccccccccccccccccccc c frank 22.7.1999 common / enemax / deltaemax, wen1, wen2, wenmax,sigmal,rcrit common / enemax2 / qne1, qne2 cccccccccccccccccccccccccccccccccccccccccccc vmax = 250.0d0 vmin = 0.0d0 estep = (vmax-vmin)/(nbin-1) wenmax = dmax1(wen,wenmax) if (wen.gt.vmax) then if (wen.lt.deltaemax) then wen1 = wen1+qw*wen qne1 = qne1+qw else wen2 = wen2+qw*wen qne2 = qne2 + qw endif endif k=nint(wen/estep) if (wen.lt.vmax) then if(k.gt.nbin.or.k.lt.0) then goto 101 endif binwe(k) = binwe(k) + qw endif 101 continue end subroutine ebinwphi(binwephi,binweph2,wen,qw,x,y) c purpose: bin azimuthal distribution of the heat load c on the wall implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binweph2(0:500) real*8 binwephi(0:500), wen, qw, x, y real*8 bfield, el, vl, fom, pi, re, elmass common / def2 / bfield, el, vl, fom, pi, re, elmass ccccccccccccccccccccccccccccccccccccccc vmax = 2.*pi vmin = 0.0 phistep = (vmax-vmin)/(nbin-1) if (dabs(x).gt.1.e-20) then phi = datan2(y,x) else if (y.gt.0.d0) then phi = pi/2. else phi = 3.*pi/2. endif if (phi.lt.0) then phi = phi+2.*pi endif k=nint(phi/phistep) if (k.le.nbin.and.k.ge.0) then binwephi(k) = binwephi(k) + wen*qw binweph2(k) = binweph2(k) + qw else binwephi(nbin) = binwephi(nbin) + wen*qw binweph2(nbin) = binweph2(nbin) + qw endif 101 continue end subroutine ebinwx(binwex,binwex2,binwex3,wen,qw,x,y) c purpose: bin x distribution of the heat load c on the wall implicit real*8 (a-h,o-z) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter (nbin = 500) ccccccccccccccccccccccccccccccccccccccccccccccc integer k real*8 binwex(0:500), binwex3(0:500) real*8 binwex2(0:500), wen, qw, x, y real*8 bfield, el, vl, fom, pi, re, elmass common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen ccccccccccccccccccccccccccccccccccccccc vmax = xbound vmin = -xbound xstep = vmax/real(nbin) k=nint(abs(x)/xstep) if (k.le.nbin.and.k.ge.0) then binwex(k) = binwex(k) + wen*qw binwex2(k) = binwex2(k) + qw if (wen.gt.30) then binwex3(k) = binwex3(k) + qw endif c else c binwex(nbin) = binwex(nbin) + wen*qw c binwex2(nbin) = binwex2(nbin) + qw endif 101 continue end subroutine spacecharge2 c fixed several bugs of previous version c 29.08.99 frankz c purpose: New space charge routine that uses a two dimensional Mesh c for the field calculation and allows the evaluation of the c effect of image charges on the boundary. c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,ngrid2=10,nimage=50,nimage2=4, & ngridffts=32) 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 Daniel: c significant increase in speed 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 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 voltx, volty real*8 rmax, rmin real*8 rm0 real*8 rphi, rphi0, rphi1, rphi2, rphi3 real*8 xl, yl real*8 denscenter c complex*16 datafft (ngridffts/2,ngridffts,1) integer nnfft(3) integer nnfft1,nnfft2,nnfft3,isign complex*16 speq(ngridffts/2,ngridffts) real*8 ukl (ngridffts/2,ngridffts) real*8 xr(20) c Complex variables for the calculation of the elliptical coordinates: complex*16 z1, z2, z3, z4, zi, zone complex*16 efz1(0:ngrid2,0:ngrid2), efz complex*16 zeric,zdiv,zr,zri,zzr,zzri data first /1/ save first common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / image / iimage, iimageb, interspace, igeom common / beam / rg, rm1 common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 common / center / denscenter c scd if (ifirst.eq.1) then do i=-ngrid2,ngrid2 do j=-ngrid2,ngrid2 iff(j,i)=0 end do end do ifirst=0 endif ccccccccccccccccccccccccccccccccccccccccccccccc c c parameter for avoiding zero charge and grid points epsi=1.d-5 c 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 do i=1,100 c x(i)=0.98*xbound*cos(2.0*acos(-1.0)*i*0.01) c y(i)=0.98*xbound*sin(2.0*acos(-1.0)*i*0.01) c q(i)=100.0 c end do c icount=100 if (igeom.ne.4) then do 103 i=1,icount c c frank: i do not understand the abs( ) - correct for quads? c c scd make inspired guess of what was meant c linx = nint(ngrid2*x(i)/xbound) liny = nint(ngrid2*y(i)/ymbound) c linx = nint(ngrid2*abs(x(i))/xbound) c liny = nint(ngrid2*abs(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 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 if(rl1.gt.rolimit) goto 331 c write(*,*) " to : ",linx,liny endif c write(*,*) ' i = ',i c Avoiding charges which are inside the inner conductor for the c image charge calculation with a wave guide geometry: rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit.and.igeom.eq.3.and.iimage.eq.1) then c write(*,*) "Changing the mesh position 2 from: ",linx,liny 332 if(linx.le.nint(ngrid2*rbound/xbound)) linx = linx + 1 if(liny.le.nint(ngrid2*rbound/ymbound)) liny = liny + 1 if(linx.gt.ngrid2) linx = ngrid2 - 1 if(liny.gt.ngrid2) liny = ngrid2 - 1 rl1 = (dble(linx)*xbound/dble(ngrid2)/rbound)**2 + * (dble(liny)*ymbound/dble(ngrid2)/rbound)**2 if(rl1.lt.rilimit) goto 332 c write(*,*) " to : ",linx,liny endif if(abs(linx).le.ngrid2.and.abs(liny).le.ngrid2) then qgrid(linx,liny) = qgrid(linx,liny) + q(i) endif 103 continue ind0 = 0 denscenter = qgrid(ind0,ind0)/(deltaxx*deltayy*belen) endif 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: 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 scd 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 force(k,l,i,j)=complex(dreal(efz),dreal(-efz*zi)) force(k,l,i,j)=efz efz=efz*charge*const tx=dreal(efz) ty=dreal(-efz*zi) iff(k,l)=1 else 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 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 c stop end subroutine offsetkick(j,dkickx,dkicky,yoff,xoff) c purpose: calculates kick on next bunch from disturbed photoelectrons c growth rate is deduced from this kick using Alex Chao's formula c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: parameter (npelm=600000,iybin=500,ngrid=500,ngrid2=10) c frank new parameter for bunch index field, nov 99 parameter (nbmax = 1000) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm),yp(npelm),zp(npelm),py(npelm),pz(npelm) real*8 px(npelm), dele(npelm), qele(npelm) real*8 ptime(npelm), esign(npelm) real*8 xpt, ypt, zpt, pxt, pyt, pzt integer index(npelm) real*8 rad(0:ngrid), crg(0:ngrid), efield(0:ngrid) real*8 rg, rm1 c oliver 23.6.197:cccccccccccccccccc real*8 bweight(50000) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 rbound, xbound, ybound, zbound, energy, belen real*8 bfield, el, vl, fom, pi, re, elmass real*8 ppb, bl, sb, sx, sy real*8 circum real*8 volt, qouter, qinner real*8 wgl, wk, vtem, vtem0 real*8 voltx, volty real*8 qacc real*8 xt, yt integer iscatter common / bunch / bweight ccccccccccccccccccccccccccccccccccccccccccccccc c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / def4 / circum common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / space / rad, crg, efield common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c Oliver 18.06.1997: common / egain / dele, qele ccccccccccccccccccccccccccccc c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave c 01.07.1997 Oliver: adding an TEM field: common / def9 / wgl, wk, vtem, vtem0 ccccccccccccccccccccccccccccccccccccccccccccccc common / beam / rg, rm1 common / immage / iimage, iimageb, interspace, igeom common / wgvolt / voltx, volty common / delay / iscatter c Achtung! npstep = 1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc write(*,*) ' off = ',xoff,yoff factor = ppb * re * vl & * sqrt(2.0d0*pi) if (iscatter.eq.1) then factor = - factor endif c not generating new photoelectrons here rp = 1.4d-18 dt = bl/vl dtex = bl/vl/real(nostep) t = t + dt if (ibend.eq.5) then a1 = (dtex-1.d0/fom*sin(fom*dtex))/fom a2 = 1.d0 a3 = (1.d0-cos(fom*dtex))/fom a4 = sin(fom*dtex)/fom b1 = (1.d0-cos(fom*dtex))/fom**2 b2 = 1.d0 b3 = sin(fom*dtex)/fom b4 = (cos(fom*dtex)-1.)/fom c1 = (1.d0-cos(fom*dtex))/fom c2 = sin(fom*dtex) c3 = cos(fom*dtex) d1 = sin(fom*dtex)/fom d2 = cos(fom*dtex) d3 = -sin(fom*dtex) endif dkickx = 0.d0 dkicky = 0.d0 do 10 ib = 1, nostep do 11 i = 1, icount if (index(i).eq.0.and.(q(i).gt.0)) then xt = x(i) yt = y(i) zt = z(i) xpt = xp(i) ypt = yp(i) zpt = zp(i) c py is momentum/mass velt = sqrt(ypt*ypt+xpt*xpt+zpt*zpt) pyt = gammaf(velt)*ypt pxt = gammaf(velt)*xpt pzt = gammaf(velt)*zpt c space charge if (ispace.eq.1) then radi = sqrt(xt*xt+yt*yt) do 12 j1 = 1, ngrid if (radi.lt.rad(j1)) then c 19.08.1997 Oliver: Changing the interpolation routine. c Frank: c ef = efield(j1-1)+(radi-rad(j1))/ c & (rad(j1)-rad(j1-1))*efield(j1) c Oliver: ef = efield(j1-1)+(radi-rad(j1-1))/ & (rad(j1)-rad(j1-1))*(efield(j1)-efield(j1-1)) goto 200 endif 12 continue ef = 0. 200 continue dpx = xt/radi*ef*dtex dpy = yt/radi*ef*dtex c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.0.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) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 if(indx.gt.ngrid2.or.indx.lt.-ngrid2.or. * indy.gt.ngrid2.or.indy.lt.-ngrid2) then q(i)=0. goto 1201 endif c Bivariate linear Interpolation: if(indx.ne.ngrid2.and.indy.ne.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif dpx = sign(efx3,xt)*dtex dpy = sign(efy3,yt)*dtex 1201 continue c end space charge c Achtung! c the motion in the longitudinal and horizontal plane is neglected c for a bending field: if (ibend.eq.0.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 (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 (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 (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 (igeom.eq.4) then amp = dmax1(dabs(x(i))/xbound,dabs(y(i))/zbound) endif if (amp.gt.1.and.iloss.eq.1) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qouter = qouter - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qouter = qouter + qtnew endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 01.07.1997: Introducing the boundary of the inner wave guide. c Inner tube boundary with sec. emission of the wave guide mode: if (amp2.le.1.and.iloss.eq.1.and.iwave.eq.1) then xt = x(i) yt = y(i) xpt = xp(i) ypt = yp(i) zt = z(i) zpt = zp(i) qt = q(i) qacc = qacc - qt qinner = qinner - qt call seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,1,1) xp(i) = xpt yp(i) = ypt zp(i) = zpt x(i) = xt y(i) = yt z(i) = zt q(i) = qt qacc = qacc + qt qinner = qinner + qtnew endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 18.06.1997: setting the energy increase to zero once a particle is lost. if (q(i).eq.0.0) dele(i) = 0.0 if (q(i).eq.0.0) qele(i) = 0.0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 11 continue 10 continue end subroutine spacecharge3 c fixed several bugs of previous version c 29.08.99 frankz c purpose: New space charge routine that uses a two dimensional Mesh c for the field calculation and allows the evaluation of the c effect of image charges on the boundary. c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,ngrid2=10,nimage=50,nimage2=4) parameter(eta=8.8542d-12) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c npelm - total maximum number of macroparticles (> product) real*8 rolimit, rilimit parameter(rolimit=0.97d0,rilimit=1.02d0) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 px(npelm), pz(npelm), py(npelm) real*8 ptime(npelm), esign(npelm) real*8 efxa(-ngrid2:ngrid2,-ngrid2:ngrid2), * efya(-ngrid2:ngrid2,-ngrid2:ngrid2), * qgrid(-ngrid2:ngrid2,-ngrid2:ngrid2) real*8 r1x(0:nimage2),r1y(0:nimage2),r2x(0:nimage2),r2y(0:nimage2) real*8 rg, rm1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real*8 qacc real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinx(0:500), webinx2(0:500), webinx3(0:500) real*8 volt, qouter, qinner real*8 voltx, volty real*8 rmax, rmin real*8 rm0 real*8 rphi, rphi0, rphi1, rphi2, rphi3 real*8 xl, yl c Complex variables for the calculation of the elliptical coordinates: complex*16 z1, z2, z3, z4, zi, zone complex*16 efz1(0:ngrid2,0:ngrid2), efz complex*16 zeric,zdiv,zr,zri,zzr,zzri common / def2 / bfield, el, vl, fom, pi, re, elmass common / def1 / rbound, xbound, ybound, zbound, energy, belen common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele common / dcfield / volt, qouter, qinner common / space2 / efxa, efya, qgrid c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave common / image / iimage, iimageb, interspace, igeom common / beam / rg, rm1 common / wgvolt / voltx, volty common / wavguid6 / x0r, y0r, rbound6, webin, webinphi common / wavguid7 / webinph2, webinn common / wavgui17 / webinx, webinx2, webinx3 ccccccccccccccccccccccccccccccccccccccccccccccc c c parameter for avoiding zero charge and grid points epsi=1.d-5 write(*,*) ' enter sc 3 ' 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) if(indx*xbound/real(ngrid2).gt.xt) indx = indx - 1 if(indx*xbound/real(ngrid2).lt.xt) indx = indx + 1 if(indy*ymbound/real(ngrid2).gt.yt) indy = indy - 1 if(indy*ymbound/real(ngrid2).lt.yt) indy = indy + 1 c Bivariate linear Interpolation: efx1=0. efx2=0. efx3=0. efy1=0. efy2=0. efy3=0. if(abs(indx).lt.ngrid2.and.abs(indy).lt.ngrid2) then efx1 = ((xt-indx*xbound/ngrid2) * efxa(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy) ) * * real(ngrid2)/xbound efx2 = ((xt-indx*xbound/ngrid2)*efxa(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efxa(indx,indy+1)) * * real(ngrid2)/xbound efx3 = ((yt-indy*ymbound/ngrid2) * efx2 + * ((indy+1)*ymbound/ngrid2-yt) * efx1 ) * * real(ngrid2)/ymbound efy1 = ((xt-indx*xbound/ngrid2) * efya(indx+1,indy) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy)) * * real(ngrid2)/xbound efy2 = ((xt-indx*xbound/ngrid2)*efya(indx+1,indy+1) + * ((indx+1)*xbound/ngrid2-xt)*efya(indx,indy+1)) * * real(ngrid2)/xbound efy3 = ((yt-indy*ymbound/ngrid2) * efy2 + * ((indy+1)*ymbound/ngrid2-yt) * efy1) * * real(ngrid2)/ymbound endif c frank e-field c radxtyt = sqrt(xt*xt+yt*yt) c field in V/m c efieldmag = 1.e6 c domegaf = 1.e10 c efmag = sqrt(1.-radxtyt**2/xbound**2)*efieldmag*sin(domegaf*t) c dpx = dpx + efmag*(xt/radxtyt) c dpy = dpy + efmag*(yt/radxtyt) c endif c end space charge efx3 = efx3*5.7e-12 efy3 = efy3*5.7e-12 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 complax fast c fourier transformas two complex arrays: c on output, data contains the zero and positive frequency values c of the 1st frequency component, while speq contains the Nyquist c critical frequency values for the 1st frequency component. c second and third frequency components are stored in standard c wrap-around order. For isign=-1 inverse transform is calculated c (times nn1*nn2*nn3/2 as multiplicative factor). c nn1,nn2,and nn3 must always be multiples of 2. integer i1,i2,i3,j1,j2,j3,nn(3) real*8 theta,wi,wpi,wpr,wr,wtemp complex*16 c1,c2,h1,h2,w write(*,*) ' in rlft3 ' write(*,*) ' nn1 =',nn1 write(*,*) ' nn2 =',nn2 write(*,*) ' nn3 =',nn3 write(*,*) ' isign =',isign do j = 1, nn2 do i = 1, nn1/2 c if (data1(i,j,1).ne.(0.,0.)) then c write(*,*) i,j,data1(i,j,1) c endif end do end do c1 = cmplx(0.5,0.) c2 = cmplx(0.0,-0.5*isign) theta=6.28318530717959d0/dble(isign*nn1) wpr=-2.0d0*sin(0.5d0*theta)**2 wpi=dsin(theta) nn(1) = nn1/2 nn(2) = nn2 nn(3) = nn3 if(isign.eq.1) then call fourn(data1,nn,3,isign) do 12 i3=1,nn3 do 11 i2=1,nn2 speq(i2,i3)=data1(1,i2,i3) 11 end do 12 end do endif do 15 i3=1,nn3 j3=1 if(i3.ne.1) j3=nn3-i3+2 wr=1.0d0 wi=0.0d0 do 14 i1=1,nn1/4+1 j1=nn1/2-i1+2 do 13 i2=1,nn2 j2=1 if(i2.ne.1) j2=nn2-i2+2 if(i1.eq.1)then h1=c1*(data1(1,i2,i3)+conjg(speq(j2,j3))) h2=c2*(data1(1,i2,i3)-conjg(speq(j2,j3))) data1(1,i2,i3)=h1+h2 speq(j2,j3)=conjg(h1-h2) else h1=c1*(data1(i1,i2,i3)+conjg(data1(j1,j2,j3))) h2=c2*(data1(i1,i2,i3)-conjg(data1(j1,j2,j3))) data1(i1,i2,i3)=h1+w*h2 data1(j1,j2,j3)=conjg(h1-w*h2) endif 13 end do wtemp=wr wr=wr*wpr-wi*wpi+wr wi=wi*wpr+wtemp*wpi+wi w=cmplx(wr,wi) 14 end do 15 end do if (isign.eq.-1) then call fourn(data1,nn,3,isign) endif write(*,*) ' end of rlft3 ' do j = 1, nn2 do i = 1, nn1/2 c if (data1(i,j,1).ne.(0.,0.)) then c write(*,*) i,j,data1(i,j,1) c endif end do end do return end c---------------------------------------------------------- c This program calculates the beam-beam-kick with image charges for c an elliptical boundary. c c 25.08.99 FZ, include offset xof, yof for correct treatment c of image charges c subroutine foliver(x,y,xof,yof,sx,sy,rg,rm1,fr,fi) implicit real*8 (a-h,o-z) c implicit integer (a-z) parameter(nimage=30) double precision xt,yt real*8 x,y,sx,sy,rg,rm1,fr,fi, efx, efy, r2 complex*16 zone, zi, z1, z2, z3, z4, efz complex*16 z1b, z2b, z3b, z4b charge = 1.0d0 zone = (1.0d0,0.0d0) zi = (0.0d0,1.0d0) c new variables dx = x-xof dy = y-yof c xt = abs(dx) yt = abs(dy) if (xt.lt.(1d-7)) xt=1.d-7 if (yt.lt.(1d-7)) yt=1.d-7 r2 = xt*xt+yt*yt r = dsqrt(r2) c write(*,*) ' in foliver ',dx,dy,sx,sy,rg,rm1 c write(*,*) xof,yof,x,y rg pi = acos(-1.0d0) res = 2.0d0/sqrt(2.0d0*pi)/r2 resmod = 2./sqrt(2.*pi) sx1 = sx sy1 = sy if (abs((sx/sy)-1.0d0).lt.1.0d-2) then 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.) return co1 = (1.0d0-exp(-r2/(2.0d0*sx*sy/100.))) frc = res*co1*yt*(dy/yt) fic = res*co1*xt*(dx/xt) if(r2.gt.sx*sy/100.) then efx = dx/ r2 efy = dy/ r2 efz = efx * zone + efy * zi z1 = x/rg * zone + y/rg * zi z2 = x/rg * zone - y/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 c introduce the same quantities for the beam z1b = xof/rg * zone + yof/rg * zi z2b = xof/rg * zone - yof/rg * zi z3b = cdlog(z1b - cdsqrt(z1b**2 - zone)) z4b = cdlog(z2b - cdsqrt(z2b**2 - zone)) rmib = dabs(dreal(z3b+z4b)/2.0d0) rphib = dreal((z4b-z3b)*zi)/2.0d0 if(rphi*y.lt.0.0d0) rphi = -rphi if(rphib*yof.lt.0.0d0) rphib = -rphib do 100 i=1,nimage charge = 1.0d0 if ((xof.eq.0.0).and.(yof.eq.0.0)) then efz = efz+((-1)**i)* * 8.0d0*charge/(dexp(4.0d0*i*rm1)+1.0d0) * * (cdexp(2.0d0*i*(rmi*zone-rphi*zi)) - * cdexp(-2.0d0*i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi)) - * cdexp(-(rmi*zone-rphi*zi)))/ rg else efz = efz+2.d0*charge*dexp(-i*rm1)*( * (dexp(i*rmib)+dexp(-i*rmib))* * cos(i*rphib)/(dexp(i*rm1)+dexp(-i*rm1))+ * zi*(dexp(i*rmib)-dexp(-i*rmib))* * sin(i*rphib)/(dexp(i*rm1)-dexp(-i*rm1)))* * (cdexp(i*(rmi*zone-rphi*zi))- * cdexp(-i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi))- * cdexp(-(rmi*zone-rphi*zi)))/rg endif 100 continue efx = dreal(efz) efy = dreal(-efz*zi) fi = fi+efx*2.0d0/sqrt(2.0d0*pi)-fic fr = fr+efy*2.0d0/sqrt(2.0d0*pi)-frc return endif 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 den = sqrt((40.*sx)**2+r*r) w1 = 40.*sx/den 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. if(r2.gt.sx*sy/100.) then efx = dx/ r2 efy = dy/ r2 efz = efx * zone + efy * zi z1 = x/rg * zone + y/rg * zi z2 = x/rg * zone - y/rg * zi z3 = cdlog(z1 - cdsqrt(z1**2 - zone)) z4 = cdlog(z2 - cdsqrt(z2**2 - zone)) rmi = dabs(dreal(z3+z4)/2.0d0) rphi = dreal((z4-z3)*zi)/2.0d0 c introduce the same quantities for the beam z1b = xof/rg * zone + yof/rg * zi z2b = xof/rg * zone - yof/rg * zi z3b = cdlog(z1b - cdsqrt(z1b**2 - zone)) z4b = cdlog(z2b - cdsqrt(z2b**2 - zone)) rmib = dabs(dreal(z3b+z4b)/2.0d0) rphib = dreal((z4b-z3b)*zi)/2.0d0 if(rphi*y.lt.0.0d0) rphi = -rphi if(rphib*yof.lt.0.0d0) rphib = -rphib do 101 i=1,nimage charge = 1.0d0 if ((xof.eq.0.0).and.(yof.eq.0.0)) then efz = efz+((-1)**i)* * 8.0d0*charge/(dexp(4.0d0*i*rm1)+1.0d0) * * (cdexp(2.0d0*i*(rmi*zone-rphi*zi)) - * cdexp(-2.0d0*i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi)) - * cdexp(-(rmi*zone-rphi*zi)))/ rg else efz = efz+2.d0*charge*dexp(-i*rm1)*( * (dexp(i*rmib)+dexp(-i*rmib))* * cos(i*rphib)/(dexp(i*rm1)+dexp(-i*rm1))+ * zi*(dexp(i*rmib)-dexp(-i*rmib))* * sin(i*rphib)/(dexp(i*rm1)-dexp(-i*rm1)))* * (cdexp(i*(rmi*zone-rphi*zi))- * cdexp(-i*(rmi*zone-rphi*zi)))/ * (cdexp((rmi*zone-rphi*zi))- * cdexp(-(rmi*zone-rphi*zi)))/rg endif 101 continue efx = dreal(efz) efy = dreal(-efz*zi) firs = efx*2.0d0/sqrt(2.0d0*pi) frrs = efy*2.0d0/sqrt(2.0d0*pi) co1 = (1.0d0-exp(-r2/(2.0d0*sx*sy/100.))) frr = res*co1*yt *(dy/yt) fir = res*co1*xt *(dx/xt) frc = frrs-frr fic = firs-fir endif c arg = sqrt(sx*sy)/5. c if (r.lt.arg) then c fr = fr1 c fi = fi1 c else fr = w1 * fr1 + w2 * fr2 + frc fi = w1 * fi1 + w2 * fi2 + fic c endif return endif c write(*,*) "Message from foliver: The beams are not round!" end c---------------------------------------------------------- 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 - atempt 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) c new variables dx = x-xof dy = y-yof c xt = abs(dx) yt = abs(dy) if (xt.lt.(1d-7)) xt=1.d-7 if (yt.lt.(1d-7)) yt=1.d-7 r2 = xt*xt+yt*yt r = dsqrt(r2) c write(*,*) ' in foliver ',dx,dy,sx,sy,rg,rm1 c write(*,*) xof,yof,x,y 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) if(r2.le.sx*sy/100.) return co1 = (1.0d0-exp(-r2/(2.0d0*sx*sy/100.))) frc = res*co1*yt*(dy/yt) fic = res*co1*xt*(dx/xt) if(r2.gt.sx*sy/100.) then dya = y-(2.*ymbound-yof) dyb = y-(-2*ymbound-yof) c dyc = y-(4.*ymbound+yof) c dyd = y-(-4*ymbound+yof) ra = (xt*xt+dya*dya) rb = (xt*xt+dyb*dyb) efx = dx/ r2 efy = dy/ r2 - dya/ra - dyb/rb fi = fi+efx*2.0d0/sqrt(2.0d0*pi)-fic fr = fr+efy*2.0d0/sqrt(2.0d0*pi)-frc return endif 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 den = sqrt((40.*sx)**2+r*r) w1 = 40.*sx/den 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. if(r2.gt.sx*sy/100.) then dya = y-(2.*ymbound-yof) dyb = y-(-2*ymbound-yof) c dyc = y-(4.*ymbound+yof) c dyd = y-(-4*ymbound+yof) ra = (xt*xt+dya*dya) rb = (xt*xt+dyb*dyb) efx = dx/ r2 efy = dy/ r2 - dya/ra - dyb/rb firs = efx*2.0d0/sqrt(2.0d0*pi) frrs = efy*2.0d0/sqrt(2.0d0*pi) co1 = (1.0d0-exp(-r2/(2.0d0*sx*sy/100.))) frr = res*co1*yt*(dy/yt) fir = res*co1*xt*(dx/xt) frc = frrs-frr fic = firs-fir endif c arg = sqrt(sx*sy)/5. c if (r.lt.arg) then c fr = fr1 c fi = fi1 c else fr = w1 * fr1 + w2 * fr2 + frc fi = w1 * fi1 + w2 * fi2 + fic c endif return endif c write(*,*) "Message from foliver: The beams are not round!" end c---------------------------------------------------------- subroutine ffrank(x,y,xof,yof,sx,sy,fr,fi) c 25.08.99 FZ, include offset xof, yof to be c consistent with foliver implicit real*8 (a-h,o-z) c implicit integer (a-z) double precision sx1,sy1,xt,yt real*8 x,y,sx,sy,fr,fi pi = 4.*datan(1.0d0) xt = abs(x-xof) yt = abs(y-yof) r = sqrt(xt*xt+yt*yt) resmod = 2./sqrt(2.*pi) c if (r.gt.(10.0d0*sx)) then pi = 4.0d0*atan(1.0d0) res = 2.0d0/sqrt(2.0d0*pi)/(r*r) sx1 = sx sy1 = sy if (abs((sx/sy)-1.0d0).lt.1.0d-2) then co = (1.0d0-exp(-r*r/(2.0d0*sx1*sy1))) fr = res*co*yt*(dy/yt) fi = res*co*xt*(dx/xt) return else c flat beam 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 den = sqrt((40.*sx)**2+r*r) w1 = 40.*sx/den w2 = 1./den fr = w1 * fr1 + w2 * fr2 fi = w1 * fi1 + w2 * fi2 return endif end c---------------------------------------------------------- c Oliver 30.06.1997 c This program calculates the kick from a TEM wave c excited in a coaxial transmission line. subroutine tem(x,y,wk,time,length,fr,fi) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 xt,yt real*8 x,y,fr,fi,wk,time,length real*8 vl parameter(vl=2.9889d8) xt = abs(x) yt = abs(y) r = sqrt(xt*xt+yt*yt) if(r.ne.0.0d0) then vcos = x/r vsin = y/r c pi = 4.0d0*atan(1.0d0) pi = acos(-1.0d0) fi = sin(2*pi*mod(wk*vl*time/length,1.0d0))/r c fi = 1.0d0/r fr = -vsin * fi fi = -vcos * fi endif if(r.eq.0.0d0) then fr = 0.0d0 fi = 0.0d0 endif c write(*,*) "TEM: ",mod(wk*vl*time/length,1.0d0),fi,1.0d0/r return end c---------------------------------------------------------- c Oliver 30.06.1997 c This program calculates the kick from a TEM wave c excited in a coaxial transmission line. subroutine tem6(x,y,wk,time,length,rout,fr,fi,vt0) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 xt,yt,vt0 real*8 x,y,fr,fi,ftmp,wk,time,length real*8 vl,ftmp1 real*8 rr(6), ri(6), x0r(6), y0r(6), vcosr(6), vsinr(6) real*8 x0i(6), y0i(6), rbound6, webin(0:500), webinn(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 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 xt = abs(x) yt = abs(y) r = dsqrt(xt*xt+yt*yt) pi = 4.*datan(1.d0) fr = 2./(sy*(sx+sy)) / sqrt(2.*pi) * & yt fi = 2./(sx*(sx+sy)) / sqrt(2.*pi) * & xt return end c--------------------------------------------------------- c this routine converts into the first quadrant c and then calls Tong's/Talman's programs c subroutine bbkick(pre1,pre2,pim1,pim2,x,y,sx,sy) implicit double precision(a-h,o-z) fac = dsqrt(2.d0*(sx**2-sy**2)) r = sy/sx u = x v = y c u = x / fac c v = y / r / fac u1 = dabs(u) v1 = dabs(v) u1a = u1 / fac v1a = v1 / fac call errf(u1a,v1a,wr1,wi1) u1b = u1 / fac * r v1b = v1 / fac / r call errf(u1b,v1b,wr2,wi2) pre1 = wr1 pre2 = wr2 pim1 = wi1 pim2 = wi2 goto 900 texp1 = 2.d0*dexp(-u**2+(r*v)**2) texp2 = 2.d0*dexp(-(r*u)**2+v**2) arguvr = 2.d0*u*r*v if(u.gt.0.and.v.gt.0)then call fbbclc(wr1,wr2,wi1,wi2,u,v,r) pre1 = wr1 pre2 = wr2 pim1 = wi1 pim2 = wi2 else if(u.gt.0.and.v.lt.0)then call fbbclc(wr1,wr2,wi1,wi2,u,-v,r) pre1 = texp1*dcos(arguvr)-wr1 pre2 = texp2*dcos(arguvr)-wr2 pim1 = texp1*dsin(arguvr)+wi1 pim2 = texp2*dsin(arguvr)+wi2 else if(u.lt.0.and.v.gt.0)then call fbbclc(wr1,wr2,wi1,wi2,-u,v,r) pre1 = wr1 pre2 = wr2 pim1 = -wi1 pim2 = -wi2 else if(u.lt.0.and.v.lt.0)then call fbbclc(wr1,wr2,wi1,wi2,-u,-v,r) pre1 = texp1*dcos(arguvr)-wr1 pre2 = texp2*dcos(arguvr)-wr2 pim1 = -texp1*dsin(arguvr)-wi1 pim2 = -texp2*dsin(arguvr)-wi2 endif 900 continue end c c #################################################################### c c 2 2 2 c -(1-r )(v +u ) c f(u,v,r) = w(u+irv) - e w(ru+iv) c c #################################################################### c subroutine fbbclc(wr1,wr2,wi1,wi2,u,v,r) implicit double precision(a-h,o-z) call errf(u,r*v,wr1,wi1) call errf(r*u,v,wr2,wi2) arg=(1.0-r*r)*(v*v+u*u) if(arg.gt.100.) then arg = 100. wr2 = 0.0 wi2 = 0.0 endif expon=exp(-arg) c fr=wr1-expon*wr2 fi=wi1-expon*wi2 return end c c fnctnw.fortran c c this program evaluates the function w(z) c (where z = zr + zi) in the first quadrant of c the complex plane (i.e. zr > 0 and zi > 0). c three different expressions, pade1, pade2, and c asymp, are used, depending on where z lies in c the quadrant. c subroutine fcnw(wr,wi,zr,zi) implicit double precision(a-h,o-z) data x1/4.1e0/,x2/3.6e0/,x3/3.5e0/,x4/2.7e0/,x5/2.2e0/ data y1/1.275e0/,y2/1.095e0/ data r2/8.7025e0/ if(zr-x1)200,30,30 200 eps1=.0625e0*(zr-x3) if(zr-x2)300,210,210 210 yc=-1.4e0*(zr-x2)+y2 if(zi-yc)220,30,30 220 if(zr*zi.lt.eps1)then call asymp(wr,wi,zr,zi) else call pade2(wr,wi,zr,zi) endif 300 if(zr-x4)400,310,310 310 yc=-.2e0*(zr-x4)+y1 if(zi-yc)320,30,30 320 if(zr.ge.x3.and.zr*zi.lt.eps1) then call asymp(wr,wi,zr,zi) else call pade2(wr,wi,zr,zi) endif 400 if(zr-x5)500,410,410 410 yc1=-1.4e0*(zr-x4)+y1 yc2=1.75e0*(zr-x4)+y1 if(zi-yc1)420,30,30 420 if(zi-yc2)20,10,10 500 if(zr*zr+zi*zi-r2)10,30,30 10 call pade1(wr,wi,zr,zi) return 20 call pade2(wr,wi,zr,zi) return 30 call asymp(wr,wi,zr,zi) return end c wasymp.fortran c c this program calculates an asymptotic expression of c w(z) valid away from the origin. c subroutine asymp(wr,wi,zr,zi) implicit double precision(a-h,o-z) data a1p/1.94443615e-1/,a2p/7.64384940e-2/, 1 a3p/1.07825546e-2/,a4p/4.27695730e-4/,a5p/2.43202531e-6/ data b1/3.42901327e-1/,b2/1.036610830e0/,b3/1.756683649e0/, 1 b4/2.532731674e0/,b5/3.436159119e0/ data pi2/1.12837917e0/ data x1/3.5e0/,x2/4.2e0/ data eps/.01e0/,check/0.e0/ 10 dr1=zr+b1 d1r=zr-b1 dr2=zr+b2 d2r=zr-b2 dr3=zr+b3 d3r=zr-b3 dr4=zr+b4 d4r=zr-b4 dr5=zr+b5 d5r=zr-b5 de1=dr1*dr1+zi*zi d1e=d1r*d1r+zi*zi de2=dr2*dr2+zi*zi d2e=d2r*d2r+zi*zi de3=dr3*dr3+zi*zi d3e=d3r*d3r+zi*zi de4=dr4*dr4+zi*zi d4e=d4r*d4r+zi*zi de5=dr5*dr5+zi*zi d5e=d5r*d5r+zi*zi if(1.e0-check)70,70,20 20 if(zr.lt.x1) goto 60 eps1=.04e0/(zr-3.29e0)-.034e0 if(zr*zi.lt.eps1) goto 50 if(.not.((zr.ge.x2).and.(zr*zi.lt.eps))) goto 60 50 check=1.e0 wi0=a1p*(dr1/de1+d1r/d1e)+a2p*(dr2/de2+d2r/d2e)+ 1 a3p*(dr3/de3+d3r/d3e)+a4p*(dr4/de4+d4r/d4e)+ 1 a5p*(dr5/de5+d5r/d5e) zi0=zi zi=0.e0 go to 10 60 wr=(a1p*(1.e0/de1+1.e0/d1e)+a2p*(1.e0/de2+1.e0/d2e)+ 1 a3p*(1.e0/de3+1.e0/d3e)+a4p*(1.e0/de4+1.e0/d4e)+ 1 a5p*(1.e0/de5+1.e0/d5e))*zi 70 wi=a1p*(dr1/de1+d1r/d1e)+a2p*(dr2/de2+d2r/d2e)+ 1 a3p*(dr3/de3+d3r/d3e)+a4p*(dr4/de4+d4r/d4e)+ 1 a5p*(dr5/de5+d5r/d5e) if(1.e0-check)80,80,90 80 wr=exp(-zr*zr)+2.e0*wi*zr*zi0-pi2*zi0 wi=wi0 zi=zi0 check=0.e0 90 return c c ################################################################## c ###################################################################### entry errasymp c write(41,*)'zi,zr,ck=',zi,zr,ck return c end c wpade1.fortran c c this program calculates a pade approximation of w(z) c around the origin. c subroutine pade1(wr,wi,zr,zi) implicit double precision(a-h,o-z) data c1/-1.25647718e0/,c2/8.25059158e-1/, 1 c3/-3.19300157e-1/,c4/7.63191605e-2/, 1 c5/-1.04697938e-2/,c6/6.44878652e-4/ data d1/-2.38485635e0/,d2/2.51608137e0/, 1 d3/-1.52579040e0/,d4/5.75922693e-1/, 1 d5/-1.35740709e-1/,d6/1.85678083e-2/, 1 d7/-1.14243694e-3/ u2r=zi*zi-zr*zr u2i=-2.e0*zr*zi u3r=-u2r*zi-u2i*zr u3i=u2r*zr-u2i*zi u4r=-u3r*zi-u3i*zr u4i=u3r*zr-u3i*zi u5r=-u4r*zi-u4i*zr u5i=u4r*zr-u4i*zi u6r=-u5r*zi-u5i*zr u6i=u5r*zr-u5i*zi u7r=-u6r*zi-u6i*zr u7i=u6r*zr-u6i*zi fr=1.e0-c1*zi+c2*u2r+c3*u3r+c4*u4r+c5*u5r+c6*u6r fi=c1*zr+c2*u2i+c3*u3i+c4*u4i+c5*u5i+c6*u6i dr=1.e0-d1*zi+d2*u2r+d3*u3r+d4*u4r+d5*u5r+d6*u6r+d7*u7r di=d1*zr+d2*u2i+d3*u3i+d4*u4i+d5*u5i+d6*u6i+d7*u7i de=dr*dr+di*di wr=(fr*dr+fi*di)/de wi=(fi*dr-fr*di)/de return end c wpade2.fortran c c this program calculates a pade approximation of w(z) c around the point z = 3. c subroutine pade2(wr,wi,zr,zi) implicit double precision(a-h,o-z) data c0r/1.23409804e-4/,c0i/2.01157318e-1/, 1 c1r/2.33746715e-1/,c1i/1.61133338e-1/, 1 c2r/1.25689814e-1/,c2i/-4.0422725e-2/, 1 c3r/8.92089179e-3/,c3i/-1.81293213e-2/ data d1r/1.19230984e0/,d1i/-1.16495901e0/, 1 d2r/8.9401545e-2/,d2i/-1.07372867e0/, 1 d3r/-1.68547429e-1/,d3i/-2.70096451e-1/, 1 d4r/-3.20997564e-2/,d4i/-1.58578639e-2/ zr=zr-3.e0 z2r=zr*zr-zi*zi z2i=2.e0*zr*zi z3r=z2r*zr-z2i*zi z3i=z2r*zi+z2i*zr z4r=z3r*zr-z3i*zi z4i=z3r*zi+z3i*zr fr=c0r+c1r*zr-c1i*zi+c2r*z2r-c2i*z2i+c3r*z3r-c3i*z3i fi=c0i+c1r*zi+c1i*zr+c2r*z2i+c2i*z2r+c3r*z3i+c3i*z3r dr=1.e0+d1r*zr-d1i*zi+d2r*z2r-d2i*z2i+d3r*z3r-d3i*z3i+ 1 d4r*z4r-d4i*z4i di=d1r*zi+d1i*zr+d2r*z2i+d2i*z2r+d3r*z3i+d3i*z3r+d4r*z4i+ 1 d4i*z4r de=dr*dr+di*di wr=(fr*dr+fi*di)/de wi=(fi*dr-fr*di)/de zr=zr+3.e0 return end SUBROUTINE ERRF(XX, YY, WX, WY) *----------------------------------------------------------------------* * Purpose: * * Modification of WWERF, double precision complex error function, * * written at CERN by K. Koelbig. * * Input: * * XX, YY (real) Argument to CERF. * * Output: * * WX, WY (real) Function result. * *----------------------------------------------------------------------* *---- Double precision version. IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N) PARAMETER (MWFLT = 2, MREAL = 4) PARAMETER (MCWRD = 4) PARAMETER (MCNAM = 16, MWNAM = MCNAM / MCWRD) PARAMETER (MCFIL = 80, MCRNG = 40, MCSTR = 80) PARAMETER (CC = 1.12837 91670 9551D0) PARAMETER (ONE = 1.D0) PARAMETER (TWO = 2.D0) PARAMETER (XLIM = 5.33D0) PARAMETER (YLIM = 4.29D0) DIMENSION RX(33), RY(33) X = ABS(XX) Y = ABS(YY) IF (Y .LT. YLIM .AND. X .LT. XLIM) THEN Q = (ONE - Y / YLIM) * SQRT(ONE - (X/XLIM)**2) H = ONE / (3.2D0 * Q) NC = 7 + INT(23.0*Q) XL = H**(1 - NC) XH = Y + 0.5D0/H YH = X NU = 10 + INT(21.0*Q) RX(NU+1) = 0. RY(NU+1) = 0. DO 10 N = NU, 1, -1 TX = XH + N * RX(N+1) TY = YH - N * RY(N+1) TN = TX*TX + TY*TY RX(N) = 0.5D0 * TX / TN RY(N) = 0.5D0 * TY / TN 10 CONTINUE SX = 0. SY = 0. DO 20 N = NC, 1, -1 SAUX = SX + XL SX = RX(N) * SAUX - RY(N) * SY SY = RX(N) * SY + RY(N) * SAUX XL = H * XL 20 CONTINUE WX = CC * SX WY = CC * SY ELSE XH = Y YH = X RX(1) = 0. RY(1) = 0. DO 30 N = 9, 1, -1 TX = XH + N * RX(1) TY = YH - N * RY(1) TN = TX*TX + TY*TY RX(1) = 0.5D0 * TX / TN RY(1) = 0.5D0 * TY / TN 30 CONTINUE WX = CC * RX(1) WY = CC * RY(1) ENDIF IF(Y .EQ. 0.) WX = EXP(-X**2) IF(YY .LT. 0.) THEN WX = TWO * EXP(Y*Y-X*X) * COS(TWO*X*Y) - WX WY = - TWO * EXP(Y*Y-X*X) * SIN(TWO*X*Y) - WY IF(XX .GT. 0.) WY = -WY ELSE IF(XX .LT. 0.) WY = -WY ENDIF END subroutine ranuni(iseed,x,n) implicit real*8 (a-h,o-z) c implicit integer (a-z) real*8 x(n) real*8 am c c creates uniform distribution between 0 and 1 c parameter(ia=16807,im=2147483647,am=1.d0/im,iq=127773,ir=2836, & mask=123459876) c initial seed idum idum = iseed c do i = 1, n idum=ieor(idum,mask) k=idum/iq idum=ia*(idum-k*iq)-ir*k if(idum.lt.0) idum=idum+IM x(i) = am*idum end do iseed = idum end subroutine seiler(xt,yt,zt,xpt,ypt,zpt,qt,qtnew,ibd,iw) c purpose: computes secondary emitted electron c implicit real*8 (a-h,o-z) c implicit integer (a-z) c 20.06.1997 Oliver: adding an input file: c parameter (nbunch = 200, npelm=600000, npepb=10000) parameter (npelm=600000,iybin=500) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc integer index(npelm) integer iycount(0:iybin) real*8 ayield(0:iybin),avcos(0:iybin) c real*8 rn(8000) real*8 x(npelm), y(npelm), z(npelm), q(npelm), t real*8 xp(npelm), yp(npelm), zp(npelm), * pz(npelm), py(npelm), px(npelm), test(npelm) real*8 ptime(npelm), esign(npelm) c oliver 6.6.1997:cccccccccccccccccc real*8 eloss, elossq, enein, ephoto, adele, qadele real*8 peeff, yim, yemax ccccccccccccccccccccccccccccccccccccccc c oliver 24.7.1997:cccccccccccccccccc real*8 semax ccccccccccccccccccccccccccccccccccccccc real*8 qacc, ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 real*8 bfield, el, vl, fom, pi, re, elmass real*8 rbound, xbound, ybound, zbound, energy, belen real*8 x0r(6), y0r(6), rbound6, webin(0:500), webinn(0:500) real*8 webinphi(0:500), webinph2(0:500) real*8 webinth(0:500), webinth2(0:500) real*8 webebb(0:500,0:500), webcos(0:500) real*8 xt, yt, zt, xpt, ypt, zpt real*8 ran2 real*8 dn1, dn2, dn3, dm1, dm2, dm3, do1, do2, do3 real*8 costheta, dphi c oliver 27.10.1997: variables for miguel: integer intn cccccccccccccccccccccccccccccccccccc c X.Zhang 14.10.1998 integer ibd, iw real*8 distw cccccccccccccccccccccccccccccccccccccc parameter (intn=1000) real*8 limit(intn), lcount(intn) real*8 avq, isectot, ltest common / miguel1 / isectot, ltest, avq common / miguel2 / lcount, limit ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc save / miguel1 / save / miguel2 / common / pel / x, y, z, pz, py, px, q, ptime, esign common / pel5 / xp, yp, zp common / pel51 / index common / pel52 / t common / part / qacc common / part2 / icount, icountact, iadele c common / benddrift / ibend common / def1 / rbound, xbound, ybound, zbound, energy, belen common / def2 / bfield, el, vl, fom, pi, re, elmass common / def3 / ppb, bl, sb, sx, sy, ppb1, sb1, ppb2, sb2 common / rann / iseed, idumy c 20.06.1997 Oliver: adding an input file: common / def5 / isemax,ibend,npepb,nbunch,nbstep,nistep,nostep common / def6 / peeff, yim, yemax common / def7 / iebin, jebin, iloss, ispace, ibeam, iwave ccccccccccccccccccccccccccccccccccccccccccccccc c switch for elastic scattering common / def20 / inel c oliver 6.6.197:cccccccccccccccccc common / loss / eloss, elossq, ephoto, adele, qadele ccccccccccccccccccccccccccccccccccccccc c oliver 24.7.197:cccccccccccccccccc common / emax / semax, emax0 ccccccccccccccccccccccccccccccccccccccc c oliver 4.8.197:cccccccccccccccccc common / byield1 / iycount common / byield2 / ayield,avcos ccccccccccccccccccccccccccccccccccccccc c X.Zhang 14.10.1998 common / wavguid6 / x0r, y0r, rbound6, webin, webinphi c common / wavguid7 / webinph2 common / wavguid7 / webinph2, webinn c , webinth, webinth2 common / wavguid8 / webebb, webcos ccccccccccccccccccccccccccccccccccccccc common / test1 / itest common / test2 / test c frank, add this block to seiler for igeom=4 common / image / iimage, iimageb, interspace, igeom c write(*,*) ' entrance seiler ' c X.Zhang 14.10.1998 c ibd: 1 = outboundary, 2 = inner conductor, iw: wire index. if(iwave.eq.2) then distw = sqrt((xt-x0r(iw))**2+(yt-y0r(iw))**2) else distw = sqrt(xt*xt+yt*yt) endif c Projecting the particles back to the boundary: if (ibd.eq.1) then if (ibend.eq.1) then if (igeom.ne.4) then if (abs(xt).lt.xbound) then yt = yt/abs(yt)*ybound*sqrt(1.-(xt/xbound)**2) else yt = yt/abs(yt)*1.d-7 xt = xt/abs(xt)*(xbound-1.d-7) endif endif if (yt.gt.zbound) yt = zbound if (yt.lt.-zbound) yt = -zbound if (igeom.eq.4.and.abs(xt).ge.xbound) then xt = xt/abs(xt)*(xbound-1.d-7) endif else c if (ibend.ne.1) then if (igeom.ne.4) then scale = 1.0d0/sqrt((xt/xbound)**2+(yt/ybound)**2) xt = xt * scale yt = yt * scale if (yt.gt.zbound) yt = zbound if (yt.lt.-zbound) yt = -zbound else if (abs(x(i)/y(i)).gt.xbound/zbound) then scale = xbound/abs(x(i)) else scale = zbound/abs(y(i)) endif xt = xt * scale yt = yt * scale endif endif endif ccccccccccccccccccccccccccccccccccccccccccccccccc c 01.07.1997 Oliver: wave guide boundaries. c 14.10.1998 X.Zhang: add 6-wire waveguide geometry. if(ibd.eq.2) then if(iwave.eq.1) then if (ibend.eq.1) then yt = yt/abs(yt)*(sqrt(rbound**2-xt**2)+1.d-7) else c if (ibend.eq.0.or.ibend.eq.5) then scale = 1.0d0/(distw/rbound) xt = xt * scale yt = yt * scale endif else if(iwave.eq.2) then xt = rbound6 * (xt-x0r(iw))/distw + x0r(iw) yt = rbound6 * (yt-y0r(iw))/distw + y0r(iw) endif endif ccccccccccccccccccccccccccccccccccccccccccccccccc c introduce 3 orthonormal vectors dn, dm and do dn3 = 0. 0d0 c 01.07.1997 Oliver: Normal vector for the outer boundary: if(ibd.eq.1) then dn1 = xt/ xbound**2/ * sqrt(xt**2/xbound**4+yt**2/ybound**4) dn2 = yt/ ybound**2/ * sqrt(xt**2/xbound**4+yt**2/ybound**4) if (abs(yt).eq.zbound) dn1 = 0.0d0 c dn3 removed dnorm = sqrt(dn1*dn1+dn2*dn2) dn1 = -dn1/dnorm dn2 = -dn2/dnorm else if(ibd.eq.2) then c 01.07.1997 Oliver: Normal vector for the inner waveguide: if(iwave.eq.1) then dn1 = xt/distw dn2 = yt/distw else if(iwave.eq.2) then c 14.10.1998 X.Zhang: add 6-wire waveguid geometry. dn1 = (xt-x0r(iw))/distw dn2 = (yt-y0r(iw))/distw endif dnorm = sqrt(dn1*dn1+dn2*dn2) dn1 = dn1/dnorm dn2 = dn2/dnorm endif dm1 = -dn2 dm2 = dn1 dm3 = 0.0d0 do1 = 0.0d0 do2 = 0.0d0 do3 = 1.0d0 xpto=xpt ypto=ypt zpto=zpt xto=xt yto=yt zto=zt c dn3 removed costheta = abs(dn1*xpt+dn2*ypt)/ * sqrt(xpt**2+ypt**2+zpt**2) costheta = max(costheta,0.2d0) c Calculate the angle of the surface normal. c The angle is used for the angular distribution of the momentum vector. angle = atan2(dn2,dn1) c incoming energy in eV: c 19.06.1997 Oliver vel2 = (xpt*xpt+ypt*ypt+zpt*zpt) beta2 = vel2/vl/vl ! Achtung: 12.7.1998 if(beta2.ge.1.0d0) write(*,*) "Seiler", beta2 if(beta2.ge.1.0d0) beta2 = 0.999d0 c write(*,*) "Seiler", vel2, beta2 ccccccccccccccccccccccccccccccccc c beta2 = max(ypt*ypt,xpt*xpt)/vl/vl gamma = 1.0d0/sqrt(1.0d0-beta2) ene = (gamma-1.0d0)*elmass*vl*vl/el enein = ene*qt eloss = eloss + enein c highly dubious statement for elastic scattering c comment this out, frank c if (ene.lt.5) then c qt = 0.0d0 c return c endif c charge of emitted secondary e- qtnew = yield(ene,costheta,yim,yemax)*qt c if (inel.eq.1) then c qtel = (0.02+0.08*exp(-(ene-5.0d0)**2 c & /50.0))*(1.0+0.26*(1-costheta**2))*qtold c most recent parametrization for elastically reflected c electrons, before Noel's note (July 2001) was released c qtel = (0.02+0.56*exp(-ene**2 c & /5408.))*(1.0+0.26*(1-costheta**2))*qtold if(ene.le.300) then qtnew = qtnew/(1-frac1(ene)) qtold = qt else qtnew = qtnew/(1-frac2(ene)) qtold = qt endif if (qtnew.gt.0.0.and.ene.le.300) then ratio = frac1(ene) else if (qtnew.gt.0.0.and.ene.gt.300) then ratio = frac2(ene) else if (qtnew.le.0.0) then return endif if (ran2(idumy).lt.ratio) goto 980 c qtnew = qtel+qtnew c qtel = qtnew endif c c qtnew = qt nindhg=nint(iybin*xt/xbound+iybin)/2 if (nindhg.gt.iybin.or.nindhg.lt.0) goto 123 c 4.8.1997 Oliver: Bining the secondary yield: iycount(nindhg) = * iycount(nindhg) + 1 if(ene.le.300) then ayield(nindhg) = * ayield(nindhg)+yield(ene,costheta,yim,yemax)/(1-frac1(ene)) else ayield(nindhg) = * ayield(nindhg)+yield(ene,costheta,yim,yemax)/(1-frac2(ene)) endif avcos(nindhg) = * avcos(nindhg) + * costheta c write(55,*) xt,yield(ene,costheta,yim,yemax),costheta cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 123 continue if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/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 if (qtnew.gt.qtref) then iq = max(2,int(qtnew/qtref+0.5d0)) if (ibend.eq.1.and. & (abs(xbound-xt).lt.0.002.or.abs(xbound+xt).lt.0.002)) & then qtnew = qtref iq = 1 endif else iq = 1 endif c c frank, set iq = 1 temporarily, November 4, 2001 c c iq = 1 do 10 i = 1, iq qt = abs(qtnew / real(iq)) c energy & angles of emitted particle c c for now assume uniform energy distribution between 1 and 20 eV c c iseed = iseed + 1 c call ranuni(iseed,rn,3) c emax = 20. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc Oliver 31.07.1997: cc Gaussian energy distribution for the secondary electrons: c emax0 = semax c if (ene.lt.emax0) emax0 = ene c eneemit = (emax0*sqrt(-2*log(ran2(idumy)))* c * cos(2*pi*ran2(idumy)) ) c if (eneemit.lt.0.0) eneemit = -eneemit cc goto 33 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Oliver 27.10.1997: c Arbitrary energy distribution defined in 'init': c c count total number of produced secondary electrons: c emax0 = 15.0d0*semax isectot = isectot + 1 avq = avq + qt if(isectot.eq.3000) then c open(unit=69,file="distr.test.data",status='UNKNOWN') c do 35 idt=1,intn c write(69,*) dble(idt+1)*emax0/dble(intn), c * lcount(idt)/avq, limit(idt) c 35 continue c close(unit=69) endif c c dice uniform energy distribution in the relevant intervall: 30 eneemit = ran2(idumy)*emax0 c c check the distribution: do 32 im=1,intn if(eneemit.lt.dble(im)*emax0/dble(intn)) then if(0.97*lcount(im)/avq.ge.limit(im)) goto 30 lcount(im) = lcount(im) + qt goto 33 endif 32 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Bin the energy distribution: 33 itest = itest + 1 if (itest.lt.npelm) test(itest) = eneemit c Oliver: 6.Juni.1997: Calculate the energy deposition in the wall c by the lost electrons. eloss = eloss - eneemit*qt ccccccccccccccccccccccccccccccccccccccccccccc c c next determine angular distribution c c scale with energy energyscale = eneemit * el velo = sqrt(2.0d0*energyscale/elmass) c New routine for uniform angle distribution: c 'aplimit' limits the opening angle of the momentum distribution. c aplimit = 1.0d0 c r2 = angle + aplimit * pi * (ran2(idumy)-0.5d0) c r3 = 2.0d0 * pi * (ran2(idumy)-0.5d0) c xpt = sqrt(4.0d0/3.0d0)*velo*cos(r2)*abs(sin(r3)) c ypt = sqrt(4.0d0/3.0d0)*velo*sin(r2)*abs(sin(r3)) c zpt = sqrt(2.0d0/3.0d0)*velo*cos(r3) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Frank's old cos theta distribution: c cos theta = c xco = sqrt(rn(2)) xsi = sqrt(ran2(idumy)) xco = sqrt(1.0d0-xsi*xsi) c phi c dphi = rn(3)*2.0d0*pi dphi = ran2(idumy)*2.0d0*pi dpco = cos(dphi) dpsi = sin(dphi) xpt = dn1*xco+xsi*(dm1*dpco+do1*dpsi) ypt = dn2*xco+xsi*(dm2*dpco+do2*dpsi) zpt = dn3*xco+xsi*(dm3*dpco+do3*dpsi) xpt = xpt * velo ypt = ypt * velo zpt = zpt * velo ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c write(*,*) "Seiler",semax,velo,xpt,ypt,zpt c treat newly generated electrons c (introduced to reduce fluctuations) if (i.lt.iq) then icount = icount + 1 icountact = icountact + 1 qacc = qacc + qt q(icount) = qt c smear out x-coordinate over typical width c of exit area according to Seiler rho = 9000. c density in kg/m^3 for Copper xwid = 1.15d-4/rho *(ene/1000.0d0)**(1.35) c call ranuni(iseed,rn,1) c x(icount) = xt + (rn(1)-0.5d0)*2.0d0*xwid x(icount) = xt + (ran2(idumy)-0.5d0)*2.0d0*xwid if (qtnew.eq.0.0) then xpt = 0.0d0 ypt = 0.0d0 zpt = 0.0d0 endif c x(icount) = xt y(icount) = yt z(icount) = zt xp(icount) = xpt yp(icount) = ypt zp(icount) = zpt endif 10 continue return c c elastic scattering... c c goto 900 980 continue c qtnew = qtel+qtnew c qtel = qtnew if (icoll.le.1) then qtref = ppb*peeff/real(npepb) else rhorg = press*1.33d-7/1.38d-23/300 dnelion = crse*1d-22*rhorg*belen*ppb qtref = dnelion/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 if (qtnew.gt.qtref) then iq = max(2,int(qtnew/qtref+0.5d0)) if (ibend.eq.1.and. & (abs(xbound-xt).lt.0.002.or.abs(xbound+xt).lt.0.002)) & then qtnew = qtref iq = 1 endif else iq = 1 endif c c frank, set iq = 1 temporarily, November 4, 2001 c c iq = 1 eneemit=ene eloss = eloss - eneemit*qtnew c c next determine angular distribution c c scale with energy energyscale = eneemit * el velo = sqrt(2.0d0*energyscale/elmass) dncomp = dn1*xpto+dn2*ypto+dn3*zpto dmcomp = dm1*xpto+dm2*ypto+dm3*zpto docomp = do1*xpto+do2*ypto+do3*zpto xt = xto yt = yto zt = zto xpt = (-dn1*dncomp+dm1*dmcomp+do1*docomp) ypt = (-dn2*dncomp+dm2*dmcomp+do2*docomp) zpt = (-dn3*dncomp+dm3*dmcomp+do3*docomp) do 110 i = 1, iq qt = abs(qtnew / real(iq)) c c if (inel.eq.1) then c c qtel = (0.02+0.08*exp(-(ene-5.0d0)**2 c & /50.0))*(1.0+0.26*(1-costheta**2))*qtold c c if (qtel.gt.1.e3) then if (i.lt.iq) then icount = icount + 1 icountact = icountact + 1 qacc = qacc + qt q(icount) = qt c smear out x-coordinate over typical width c of exit area according to Seiler rho = 9000. c density in kg/m^3 for Copper xwid = 1.15d-4/rho *(ene/1000.0d0)**(1.35) c call ranuni(iseed,rn,1) c x(icount) = xt + (rn(1)-0.5d0)*2.0d0*xwid x(icount) = xt + (ran2(idumy)-0.5d0)*2.0d0*xwid if (qtnew.eq.0.0) then xpt = 0.0d0 ypt = 0.0d0 zpt = 0.0d0 endif c x(icount) = xt y(icount) = yt z(icount) = zt xp(icount) = xpt yp(icount) = ypt zp(icount) = zpt endif 110 continue cc nindhg=nint(iybin*xt/xbound+iybin)/2 cc if (nindhg.gt.iybin.or.nindhg.lt.0) goto 923 ccc comment out from this part of the code for debugging, fz, oct.99 ccc 4.8.1997 Oliver: Bining the secondary yield: cc iycount(nindhg) = cc * iycount(nindhg) + 1 cc ayield(nindhg) = cc * ayield(nindhg) + cc * yield(ene,costheta,yim,yemax) cc avcos(nindhg) = cc * avcos(nindhg) + cc * costheta ccc 923 continue c c 900 continue c c if(isectot.eq.3000) then c open(unit=169,file="inel.data",status='UNKNOWN') c write(169,*) xpto,ypto,zpto,xp(icount),yp(icount), c * zp(icount),xt,yt,zt,eneemit,qtel,qtold c c close(unit=169) c endif c endif c endif c if (qtnew.eq.0.0) then c xpt = 0.0d0 c ypt = 0.0d0 c zpt = 0.0d0 c endif c write(*,*) ' exit seiler ' return end real*8 function yield(ene,costheta,yim,yemax) c secondary emission yield implicit real*8 (a-h,o-z) c reduced energy (energy at maximum = 840 eV) cc er = ene / 840. c er = ene / 400.0d0 c er = ene / yemax c NEW cc er = ene*(1.+0.7*(1.-costheta))/yemax er = ene*(1.+0.7*(1.-costheta))/yemax c OLD WRONG 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 D02CJW, D02CJX EXTERNAL D02CJW, D02CJX, out, fcn, fcn2, bsstep, gfcn2 common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / nagv / ibend, isel, tend, dpx, dpy, dpz common / pel52 / time0 vrel = sqrt(vx*vx+vy*vy+vz*vz) gammaf = 1.d0/sqrt(1.0d0-(vrel/vl)**2) dpx = dpxi dpy = dpyi dpz = dpzi c dpx = 0.0d0 c dpy = 0.0d0 c dpz = 0.0d0 isel = lisel ibend = libend c write(*,*) 'gamma:',gammaf c write(*,*) 'vel: ',vx,vy,vz c write(*,*) 'DP: ',dpx,dpy,dpz if(ibend.eq.1) then tol = 1.0d-3 t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-4 ifail = 0 c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif if(ibend.eq.2) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-6 ifail = 0 dt0=dt/500. c scd 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) cc 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. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c strong dipole if(ibend.eq.18) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-6 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c KEKB solenoid, adjacent coils with equal polarity if(ibend.eq.19) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c exact solenoid, symmetric if(ibend.eq.20) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c exact solenoid, antisymmetric if(ibend.eq.21) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c more exact C yoke, symmetric if(ibend.eq.22) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c more exact C yoke, antisymmetric if(ibend.eq.23) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0 = dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c combined function magnet if(ibend.eq.24) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c TE_1,0 wave if(ibend.eq.25) then t = time0-dt tend = time0 ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-5 ifail = 0 dt0=dt/500. c call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif c strong dipole with y el. field for IPM simulation if(ibend.eq.38) then t = 0.0d0 tend = dt ifail = 0 var(1) = x var(2) = y var(3) = z var(4) = vx var(5) = vy var(6) = vz tol = 1.0d-6 ifail = 0 dt0=dt/500. call ddeqmr(n,t,tend,var,dt0,tol,fcn,w) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',OUT,D02CJW,W,IFAIL) c CALL D02CJF(t,tend,N,VAR,FCN,TOL,'Default',D02CJX,D02CJW,W,IFAIL) if (ifail.ne.0) write(*,*) 'IFAIL = ',ifail x = var(1) y = var(2) z = var(3) vx = var(4) vy = var(5) vz = var(6) endif return end subroutine fcn(t,var,f) c purpose: defines the system of differential equations. implicit real*8 (a-h,o-z) integer n, isel, ibend parameter(n=6) real*8 gammaf, vrel, dpx, dpy, dpz real*8 t, tend, var(n), f(n) real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient, f0, efieldrf real*8 k real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail real*8 function s17aff, s17aef common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf common / def1 / rbound, xbound, ybound, zbound, energy, belen if(ibend.eq.1) then gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = (dpx - el*var(6)*bfield/elmass) f(5) = dpy f(6) = (dpz + el*var(4)*bfield/elmass) endif if(ibend.eq.2) then gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = (dpx - el*var(6)*bfield*var(1)/elmass) f(5) = (dpy + el*var(6)*bfield*var(2)/elmass) f(6) = (dpz + el*var(4)*bfield*var(1)/elmass * - el*var(5)*bfield*var(2)/elmass) c write(*,*) bfield*var(1), bfield*var(2) endif if(ibend.eq.3) then gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = (dpx - el*var(5)*bfield/elmass) f(5) = (dpy + el*var(4)*bfield/elmass) f(6) = dpz endif if (ibend.eq.11) then c kekb symmetric c yoke c a and b are in Tesla/meter, k in 1/meter a = 0.3 b = 0.2 k=2.*pi/0.1 bx = (a+b*cos(k*var(3)))*var(2) by = (a+b*cos(k*var(3)))*var(1) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.12) then c kekb asymmetric c yoke c a and b are in Tesla/meter, k in 1/meter a = 0.0 b = 0.5 k=2.*pi/0.2 bx = (a+b*cos(k*var(3)))*var(2) by = (a+b*cos(k*var(3)))*var(1) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.13) then c kekb symmetric c yoke dipole type c a and b are in Tesla, k in 1/meter a = 0.0141 b = 0.0094 k=2.*pi/0.1 bx = 0. by = (a+b*cos(k*var(3))) bz = (-b*k*sin(k*var(3)))*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.14) then c kekb asymmetric c yoke dipole type c a and b are in Tesla, k in 1/meter a = 0.0 c b = 0.0235 b = 1. k=2.*pi/0.2 bx = 0. by = (a+b*cos(k*var(3))) bz = (-b*k*sin(k*var(3)))*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.15) then c kekb solenoid c b is in Tesla, k in 1/meter b = 0.0050 k = 2.*pi/15. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = -0.5*b*rad*k*cos(k*var(3))*cos(phi) by = -0.5*b*rad*k*cos(k*var(3))*sin(phi) bz = b*sin(k*var(3)) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.16) then c uniform dipole c a and b are in Tesla, k in 1/meter a = 1. b = 0.0 k= 2.*pi/0.1 gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl bx = 0. by = (a+b*cos(k*var(3))) bz = (-b*k*sin(k*var(3)))*var(2) f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.17) then c uniform weak solenoid c b is in Tesla, k in 1/meter b = 0.0050 k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = 0. by = 0. bz = b gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)/gamma*bz & -var(6)/gamma*by) f(5) = dpy - el/elmass*(var(6)/gamma*bx & -var(4)/gamma*bz) f(6) = dpz - el/elmass*(var(4)/gamma*by & -var(5)/gamma*bx) endif if (ibend.eq.18) then c strong dipole c b is in Tesla, k in 1/meter b = bfield k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = 0. by = b bz = 0. gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)/gamma*bz & -var(6)/gamma*by) f(5) = dpy - el/elmass*(var(6)/gamma*bx & -var(4)/gamma*bz) f(6) = dpz - el/elmass*(var(4)/gamma*by & -var(5)/gamma*bx) endif if (ibend.eq.19) then c kekb solenoid, two adjacent coils with equal polarity c b is in Tesla, k in 1/meter b = 0.0020 bz0 = 0.0030 k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = -0.5*b*rad*k*cos(k*var(3))*cos(phi) by = -0.5*b*rad*k*cos(k*var(3))*sin(phi) bz = b*sin(k*var(3))+bz0 gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.20) then c exact solenoid, two adjacent coils with unequal polarity c b is in Tesla, k in 1/meter scalel = 15. b = 0.005 k = 2.*pi/2./scalel rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) c bx = -0.5*b*rad*k*cos(k*var(3))*cos(phi) c by = -0.5*b*rad*k*cos(k*var(3))*sin(phi) arg = k*rad br = 0. bz = 0. solrad = 0.07 soll = 0.4*scalel coefs = b*4*k*solrad/pi do ks = 0, 0 km = real(ks*2+1) s1 = sin(km*k*soll) sz1 = sin(km*k*var(3)) cz1 = cos(km*k*var(3)) bk1 = dbesk1(km*k*solrad) br = br + s1*bk1*dbesi1(km*solrad*rad)*sz1 bz = bz + s1*bk1*dbesi0(km*solrad*rad)*cz1 end do br = br*coefs bz = bz*coefs bx = br*cos(phi) by = br*sin(phi) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.21) then c exact solenoid, two adjacent coils with equal polarity c b is in Tesla, k in 1/meter scalel = 15. b = 0.005 c bz0 = 0.0030 k = 2.*pi/1./scalel rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) arg = k*rad solrad = 0.07 soll = 0.4*scalel coefs = 2*k*solrad/pi br = 0. bz = soll/Pi*k do ks = 1, 1 km = real(ks) s1 = sin(km*k*soll) sz1 = sin(km*k*var(3)) cz1 = cos(km*k*var(3)) bk1 = dbesk1(km*k*solrad) br = br + coefs*s1*bk1*dbesi1(km*solrad*rad)*sz1 bz = bz + coefs*s1*bk1*dbesi0(km*solrad*rad)*cz1 end do br = br*b bz = bz*b bx = br*cos(phi) by = br*sin(phi) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.22) then c kekb symmetric c yoke, more exact c a and b are in Tesla/meter, k in 1/meter a = 0.3 b = 0.2 k=2.*pi/0.1 bx = a*var(2)+b*cos(k*var(3))*(var(2)+1./4.*k*k*( & var(1)*var(1)+var(2)*var(2)/3.)) by = a*var(1)+b*cos(k*var(3))*(var(1)+1./4.*k*k*( & var(2)*var(2)+var(1)*var(1)/3.)) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.23) then c kekb asymmetric c yoke, more exact c a and b are in Tesla/meter, k in 1/meter a = 0.0 b = 0.5 k=2.*pi/0.2 bx = a*var(2)+b*cos(k*var(3))*(var(2)+1./4.*k*k*( & var(1)*var(1)+var(2)*var(2)/3.)) by = a*var(1)+b*cos(k*var(3))*(var(1)+1./4.*k*k*( & var(2)*var(2)+var(1)*var(1)/3.)) bz = (-b*k*sin(k*var(3)))*var(1)*var(2) gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.24) then c combined function magnet c b is bfield c g is bgradient bx = + bgradient*var(2) by = bfield - bgradient*var(1) bz = 0. gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx) endif if (ibend.eq.25) then c H_1,1 wave c 5 GHz, 100 kV/m c c for debugging c var(1) = 0.0001 c var(2) = 0.0001 c var(3) = 0. c f0 = 6.3e9 c efield = 1.e4 c amplfield = efield/(3.7)*xbound domegaw = 2*pi*f0 dlambda0 = 2*pi*vl/domegaw dlambda11 = 1.71*2.*xbound dmu0 = 4.*pi*1.e-7 z0 = 377 zf = z0/sqrt(1-(dlambda0/dlambda11)**2) dlambdah = dlambda0/sqrt(1.-(dlambda0/dlambda11)**2) dbeta0 = 2.*pi/dlambdah rad = sqrt(var(1)*var(1)+var(2)*var(2)) arg = rad*3.7/(2*xbound) bj0 = s17aef(arg,ifail) bj1 = s17aff(arg,ifail) bj1p = bj0-1.d0/arg*bj1 ampl = amplfield*cos(dbeta0*var(3)-domegaw*t) ampl1 = amplfield*sin(dbeta0*var(3)-domegaw*t) ex = ampl*(bj1-arg*bj1p)*var(1)*var(2)/rad**3 ey = ampl*(bj1*var(2)**2+arg*bj1p*var(1)**2)/rad**3 ez = 0. bx = ampl/zf*dmu0*(arg*bj1p*var(1)**2+bj1*var(2)**2)/rad**3 by = bfield+ampl/zf*dmu0*(arg*bj1p-bj1)*var(1)*var(2)/rad**3 bz = ampl1/zf*dmu0*arg**2*dlambdah/(2.*pi)*bj1*var(2)/rad**3 c write(*,*) ' ibend = 25 ' c write(*,*) ' coordinates ',var(1),var(2),var(3) c write(*,*) ' time ',t c write(*,*) ' dlambda0 ',dlambda0 c write(*,*) ' dlambda11 ',dlambda11 c write(*,*) ' domegaw ',domegaw c write(*,*) ' f0 ',f0 c write(*,*) ' ex,ey,ez',ex,ey,ez c write(*,*) ' bx,by,bz',bz,by,vz gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)*bz-var(6)*by + ex) f(5) = dpy - el/elmass*(var(6)*bx-var(4)*bz + ey) f(6) = dpz - el/elmass*(var(4)*by-var(5)*bx + ez) endif if (ibend.eq.38) then c strong dipole with vertical e field 20 kV/m for IPM c ef is in V/m ef = 20.e3 c b is in Tesla, k in 1/meter b = bfield k = 2.*pi/1. rad = sqrt(var(1)*var(1)+var(2)*var(2)) phi = datan2(var(2),var(1)) bx = 0. by = b bz = 0. gamma = 1.0d0*sqrt(vl**2+var(4)**2+ & var(5)**2+var(6)**2)/vl f(1) = var(4)/gamma f(2) = var(5)/gamma f(3) = var(6)/gamma f(4) = dpx - el/elmass*(var(5)/gamma*bz & -var(6)/gamma*by) f(5) = dpy - el/elmass*(var(6)/gamma*bx & -var(4)/gamma*bz) - el/elmass/gamma*ef f(6) = dpz - el/elmass*(var(4)/gamma*by & -var(5)/gamma*bx) endif return end subroutine fcn2(t,var,f) c purpose: defines the system of differential equations. c Daniel: 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 real*8 k real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail real*8 function s17aff, s17aef common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf common / def1 / rbound, xbound, ybound, zbound, energy, belen 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 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 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 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) implicit real*8 (a-h,o-z) integer n, isel, ibend parameter(n=6) real*8 gammaf, vrel, dpx, dpy, dpz real*8 t, tend, var(n), f(n) real*8 bfield, el, vl, fom, pi, re, elmass real*8 bgradient, f0, efieldrf real*8 k real*8 rbound, xbound, ybound, zbound, energy, belen integer ifail real*8 function s17aff, s17aef common / nagv / ibend, isel, tend, dpx, dpy, dpz common / def2 / bfield, el, vl, fom, pi, re, elmass common / def2b / bgradient common / def2c / f0,efieldrf common / def1 / rbound, xbound, ybound, zbound, energy, belen 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 *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 ELSEIF (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 ELSEIF (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