c***************************************************************************** c The set of comments after the next row of stars will hopefully c serve to confirm that over 99% of this program is not written by me. c c The authors listed below deserve full credit for their efforts. c c The modifications I have made have spoiled some of the elegance c of the command structure (at the expense of creating a rudimentary text c command). The modifications are in no way associated with the original c autohors of FEYNFIG so don't blame them for any problems they may cause. c c Christopher Lester. lester@hep.phy.cam.ac.uk c St John's College, Cabbridge, CB2 1TP. UK. c***************************************************************************** c c c FEYNFIG 1.2 c c a program to draw feynman graphs using xfig. c c Adapted by Gavin Salam, 1994-1997, with enhancements by c Thomas Pollehn, from FeynMongo written by Paolo Nason and c Manfred Lindner in 1988 to generate feynman graphs with c mongo. c c This program may be redistributed free of charge. c c Please send comments, suggestions and complaints to salam@mi.infn.it c Latest version available from http://wwwteor.mi.infn/???? c c For list of changes since last version, see the file CHANGELOG in this c directory. c***************************************************************************** c In order to use the program: c 1) compile and link it with "f77 feynfig.f -o feynfig" c 2) put it in your path (if you want to) c Usage example: c $ cat > mmm.in c gluon 1 1 5 5 c ^D c $ feynfig mmm c $ xfig mmm.fig c and look at the nice picture. If it fails, make sure that you are using c xfig 3.1 or higher -- if not, either update your xfig, or use feynfig-1.0 c c feynfig file creates a file: file.fig containing xfig commands and data c derived from the instructions in file.in c c---------------------------------------------------------------------- c The input file name contains: c 1) a command among the following (command names must be lowercase!) c c ! xxxx a comment line c expand float expand all commands wrt origin c relocate loc Change the current 'pointer' location c draw loc Draw a line from current psn to loc c draw loc1 loc2 same as relocate loc1, draw loc2 c c gluon loc1 loc2 gluon propagator (curly line) c fermion loc1 loc2 fermion (with arrow) c dfermion loc1 loc2 double-line fermion (with arrow) c photon loc1 loc2 photon (wavy line) c scalar loc1 loc2 scalar (dashed line) c ghost loc1 loc2 ghost (dotted line with arrow) c pomeron loc1 loc2 pomeron (spring-like line) c vertex mark current psn as a vertex (blob) c c The following commands take as a last argument an opening angle c which must be in the range -358..358 c c cgluon loc1 loc2 angle curved gluon c cfermion loc1 loc2 angle curved fermion c cdfermion loc1 loc2 angle curved dfermion c cphoton loc1 loc2 angle curved photon c cscalar loc1 loc2 angle curved scalar c cghost loc1 loc2 angle curved ghost c cpomeron loc1 loc2 angle curved pomeron c cline loc1 loc2 angle curved plain line c c O and S are the orientation (in degrees) and spacing (in cm) c of the shading of the circle. Plain circles are shaded c according to the fill value set below (default none). c c circle loc1 radius circle centered at loc1 c circl2 loc1 loc2 circle between two opposite points c circl3 loc1 loc2 loc3 draws a circle thru 3 points. c cshade loc1 radius O S shaded circle c cshade2 loc1 loc2 O S shaded circle between 2 points c c The following set general properties of the diagrams (default values c are given in brackets) c c mark n loc1 define mark n to be at loc c blob float set vertex blob size (0.1) c arrow float sets arrow length on fermionic lines (0.5) c loop float sets the wavelength in lines (0.35) c double float sets the line separation for dfermion (0.1) c width integer Width of all lines in points (2) c scale float sets scale of plot (1.0) c c colour integer sets the drawing colour c color integer 1 = default (black), 0 = black c 1 = blue 2 = green c 3 = cyan 4 = red c 5 = magenta 6 = yellow c 7 = white c fill integer c sets the fill style for curved commands c (fills enclosed regions like xfig does) c 0 = no filling c 1..100 = percent filling (100=black) c -1..-22 = xfig patterns (hatched...) c c 2) loc is any of the following: c a) 5.4 3.2 a pair of coordinates x y c b) @ current location xr, yr established by c relocate loc c c) x.45y1.23 location xr+.45, yr+1.23; y1.2 is the c same as x0y1.2, and x3 is as x3y0; also c y4x3.4 is good. c d) r1.2a45 = xr+cos(45 deg)*1.2, yr+sin(45 deg)*1.2 c c 3) locations can be stored. After the instruction: c mark 13 loc c the following location expressions are valid: c - #13 location marked 13 ( up to 99 locations) c - any combination x2.3y.4#13 or x2.1y.3#11, where the c meaning is the same as in 3c),3d) except that the c location is calculated relative to the point marked c #13 or #11 c c 4) The plotting area is more or less unlimited (as long as it's c less than 1m in size). Coordinates are in cm. c c 5) Text labels to the diagrams can easily be added using xfig, as can c any simple diagrammatic features not provided here (such as c oval regions, filled in rectangles, eps inserts, ...) To get latex c text, make sure special is selected under the text flags, and then c use an export mechanism that goes via latex c c Looking through the code may help to understand what goes on. c c c USEFUL TIPS c ----------- c c Bug in xfig3.1 means that compound objects (shaded circles, as of c feynfig-1.1) don't update properly when they are moved -- so you have c to explicitly click on the 'redraw' button at the top of the xfig c window. c c A quick way of generating graphs is to create a template file (see the c example files in this directory) with standard bits and pieces and c then to use xfig to move, copy, rotate them, etc... c c BUGS c ---- c A feature of some implementations of fortran is that the last line of input c will not be read in unless it is followed by a carriage return -- so if the c the last line of your input file fails to work this could be the reason. c c In xfig gluon lines may look uneven; this problem goes away (mostly) c when the xfig figure is converted to postscript or some other format. c c GOOD BYE (from all the authors!) AND HAVE FUN c c**************************************************************************** c Details of code origin: c Left from Paolo Nason's original code (as enhanced by Manfred Lindner): c 2 and 3pt circle routines and shaded circle routines c The parsing routine c The main routine c The instructions. c The basic idea! c**************************************************************************** subroutine PutText(valx,valy) integer x,y character*80 string x=int(valx) y=int(valy) read (5,'(a)') string write (6,10) x,y,string,'\\' 10 format('4 0 -1 0 0 0 12 0.0000 4 135 405 ',I5,' ',I5,' ', & A80,A1,'001') !\001 end C============================================================================ subroutine parse(comm,string,val,k) parameter (nmarks=99) c----------------------------------------------------------------------- c Commands have the form: c command loc1 loc2 loc3 ... c for at most 5 locations. c Locations have one of the following forms: c 1) @ current location xr, yr c 2) x.45y1.23 location xr+.45, yr+1.23 c 3) r1.2a45 location xr+cos(45 deg)*1.2, yr+sin(45 deg)*1.2 c 4) #13 location marked 13 ( up to 99 locations) c 5) any combination x2.3y.4#13 or x2.1y.3#11, where the meaning c is the same as in 2), 3) except that the location is calculated c relative to the point marked #13 or #11 c character * 80 string character * 10 comm character * 80 token common /xmark/xmark(2,nmarks) common/offset/offx,offy,ulengt,cmtopts dimension val(10) c-------------------------------------------------------- c Find command string. c do 1 j=1,79 if(string(j:j).ne.' ') go to 2 1 continue comm=' ' return 2 it=index(string(j:),' ') comm=string(j:j+it-2) c Don't go any further if it's a comment line if (comm(1:1).eq.'!') return c--------------------------------------------------------- c Begin loop for arguments. c j = j+it-1 k = 0 5 j = j+1 if(string(j:j).eq.' ') then if(j.lt.79) goto 5 return endif c------------------------------------------- c Find next token. c it = index(string(j:),' ') token = string(j:j+it-2) j = j+it-1 c-------------------------------------------- c If the token ends with #i then the rest of the c token is interpreted as relative position c with respect to the point marked i, else is relative c to the current position. c it = index(token,'#') if(it.eq.0) then xr = offx yr = offy else read(unit=token(it+1:),fmt=*) m if(m.gt.nmarks) then write(6,*) 'maximum number of markers exceeded: >',nmarks stop endif xr = xmark(1,m) yr = xmark(2,m) if(it.eq.1) then token='@' else token = token(1:it-1) endif endif c-------------------------------------------------- c @ ( can be omitted if # was present ) is no shift. c if(token(1:1).eq.'@') then val(k+1) = xr val(k+2) = yr k=k+2 c-------------------------------------------------------------------------- c Cartesian x,y shift: any of x# y# x#y# y#x# ( # stands for a real number) c elseif(token(1:1).eq.'x') then it = index(token,'y') if(it.gt.0) then read(unit=token(2:it-1),fmt=*,err=9)tmpx read(unit=token(it+1:),fmt=*,err=9)tmpy else read(unit=token(2:),fmt=*,err=9)tmpx tmpy=0 endif val(k+1) = xr+tmpx val(k+2) = yr+tmpy k = k+2 elseif(token(1:1).eq.'y') then it = index(token,'x') if(it.gt.0) then read(unit=token(2:it-1),fmt=*,err=9)tmpy read(unit=token(it+1:),fmt=*,err=9)tmpx else read(unit=token(2:),fmt=*,err=9)tmpy tmpx=0 endif val(k+1) = xr+tmpx val(k+2) = yr+tmpy k = k+2 c------------------------------------------------------------------------ c Polar shift. Any of r#a# or a#r#, where r is the radius and a is the c angle in degrees. c elseif(token(1:1).eq.'r') then it=index(token,'a') read(unit=token(2:it-1),fmt=*,err=9)r read(unit=token(it+1:),fmt=*,err=9)a a = 2*3.14159*a/360 val(k+1) = xr+r*cos(a) val(k+2) = yr+r*sin(a) k = k+2 elseif(token(1:1).eq.'a') then it=index(token,'r') read(unit=token(2:it-1),fmt=*,err=9)a read(unit=token(it+1:),fmt=*,err=9)r a = 2*3.14159*a/360 val(k+1) = xr+r*cos(a) val(k+2) = yr+r*sin(a) k = k+2 else c----------------------------------------------------------- c If all the above failed, the token can be a number: pass it c unaltered. If not a number could be a comment c read(unit=token,fmt=*,err=9)val(k+1) k = k+1 endif goto 5 9 return end ********************************************************************** * MAIN PROGRAM UNIT * GPS 29/10/94: Modified for Unix, and more general drawing package. ********************************************************************** parameter (x0=.0,y0=.0) parameter(nmarks=99) character * 79 string character * 10 comm,ptype integer i_colour, i_patt common /offset/offx,offy,ulengt,cmtopts common /width/ line_width common /xmark/xmark(2,nmarks) common /ptype/ ptype common /colour/ i_colour, i_patt dimension val(10) equivalence (val(1),val1),(val(2),val2),(val(3),val3), # (val(4),val4),(val(5),val5),(val(6),val6),(val(7),val7), # (val(8),val8),(val(9),val9),(val(10),val10) data xloop/0.35/,arr/0.5/,dfsep/0.1/vsize/0.1/ !----- do the initialisation -------------------- call init_packg() 1 continue c read(5,'(q,a)',end=10) nbyte, string read(5,'(a)',end=10) string call parse(comm,string,val,k) dflt_angl = 0.0 if(comm.eq.'fermion') then cc-------------------------------------------- ferm(x1,y1,x2,y2) ptype = 'fermion' call arcprt(val1,val2,val3,val4,dflt_angl,arr) elseif(comm.eq.'dfermion') then cc-------------------------------------------- double ferm(x1,y1,x2,y2) ptype = 'dfermion' call arcprt(val1,val2,val3,val4,dflt_angl,dfsep) elseif(comm.eq.'gluon') then cc-------------------------------------------- gluon(x1,y1,x2,y2) ptype = 'gluon' call arcprt(val1,val2,val3,val4,dflt_angl,xloop) c call gluon(val1,val2,val3,val4,xloop) elseif(comm.eq.'photon') then cc-------------------------------------------- photon(x1,y1,x2,y2) ptype = 'photon' call arcprt(val1,val2,val3,val4,dflt_angl,xloop) c call photon(val1,val2,val3,val4,xloop) elseif(comm.eq.'scalar') then cc-------------------------------------------- scalar(x1,y1,x2,y2) ptype = 'scalar' call arcprt(val1,val2,val3,val4,dflt_angl,xloop) c call scalar(val1,val2,val3,val4,xloop) elseif(comm.eq.'ghost') then cc-------------------------------------------- ghost(x1,y1,x2,y2) ptype = 'ghost' call arcprt(val1,val2,val3,val4,dflt_angl,arr) c call ghost(val1,val2,val3,val4,arr) elseif(comm.eq.'pomeron') then cc-------------------------------------------- pomeron(x1,y1,x2,y2) ptype = 'pomeron' call arcprt(val1,val2,val3,val4,dflt_angl,arr) elseif(comm.eq.'cgluon') then cc-------------------------------------------- curved gluon(z1,z2,phi) ptype = 'gluon' call arcprt(val1,val2,val3,val4,val5,xloop) elseif(comm.eq.'cphoton') then c-------------------------------------------- curved photon(z1,z2,phi) ptype = 'photon' call arcprt(val1,val2,val3,val4,val5,xloop) elseif(comm.eq.'cfermion') then c-------------------------------------------- curved fermion(z1,z2,phi) ptype = 'fermion' call arcprt(val1,val2,val3,val4,val5,arr) elseif(comm.eq.'cdfermion') then c-------------------------------------------- curved dfermion(z1,z2,phi) ptype = 'dfermion' call arcprt(val1,val2,val3,val4,val5,dfsep) elseif(comm.eq.'cscalar') then c-------------------------------------------- curved scalar(z1,z2,phi) ptype = 'scalar' call arcprt(val1,val2,val3,val4,val5,xloop) elseif(comm.eq.'cghost') then c-------------------------------------------- curved ghost(z1,z2,phi) ptype = 'ghost' call arcprt(val1,val2,val3,val4,val5,arr) elseif(comm.eq.'cpomeron') then c-------------------------------------------- curved pomeron(z1,z2,phi) ptype = 'pomeron' call arcprt(val1,val2,val3,val4,val5,arr) elseif(comm.eq.'cline') then c-------------------------------------------- curved plain line(z1,z2,phi) ptype = 'plain' call arcprt(val1,val2,val3,val4,val5,arr) c elseif(comm.eq.'circle') then c-------------------------------------------- circle(x,y,r) call circle(val1,val2,val3) c-------------------------------------------- shaded circle(x,y,r,del,phi) c val4 is the spacing, val5 is the inclination elseif(comm.eq.'cshade') then call circleshade(val1,val2,val3,val4,val5) c-------------------------------------------- shaded circle inbetween 2 points c val5 is the spacing, val6 is the inclination elseif(comm.eq.'cshade2') then x2r = ( val1 + val3 )/2. y2r = ( val2 + val4 )/2. r2 = sqrt((val4-val2)*(val4-val2)+(val3-val1)*(val3-val1))/2. call circleshade(x2r,y2r,r2,val5,val6) c-------------------------------------------- circle at center of two points elseif(comm.eq.'circl2') then c find third point x2r = ( val1 + val3 )/2. y2r = ( val2 + val4 )/2. dxr = ( val3 - val1 )/2. dyr = ( val4 - val2 )/2. x2r = x2r - dyr y2r = y2r + dxr call circl3(val1,val2,x2r,y2r,val3,val4) c-------------------------------------------- circle through three points elseif(comm.eq.'circl3') then call circl3(val1,val2,val3,val4,val5,val6) c-------------------------------------------- fix size of fermionic arrow elseif(comm.eq.'arrow') then arr = val1 c-------------------------------------------- fix size of gluon loop elseif(comm.eq.'loop') then xloop = val1 c-------------------------------------------- fix double line seprn elseif(comm.eq.'double') then dfsep = val1 c-------------------------------------------- text addition elseif(comm.eq.'text') then call PutText(val1,val2) c-------------------------------------------- set line width elseif(comm .eq. 'width') then line_width = int(val1) if (line_width .gt. 99) then write(0,*) 'Error: Maximum allowed line width is 99' write(0,*) ' Line width has been set to 99' line_width = 99 endif c-------------------------------------------- relocate elseif(comm(1:3).eq.'rel') then call reloc(val1,val2) c-------------------------------------------- mark a vertex C Scale was defined to be 1, now changed - check effects later elseif(comm(1:3).eq.'ver') then val1 = offx val2 = offy call draw_circle(val1,val2,vsize,1) c write(6,*)'ptype 16 3' c write(6,*)'expand ',vsize*.7 c write(6,*)'dot' c write(6,*)'expand ',scale c write(6,*)'ptype 1 0' c-------------------------------------------- change size of vertex blob elseif(comm.eq.'blob') then vsize = val1 c-------------------------------------------- draw elseif(comm.eq.'draw') then if(k.eq.2) then call join_to_pnt(val1,val2,0) else c-------------------------------------------- draw with four arguments c call reloc(val1,val2) c write(6,*)'draw',val3,val4 call join_pair(val1,val2,val3,val4,0) endif c-------------------------------------------- mark k loc1 loc2 elseif(comm.eq.'mark') then xmark(1,int(val1))=val2 xmark(2,int(val1))=val3 c-------------------------------------------- change the default colour elseif(comm.eq.'colour'.or.comm.eq.'color') then i_colour = val1 c-------------------------------------------- change the default fill style elseif(comm.eq.'fill') then if(val1.gt.0) then i_patt = (101-val1)/5 elseif(val1.lt.0) then i_patt = 40-val1 else i_patt=-1 endif c-------------------------------------------- scale the whole plot elseif(comm.eq.'scale') then call rescale(val1) c scale = val1 c write(6,*)'limit ',0,20/scale,0,15/scale c write(6,*)'expand ',scale elseif(comm(1:3).eq.'exp') then call expand(val1) c write(6,*)'expand ',val1*scale elseif(comm(1:1).ne.'!' .and. comm(1:1).ne.' ') then write(6,'(a)') 'Following command not understood:' write(6,*)string endif goto 1 10 stop end !---------------------------------------------------------------------- subroutine reloc(x,y) common /offset/offx,offy,ulengt,cmtopts offx = x offy = y return end !---------------------------------------------------------------------- subroutine circle(x,y,r) common /offset/offx,offy,ulengt,cmtopts common/irow/irow call draw_circle(x,y,r,-1) return end !---------------------------------------------------------------------- subroutine circleshade(x,y,r,angle,space) common /offset/offx,offy,ulengt,cmtopts common/irow/irow data pi/3.14159/ !----- bind together ----- call start_cmpnd(x-r, y-r, x+r, y+r) call draw_circle(x,y,r,0) c call circle(x,y,r) phi = angle/360 * 2 * pi cph = cos(phi) sph = sin(phi) n = 2*r/space sp = 2*r/n do j = 1,n-1 y10 = r - j*sp x10 = -sqrt(r**2-y10**2) y20 = y10 x20 = -x10 x1 = cph*x10 - sph*y10 + x y1 = sph*x10 + cph*y10 + y x2 = cph*x20 - sph*y20 + x y2 = sph*x20 + cph*y20 + y call join_pair(x1,y1,x2,y2,0) enddo call end_cmpnd return end c !---------------------------------------------------------------------- subroutine circl3(x1,y1,x2,y2,x3,y3) c draws a circles through 3 points. Find center: den = (x2*y3-x1*y3-x3*y2+x1*y2+x3*y1-x2*y1)*2.0 if(den.eq.0.) then write(6,*) 'error: circle through 3 aligned points' stop endif x = -(y2*y3**2-y1*y3**2-y2**2*y3+y1**2*y3-x2**2*y3+x1**2*y3 1 +y1*y2**2-y1**2*y2+x3**2*y2-x1**2*y2-x3**2*y1+x2**2*y1)/den y = (x2*y3**2-x1*y3**2-x3*y2**2+x1*y2**2+x3*y1**2-x2*y1**2+ 1 x2*x3**2-x1*x3**2-x2**2*x3+x1**2*x3+x1*x2**2-x1**2*x2)/den r = sqrt((x-x1)**2+(y-y1)**2) call reloc(x,y) call circle(x,y,r) return end ********************************************************************** * Draw a curved particle line, corresponding to PTYPE. * THETDG is the opening angle in degrees - |THETDG|<359. * Positive and negative opening angles are catered for. * For small angles, the curve will be approximated by a * straight line. * GPS 11/07/94 * GPS 29/10/94 Modified for general drawing program * Tuned for use with xfig ********************************************************************** subroutine arcprt(x1,y1,xf,yf,thetdg,sz) implicit none complex z1, zf, z, vertrd, centre, conv complex w0,w,zm,za1,za2 real x1,xf,y1,yf real xlo, ylo, xhi, yhi real offx,offy,ulengt,cmtopts real radius, length, arclen real thetdg,theta,theta2,s,t,sz,hs,pi,tm integer m, npts,irow,iflag,ltype,i character*10 ptype parameter (pi=3.14159) c-- narr = number of extra points for an arrow; iarr is point where it goes. integer narr, iarr common /irow/ irow common /offset/ offx,offy,ulengt,cmtopts common /arcgm/ theta2,centre,vertrd,length common /arcpat/ iflag,m,hs common /ptype/ ptype if (abs(thetdg) .gt. 359.0) then write(0,*) '****Error: ****' write(0,*) 'Opening angle should be less than 359 degrees' return endif z1 = cmplx(x1,y1) zf = cmplx(xf,yf) theta = thetdg * (pi/180.0) theta2 = theta/2.0 length = abs(zf-z1) s = sign(1.0,theta2) hs = sz/2.0 c-------------------------------------------------- Determine if straight !-- iflag = 1 means that it is straight if (abs(theta) .lt. 1.0e-3) then arclen = length iflag = 1 else centre = - length/2.0 * cmplx(1.0,1.0/tan(theta2)) radius = abs(centre) vertrd = s*radius*(0.0,1.0) arclen = abs(theta)*radius iflag = 0 endif c-------------------------------------------------- Decide line type if (ptype.eq.'ghost') then ltype = 1 elseif (ptype.eq.'scalar') then ltype = 2 else ltype = 0 endif c---------------- Decide number of repetitions (for photons and gluons) c---------------- and the total number of points if (ptype.eq.'gluon') then m = arclen/sz * 1.3/2.0 npts = 21 * m + 1 elseif (ptype .eq. 'photon') then m = arclen / sz / 2.0 npts = 16 * m + 1 ! npts = 8 * m - 1 elseif (ptype .eq. 'pomeron') then m = arclen / sz / 1.5 npts = 2*m + 1 elseif (iflag .eq. 1) then m = 0 npts = 2 else m = 0 npts = max(int(arclen*ulengt*cmtopts/4.0),2) endif npts = max(2,npts) w0 = w(0.0) conv = (zf-z1)/(w(1.0)-w0) c-------------------------------------------------- branch off for dfermion if (ptype .eq. 'dfermion') then call drawdf(arclen, npts, conv, w0, z1) call reloc(xf,yf) return endif c-------------------------------------------------- set up arrow params if (ptype .eq. 'fermion' .or. ptype.eq.'ghost') then tm = 0.5 + sz/arclen/2.0 iarr = int(tm * (npts-1)) + 1 narr = 5 else iarr = 0 narr = 0 endif c---------------------------------------------------- Plot if (ptype .eq. 'pomeron' .or. ptype .eq. 'fermion' $ .or. ptype.eq.'ghost') then c if (ptype .eq. 'pomeron' ) then !-- not a spline call start_many(npts+narr, ltype, 0) else call start_many(npts+narr, ltype, 1) endif do 10 i = 1, npts t = (i-1)*1.0/(npts-1) z = conv*(w(t)-w0) + z1 call add_pnt(real(z),imag(z)) if (i .eq. iarr) then call draw_arrow(tm, arclen, narr, conv, w0, z1) endif 10 continue call end_many() call reloc(xf,yf) end ********************************************************************** * routine for doing all the steps of the double fermion * * GPS 15/3/97 ********************************************************************** subroutine drawdf(arclen, npts, conv, w0, z1) implicit none c------- args --------------- real arclen complex conv, w0, z1 integer npts c------ internal vars ------- integer ltype, i, j, idir real t complex z c------ external functions -- complex w c------ commons ------------- integer iflag, m real hs common /arcpat/ iflag,m,hs c--------------------------------------------------------------------- c---- convert to number of points for half line npts = max(npts/2,2) ltype = 0 call start_many(6*npts+6, ltype, 0) c---- lower left line -- m = -1 do i = 1, npts t = (i-1) * 0.5/(npts-1) z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) enddo c---- arrow ------------ t = 0.5d0 do m = -2, 2 z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) enddo c---- top line --------- m = 1 do j = 1, 2 idir = (-1)**j do i = 1, npts t = 0.5 + idir * (i-1) * 0.5/(npts-1) z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) end do do i = npts, 1, -1 t = 0.5 + idir * (i-1) * 0.5/(npts-1) z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) end do end do c---- middle of arrow again m = 0 t = 0.5d0 z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) c---- second half of bottom line m = -1 do i = 1, npts t = 0.5 + (i-1) * 0.5/(npts-1) z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) enddo c---- finish things off call end_many() end *********************************************************** * driver routine for doing arrow on single fermion line * * GPS 9/3/97 ************************************************************ subroutine draw_arrow(tm, arclen, narr, conv, w0, z1) implicit none real tm, arclen, t complex z, z1, w, w0, conv integer narr c---- for common blocks --------- character*10 ptype, rl_ptype integer iflag, m real hs common /ptype/ ptype common /arcpat/ iflag,m,hs c---- keep a record of the particle type rl_ptype = ptype ptype = 'arrow' c---- m will serve to indicate the arrow shift routine which point c---- of the arrow is currently being done. The component along the c---- direction of the fermion/ghost can be shifted between this c---- (value of t) and the arrsft routine. This will alter things c---- in terms of the rotation of the back of the arrow. do m = 1, narr if (m .eq. 2 .or. m .eq. 4) then t = tm - 0.5*(2.0*hs/arclen) else t = tm endif z = conv*(w(t)-w0) + z1 call add_pnt(real(z), imag(z)) enddo ptype = rl_ptype end ********************************************************************** * Returns the coord a fraction t along a curve starting at * (0,0) finishing at (length,0) with opening angle 2*theta2. * Centre of arc, and a radius vector from centre to uppermost * part of arc MUST be provided in common block by the calling * routine. * Adds any necessary waves or curls for photons and gluons * GPS 11/7/94 ********************************************************************** function w(t) implicit none integer m,iflag real t,theta2,ang,hs,length complex w,centre,vertrd,rotn,glusft,ptnsft,pomsft complex arrsft, dfmsft character*10 ptype common /arcgm/ theta2,centre,vertrd,length common /arcpat/ iflag,m,hs common /ptype/ ptype c--------------------------------------------------set up location if (iflag .eq. 1) then w = cmplx(t*length,0.0) rotn = (1.0,0.0) else ang = theta2 - t*(2*theta2) rotn = cmplx(cos(ang),sin(ang)) w = centre + rotn*vertrd endif c--------------------------------------------------add glue/photon parts if (ptype .eq. 'gluon') then w = w + rotn*hs*glusft(t,m) elseif (ptype .eq. 'photon') then w = w + rotn*hs*ptnsft(t,m) elseif (ptype .eq. 'pomeron') then w = w + rotn*hs*pomsft(t,m) elseif (ptype .eq. 'arrow') then w = w + rotn*hs*arrsft(t,m) elseif (ptype .eq. 'dfermion') then w = w + rotn*hs*dfmsft(t,m) endif end ********************************************************************** * Returns the amount that must be added to give the gluon * curl, at a point a fraction t along a path with m curls * in total. * phi1 and phif are initial and final phases that the user * may wish to alter. (NB Altering these in xfig version may * reduce quality of output - play around and see what happens). * GPS 11/7/94 ********************************************************************** function glusft(t,m) implicit none integer m complex glusft real phi,phi1,phif,t,pi parameter(pi=3.14159) ! phi1 = -pi/2.0 ! phif = -pi/2.0 phi1 = -pi/2.0 - pi/16.0d0 phif = -pi/2.0 + pi/16.0d0 phi = phi1 + t*(2*m*pi + phif-phi1) glusft = cmplx(1.1*cos(phi),sin(phi)) end ********************************************************************** * Returns the amount that must be added to give the photon * waves, at a point a fraction t along a path with m waves * in total. * phi1 and phif are initial and final phases that the user * may wish to alter. If these phases are altered, then to * ensure reasonable quality with the xfig splines, the total * number of points should be changed. * GPS 11/7/94 ********************************************************************** function ptnsft(t,m) implicit none integer m complex ptnsft real phi,phi1,phif,t,pi parameter(pi=3.14159) phi1 = 0.0 phif = 1.0d0*pi ! phi1 = pi/4.0d0 ! phif = 0.75d0*pi phi = phi1 + t*(2*m*pi + phif-phi1) ptnsft = cmplx(0.0,sin(phi)) end ********************************************************************** * Reutnrs the amount that must be added to give the pomeron spring at * a point a fraction t along a path with m waves in total * GPS 22/5/96 ********************************************************************** function pomsft(t,m) implicit none integer m, hlfwvs complex pomsft real t, ssign, tmshft !-- determine how many half waves along one is tmshft = t * m * 2 hlfwvs = int(tmshft+0.5) if (mod(hlfwvs,2) .eq. 0) then ssign = -0.75 else ssign = 0.75 endif pomsft = cmplx(0.0,ssign) end ********************************************************************** * Returns the shift for an arrow in units of hs. Remember to * coordinate shift between here and the draw_arrow routine. * * GPS 9/3/97 ********************************************************************** function arrsft(t,m) implicit none complex arrsft real t integer m if (m .eq. 2) then arrsft = (-0.5, -0.25) elseif ( m .eq. 4) then arrsft = (-0.5, 0.25) else arrsft = (0.0, 0.0) endif c-- remember to multiply by two to get into units of hs, not sz arrsft = arrsft * 2.0 end ********************************************************************** * dfermion shifts ********************************************************************** function dfmsft(t,m) implicit none complex dfmsft real t, arrwdt, cotang integer m c----- 'vertical' distance between back or arrow and dferm line arrwdt = 1.7 c----- cot of the angle of arrow line rel to dferm direction cotang = 1.5 if (m .eq. -2) then dfmsft = cmplx(-arrwdt*cotang, -0.5-arrwdt) elseif (m .eq. -1) then dfmsft = cmplx(0.0, -0.5) elseif (m .eq. 0) then dfmsft = cmplx(0.5*cotang, 0.0) elseif (m .eq. 1) then dfmsft = cmplx(0.0, 0.5) elseif (m .eq. 2) then dfmsft = cmplx(-arrwdt*cotang, arrwdt+0.5) endif c-- remember to multiply by two to get into units of hs, not sz dfmsft = dfmsft * 2.0 end *====================================================================== * ROUTINES FOR INTERFACE BETWEEN FEYNMAN DRAWING PROGRAM AND XFIG * GPS 29/10/94 *====================================================================== C---------------------------------------------------------------------- C The two following routines only affect subsequent commands C---------------------------------------------------------------------- subroutine rescale(s) implicit none real offx,offy,ulengt,cmtopts real s common /offset/offx,offy,ulengt,cmtopts ulengt = s end !---------------------------------------------------------------------- subroutine expand(e) implicit none real offx,offy,ulengt,cmtopts real e common /offset/offx,offy,ulengt,cmtopts ulengt = ulengt * e end C********************************************************************** C All the routines specific to the graphics package being used C should be placed after here. C********************************************************************** C********************************************************************** C XFIG3.1 INTERFACE C********************************************************************** C============================================================================ C Block Data file for xfig3.1 version C ----------------------------------- c Ulengt is the unit length in cm. c cmtopts is the number of points per cm (= 1200/inch) c should be 472.4, but because of bug in xfig, xfig thinks it is 450 C============================================================================ block data icount integer i_colour common /colour/ i_colour, i_patt common /irow/ irow common /offset/ offx, offy, ulengt, cmtopts common /width/ line_width data i_colour/-1/ data i_patt/-1/ data irow/1/, offx/0./, offy/0./, ulengt/1./, cmtopts/450/ data line_width /2/ end C====================================================================== C Initialise xfig -- for version 3.1 C====================================================================== subroutine init_packg() implicit none integer i, j, iargc character*79 string, namevers*11 data namevers/'FeynFig 1.2.dvlp'/ !----- open files for input and output ---------- i = iargc() c if (i .ne. 1) then c call getarg(0,string) c write(6,*) ' Usage: ',string(1:index(string,' ')),'file' c stop c endif c call getarg(1,string) c j = index(string,' ')-1 c open(unit=13,file=string(1:j)//'.in',status='old') c 13 is input c open(unit=10,file=string(1:j)//'.fig',status='unknown') c $ carriagecontrol='list') c unit 10 is the plot file. Specific to xfig !---- inform user of details of this program ------ c write(6,*) namevers c write(6,*) "Taking input from ",string(1:j)//'.in' c write(6,*) "Writing output to ",string(1:j)//'.fig' c write(6,*) "Output is suitable for viewing with ", c $ "xfig 3.1 or higher" !---- start off the xfig file ------- write(6,98) '#FIG 3.1' write(6,98) 'Portrait' write(6,98) 'Center' write(6,98) 'Metric' write(6,98) '1200 2' write(6,99) '# File produced from Lesters modified feynfig' c write(6,98) namevers 98 format(a) 99 format(3a,$) end C====================================================================== C Routine which allows indication of start of a compound object C Bounding box must be supplied C C GPS 23/8/95 C====================================================================== subroutine start_cmpnd(xlo,ylo,xhi,yhi) implicit none real offx,offy,ulengt,cmtopts common /offset/offx,offy,ulengt,cmtopts real xhi, yhi, xlo, ylo integer ihi, jhi, ilo, jlo ihi = int(xhi * ulengt * cmtopts + 0.5) ilo = int(xlo * ulengt * cmtopts + 0.5) jhi = int(yhi * ulengt * cmtopts + 0.5) jlo = int(ylo * ulengt * cmtopts + 0.5) write(6,21) '6 ', ihi, jlo, ilo, jhi 21 format(a,4i6) end C====================================================================== C End of compund object C====================================================================== subroutine end_cmpnd() write(6,21) '-6' 21 format(a) end C====================================================================== C Set of routines joining points with curved/straight line depending C on number of points. C Various line types are available as indicated. Spacing of dots and C dashes not yet implemented C GPS 29/10/94 C Variable line widths added 30/12/94 C====================================================================== C====================================================================== C Pair of short cut routines when drawing a straight line between C two points. C====================================================================== subroutine join_to_pnt(x2,y2,line_type) implicit none real offx,offy,ulengt,cmtopts real x1,x2,y1,y2 integer line_type common /offset/offx,offy,ulengt,cmtopts x1 = offx y1 = offy call join_pair(x1,y1,x2,y2,line_type) end !---------------------------------------------------------------------- subroutine join_pair(x1,y1,x2,y2,line_type) implicit none real offx,offy,ulengt,cmtopts common /offset/offx,offy,ulengt,cmtopts real x1,y1,x2,y2 integer i1,i2,j1,j2, line_type i1 = int(x1 * ulengt * cmtopts + 0.5) i2 = int(x2 * ulengt * cmtopts + 0.5) j1 = int(y1 * ulengt * cmtopts + 0.5) j2 = int(y2 * ulengt * cmtopts + 0.5) call xfig_start_spline(2, line_type) write(6,21) i1,j1 write(6,21) i2,j2 write(6,*) return c NB $ means stay at current position 21 format(2i7,$) end C====================================================================== C If joining many points together, then should call this first C followed by add_pnt for however many points need to be added C and when finished, end_many which does any necessary tydying up. C====================================================================== subroutine start_many(npts,line_type,spline) implicit none integer npts,line_type, spline integer count common /frmt/ count count = 0 if (spline .eq. 1) then call xfig_start_spline(npts, line_type) else call xfig_start_plyline(npts, line_type) endif return end !---------------------------------------------------------------------- subroutine add_pnt(x,y) implicit none real offx,offy,ulengt,cmtopts common /offset/offx,offy,ulengt,cmtopts real x,y integer count,i,j common /frmt/ count count = count + 1 i = int(x * ulengt * cmtopts + 0.5) j = int(y * ulengt * cmtopts + 0.5) if (mod(count,4) .ne. 0) then write(6,21) i,j else write(6,22) i,j endif return 21 format(2i7,$) 22 format(2i7) end !---------------------------------------------------------------------- ! Termination for xfig3.1: just end the line !---------------------------------------------------------------------- subroutine end_many() implicit none integer count common /frmt/ count if (mod(count,4) .ne. 0) then write (6,*) endif end C====================================================================== C This contains the details of what to do for line style, as well C as writing the xfig3.1 drawing command. C====================================================================== subroutine xfig_start_spline(npts, line_type) implicit none integer npts, line_type integer i_colour, i_patt, line_width character*5 solid,dashed,dotted character term*6, midl*6 common /width/ line_width common /colour/ i_colour, i_patt data solid /'3 0 0'/ data dashed /'3 0 1'/ data dotted /'3 0 2'/ c data midl /' 7 0 0 -1'/ data midl /' 7 0 0'/ data term /' 0 0 0'/ if (line_type .eq. 0) then write(6,20) solid, line_width, i_colour, midl, i_patt, $ 0.0, term elseif (line_type .eq. 2) then write(6,20) dashed, line_width, i_colour, midl, i_patt, $ 5.0,term elseif (line_type .eq. 1) then write(6,20) dotted, line_width, i_colour, midl, i_patt, $ 2.5,term else write(0,*) ' Line type',line_type,' not yet supported' return endif !------ number of points ------ write(6,21) npts 20 format(a,2i3,a,i6,f9.3,a,$) c 20 format(a,2i3,a,f9.3,a,$) 21 format(i6) end C====================================================================== C This contains the details of what to do for line style, as well C as writing the xfig3.1 drawing command. C====================================================================== subroutine xfig_start_plyline(npts, line_type) implicit none integer npts, line_type integer i_colour, i_patt, line_width character*5 solid,dashed,dotted character term*11, midl*6 common /width/ line_width common /colour/ i_colour, i_patt data solid /'2 1 0'/ data dashed /'2 1 1'/ data dotted /'2 1 2'/ c data midl /' 7 0 0 -1'/ data midl /' 7 0 0'/ data term /' 2 0 -1 0 0'/ if (line_type .eq. 0) then write(6,40) solid, line_width, i_colour, midl, i_patt, $ 0.0, term elseif (line_type .eq. 2) then write(6,40) dashed, line_width, i_colour, midl, i_patt, $ 5.0,term elseif (line_type .eq. 1) then write(6,40) dotted, line_width, i_colour, midl, i_patt, $ 2.5,term else write(0,*) ' Line type',line_type,' not yet supported' return endif !------ number of points ------ write(6,41) npts c 40 format(a,2i3,a,f9.3,a,$) 40 format(a,2i3,a,i6,f9.3,a,$) 41 format(i6) end C====================================================================== C Routine to get a real circle through xfig. Needs center and C radius. Xfig usually determines these through two clicks, C so two point positions also need to be speicified. C Fill = 0 for no fill. Fill = 1 for 100% fill C GPS 29/10/94 C Varaiable line width added 30/12/94 C====================================================================== subroutine draw_circle(x,y,r,i_fill) implicit none real x,y,r integer i1,j1,i2,j2,i_rad,i_fill,i, line_width integer i_colour, i_patt real offx,offy,ulengt,cmtopts common /offset/offx,offy,ulengt,cmtopts common /width/ line_width common /colour/ i_colour, i_patt character circle_cmnd1*6, circle_cmnd2*5 data circle_cmnd1/'1 3 0 '/ data circle_cmnd2/' 0 0 '/ i1 = int(ulengt*cmtopts*x + 0.5) j1 = int(ulengt*cmtopts*y + 0.5) i_rad = int(ulengt*cmtopts*r + 0.5) i2 = i1+i_rad j2 = j1 if (i_fill .ge. 0) then ! 20 for black (with default pen), -1 for not filled. i = i_fill * 21 - 1 else i = i_patt write(0,*) i endif write(6,20) circle_cmnd1, line_width, $ i_colour, i_colour, circle_cmnd2, i, 0.0,1,0.0 write(6,21) i1,j1,i_rad,i_rad,i1,j1,i2,j2 20 format(a, 3i4, a, i3, f8.5, i2, f6.3, $) 21 format(8i6) end * c-------------------------------------------------- Work out bounding box * c-------------------------------------------------- for compund objects * if (ptype .eq. 'fermion' .or. ptype.eq.'ghost') then * xlo = min(x1, xf) - 0.1 * xhi = max(x1, xf) + 0.1 * ylo = min(y1, yf) - 0.1 * yhi = max(y1, yf) + 0.1 * call start_cmpnd(xlo,ylo,xhi,yhi) * endif * c---------------------------------------------------- Draw an arrow? * if (ptype.eq.'fermion' .or. ptype.eq.'ghost') then * tm = 0.5 + sz/arclen/2.0 * zm = conv*(w(tm)-w0) + z1 * za1 = zm + sz*(zf-z1)/length*(-1.0,0.2) * za2 = zm + sz*(zf-z1)/length*(-1.0,-0.2) * c call join_pair(zm,za1,0) * c call join_pair(zm,za2,0) * call join_pair(real(zm),imag(zm),real(za1),imag(za1),0) * call join_pair(real(zm),imag(zm),real(za2),imag(za2),0) * call end_cmpnd() * endif