c c REVISED VERSION 2/15/89 NVB c c This program calls the subroutine plotps. c ******************************************************************** program plot c********************************************************************* c pdim leading dim in x y, xm ym vectors (all the same lead. dim c p(pdim) no. of separate plots (lines) c n(pdim) no. of points in each array c np(pdim) alternate number of points altered by skip function c nn(pdim) temporary array c pointx(pdim) pointer to column of data in xdat_file c pointy(pdim) pointer to column of data in ydat_file c x(pdim,mxlnpt) an array containing actual x values c xmin, xmax first and last x values c xbegin(pdim),xend(pdim) range to plot --- not yet implemented c xmbegin(pdim),xmend(pdim) range to plot --- not yet implemented c y(pdim,mxlnpt) y-values array c ymin, ymax min and max of y values c pm number of mark plots c nm(pdim) number of points to plot for mark function (i) c xm(pdim,mxmkpt) vector of mark function x points c ym(pdim,mxmkpt) vector of mark function y points c ytype(pdim) type of plot for function (i) LINE or MARK c samefile a flag for repeated filename entries c skip(pdim) skip factor: 0 plots all points; 1 every other point; etc c format_name file name of plot format file (without suffix) c plot_name postscript file name (without any suffix) c fmt_name file name of format file (format_name//'.fmt') c ps_file file name of ps file (plot_name//'.ps') c xdat_file(pdim) file name of x data file c xmdat_file(pdim) file name of xm data file c ydat_file(pdim) file name of y data file c ymdat_file(pdim) file name of ym data file c box if .true. then draws axes completely around plot. c sm_tics if .true. then draws small tic marks using c smxincr, smyincr smxincr and smyincr as the increments c extra_tics if .true. then draw the tic marks on the box (if box = .true.) c grid if .true. then draws a grid on the plot at the large tic marks c marksize to make marks larger or smaller: a scale factor c ulinestyle(pdim) integers for linestyle to use for line #i c umarktype(pdim) integers for mark type to use for mark-vector #i c clipmarks if .true. then clips marks at plot boundaries c lgnd if .true. creates legend. c nlines # of lines of type in the legend c line_num(pdim) type of line to draw on ith line of legend (-1 for none) c mark_num(pdim) type of mark to draw on ith line of legend (-1 for none) c comments(pdim) text of comments describing each entry in legend. c lgnd_ptsize point size of text in legend c xrel, yrel relative offset (x-y coordinates) of lower left corner of legend c extrax, extray .true. draws an extra x,y axis c xcoord, ycoord xcoord of extra y-axis, ycoord of extra x-axis to draw c axes_linewidth, plot_linewidth play with 'em. ( typ .5) c tic_length, smtic_length play with 'em, should be <1. (.02) c xsize, ysize size of plot in inches c xoffset, yoffset offset of plot lower left corner to paper corner, inches c iptsize, tptsize, nptsize axes labels-, title-, numbers- pt size c landscape if .true. for landscape c preview if .true. for screen preview c font font for titles, labels implicit none integer pdim,mxmkpt,mxlnpt parameter(pdim=10,mxmkpt=1000,mxlnpt=2500) integer p, pm integer n(pdim), np(pdim), nn(pdim), nm(pdim), nmp(pdim) integer pointx(pdim), pointy(pdim) integer skip(pdim), skip_line(pdim), skip_mark(pdim) integer nlines integer ulinestyle(pdim), umarktype(pdim) integer line_num(pdim), mark_num(pdim) integer lgnd_ptsize, iptsize, tptsize, nptsize real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real xmin, xmax real ymin, ymax real xincr, yincr real smxincr, smyincr real xbegin(pdim),xend(pdim), xmbegin(pdim),xmend(pdim) real marksize real axes_linewidth, plot_linewidth, tic_length, smtic_length real xsize, ysize, xoffset, yoffset, xrel, yrel character*4 ytype(pdim) character*150 xlabel, ylabel, title character*150 comments(pdim) character*8 xfmt, yfmt character*15 format_name, plot_name character*19 fmt_name character*18 ps_file character*30 xdat_file(pdim), xmdat_file(pdim) character*30 ydat_file(pdim), ymdat_file(pdim) character*30 dummy character*15 dumm character*11 font character*1 ans character*8 check logical xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks logical lgnd, landscape, preview, exists, first_time logical first_read, samefile logical extrax, extray real xcoord, ycoord integer i, ncmt, i1, i2 integer ip,ipm,ii,nx,ny integer ptemp,pmtemp real xmmax,xmmin,ymmax,ymmin character*5 xi(pdim),yi(pdim),ci(pdim) data xi/'[X1]','[X2]','[X3]','[X4]','[X5]', & '[X6]','[X7]','[X8]','[X9]','[X10]'/ data yi/'[Y1]','[Y2]','[Y3]','[Y4]','[Y5]', & '[Y6]','[Y7]','[Y8]','[Y9]','[Y10]'/ data ci/'[C1]','[C2]','[C3]','[C4]','[C5]', & '[C6]','[C7]','[C8]','[C9]','[C10]'/ c************************************************************** c******** DEFINE FILES TO STORE PLOT FORMAT c**************************** 901 first_read = .true. write(6,*) 'Enter name of plot format file (no suffix):' read(5,'(A15)') format_name call trim(format_name,i1,i2) if (i1.eq.i2) stop plot_name = format_name fmt_name = format_name(i1:i2)//'.fmt' ps_file=plot_name(i1:i2)//'.ps' call trim(fmt_name,i1,i2) inquire(file=fmt_name(i1:i2),exist=exists) if (exists ) then write(6,*)'WARNING: File '//fmt_name(i1:i2)//' already exists' write(6,*)'Use existing file? ( = yes )' read (5,'(a1)') ans call lwc(ans) if ((ans.ne.'y').and.(ans.ne.' ')) goto 901 first_time = .false. call readfmt(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, pointy, & skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, & tic_length, smtic_length, font, np, nmp, first_read) write(6,*) 'You may have to RR and R to get plot' else c new file initialization ******************************************* c******** FORMAT IMFORMATION ***************** 905 write(6,*) 'Enter # of functions to be plotted ( <',pdim+1,'):' read(5,'(i3)') p if (p.gt.pdim) then write(6,*) 'No more than ',pdim,' functions per plot allowed' goto 905 endif first_time = .true. call default(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, & pointy, skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, & tic_length, smtic_length, font, np, nmp, first_read) write(6,*) 'Files assumed to have data in spaced columns' write(6,*) 'Data only -- no text' write(6,*) 'For repeated data file names - enter ' do 910 i=1,p+pm 906 write(6,510) i 510 format(' Enter name of data file (with suffix) for x(',i2,')') read(5,'(A30)') xdat_file(i) if(xdat_file(i).eq.' ') xdat_file(i)=xdat_file(i-1) call trim(xdat_file(i),i1,i2) xdat_file(i) = xdat_file(i)(i1:i2) inquire(file=xdat_file(i),exist=exists) if (.not.exists ) then write(6,*) ' File '//xdat_file(i)(i1:i2)//' does not exist.' goto 906 endif write(6,*) 'Enter column number of x data' read(5,'(i4)') pointx(i) if(pointx(i).eq.0) pointx(i)=pointx(i-1) write(6,*) 'Enter number of points to plot' read(5,'(i5)') n(i) if( (n(i).eq.0).and.(i.gt.0) ) n(i)=n(i-1) nm(i) = n(i) 908 write(6,511) i 511 format(' Enter name of data file (with suffix) for y(',i2,')') read(5,'(A30)') ydat_file(i) if(ydat_file(i).eq.' ') ydat_file(i)=xdat_file(i) call trim(ydat_file(i),i1,i2) ydat_file(i) = ydat_file(i)(i1:i2) inquire(file=ydat_file(i),exist=exists) if (.not.exists ) then write(6,*) ' File '//ydat_file(i)(i1:i2)//' does not exist.' goto 908 endif write(6,*) 'Enter column number of y data' read(5,'(i4)') pointy(i) if(pointy(i).eq.0) pointy(i)=pointy(i-1) write(6,*) 'Type of plot file; Line [L] (default)', & ' or Mark [M] ?' read (5,'(a1)') ans call lwc(ans) if ( ans.eq.'m' ) then ytype(i) = 'MARK' p = p - 1 pm = pm + 1 else ytype(i) = 'LINE' endif write(6,*) 'Enter skip factor ( = 0) ' read(5,'(i5)') skip(i) 910 continue c sort out 'number of points' vectors c and legend mark/line types ip = 0 ipm = 0 do i = 1, p+pm if (ytype(i)(1:1).eq.'M') then ipm = ipm + 1 nm(ipm) = n(i) ulinestyle(i) = -1 line_num(i) = -1 umarktype(i) = ipm mark_num(i) = ipm skip_mark(ipm) = skip(i) else ip = ip + 1 n(ip) = n(i) ulinestyle(i) = ip line_num(i) = ip umarktype(i) = -1 mark_num(i) = -1 skip_line(ip) = skip(i) endif enddo endif c*************************************************************** c********** CHECK FOR MODIFICATIONS TO FORMAT FILE ************ 300 continue write(6,*) 'Enter selection: ' read(5,'(A8)') check call trim(check,i1,i2) check = check(i1:i2) call lwc(check) if (check.eq.'q') stop if (check.eq.'p') then call trim(ps_file,i1,i2) inquire (file=ps_file(i1:i2), exist=exists) if (exists .and. first_time) then write(6,*)'WARNING: File '//ps_file(i1:i2)//' already exists.' write(6,*)' Do you want to overwrite it? ( = yes)' read (5,'(a1)') ans call lwc(ans) if ((ans .ne. 'y') .and. (ans .ne. ' ')) goto 300 first_time = .false. endif call writeout(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, pointy, & skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, & tic_length, smtic_length, font, np, nmp) goto 300 endif if (check.eq.'r') then call autoscale(pdim,mxmkpt,mxlnpt, p, pm, n, nm, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, xbegin, xend, xmbegin, xmend, & xmmin, xmmax, ymmin, ymmax, xrel, yrel, & np, nmp, ylog, first_time) goto 300 endif if (check.eq.'rr') then call reread(pdim,mxmkpt,mxlnpt,p,n,x,y,pm,nm,xm,ym,pointx, & pointy,ytype,xdat_file,ydat_file,xmdat_file,ymdat_file) goto 300 endif if (check.eq.'m') then call menu(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, pointy, & skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci) goto 300 endif if (check.eq.'preview') then preview = .not. preview write(6,*) 'PREVIEW changed to ; ',Preview goto 300 endif if (check.eq.'format') then 990 write(6,*) 'Enter new name of plot format file (no suffix):' read(5,'(A15)') dumm call trim(dumm,i1,i2) dummy = dumm(i1:i2)//'.fmt' call trim(dummy,i1,i2) inquire(file=dummy(i1:i2), exist=exists) if (exists ) then write(6,*)'WARNING: File '//dummy(i1:i2)//' already exists.' write(6,*)' Use existing file? ( = yes )' read (5,'(a1)') ans call lwc(ans) if ((ans.ne.'y').and.(ans.ne.' ')) goto 990 format_name=dumm fmt_name=dummy first_read = .true. call readfmt(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, pointy, & skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, & tic_length, smtic_length, font, np, nmp, first_read) write(6,*) 'You may have to RR and R to get plot' else format_name=dumm fmt_name=dummy write(6,*) 'FORMAT changed to ; ',fmt_name endif goto 300 endif if (check.eq.'fl') then 301 write(6,*) 'ENTER NUMBER OF LINE FUNCTIONS TO BE PLOTTED: ' read(5,*) ptemp if( (ptemp+pm).gt.pdim) then write(6,*) 'No more than ',pdim,' functions per plot allowed' goto 301 endif p = ptemp nlines = p + pm write(6,*) 'Number of line functions [FL] changed to ; ' write(6,*) p goto 300 endif if (check.eq.'fm') then 302 write(6,*) 'ENTER NUMBER OF MARK FUNCTIONS TO BE PLOTTED: ' read(5,*) pmtemp if( (p+pmtemp).gt.pdim) then write(6,*) 'No more than ',pdim,' functions per plot allowed' goto 302 endif pm = pmtemp nlines = pm + p write(6,*) 'Number of mark functions [FL] changed to ; ' write(6,*) pm goto 300 endif if (check(1:1).eq.'x') then i = 0 if ( check(2:3).eq.'1 ') i=1 if ( check(2:3).eq.'2 ') i=2 if ( check(2:3).eq.'3 ') i=3 if ( check(2:3).eq.'4 ') i=4 if ( check(2:3).eq.'5 ') i=5 if ( check(2:3).eq.'6 ') i=6 if ( check(2:3).eq.'7 ') i=7 if ( check(2:3).eq.'8 ') i=8 if ( check(2:3).eq.'9 ') i=9 if ( check(2:3).eq.'10') i=10 if (i.ne.0) goto 970 endif if (check(1:1).eq.'y') then i = 0 if ( check(2:3).eq.'1 ') i=1 if ( check(2:3).eq.'2 ') i=2 if ( check(2:3).eq.'3 ') i=3 if ( check(2:3).eq.'4 ') i=4 if ( check(2:3).eq.'5 ') i=5 if ( check(2:3).eq.'6 ') i=6 if ( check(2:3).eq.'7 ') i=7 if ( check(2:3).eq.'8 ') i=8 if ( check(2:3).eq.'9 ') i=9 if ( check(2:3).eq.'10') i=10 if (i.ne.0) goto 975 endif c if (check.eq.'rx') then call limits(xmin,xmax,xincr,xlog) smxincr=0.2*xincr write(6,*) 'XMIN,XMAX,XINCR changed to :',xmin,xmax,xincr goto 300 endif if (check.eq.'ry') then call limits(ymin,ymax,yincr,ylog) smyincr=0.2*yincr write(6,*) 'YMIN,YMAX,YINCR changed to :',ymin,ymax,yincr goto 300 endif c if (check.eq.'xmax') then write(6,*) 'ENTER XMAX' read(5,*) xmax c xincr=0.1*(xmax-xmin) c smxincr=0.2*xincr write(6,*) 'XMAX changed to ; ',xmax goto 300 endif if (check.eq.'ymax') then write(6,*) 'ENTER YMAX' read(5,*) ymax c yincr=0.1*(ymax-ymin) c smyincr=0.2*yincr write(6,*) 'YMAX changed to ; ',ymax goto 300 endif if (check.eq.'xmin') then write(6,*) 'ENTER XMIN' read(5,*) xmin c xincr=0.1*(xmax-xmin) c smxincr=0.2*xincr write(6,*) 'XMIN changed to ; ',xmin goto 300 endif if (check.eq.'ymin') then write(6,*) 'ENTER YMIN' read(5,*) ymin c yincr=0.1*(ymax-ymin) c smyincr=0.2*yincr write(6,*) 'YMIN changed to ; ',ymin goto 300 endif if (check.eq.'xincr') then write(6,*) 'ENTER XINCR' read(5,*) xincr write(6,*) 'XINCR changed to ; ',xincr goto 300 endif if (check.eq.'yincr') then write(6,*) 'ENTER YINCR' read(5,*) yincr write(6,*) 'YINCR changed to ; ',yincr goto 300 endif if (check.eq.'smxincr') then write(6,*) 'ENTER SMXINCR' read(5,*) smxincr write(6,*) 'SMXINCR changed to ; ',smxincr goto 300 endif if (check.eq.'smyincr') then write(6,*) 'ENTER SMYINCR' read(5,*) smyincr write(6,*) 'SMYINCR changed to ; ',smyincr goto 300 endif if (check.eq.'box') then box = .not.box write(6,*) 'BOX changed to ; ',box goto 300 endif if (check.eq.'grid') then grid = .not.grid write(6,*) 'GRID changed to ; ',grid goto 300 endif if (check.eq.'land') then landscape = .not.landscape write(6,*) 'LAND changed to ; ',landscape goto 300 endif if (check.eq.'extrat') then extra_tics = .not.extra_tics write(6,*) 'EXTRAT changed to ; ',extra_tics goto 300 endif if (check.eq.'smtics') then sm_tics = .not.sm_tics write(6,*) 'SMTICS changed to ; ',sm_tics goto 300 endif if (check.eq.'clip') then clipmarks = .not.clipmarks write(6,*) 'CLIP changed to ; ',clipmarks goto 300 endif if (check.eq.'marksz') then write(6,*) 'ENTER RELATIVE MARK SIZE ( < 1. )' read(5,*) marksize write(6,*) 'MARKSZ changed to ; ',marksize goto 300 endif if (check.eq.'linesz') then write(6,*) 'ENTER RELATIVE LINE SIZE ( < 1. )' read(5,*) plot_linewidth write(6,*) 'LINESZ changed to ; ',plot_linewidth goto 300 endif if (check.eq.'xsize') then write(6,*) 'ENTER XSIZE (in inches)' read(5,*) xsize write(6,*) 'XSIZE changed to ; ',xsize goto 300 endif if (check.eq.'ysize') then write(6,*) 'ENTER YSIZE (in inches)' read(5,*) ysize write(6,*) 'YSIZE changed to ; ',ysize goto 300 endif if (check.eq.'xoffset') then write(6,*) 'ENTER XOFFSET (in inches)' read(5,*) xoffset write(6,*) 'XOFFSET changed to ; ',xoffset goto 300 endif if (check.eq.'yoffset') then write(6,*) 'ENTER YOFFSET (in inches)' read(5,*) yoffset write(6,*) 'YOFFSET changed to ; ',yoffset goto 300 endif if (check.eq.'extrax') then extrax = .not.extrax write(6,*) 'EXTRAX changed to ; ',extrax goto 300 endif if (check.eq.'xcoord') then write(6,*) 'Enter position for extra x axis; ' read(5,*) xcoord goto 300 endif if (check.eq.'extray') then extray = .not.extray write(6,*) 'EXTRAY changed to ; ',extray goto 300 endif if (check.eq.'ycoord') then write(6,*) 'Enter position for extra y axis; ' read(5,*) ycoord goto 300 endif if (check.eq.'xfmt') then write(6,*) 'ENTER XFMT' read(5,'(a8)') xfmt call trim(xfmt,i1,i2) xfmt=xfmt(i1:i2) write(6,*) 'XFMT changed to ; ',xfmt goto 300 endif if (check.eq.'yfmt') then write(6,*) 'ENTER YFMT' read(5,'(a8)') yfmt call trim(yfmt,i1,i2) yfmt=yfmt(i1:i2) write(6,*) 'YFMT changed to ; ',yfmt goto 300 endif if (check.eq.'xlog') then if ((.not. xlog).and.(xmin.le.0.0)) then write(6,*) 'logarithmic display will not work with current' write(6,*) 'data limits - display remains linear' else xlog = .not. xlog write(6,*) 'XLOG changed to ; ',xlog endif goto 300 endif if (check.eq.'ylog') then if ((.not. ylog).and.(ymin.le.0.0)) then write(6,*) 'logarithmic display will not work with current' write(6,*) 'data limits - display remains linear' else ylog = .not. ylog write(6,*) 'YLOG changed to ; ',ylog if(.not.ylog) then yrel = ymin - .75 * (ymax - ymin) else yrel = ymin endif endif goto 300 endif c if (check.eq.'title') then write(6,*) 'ENTER TITLE' read(5,'(a150)') title call trim(title,i1,i2) title=title(i1:i2) write(6,*) 'TITLE changed to ; ' write(6,*) title(i1:i2) goto 300 endif if (check.eq.'xlabel') then write(6,*) 'ENTER XLABEL' read(5,'(a150)') xlabel call trim(xlabel,i1,i2) xlabel=xlabel(i1:i2) write(6,*) 'XLABEL changed to ; ' write(6,*) xlabel(i1:i2) goto 300 endif if (check.eq.'ylabel') then write(6,*) 'ENTER YLABEL' read(5,'(a150)') ylabel call trim(ylabel,i1,i2) ylabel=ylabel(i1:i2) write(6,*) 'YLABEL changed to ; ' write(6,*) ylabel(i1:i2) goto 300 endif if (check.eq.'name') then write(6,*) 'ENTER NAME (WITHOUT SUFFIX)' read(5,'(a15)') plot_name call trim(plot_name,i1,i2) ps_file=plot_name(i1:i2)//'.ps' write(6,*) 'NAME changed to ; ' write(6,*) plot_name goto 300 endif if (check.eq.'lgnd') then lgnd = .not. lgnd write(6,*) 'LGND changed to ; ',lgnd yrel=ymin xrel=xmax+(xmax-xmin)/50. goto 300 endif if (check.eq.'nlines') then write(6,*) 'ENTER NUMBER OF LINES IN LEGEND' read(5,*) nlines write(6,*) 'NLINES changed to ; ',nlines goto 300 endif if (check.eq.'xrel') then write(6,*) 'ENTER XREL' read(5,*) xrel write(6,*) 'XREL changed to ; ',xrel goto 300 endif if (check.eq.'yrel') then write(6,*) 'ENTER YREL' read(5,*) yrel write(6,*) 'YREL changed to ; ',yrel goto 300 endif if (check(1:1).eq.'c') then ncmt = 0 if ( check(2:3).eq.'1 ') ncmt=1 if ( check(2:3).eq.'2 ') ncmt=2 if ( check(2:3).eq.'3 ') ncmt=3 if ( check(2:3).eq.'4 ') ncmt=4 if ( check(2:3).eq.'5 ') ncmt=5 if ( check(2:3).eq.'6 ') ncmt=6 if ( check(2:3).eq.'7 ') ncmt=7 if ( check(2:3).eq.'8 ') ncmt=8 if ( check(2:3).eq.'9 ') ncmt=9 if ( check(2:3).eq.'10') ncmt=10 if (ncmt.ne.0) then write(6,*) 'ENTER COMMENT' read(5,'(A150)') comments(ncmt) call trim(comments(ncmt),i1,i2) comments(ncmt)=comments(ncmt)(i1:i2) write(6,*) ci(ncmt),' changed to ; ' write(6,*) comments(ncmt)(i1:i2) else write(6,*) 'invalid comment number' endif goto 300 endif if (check.eq.'line') then write(6,*) 'ENTER LEGEND ENTRY NUMBER' read(5,*) ncmt write(6,*) 'ENTER LINE STYLE (-1 for no line)' read(5,*) line_num(ncmt) write(6,*) 'LINE style for',ci(ncmt),' changed to ; ', & line_num(ncmt) goto 300 endif if (check.eq.'mark') then write(6,*) 'ENTER LEGEND ENTRY NUMBER' read(5,*) ncmt write(6,*) 'ENTER MARK STYLE (-1 for no mark)' read(5,*) mark_num(ncmt) write(6,*) 'MARK style for',ci(ncmt),' changed to ; ', & mark_num(ncmt) goto 300 endif write(6,*) 'Choice made not on the menu. Try again.' goto 300 970 samefile = .false. write(6,510) i read(5,'(A30)') dummy if (dummy.eq.' ') then if (xdat_file(i).eq.'no_file_specified') then write(6,*) 'No existing file name exist' goto 970 else samefile = .true. endif else call trim(dummy,i1,i2) inquire(file=dummy,exist=exists) if (.not.exists ) then write(6,*) ' File '//dummy(i1:i2)//' does not exist. ' goto 970 endif if (i.gt.(p+pm)) then if( (p+pm).ge.pdim ) then write(6,*) 'No more than ',pdim,' files allowed' goto 300 endif p = p + 1 nlines = p + pm endif xdat_file(i) = dummy(i1:i2) endif nx = 0 write(6,*) 'Enter column number of x data' read(5,'(i4)') nx if(nx.ne.0) then pointx(i)=nx else if (.not.samefile) then if (i.ne.1) then pointx(i)=pointx(i-1)+1 else pointx(i)=1 endif endif endif c write(6,*) 'Enter beginning point' c read(5,'(E14.7)') xbegin(i) c write(6,*) 'Enter ending point' c read(5,'(E14.7)') xend(i) ip = 0 c put 'number of point' in n(i) ipm = 0 c to be resorted do ii = 1, pdim if (ytype(ii)(1:1).eq.'M') then ipm = ipm + 1 nn(ii) = nm(ipm) else ip = ip + 1 nn(ii) = n(ip) endif enddo nx = 0 write(6,*) 'Enter number of points to plot' read(5,'(i5)') nx if(nx.ne.0) then nn(i) = nx else if (.not.samefile) then if (i.ne.1) then nn(i) = n(i-1) else nn(i) = 1 endif endif endif if(i.gt.(p+pm)) then if (ytype(i)(1:).eq.'M') then pm = pm + 1 else p = p + 1 endif nlines = nlines + 1 endif do ii = 1, pdim n(ii) = nn(ii) enddo goto 976 975 samefile = .false. write(6,511) i read(5,'(A30)') dummy if (dummy.eq.' ') then if (ydat_file(i).eq.'no_file_specified') then write(6,*) 'No existing file name exist' goto 975 else samefile = .true. endif else call trim(dummy,i1,i2) inquire(file=dummy,exist=exists) c check if file exist if (.not.exists ) then write(6,*) ' File '//dummy(i1:i2)//' does not exist. ' goto 975 endif ydat_file(i) = dummy(i1:i2) endif ny=0 write(6,*) 'Enter column number of y data' read(5,'(i4)' ) ny if(ny.ne.0) then pointy(i) = ny else if (.not.samefile) then if (i.ne.1) then pointy(i)=pointy(i-1)+1 else pointy(i)=2 endif endif endif ip = 0 c put 'number of point' in n(i) ipm = 0 c to be resorted do ii = 1, pdim if (ytype(ii)(1:1).eq.'M') then ipm = ipm + 1 nn(ii) = nm(ipm) else ip = ip + 1 nn(ii) = n(ip) endif enddo write(6,*) 'Type of plot file; Line [L] (default) or Mark [M] ? ' read (5,'(a1)') ans if ( (ans.eq.'m').or.(ans.eq.'M') ) then if (i.gt.(p+pm)) then pm = pm + 1 nlines = p + pm else if ( ytype(i)(1:1).ne.'M' ) then p = p - 1 pm = pm + 1 endif endif ytype(i) = 'MARK' else if (i.gt.(p+pm)) then if( (p+pm).ge.pdim ) then write(6,*) 'No more than ',pdim,' files allowed' goto 300 endif p = p + 1 nlines = p + pm else if( ytype(i)(1:1).eq.'M' ) then p = p + 1 pm = pm - 1 endif endif ytype(i) = 'LINE' endif write(6,*) 'Enter skip factor ( = 0) ' read(5,'(i5)') skip(i) do ii = 1, pdim n(ii) = nn(ii) enddo c sort out 'number of points' vectors c and legend mark/line types 976 ip = 0 ipm = 0 do i = 1, p+pm if (ytype(i)(1:1).eq.'M') then ipm = ipm + 1 nm(ipm) = n(i) ulinestyle(i) = -1 line_num(i) = -1 umarktype(i) = ipm mark_num(i) = ipm skip_mark(ipm) = skip(i) else ip = ip + 1 n(ip) = n(i) ulinestyle(i) = ip line_num(i) = ip umarktype(i) = -1 mark_num(i) = -1 skip_line(ip) = skip(i) endif enddo c call menu(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, pointy, c & skip, nlines, ulinestyle, umarktype, c & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, c & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, c & smxincr, smyincr, marksize, plot_linewidth, c & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, c & xlabel, ylabel, title, comments, xfmt, yfmt, c & format_name, plot_name, fmt_name, ps_file, c & xdat_file, xmdat_file, ydat_file, ymdat_file, c & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, c & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, c & xi,yi,ci) goto 300 end subroutine trim(char_str,i1,i2) c**********************************************************************c c c c finds positions of the first and last non-blank characters c c in a string c c c c**********************************************************************c implicit none integer length_spec,i1,i2,i character*(*) char_str length_spec=len(char_str) do 10 i=1,length_spec if (char_str(i:i).ne.' ') then i1=i goto 15 endif 10 continue 15 do 20 i=length_spec,1,-1 if (char_str(i:i).ne.' ') then i2=i goto 25 endif 20 continue 25 return end c ******************************************************************c subroutine reread(pdim,mxmkpt,mxlnpt,p,n,x,y,pm,nm,xm,ym,pointx, & pointy,ytype,xdat_file,ydat_file,xmdat_file,ymdat_file) c**********************************************************************c c reads the data from the data files c**********************************************************************c implicit none integer pdim,mxmkpt,mxlnpt integer p, n(pdim), pm, nm(pdim), pointx(pdim), pointy(pdim) real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real x_read, y_read character*4 ytype(pdim) character*30 xdat_file(pdim), ydat_file(pdim) character*30 xmdat_file(pdim), ymdat_file(pdim) integer i, j, i1, i2 integer ip, ipm, k logical exists ip = 0 ipm = 0 do 920 i=1,p+pm call trim(xdat_file(i),i1,i2) inquire(file=xdat_file(i), exist=exists) if (.not.exists ) then write(6,*) ' WARNING: Referenced file ' & //xdat_file(i)(i1:i2)//' does not exist.' else call trim(ydat_file(i),i1,i2) inquire(file=ydat_file(i), exist=exists) if (.not.exists ) then write(6,*) ' WARNING: Referenced file ' & //ydat_file(i)(i1:i2)//' does not exist.' else open(20,file=xdat_file(i)) open(30,file=ydat_file(i)) if (ytype(i)(1:1).eq.'M') then ipm = ipm + 1 do j = 1, nm(ipm) if (pointx(i).lt.0) then x_read=float(j) else read(20,*,err=99) (x_read,k=1,pointx(i)) endif read(30,*,err=99) (y_read,k=1,pointy(i)) xm(ipm,j) = x_read ym(ipm,j) = y_read enddo 99 nm(ipm)=j-1 else ip = ip + 1 do j = 1, n(ip) if (pointx(i).lt.0) then x_read=float(j) else read(20,*,err=98) (x_read,k=1,pointx(i)) endif read(30,*,err=98) (y_read,k=1,pointy(i)) x(ip,j) = x_read y(ip,j) = y_read enddo 98 n (ip )=j-1 endif close(20) close(30) endif endif 920 continue return end c subroutine lwc(str) c converts string 'str' to lowercase implicit none character*(*) str integer i,ich do 1 i=1,len(str) ich=ichar(str(i:i)) c note: ichar('A')=65, ichar('Z')=90 if(ich.ge.65.and.ich.le.90) then str(i:i)=char(ich+32) endif 1 continue end c subroutine upc(str) c converts string 'str' to uppercase implicit none character*(*) str integer i,ich do 1 i=1,len(str) ich=ichar(str(i:i)) c note: ichar('a')=97, ichar('z')=122 if(ich.ge.97.and.ich.le.122) then str(i:i)=char(ich-32) endif 1 continue end c subroutine limits(dmin,dmax,dincr,dlogflg) implicit none real dmin,dmax,dincr logical dlogflg dincr=10.**nint(log10(dmax-dmin)-0.5) dmax=dincr*(nint(dmax/dincr +0.4999)) if (dlogflg) then dmin=10.**nint(log10(dmin)-0.5) else dmin=dincr*(nint(dmin/dincr -0.4999)) endif end c c--------------------------------------------------------------------------- c subroutine menu(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, pointy, & skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci) implicit none integer pdim,mxmkpt,mxlnpt integer p, pm, n(pdim), nm(pdim), pointx(pdim), pointy(pdim) integer skip(pdim) integer nlines integer ulinestyle(pdim), umarktype(pdim) integer line_num(pdim), mark_num(pdim) integer lgnd_ptsize, iptsize, tptsize, nptsize real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real xmin, xmax, ymin, ymax, xincr, yincr, smxincr, smyincr real marksize, plot_linewidth real xsize, ysize, xoffset, yoffset, xrel, yrel character*(*) ytype(pdim) character*(*) xlabel, ylabel, title character*(*) comments(pdim) character*(*) xfmt, yfmt character*(*) format_name, plot_name character*(*) fmt_name character*(*) ps_file character*(*) xdat_file(pdim), xmdat_file(pdim) character*(*) ydat_file(pdim), ymdat_file(pdim) logical xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks logical lgnd, landscape, preview logical extrax, extray real xcoord, ycoord integer i, i1, i2 integer ip,ipm character*(*) xi(pdim),yi(pdim),ci(pdim) write(6,*) ' *************** MENU ****************' write(6,*) call trim(format_name,i1,i2) write(6,941) format_name(i1:i2) call trim(plot_name,i1,i2) write(6,265) plot_name(i1:i2) write(6,946) p write(6,947) pm write(6,942) ip = 0 ipm = 0 do i = 1, p + pm if (ytype(i)(1:1).eq.'M') then ipm = ipm + 1 write(6,943) xi(i),xdat_file(i),pointx(i),nm(ipm) else ip = ip + 1 write(6,943) xi(i),xdat_file(i),pointx(i),n(ip) endif enddo write(6,944) write(6,945) (yi(i),ydat_file(i),pointy(i), & ytype(i),skip(i),i=1,p+pm) call trim(title,i1,i2) write(6,240) title(i1:i2) call trim(xlabel,i1,i2) write(6,250) xlabel(i1:i2) call trim(ylabel,i1,i2) write(6,260) ylabel(i1:i2) write(6,*) write(6,210) preview, xmax, ymax write(6,211) box, xmin, ymin write(6,212) grid, xincr, yincr write(6,213) landscape, smxincr, smyincr write(6,214) extra_tics, xsize, ysize write(6,215) sm_tics, xoffset, yoffset write(6,216) clipmarks, extrax, extray write(6,217) marksize, xcoord, ycoord write(6,230) plot_linewidth, xfmt, yfmt write(6,232) lgnd, xlog, ylog write(6,270) nlines if (lgnd) then write(6,*) ' LEGEND' write(6,275) xrel, yrel write(6,*) 'COMMENT LINE MARK TEXT ' do i=1,nlines call trim(comments(i),i1,i2) write(6,280) ci(i),line_num(i),mark_num(i), comments(i)(i1:i2) enddo endif write(6,940) 940 format (/,'VARIABLE NAME to change value,',/, & ' P to plot, ',/, & ' R to rescale X/Y MIN/MAX, ',/, & ' RR to re-read data files, ',/, & ' M to update menu : ',/ ) 941 format('FORMAT: ',A15,' (FORMAT.fmt file)') 265 format('NAME : ',A15,' (postscript NAME.ps file)') 942 format(/,'FILE',3X,'DATA FILES FOR X COORDINATE:',5X,'COLUMN #', & 5X,'NUM. POINTS') 943 format(A5,4x,A30,5X,i3,7X,i5) 944 format(/,'FILE',3X,'DATA FILES FOR Y COORDINATE:',5X,'COLUMN #', & 5X,'TYPE',5X,'SKIP') 945 format(10(A5,4x,A30,5X,i3,6x,a4,5x,i3,/)) 946 format('Number of LINE functions : [FL] ',I5) 947 format('Number of MARK functions : [FM] ',I5) 210 format( & 'PREVIEW = ',2x,l1,9x,'XMAX = ',E10.3, ' YMAX = ',E10.3) 211 format( & 'BOX = ',2x,l1,9x,'XMIN = ',E10.3, ' YMIN = ',E10.3) 212 format( & 'GRID = ',2x,l1,9x,'XINCR = ',E10.3, ' YINCR = ',E10.3) 213 format( & 'LAND = ',2x,l1,9x,'SMXINCR = ',E10.3, ' SMYINCR = ',E10.3) 214 format( & 'EXTRAT = ',2x,l1,9x,'XSIZE = ',f5.2,5X, ' YSIZE = ',f5.2 ) 215 format( & 'SMTICS = ',2x,l1,9x,'XOFFSET = ',f5.2,5X, ' YOFFSET = ',f5.2 ) 216 format( & 'CLIP = ',2x,l1,9x,'EXTRAX = ',2x,l1,7x,' EXTRAY = ',2x,l1) 217 format( & 'MARKSZ = ',f5.2,7x,'XCOORD = ',f5.2,5x, ' YCOORD = ',f5.2 ) 230 format( & 'LINESZ = ',f5.2,7x,'XFMT = ',A8,2X, ' YFMT = ',A8 ) 232 format( & 'LGND = ',2x,l1,9x,'XLOG = ',2x,l1,7X,' YLOG = ',l1 ) 240 format(/,'TITLE = ',A) 250 format('XLABEL = ',A) 260 format('YLABEL = ',A) 270 format('NLINES = ',I2/) 275 format('XREL = ',E14.7,' YREL = ',E14.7/) 280 format(2X,A5,4X,I2,4X,I2,5X,A) end c c------------------------------------------------------------------------------ c subroutine writeout(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, & pointy, skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, tic_length, & smtic_length, font, np, nmp) implicit none integer pdim,mxmkpt,mxlnpt integer p, pm, pointx(pdim), pointy(pdim) integer n(pdim), np(pdim), nm(pdim), nmp(pdim) integer skip(pdim), skip_line(pdim), skip_mark(pdim) integer nlines integer ulinestyle(pdim), umarktype(pdim) integer line_num(pdim), mark_num(pdim) integer lgnd_ptsize, iptsize, tptsize, nptsize real xbegin(pdim),xend(pdim) real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real xmin, xmax, ymin, ymax, xincr, yincr, smxincr, smyincr real marksize real axes_linewidth, plot_linewidth, tic_length, smtic_length real xsize, ysize, xoffset, yoffset, xrel, yrel character*(*) ytype(pdim) character*(*) xlabel, ylabel, title character*(*) comments(pdim) character*(*) xfmt, yfmt character*(*) format_name, plot_name character*(*) fmt_name character*(*) ps_file character*(*) xdat_file(pdim), xmdat_file(pdim) character*(*) ydat_file(pdim), ymdat_file(pdim) character*(*) font logical xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks logical lgnd, landscape, preview logical extrax, extray real xcoord, ycoord integer i, j, k character*(*) xi(pdim),yi(pdim),ci(pdim) c******** RE-ASSIGN FUNCTIONS VALUES TO SKIP OVER POINTS call reread(pdim,mxmkpt,mxlnpt,p,n,x,y,pm,nm,xm,ym,pointx, & pointy,ytype,xdat_file,ydat_file,xmdat_file,ymdat_file) do i = 1,p j=1 k=1 do while ( j.lt.n(i) ) x(i,k) = x(i,j) y(i,k) = y(i,j) j = j + skip_line(i) + 1 k = k + 1 enddo x(i,k) = x(i,n(i)) c plots the endpoint too y(i,k) = y(i,n(i)) np(i) = k enddo do i = 1,pm j=1 k=1 do while ( j.lt.nm(i) ) xm(i,k) = xm(i,j) ym(i,k) = ym(i,j) j = j + skip_mark(i) + 1 k = k + 1 enddo xm(i,k) = xm(i,nm(i)) c plots the endpoint too ym(i,k) = ym(i,nm(i)) nmp(i) = k enddo c************* WRITE FORMAT INFORMATION TO FORMAT FILE open(10,file=fmt_name) write(10,950) plot_name,p,pm write(10,951) (xdat_file(i),i=1,pdim) write(10,952) (pointx(i),i=1,pdim) write(10,957) (n(i),i=1,pdim) write(10,959) (nm(i),i=1,pdim) write(10,953) (xbegin(i),i=1,pdim) write(10,954) (xend(i),i=1,pdim) write(10,955) (ydat_file(i),i=1,pdim) write(10,956) (pointy(i),i=1,pdim) write(10,958) (ytype(i),i=1,pdim) write(10,960) (skip(i),i=1,pdim) 950 format('plot_name'/A15/'number of line plots'/I5/ & 'number of mark plots'/I5) 951 format('xdat_files'/10(A30/)) 952 format('pointx'/10(i3/)) 953 format('beginning x points'/10(e14.7/)) 954 format('ending x points'/10(e14.7/)) 955 format('ydat_files'/10(A30/)) 956 format('column'/10(I3/)) 957 format('number of line points to plot'/10(i5/)) 958 format('plot type'/10(a4/)) 959 format('number of mark points to plot'/10(i5/)) 960 format('number of data points to skip between plotted points' & /10(i5/)) write(10,200) xmin,xmax,ymin,ymax,xlog,ylog,xincr,smxincr,yincr, & smyincr,box,xsize,ysize,xoffset,yoffset, & xfmt,yfmt,title,xlabel,ylabel,lgnd, & nlines,xrel,yrel,(comments(i),i=1,pdim), & (line_num(i),i=1,pdim),(mark_num(i),i=1,pdim) 200 format('xmin'/e14.7/'xmax'/e14.7/'ymin'/e14.7/'ymax'/e14.7/ & 'xlog'/l2/'ylog'/l2/'xincr'/e14.7/'smxincr'/e14.7/ & 'yincr'/e14.7/'smyincr'/e14.7/'box'/l2/'xsize'/e14.7/ & 'ysize'/e14.7/'xoffset'/e14.7/'yoffset'/e14.7/ & 'xfmt'/a8/'yfmt'/a8/ & 'title'/a150/'xlabel'/a150/'ylabel'/a150/'lgnd'/l2/ & 'nlines'/i2/'xrel'/e14.7/'yrel'/e14.7/'comments'/ & 10(a150/),'line_num'/10(i2/),'mark_num'/9(i2/),i2) write(10,201) box,sm_tics,extra_tics,grid,landscape,marksize, & lgnd_ptsize,extrax,ycoord,extray,xcoord,axes_linewidth, & plot_linewidth,tic_length,smtic_length,xsize,ysize,xoffset, & yoffset,iptsize,nptsize,tptsize, & (ulinestyle(i),i=1,pdim),(umarktype(i),i=1,pdim), & preview,font,clipmarks 201 format ('box'/l2/'sm_tics'/l2/'extra_tics'/l2/'grid'/l2/ & 'landscape'/l2/'marksize'/f5.2/'lgnd_ptsize'/i4/ & 'extrax'/l2/'ycoord'/e10.3/'extray'/l2/'xcoord'/e10.3/ & 'axes_linewidth'/f6.4/'plot_linewidth'/f6.4/ & 'tic_length'/f6.4/'smtic_length'/f6.4/'xsize'/f6.3/ & 'ysize'/f6.3/'xoffset'/f6.3/'yoffset'/f6.3/ & 'iptsize'/i4/'nptsize'/i4/'tptsize'/i4/ & 'ulinestyle'/10(i2/),'umarktype'/10(i2/), & 'preview'/l2/'font'/a11/'clipmarks'/l2) close(10) call plotps(pdim,p,np,x,xmin,xmax,xlabel,xincr,xfmt, & y,ymin,ymax,ylabel,yincr,yfmt, & title,ps_file, & pm,nmp,xm,ym, & box,sm_tics,smxincr,smyincr,extra_tics,grid, & marksize,ulinestyle,umarktype,lgnd, & nlines,line_num,mark_num,comments,lgnd_ptsize, & xrel,yrel,extrax,ycoord,extray,xcoord, & axes_linewidth,plot_linewidth,tic_length, & smtic_length,xsize,ysize,xoffset,yoffset, & iptsize,nptsize,tptsize,landscape,xlog,ylog, & font,preview,clipmarks) end c c------------------------------------------------------------------------- c subroutine readfmt(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, & pointy, skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, tic_length, & smtic_length, font, np, nmp, first_read) implicit none integer pdim,mxmkpt,mxlnpt integer p, pm, pointx(pdim), pointy(pdim) integer n(pdim), np(pdim), nm(pdim), nmp(pdim) integer skip(pdim), skip_line(pdim), skip_mark(pdim) integer nlines integer ulinestyle(pdim), umarktype(pdim) integer line_num(pdim), mark_num(pdim) integer lgnd_ptsize, iptsize, tptsize, nptsize real xbegin(pdim),xend(pdim) real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real xmin, xmax, ymin, ymax, xincr, yincr, smxincr, smyincr real marksize real axes_linewidth, plot_linewidth, tic_length, smtic_length real xsize, ysize, xoffset, yoffset, xrel, yrel character*(*) ytype(pdim) character*(*) xlabel, ylabel, title character*(*) comments(pdim) character*(*) xfmt, yfmt character*(*) format_name, plot_name character*(*) fmt_name character*(*) ps_file character*(*) xdat_file(pdim), xmdat_file(pdim) character*(*) ydat_file(pdim), ymdat_file(pdim) character*(*) font logical xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks logical lgnd, landscape, preview logical extrax, extray real xcoord, ycoord logical first_read character*(*) xi(pdim),yi(pdim),ci(pdim) c xmini, xmaxi temporary first and last x values c ymini, ymaxi temporary min and max of y values c xincri, yincri temporary variables for xincr, yincr c smxincri, smyincri temporary smxincr and smyincr as the increments integer i, i1, i2, ip, ipm real xmini, xmaxi, xincri, smxincri real ymini, ymaxi, yincri, smyincri c read format data from old file open(10,file=fmt_name) read(10,930) plot_name,p,pm call trim(plot_name,i1,i2) ps_file=plot_name(i1:i2)//'.ps' read(10,931) (xdat_file(i),i=1,pdim) read(10,932) (pointx(i),i=1,pdim) read(10,934) (n(i),i=1,pdim) read(10,934) (nm(i),i=1,pdim) read(10,933) (xbegin(i),i=1,pdim) read(10,933) (xend(i),i=1,pdim) read(10,931) (ydat_file(i),i=1,pdim) read(10,932) (pointy(i),i=1,pdim) read(10,935) (ytype(i),i=1,pdim) read(10,936) (skip(i),i=1,pdim) 930 format(/A15//I5//I5) 931 format(/10(A30/)) 932 format(/10(i3/)) 933 format(/10(e14.7/)) 934 format(/10(i5/)) 935 format(/10(a4/)) 936 format(/10(i5/)) ip = 0 ipm = 0 do i = 1, p+pm if (ytype(i)(1:1).eq.'M') then ipm = ipm + 1 skip_mark(ipm) = skip(i) else ip = ip + 1 skip_line(ip) = skip(i) endif enddo read(10,202) xmini,xmaxi,ymini,ymaxi,xlog,ylog, & xincri,smxincri,yincri,smyincri, & box,xsize,ysize,xoffset,yoffset,xfmt,yfmt, & title,xlabel,ylabel,lgnd,nlines,xrel,yrel, & (comments(i),i=1,pdim),(line_num(i),i=1,pdim), & (mark_num(i),i=1,pdim) 202 format(/e14.7//e14.7//e14.7//e14.7//l2//l2/ & /e14.7//e14.7//e14.7//e14.7/ & /l2//e14.7//e14.7//e14.7//e14.7//a8//a8/ & /a150//a150//a150//l2/ & /i2//e14.7//e14.7// & 10(a150/),/10(i2/),/9(i2/),i2) if (first_read) then xmin = xmini xmax = xmaxi xincr = xincri smxincr = smxincri ymin = ymini ymax = ymaxi yincr = yincri smyincr = smyincri first_read = .false. endif read(10,203) box,sm_tics,extra_tics,grid,landscape,marksize, & lgnd_ptsize,extrax,ycoord,extray,xcoord,axes_linewidth, & plot_linewidth,tic_length,smtic_length,xsize,ysize,xoffset, & yoffset,iptsize,nptsize,tptsize, & (ulinestyle(i),i=1,pdim),(umarktype(i),i=1,pdim), & preview,font,clipmarks 203 format (/l2//l2//l2//l2/ & /l2//f5.2//i4/ & /l2//e10.3//l2//e10.3/ & /f6.4//f6.4/ & /f6.4//f6.4//f6.3/ & /f6.3//f6.3//f6.3/ & /i4//i4//i4/ & /10(i2/),/10(i2/), & /l2//a11//l2) close(10) call trim(xfmt,i1,i2) xfmt=xfmt(i1:i2) call trim(yfmt,i1,i2) yfmt=yfmt(i1:i2) call trim(title,i1,i2) title=title(i1:i2) call trim(xlabel,i1,i2) xlabel=xlabel(i1:i2) call trim(ylabel,i1,i2) ylabel=ylabel(i1:i2) do i=1,pdim call trim(comments(i),i1,i2) comments(i)=comments(i)(1:i2) enddo end c c-------------------------------------------------------------------------- c subroutine default(pdim,mxmkpt,mxlnpt, p, pm, n, nm, pointx, & pointy, skip, nlines, ulinestyle, umarktype, & line_num, mark_num, lgnd_ptsize, iptsize, tptsize, nptsize, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, marksize, plot_linewidth, & xsize, ysize, xoffset, yoffset, xrel, yrel, ytype, & xlabel, ylabel, title, comments, xfmt, yfmt, & format_name, plot_name, fmt_name, ps_file, & xdat_file, xmdat_file, ydat_file, ymdat_file, & xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks, & lgnd, landscape, preview, extrax, extray, xcoord, ycoord, & xi,yi,ci, & skip_line, skip_mark, xbegin, xend, axes_linewidth, tic_length, & smtic_length, font, np, nmp, first_read) implicit none integer pdim,mxmkpt,mxlnpt integer p, pm, pointx(pdim), pointy(pdim) integer n(pdim), np(pdim), nm(pdim), nmp(pdim) integer skip(pdim), skip_line(pdim), skip_mark(pdim) integer nlines integer ulinestyle(pdim), umarktype(pdim) integer line_num(pdim), mark_num(pdim) integer lgnd_ptsize, iptsize, tptsize, nptsize real xbegin(pdim),xend(pdim) real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real xmin, xmax, ymin, ymax, xincr, yincr, smxincr, smyincr real marksize real axes_linewidth, plot_linewidth, tic_length, smtic_length real xsize, ysize, xoffset, yoffset, xrel, yrel character*(*) ytype(pdim) character*(*) xlabel, ylabel, title character*(*) comments(pdim) character*(*) xfmt, yfmt character*(*) format_name, plot_name character*(*) fmt_name character*(*) ps_file character*(*) xdat_file(pdim), xmdat_file(pdim) character*(*) ydat_file(pdim), ymdat_file(pdim) character*(*) font logical xlog, ylog, box, sm_tics, extra_tics, grid, clipmarks logical lgnd, landscape, preview logical extrax, extray real xcoord, ycoord logical first_read character*(*) xi(pdim),yi(pdim),ci(pdim) c integer i lgnd_ptsize=10 do i=1,pdim ulinestyle(i)=i ytype(i) = 'LINE' umarktype(i)=i skip(i) = 0 enddo extrax=.false. ycoord=0. extray=.false. xcoord=0. box=.true. sm_tics=.true. extra_tics=.true. grid=.false. marksize=.8 clipmarks=.true. axes_linewidth=.7 plot_linewidth=.5 tic_length=+0.020 smtic_length=+0.007 c size of plot xsize=4.5 c inches ysize=3.5 c offset of lower left corner from paper corner xoffset=2.0 c inches yoffset=6.0 c inches c various point sizes of type: nptsize=12 c numbers iptsize=14 c axes labels tptsize=18 c title landscape = .false. c landscape or portrait preview = .true. c no screen preview font = 'Times-Roman' c default font do i = 1, pdim line_num(i) = i mark_num(i) = -1 comments(i) = 'Legend entry number'//char(48+i) enddo nlines = p + pm xlog = .false. ylog = .false. xfmt = '(f5.1)' yfmt = '(f5.1)' xlabel = 'Independent Variable' ylabel = 'Dependent Variable' title = 'Title of Graph' c* DATA SPECIFIC INFORMATION c****** SPECIFY DATA FILES AND DATA LOCATIONS ************ do i=1,pdim xdat_file(i) = 'no_file_specified' pointx(i) = 0 ydat_file(i) = 'no_file_specified' pointy(i) = 0 enddo end c c--------------------------------------------------------------------------- c subroutine autoscale(pdim,mxmkpt,mxlnpt, p, pm, n, nm, & x, y, xm, ym, xmin, xmax, ymin, ymax, xincr, yincr, & smxincr, smyincr, xbegin, xend, xmbegin, xmend, & xmmin, xmmax, ymmin, ymmax, xrel, yrel, & np, nmp, ylog, first_time) implicit none integer pdim,mxmkpt,mxlnpt integer p, pm integer n(pdim), np(pdim), nm(pdim), nmp(pdim) real xbegin(pdim), xend(pdim) real xmbegin(pdim), xmend(pdim) real x(pdim,mxlnpt), y(pdim,mxlnpt) real xm(pdim,mxmkpt), ym(pdim,mxmkpt) real xmin, xmax, ymin, ymax, xincr, yincr, smxincr, smyincr real xmmin, xmmax, ymmin, ymmax real xrel, yrel logical ylog, first_time c integer i,j xmax=x(1,1) xmin=x(1,1) ymax=y(1,1) ymin=y(1,1) do i=1,p do j=1,n(i) if (x(i,j).gt.xmax) xmax=x(i,j) if (x(i,j).lt.xmin) xmin=x(i,j) if (y(i,j).gt.ymax) ymax=y(i,j) if (y(i,j).lt.ymin) ymin=y(i,j) enddo if(first_time) then xbegin(i) = xmin xend(i) = xmax endif enddo if(p.ne.0) then xmmax=xmax xmmin=xmin ymmax=ymax ymmin=ymin else xmmax = xm(1,1) xmmin = xm(1,1) ymmax = ym(1,1) ymmin = ym(1,1) endif do i = 1,pm do j=1,nm(i) if (xm(i,j).gt.xmmax) xmmax=xm(i,j) if (xm(i,j).lt.xmmin) xmmin=xm(i,j) if (ym(i,j).gt.ymmax) ymmax=ym(i,j) if (ym(i,j).lt.ymmin) ymmin=ym(i,j) enddo if(first_time) then xmbegin(i) = xmmin xmend(i) = xmmax endif enddo if ((p.eq.0).and.(pm.ne.0)) then xmax = xmmax xmin = xmmin ymax = ymmax ymin = ymmin endif xrel = xmin + .25 * (xmax - xmin) if (.not.ylog) then yrel = ymin - 1.1*(ymax - ymin) c yrel = ymin + .75*(ymax-ymin) else yrel = ymin endif xincr=0.1*(xmax-xmin) smxincr=0.2*xincr yincr=0.1*(ymax-ymin) smyincr=0.2*yincr end c c---------------------------------------------------------------------------- c c subroutine plotps c version 2.3 c 890620 c c WARNING! In order to use the preview option, this subroutine c requires the existence of the shell script "pspreview", which must c be in the same directory as the bound FORTRAN program or reside c in the ~/com directory (or other more complicated acceptable c arrangements). The shell script is listed below: c c #!/bin/csh c # c # Preview a postscript file c # c setenv POSTSCRIPTLIB //sw_master/bsd4.2/usr/local/lib/pspreview c //sw_master/bsd4.2/usr/local/lib/pspreview/pspreview -c A4 $argv[1] c c '~/com/pspreview' will run under sr10.1 aegis, but not sr10.1 unix. c this can be repaired by changing c '$argv[1]' to '$1' c and it will run from a unix shell. it will also work under sr9.7 c aegis (i think, lemme check) and unix. but it doesnt allow your c plotting routine to work under sr10.1 , but it does still work c under sr9.7 ... so, this is a minor 'caen bug' fix. happy computing. c -RdR c subroutine plotps(pdim,p,n,x,xmin,xmax,xlabel,xincr,xfmt, 1 y,ymin,ymax,ylabel,yincr,yfmt, 2 title,name, 3 pm,nm,xm,ym, 4 box,sm_tics,smxincr,smyincr,extra_tics,grid, 5 marksize,ulinestyle,umarktype,lgnd, 6 nlines,line_num,mark_num,comments,lgnd_ptsize, 7 xrel,yrel,extrax,ycoord,extray,xcoord, 8 axes_linewidth,plot_linewidth,tic_length, 9 smtic_length,xsize,ysize,xoffset,yoffset, & iptsize,nptsize,tptsize,landscape, & xlog,ylog,font,preview,clipmarks) c c%nolist c%include '/sys/ins/base.ins.ftn' c%include '/sys/ins/error.ins.ftn' c%include '/sys/ins/pgm.ins.ftn' c%list c integer pdim c leading dim in x y, xm ym vectors (all the same lead. dim integer p c no. of separate plots (lines) integer n(pdim) c no. of pts in each array (each line) real x(pdim,*) c an array containing actual x values real xmin,xmax c first and last x values real y(pdim,*) c y-values array real ymin,ymax c min and max of y values character*(*) xlabel,ylabel character*(*) xfmt,yfmt logical xlog c .true. puts x-axis in log format logical ylog c .true. puts y-axis in log format real xincr,yincr real xspot,yspot,step character*(*) title character*18 name c name that file name for plot gets formed c ends in .ps integer pm c no. of separate sets of marks integer nm(pdim) c no. of pts in each array of mark posns real xm(pdim,*),ym(pdim,*) c arrays containing mark posns logical box c if .true. then draws axes completely around plot. logical sm_tics c if .true. then draws small tic marks using real smxincr,smyincr c smxincr and smyincr as the increments logical extra_tics c if .true. then draw the tic marks on the box(if box=y) logical grid c if .true. then draws a grid on the plot at the c large tic marks real marksize c to make marks larger or smaller: a scale factor integer ulinestyle(p) c numbers indicating which linestyle to use for line# i integer umarktype(pm) c numbers indicating which mark type to use for mark-vector # i logical clipmarks c if .true. then clip marks at plot boundaries logical lgnd c .true. if want a legend integer nlines c # of lines of type in the legend integer line_num(p) c type of line to draw on ith line of legend (-1 for none) integer mark_num(pm) c type of mark to draw on ith line of legend (-1 for none) character*(*) comments(p) c text of comments describing each entry in lgnd. integer lgnd_ptsize c pt size of text in legend real xrel,yrel c relative offset (x-y coordinates) of lower left corner of legend logical extrax c .true. to signify wheather want an extra axis drawn logical extray real xcoord,ycoord c xcoord of the y-axis to draw, c and ycoord of the x-axis to draw. If applicable. real axes_linewidth,plot_linewidth c play with 'em. (<1. typ .5) real tic_length,smtic_length c play with 'em, should be <1. (.02) real xsize,ysize c size of plot in inches real xoffset,yoffset c offset of bottom left corner of c plot from papaer corner, inches integer iptsize,tptsize,nptsize c axes labels ptsize, title pt size, numbers pt size logical landscape c .true. for landscape mode logical preview c .true. if screen preview is desired integer xfirstlogtic,xlastlogtic c log of the first,last x large tics integer yfirstlogtic,ylastlogtic c log of the first,last x large tics character*150 label character*11 font c font to use in labels, titles character*10 newfmt c (either Times-Roman or Helvetica) real x1,y1,d,xdenom,ydenom real dist integer num integer l,lsave integer floor integer length character*30 linestyle(10) integer marktype(10) real*8 mydble c function c integer*2 namelength,argcount,arg1(2),arg2(2),arg3(6),arg4(10), c & conv,stcnt c integer*2 mode c integer*4 argvector(4),handle,status c character*18 nameeq c equivalence (arg4(2),nameeq(1:2)) integer i,j real dummy c arg1(1) = 2 c arg1(2) = 'sh' c arg2(1) = 2 c arg2(2) = '-c' c arg3(1) = 9 c arg3(2) = 'ps' c arg3(3) = 'pr' c arg3(4) = 'ev' c arg3(5) = 'ie' c arg3(6) = 'w' c arg4(1) = 18 c argcount = 4 c stcnt = 0 c namelength = 7 c nameeq = name c mode = pgm_$wait c argvector(1) = iaddr(arg1) c argvector(2) = iaddr(arg2) c argvector(3) = iaddr(arg3) c argvector(4) = iaddr(arg4) linestyle(1) = '[ ] 0 setdash' c yet to finish linestyles. linestyle(2) = '[ 2 2 ] 0 setdash' linestyle(3) = '[ 4 2 ] 0 setdash' linestyle(4) = '[ 2 4 ] 0 setdash' linestyle(5) = '[ 6 4 2 4 ] 0 setdash' linestyle(6) = '[ 8 2 2 2 2 2 ] 0 setdash' linestyle(7) = '[ 4 4 ] 0 setdash' linestyle(8) = '[ 1 1 ] 0 setdash' linestyle(9) = '[ 8 2 8 2 2 2 ] 0 setdash' linestyle(10) = '[ 4 1 4 1 1 1 ] 0 setdash' c yet to finish marktypes too marktype(1) = 1 marktype(2) = 2 marktype(3) = 3 marktype(4) = 4 marktype(5) = 5 marktype(6) = 6 marktype(7) = 7 marktype(8) = 8 marktype(9) = 9 marktype(10) = 0 c----------------------------------------------------------------------- open (unit=7,file=name) rewind 7 if ((p .gt. 10) .or. (pm .gt. 10)) then print *,'no. of plots or no. of mark types >10 [too many]' print *,' no plot generated.' close (unit=7) return endif c set default linestyles and marktypes if (p.gt.0) then if (ulinestyle(1) .le. 0) then do i = 1, p ulinestyle(i) = i enddo endif endif if (pm.gt.0) then if (umarktype(1) .le. 0) then do i = 1, pm umarktype(i) = i enddo endif endif write (7,201) 201 format ('%!'/'/inch {72 mul} def') c added %! to top for non-apollo c printers--RTA 6/20/89 c decide on landscape or portrait if (landscape) then write (7,6101) c special extra code to do landscape: 6101 format ('8.5 inch 0 translate 90 rotate') endif write(7,1002)xoffset,yoffset 1002 format(f10.5,' inch ',f10.5,' inch translate') write(7,1003)iptsize 1003 format('/ptsize {',i3,'} def') write(7,202) font 202 format('/',a11,' findfont ptsize scalefont setfont') write(7,41) 41 format('/xskip {stringwidth pop 0 rmoveto } def') write(7,2001) 2001 format(' /vertshowb { gsave currentpoint translate'/ & ' 90 rotate }def ') write(7,2002) 2002 format('/vertshowe { grestore} def') write(7,1020) 1020 format('/nhalfxskip {stringwidth pop -0.5 mul 0 rmoveto } def') write(7,1021) 1021 format('/nyskip {0 ptsize neg rmoveto } def') write(7,1024) 1024 format('/nhalfyskip {0 ptsize -.35 mul rmoveto } def') write(7,1022) 1022 format('/nxskip {stringwidth pop neg 0 rmoveto } def') write(7,1023) 1023 format('/pyskip {0 ptsize rmoveto } def') write(7,1025) 1025 format('/rnhalfxskip {stringwidth pop', & ' -0.5 mul 0 exch rmoveto } def') call write_marks(dummy) c write defs for the marks c----------------------------------------------------------------------------------- c scale the input vectors if (xlog) then xdenom = alog10(xmax) - alog10(xmin) else xdenom = xmax - xmin endif if (ylog) then ydenom = alog10(ymax) - alog10(ymin) else ydenom = ymax - ymin endif if ((xdenom .eq. 0.) .or. (ydenom .eq. 0.)) then c need to scale the vectors here. xmax = -1.e10 xmin = +1.e10 ymax = -1.e10 ymin = +1.e10 do i = 1, p do j = 1, n(i) if (x(i,j) .gt. xmax) xmax = x(i,j) if (y(i,j) .gt. ymax) ymax = y(i,j) if (x(i,j) .lt. xmin) xmin = x(i,j) if (y(i,j) .lt. ymin) ymin = y(i,j) enddo enddo do i = 1, pm do j = 1, nm(i) if (xm(i,j) .gt. xmax) xmax = xm(i,j) if (ym(i,j) .gt. ymax) ymax = ym(i,j) if (xm(i,j) .lt. xmin) xmin = xm(i,j) if (ym(i,j) .lt. ymin) ymin = ym(i,j) enddo enddo if (xlog) then xdenom = alog10(xmax) - alog10(xmin) else xdenom = xmax - xmin endif if (ylog) then ydenom = alog10(ymax) - alog10(ymin) else ydenom = ymax - ymin endif if ((xdenom .eq. 0.) .or. (ydenom .eq. 0.)) then print *,'bad input data: max=min for x or y.' print *,' no plot generated.' close (unit=7) return endif endif c----------------------------------------------------------------------------------- c now scale the input vectors if (xlog) then do i = 1, p do j = 1, n(i) x(i,j) = (alog10(x(i,j)) - alog10(xmin)) / xdenom enddo enddo do i = 1, pm do j = 1, nm(i) xm(i,j) = (alog10(xm(i,j)) - alog10(xmin)) / xdenom enddo enddo else do i = 1, p do j = 1, n(i) x(i,j) = (x(i,j) - xmin) / xdenom enddo enddo do i = 1, pm do j = 1, nm(i) xm(i,j) = (xm(i,j) - xmin) / xdenom enddo enddo endif if (ylog) then do i = 1, p do j = 1, n(i) y(i,j) = (alog10(y(i,j)) - alog10(ymin)) / ydenom enddo enddo do i = 1, pm do j = 1, nm(i) ym(i,j) = (alog10(ym(i,j)) - alog10(ymin)) / ydenom enddo enddo else do i = 1, p do j = 1, n(i) y(i,j) = (y(i,j) - ymin) / ydenom enddo enddo do i = 1, pm do j = 1, nm(i) ym(i,j) = (ym(i,j) - ymin) / ydenom enddo enddo endif c now all x,y are 0 < # < 1 c also scale xcoord, ycoord, xrel, yrel (0 < # < 1) if (xlog) then if (extray) xcoord = (alog10(xcoord) - alog10(xmin)) / xdenom xrel = (alog10(xrel) - alog10(xmin)) / xdenom else if (extray) xcoord = (xcoord - xmin) / xdenom xrel = (xrel - xmin) / xdenom endif if (ylog) then if (extrax) ycoord = (alog10(ycoord) - alog10(ymin)) / ydenom yrel = (alog10(yrel) - alog10(ymin)) / ydenom else if (extrax) ycoord = (ycoord - ymin) / ydenom yrel = (yrel - ymin) / ydenom endif write(7,2)xsize 2 format('/xscale {',f10.5,' inch mul} def') write(7,3)ysize 3 format('/yscale {',f10.5,' inch mul} def') c----------------------------------------------------------------------------------- c now do grid if (xlog) then xfirstlogtic = aint(dlog10(mydble(xmin))) c want 1st x tic >= xmin xlastlogtic = aint(dlog10(mydble(xmax))) c want last x tic <= xmax endif if (ylog) then yfirstlogtic = aint(dlog10(mydble(ymin))) c want 1st y tic >= ymin ylastlogtic = aint(dlog10(mydble(ymax))) c want last y tic <= ymax endif c print *,'xfirstlogtic,xlastlogtic:',xfirstlogtic,xlastlogtic c print *,'yfirstlogtic,ylastlogtic:',yfirstlogtic,ylastlogtic if (grid) then c vertical grid lines first if (xlog) then if (xlastlogtic .lt. xfirstlogtic) goto 91098 write (7,71) do i = xfirstlogtic, xlastlogtic write (7,4) c newpath d = (real(i) - alog10(xmin)) / xdenom write (7,72) d write (7,73) d write (7,12) c stroke enddo 91098 step = 10.0 ** aint(dlog10(mydble(xmin))) 91099 do i = 1, 9 xspot = step * i if (xspot .lt. xmin) goto 91100 if (xspot .gt. xmax) goto 1175 write (7,4) c newpath d = (dlog10(mydble(xspot)) - dlog10(mydble(xmin))) / xdenom write (7,72) d write (7,73) d write (7,12) c stroke 91100 enddo step = step * 10.0 goto 91099 else num = floor(xdenom / xincr + .01) + 1 dist = xincr / xdenom write(7,71) 71 format(' .005 setlinewidth') do i = 1, num write (7,4) c Newpath d = dist * (i - 1) write (7,72) d 72 format (5x,f10.4,' xscale 0 moveto') write (7,73) d 73 format(5x,f10.4,' xscale 1 yscale lineto') write (7,12) c stroke enddo endif c horizontal grid lines now 1175 if (ylog) then if (ylastlogtic .lt. yfirstlogtic) goto 91198 do i = yfirstlogtic, ylastlogtic write (7,4) c newpath d = (real(i) - alog10(ymin)) / ydenom write (7,74) d write (7,175) d write (7,12) c stroke enddo 91198 step = 10.0 ** aint(dlog10(mydble(ymin))) 91199 do i = 1, 9 yspot = step * i if (yspot .lt. ymin) goto 91200 if (yspot .gt. ymax) goto 149 write (7,4) c newpath d = (dlog10(mydble(yspot)) - dlog10(mydble(ymin))) / ydenom write (7,74) d write (7,175) d write (7,12) c stroke 91200 enddo step = step * 10.0 goto 91199 else num = floor(ydenom / yincr + .01) + 1 dist = yincr / ydenom do i = 1, num write (7,4) c Newpath d = dist * (i - 1) write (7,74) d 74 format (5x,'0 ',f10.4,' yscale moveto') write (7,175) d 175 format(5x,'1 xscale ',f10.4,' yscale lineto') write (7,12) c stroke enddo endif 149 write (7,176) c reset line to solid 176 format ('[] 0 setdash') write (7,177) c black lines again 177 format ('0 setgray') endif c----------------------------------------------------------------------------------- c draw axes write (7,4) 4 format ('newpath') write (7,5) 5 format (5x,'0',5x,'1 yscale moveto') write (7,6) 6 format (5x,'0',5x,'0',5x,'lineto') write (7,7) 7 format (5x,'1 xscale 0',5x,'lineto') write (7,8) axes_linewidth 8 format (f5.1,' setlinewidth stroke') if (box) then write (7,4) c newpath write (7,151) 151 format (5x,'1 xscale 0 moveto') write (7,152) 152 format (5x,'1 xscale 1 yscale lineto') write (7,153) 153 format (5x,'0 1 yscale lineto') write (7,12) c stroke endif c----------------------------------------------------------------------------------- c draw extra axes if (extrax) then if ((ycoord .le. 1.0) .and. (ycoord .ge. 0.0)) then c ycoord has been scaled write (7,740) axes_linewidth 740 format (f10.5,' setlinewidth') write (7,741) ycoord 741 format ('newpath 0 ',f10.5,' yscale moveto ') write (7,742) ycoord 742 format (' 1 xscale ',f10.5,' yscale lineto stroke') endif endif if (extray) then if ((xcoord .le. 1.0) .and. (xcoord .ge. 0.0)) then c xcoord has been scaled write (7,740) axes_linewidth write (7,744) xcoord 744 format ('newpath ',f10.5,' xscale 0 moveto ') write (7,745) xcoord 745 format (f10.5,' xscale 1 yscale lineto stroke') endif endif c----------------------------------------------------------------------------------- c tic marks and labels (numeric) write (7,1003) nptsize write (7,202) font c c 1. LARGE X TIC MARKS AND LABELS: c if (xlog) then if (grid) write (7,71) num = xlastlogtic - xfirstlogtic + 1 else num = floor(xdenom / xincr + .01) + 1 endif dist = xincr / xdenom newfmt = xfmt(1:length(xfmt)) c print *,'(xtic) num:',num do i = 1, num write (7,4) c newpath if (xlog) then d = (real(xfirstlogtic + i - 1) - alog10(xmin)) / xdenom else d = dist * (i - 1) endif write (7,10) d 10 format (5x,f10.4,' xscale',5x,'0 moveto') write (7,11) d, tic_length 11 format(5x,f10.4,' xscale',f10.4,' xscale lineto') if (xlog) then x1 = 10.0 ** (real(xfirstlogtic + i - 1)) else x1 = xmin + (i - 1) * xincr endif CC(lep,begin) CC write (label,newfmt) x1 if((newfmt(2:2).eq.'i').or.(newfmt(2:2).eq.'i'))THEN write (label,newfmt) int(x1) else write (label,newfmt) x1 endif CC(lep,end) l = length(label) if (tic_length .gt. 0.) then write (7,9903) 9903 format ('currentpoint pop 0. moveto') c moveto to (x,0) endif write (7,801) 801 format ('0 ') call length_label(label,length(label),nptsize,font) write (7,802) 802 format (' -.5 mul 0 rmoveto nyskip nhalfyskip') call write_label(label(1:l),l,nptsize,font) write (7,12) 12 format ('stroke') if (box .and. extra_tics) then c draw tics at top write (7,4) c newpath write (7,310) d 310 format(5x,f10.4,' xscale',5x,'1 yscale moveto') write (7,311) d, -tic_length 311 format(5x,f10.4,' xscale',f10.4,' xscale', & ' 1 yscale add lineto') write (7,12) c stroke endif enddo if (xlog .and. grid) then write (7,176) c reset line to solid write (7,177) c black lines again endif c c 2. LARGE Y TIC MARKS AND LABELS: c if (ylog) then if (grid) write (7,71) num = ylastlogtic - yfirstlogtic + 1 else num = floor(ydenom / yincr + .01) + 1 endif dist = yincr / ydenom newfmt = yfmt(1:length(yfmt)) do i = 1, num write (7,4) c newpath if (ylog) then d = (real(yfirstlogtic + i - 1) - alog10(ymin)) / ydenom else d = dist * (i - 1) endif write (7,620) d 620 format(5x,'0',5x,f10.4,' yscale moveto') write (7,21) tic_length, d 21 format (5x,f10.4,' xscale',5x,f10.4,' yscale lineto') if (ylog) then y1 = 10.0 ** (real(yfirstlogtic + i - 1)) else y1 = ymin + (i - 1) * yincr endif CC(lep,begin) CC write (label,newfmt) y1 if((newfmt(2:2).eq.'i').or.(newfmt(2:2).eq.'i'))THEN write (label,newfmt) int(y1) else write (label,newfmt) y1 endif CC(lep,end) lsave = length(label) if (tic_length .gt. 0.) then write (7,9904) 9904 format ('currentpoint exch pop 0. exch moveto') c moveto (0.,y) write (7,22) -tic_length else write (7,22) tic_length 22 format (5x,f10.4,' xscale 1 mul 0 rmoveto') c fiddle with y tic label posns here.************ endif write (7,801) call length_label(label,length(label),nptsize,font) write (7,803) 803 format (' neg 0 rmoveto') write (7,806) 806 format (' nhalfyskip') call write_label(label(1:lsave),lsave,nptsize,font) write (7,12) c stroke if (box .and. extra_tics) then c draw tics on right write (7,4) c newpath write (7,520) d 520 format (5x,'1 xscale ',5x,f10.4,' yscale moveto') write (7,521) -tic_length, d 521 format (5x,f10.4,' xscale 1 xscale add ',5x,f10.4, & ' yscale lineto') write(7,12) c stroke endif enddo if (ylog .and. grid) then write (7,176) c reset line to solid write (7,177) c black lines again endif if (sm_tics) then c c 3. small X TIC MARKS : c if (xlog) then if (grid) write (7,71) step = 10.0 ** aint(dlog10(mydble(xmin))) 1099 do i = 1, 9 xspot = step * i if (xspot .lt. xmin) goto 1100 if (xspot .gt. xmax) goto 1110 write (7,4) c newpath d = (alog10(xspot) - alog10(xmin)) / xdenom write (7,10) d write (7,11) d, smtic_length write (7,12) c stroke if (box .and. extra_tics) then c draw tics at top write (7,4) c newpath write (7,310) d write (7,311) d, -smtic_length write (7,12) c stroke endif 1100 enddo step = step * 10.0 goto 1099 else num = floor(xdenom / smxincr + .01) + 1 dist = smxincr / xdenom do i = 1, num write (7,4) c newpath d = dist * (i - 1) write (7,10) d write (7,11) d, smtic_length write(7,12) c stroke if (box .and. extra_tics) then c draw tics at top write (7,4) c newpath write (7,310) d write (7,311) d, -smtic_length write (7,12) c stroke endif enddo endif if (xlog .and. grid) then write (7,176) c reset line to solid write (7,177) c black lines again endif c c 4. small Y TIC MARKS: c 1110 if (ylog) then if (grid) write (7,71) step = 10.0 ** aint(dlog10(mydble(ymin))) 1199 do i = 1, 9 yspot = step * i if (yspot .lt. ymin) goto 1200 if (yspot .gt. ymax) goto 1210 write (7,4) c newpath d = (alog10(yspot) - alog10(ymin)) / ydenom write (7,620) d write (7,21) smtic_length, d write (7,12) c stroke if (box .and. extra_tics) then write (7,4) c newpath write (7,520) d write (7,521) -smtic_length, d write (7,12) c stroke endif 1200 enddo step = step * 10.0 goto 1199 else num = floor(ydenom / smyincr + .01) + 1 dist = smyincr / ydenom do i = 1, num write (7,4) c newpath d = dist * (i - 1) write (7,620) d write (7,21) smtic_length, d write (7,12) c stroke if (box .and. extra_tics) then write (7,4) c newpath write (7,520) d write (7,521) -smtic_length, d write (7,12) c stroke endif enddo endif if (ylog .and. grid) then write (7,176) c reset line to solid write (7,177) c black lines again endif 1210 endif write(7,1003)iptsize write(7,202) font c----------------------------------------------------------------------------------- c now do y label c use last y-tic-label as guide to positioning y-label: write (7,50) -abs(tic_length) 50 format (5x,f10.4,' xscale 0.5 yscale moveto') write (7,801) call length_label(label,length(label),iptsize,font) write (7,803) write (7,760) 1.5 * iptsize 760 format (f10.5,' neg 0 rmoveto') label = ylabel(1:length(ylabel)) l = length(label) write (7,801) call length_label(label,length(label),iptsize,font) write (7,804) 804 format (' -.5 mul 0 exch rmoveto') write (7,669) 669 format (' vertshowb') call write_label(label(1:l),l,iptsize,font) write (7,668) 668 format ('vertshowe') c----------------------------------------------------------------------------------- c now x label label = xlabel(1:length(xlabel)) l = length(label) write (7,3020) 3020 format ('0.5 xscale 0 moveto') write (7,3021) 3021 format ('nyskip nyskip nyskip nhalfyskip ') write (7,801) call length_label(label,length(label),iptsize,font) write (7,805) 805 format (' -.5 mul 0 rmoveto') call write_label(label(1:l),l,iptsize,font) c----------------------------------------------------------------------------------- c now do title write (7,44) tptsize 44 format ('/tptsize {',i3,'} def') write (7,45) font 45 format ('/',a11,' findfont tptsize scalefont setfont') label = title(1:length(title)) l = length(label) write (7,1034) 1034 format (' 0.5 xscale 1. yscale moveto pyskip') write (7,801) call length_label(label(1:l),L,tptsize,font) write (7,805) call write_label(label(1:l),L,tptsize,font) write (7,202) font c return the font to iptsize c----------------------------------------------------------------------------------- c NOW PLOTTING c clipping: write (7,4) c newpath write (7,75) 75 format (5x,'1',5x,'1 yscale 1 sub moveto') write (7,76) 76 format (5x,'1',5x,'1',5x,'lineto') write (7,77) 77 format (5x,'1 xscale 1 sub 1',5x,'lineto') write (7,78) 78 format (5x,'1 xscale 1 sub 1 yscale 1 sub lineto closepath') write (7,7008) 7008 format ('clip') c----------------------------------------------------------------------------------- CC do i = 1, p CC write (7,4) CCc newpath CC write (7,30) x(i,1), y(i,1) CC 30 format (5x,f10.5,' xscale ',f10.5,' yscale moveto') CC do j = 2, n(i) CC write (7,31) x(i,j), y(i,j) CC 31 format (5x,f10.5,' xscale ',f10.5,' yscale lineto') CC enddo CC write (7,32) plot_linewidth CC 32 format (f10.4,' setlinewidth') CC write (7,333) linestyle(ulinestyle(i)) CC 333 format (5x,a30) CC write (7,12) CCc stroke CC enddo do i = 1, p IF(n(i).le.250)THEN write (7,4) c newpath write (7,30) x(i,1), y(i,1) 30 format (5x,f10.5,' xscale ',f10.5,' yscale moveto') do j = 2, n(i) write (7,31) x(i,j), y(i,j) 31 format (5x,f10.5,' xscale ',f10.5,' yscale lineto') enddo write (7,32) plot_linewidth 32 format (f10.4,' setlinewidth') write (7,333) linestyle(ulinestyle(i)) c write (7,333) linestyle(1) 333 format (5x,a30) write (7,12) c stroke ELSE c {here need to break up the line into multiple 500-pt lines: NMULT=N(I)/250 + 1 DO JJ=1,NMULT JSTART = (JJ-1)*250 + 1 IF(JSTART.GT.N(I))JSTART=N(I) JEND = JSTART + 250 IF(JEND.GT.N(I))JEND=N(I) c print *,'jstart,jend:',jstart,jend write(7,4) C !NEWPATH write(7,30)x(i,JSTART),y(i,JSTART) C!MOVETO if(jstart+1.ge.jend)then do j=JSTART+1,JEND write(7,31)x(i,j),y(i,j) C!LINETO enddo else do j=JSTART,JEND write(7,31)x(i,j),y(i,j) C !LINETO enddo endif write(7,32)plot_linewidth write(7,333)linestyle(ulinestyle(i)) c write (7,333) linestyle(1) write(7,12) C!stroke ENDDO ENDIF enddo write (7,176) c reset line to solid c----------------------------------------------------------------------------------- c now MARK(s) if (.not. clipmarks) then write (7,4439) 4439 format ('initclip') endif do i = 1, pm write (7,4490) 4490 format ('newpath') do j = 1, nm(i) write (7,441) xm(i,j), ym(i,j), marksize, & marktype(umarktype(i)) 441 format (5x,f10.5,' xscale ',f10.5,' yscale moveto ',f10.5, & ' mark',i1) enddo enddo c----------------------------------------------------------------------------------- c now LEGEND if (lgnd) then call legend(nlines,line_num,mark_num,comments, & lgnd_ptsize,iptsize,marksize,xrel,yrel, & plot_linewidth,axes_linewidth, & linestyle,marktype,font) endif write(7,90) 90 format('showpage') c----------------------------------------------------------------------------------- c Now unscale the input vectors: do i = 1, p do j = 1, n(i) if (xlog) then x(i,j) = 10.0 ** (xdenom * x(i,j) + alog10(xmin)) else x(i,j) = xdenom * x(i,j) + xmin endif if (ylog) then y(i,j) = 10.0 ** (ydenom * y(i,j) + alog10(ymin)) else y(i,j) = ydenom * y(i,j) + ymin endif enddo enddo do i = 1, pm do j = 1, nm(i) if (xlog) then xm(i,j) = 10.0 ** (xdenom * xm(i,j) + alog10(xmin)) else xm(i,j) = xdenom * xm(i,j) + xmin endif if (ylog) then ym(i,j) = 10.0 ** (ydenom * ym(i,j) + alog10(ymin)) else ym(i,j) = ydenom * ym(i,j) + ymin endif enddo enddo c also unscale xcoord, ycoord, xrel, yrel if (xlog) then if (extray) xcoord = 10.0 ** (xcoord * xdenom + alog10(xmin)) xrel = 10.0 ** (xrel * xdenom + alog10(xmin)) else if (extray) xcoord = xcoord * xdenom + xmin xrel = xrel * xdenom + xmin endif if (ylog) then if (extrax) ycoord = 10.0 ** (ycoord * ydenom + alog10(ymin)) yrel = 10.0 ** (yrel * ydenom + alog10(ymin)) else if (extrax) ycoord = ycoord * ydenom + ymin yrel = yrel * ydenom + ymin endif close (unit=7) c------------------------------------------------------------------------------ c if (preview) then c call pgm_$invoke('/com/sh', c & namelength,argcount, c & argvector,stcnt,conv,mode,handle, c & status) c if (status .ne. status_$ok) then c print *, 'Error in preview' c call error_$print(status) c print *, 'status = ',status c endif c endif return end c c******************************************************************** subroutine write_label(label,L,ptsize,font) character*(*) label character*(*) font integer L,ptsize character*5 char,mate*1 logical greek,normal,sub,sup,ps integer kk real scale parameter(scale=0.9) kk=0 do while(kk.lt.L) kk=kk+1 greek = .false. ps = .false. sub = .false. sup = .false. normal=.true. if (label(kk:kk) .eq. '~') then c ***** 1.look for greek if (kk+8 .le. L) then char=label(kk+1:kk+5) call lc(char) if (char.eq.'greek') greek=.true. endif c ***** 1A.look for postscript char if (kk+7 .le. L) then char=label(kk+1:kk+2) call lc(char) if (char.eq.'ps') ps=.true. endif c ***** 2.look for sub if (kk+6 .le. L) then char=label(kk+1:kk+3) call lc(char) if (char.eq.'sub') sub=.true. c ***** 3.look for sup if (char.eq.'sup') sup=.true. endif if ( greek .or. ps .or. sub .or. sup ) normal=.false. endif if (greek) then c so it's ~greek c now grab the single character in () c and change fonts and advance kk: write (7,100) ptsize*scale 100 format('/Symbol findfont ',f10.5,' scalefont setfont') mate=label(kk+6:kk+6) if (mate.eq.'(') mate=')' kk=kk+7 do while ((label(kk:kk).ne.mate).and.(kk.lt.L)) write(7,102) label(kk:kk) kk=kk+1 end do 102 format('(',a,') show') write (7,104) font,ptsize 104 format('/',a11,' findfont ',i4,' scalefont setfont') endif if (ps) then c so it's ~ps c now grab the three digit character in () c and change fonts and advance kk: write (7,100) ptsize*scale write (7,9102) label(kk+4:kk+6) c9102 format('(\',a3,') show') 9102 format('(\\',a3,') show') write (7,104) font,ptsize kk=kk+7 endif if (sub.or.sup) then c so it's ~sub c now grab the single character in () c and change fonts and advance kk: write (7,200) font,ptsize*0.7 200 format('/',a11,' findfont ',f10.5,' scalefont setfont') if (sub) write (7,201) -0.33*ptsize if (sup) write (7,201) +0.5*ptsize 201 format(' 0 ',f10.5,' rmoveto') mate=label(kk+4:kk+4) if (mate.eq.'(') mate=')' kk=kk+5 do while ((label(kk:kk).ne.mate).and.(kk.lt.L)) write(7,202) label(kk:kk) kk=kk+1 end do 202 format('(',a,') show') if (sub) write (7,203) +0.33*ptsize if (sup) write (7,203) -0.5*ptsize 203 format(' 0 ',f10.5,' rmoveto') write (7,204) font,ptsize 204 format('/',a11,' findfont ',i4,' scalefont setfont') endif if (normal) then c no greek,sub,sup for this letter: if ((label(kk:kk).eq.'(').or.(label(kk:kk).eq.')')) then write(7,16)label(kk:kk) c16 format('(\',a,') show') 16 format('(\\',a,') show') else if (label(kk:kk).eq.' ') then write(7,15) 15 format('( ) xskip') else write(7,14)label(kk:kk) 14 format(5x,'(',a,') show') endif endif enddo return end c****************************************************************** subroutine length_label(label,L,ptsize,font) character*(*) label character*(*) font integer L,ptsize character*5 char,mate*1 logical greek,sub,sup,normal,ps integer kk real scale parameter(scale=0.9) kk=0 do while(kk.lt.L) kk=kk+1 greek = .false. ps = .false. sub = .false. sup = .false. normal=.true. if (label(kk:kk) .eq. '~') then c ***** 1.look for greek if (kk+8 .le. L) then char=label(kk+1:kk+5) call lc(char) if (char.eq.'greek') greek=.true. endif c ***** 1A.look for postscript char if (kk+7 .le. L) then char=label(kk+1:kk+2) call lc(char) if (char.eq.'ps') ps=.true. endif c ***** 2.look for sub if (kk+6 .le. L) then char=label(kk+1:kk+3) call lc(char) if (char.eq.'sub') sub=.true. c ***** 3.look for sup if (char.eq.'sup') sup=.true. endif if ( greek .or. ps .or. sub .or. sup ) normal=.false. endif if (greek) then c so it's ~greek c now grab the single character in () c and change fonts and advance kk: write(7,100)ptsize*scale 100 format('/Symbol findfont ',f10.5,' scalefont setfont') mate=label(kk+6:kk+6) if (mate.eq.'(') mate=')' kk=kk+7 do while ((label(kk:kk).ne.mate).and.(kk.lt.L)) write(7,102) label(kk:kk) kk=kk+1 end do 102 format('(',a,') stringwidth pop add') write(7,104) font,ptsize 104 format('/',a11,' findfont ',i4,' scalefont setfont') endif if(ps)then c so it's ~ps c now grab the three digit character in () c and change fonts and advance kk: write(7,100)ptsize*scale write(7,9102)label(kk+4:kk+6) c9102 format('(\',a3,') stringwidth pop add') 9102 format('(\\',a3,') stringwidth pop add') write(7,104) font,ptsize kk=kk+7 endif if(sub.or.sup)then c so it's ~sub c now grab the single character in () c and change fonts and advance kk: write(7,200) font,ptsize*0.7 200 format('/',a11,' findfont ',f10.5,' scalefont setfont') mate=label(kk+4:kk+4) if (mate.eq.'(') mate=')' kk=kk+5 do while ((label(kk:kk).ne.mate).and.(kk.lt.L)) write(7,202) label(kk:kk) kk=kk+1 end do 202 format('(',a,') stringwidth pop add') write(7,204) font,ptsize 204 format('/',a11,' findfont ',i4,' scalefont setfont') endif if(normal)then c no greek,sub,sup for this letter: if ((label(kk:kk).eq.'(').or.(label(kk:kk).eq.')')) then write(7,16)label(kk:kk) c16 format('(\',a,') stringwidth pop add') 16 format('(\\',a,') stringwidth pop add') else if(label(kk:kk).eq.' ')then write(7,15) 15 format('( ) stringwidth pop add') else write(7,14)label(kk:kk) 14 format(5x,'(',a,') stringwidth pop add') endif endif enddo return end c***************************************************************** subroutine legend(nlines,line_num,mark_num,comments, & lgnd_ptsize,iptsize,marksize,xn,yn, & plot_linewidth,axes_linewidth, & linestyle,marktype,font) integer nlines integer line_num(nlines),mark_num(nlines) character*(*) comments(nlines) character*(*) font integer lgnd_ptsize,iptsize real marksize,xn,yn real plot_linewidth real axes_linewidth character*30 linestyle(10) integer marktype(10) c--------------------------------------------------------------- c integer max real boxLength,boxHeight real xtext,line_start,line_end c real x,y real y character*150 charc real xfrac,yfrac c integer i,length,imax integer i,length c--------------------------------------------------------------- write(7,1100)lgnd_ptsize 1100 format('/Times-Roman findfont ',i3,' scalefont setfont') do i=1,nlines if(i.le.9) then write(7,1101)i 1101 format('/comm',i1,' { 0') else write(7,1111)i 1111 format('/comm',i2,' { 0') endif charc = comments(i) call length_label(charc,length(charc),lgnd_ptsize,font) write(7,2) c '}def ' c if(length(comments(i)).gt.max)then c max=length(comments(i)) c imax=i c endif enddo c c Need def for max here: write(7,1201) 1201 format('/max { /num exch def /max1 0 def ') write(7,1202) 1202 format(' num { /value exch def value max1 gt ') write(7,1203) 1203 format(' { /max1 value def }if }repeat max1 ') write(7,2) c '}def' yfrac=1. xfrac=.5 boxLength=6.*lgnd_ptsize*xfrac+7.*marksize*(.08*72.) write(7,1)boxLength 1 format('/boxLength { ',f10.5) do i=1,nlines if(i.le.9) then write(7,1102)i 1102 format(' comm',i1,' ') else write(7,1112)i 1112 format(' comm',i2,' ') endif enddo write(7,1104)nlines 1104 format(' ',i2,' ') write(7,1103) 1103 format(' max add') c max leaves the max on the stack write(7,2) 2 format(' } def') c write(7,7)boxLength c 7 format('/boxLength c ',f10.5,' }def') Ca temp test above boxHeight=(nlines*2+1)*lgnd_ptsize*yfrac xtext=xfrac*4.*lgnd_ptsize + 7.*marksize*(.08*72.) line_start=xfrac*2.*lgnd_ptsize line_end =line_start + 7.*marksize*(.08*72.) c reset clipping boundary: write(7,3) 3 format(' initclip ') c**************************************************************** c draw the outline box and fill with white: write(7,20)axes_linewidth c set linewidth write(7,5)xn,yn 5 format(f10.5,' xscale ',f10.5,' yscale translate') write(7,10) 10 format('/box { newpath 0 0 moveto ') write(7,11)boxHeight 11 format('boxLength 0 lineto boxLength ',f10.5,' lineto') write(7,12)boxHeight 12 format('0 ',f10.5,' lineto closepath } def') write(7,13) 13 format('box box white setgray fill') write(7,14) 14 format(' box black setgray stroke') c***************************************************************** c now draw the lines in the linestyles write(7,20)plot_linewidth 20 format(f10.4,' setlinewidth') y=boxHeight-2.*lgnd_ptsize*yfrac do i=1,nlines if(line_num(i).le.0)goto 100 write(7,21)linestyle(line_num(i)) 21 format(5x,a30) write(7,22)line_start,y+0.3*lgnd_ptsize 22 format(' newpath ',f10.5,2x,f10.5,' moveto') write(7,23)line_end,y+0.3*lgnd_ptsize 23 format(f10.5,2x,f10.5,' lineto stroke') 100 continue y=y-2.*lgnd_ptsize enddo write(7,176) c reset line to solid 176 format('[] 0 setdash') c***************************************************************** c draw marks now: y=boxHeight-2.*lgnd_ptsize*yfrac do i=1,nlines if(mark_num(i).le.0)goto 101 write(7,24)line_start+3.5*marksize*(.08*72.), 1 y+0.3*lgnd_ptsize,marksize, 2 marktype(mark_num(i)) 24 format(5x,f10.5,2x,f10.5,' moveto ',f10.5,' mark',i1) 101 continue y=y-2.*lgnd_ptsize enddo c***************************************************************** c write comments now: write(7,45) font,lgnd_ptsize 45 format('/',a11,' findfont ',i3,' scalefont setfont') y=boxHeight-2.*lgnd_ptsize*yfrac do i=1,nlines if(length(comments(i)).eq.0)goto 102 write(7,25)xtext,y 25 format(f10.5,2x,f10.5,' moveto') call write_label(comments(i),length(comments(i)), 1 lgnd_ptsize,font) 102 continue y=y-2.*lgnd_ptsize enddo c all done. return end c******************************************************************** integer function floor(a) real a if (a.ge.0.)then floor=aint(a) else floor=aint(a)+1 endif return end c********************************************************************** integer function length(bufr) character*(*) bufr integer i,ilen c returns position of last non-blank character c or c returns one if string is all blank ilen=len(bufr) do i = ilen, 1, -1 if (bufr(i:i).ne.' ') then length = i return endif enddo length = 1 return end c******************************************************************* subroutine write_marks(dummy) real dummy write(7,2020) 2020 format('/white 1 def') write(7,2021) 2021 format('/black 0 def') write(7,2022) 2022 format('/circlemark { gsave currentpoint translate') write(7,2023) 2023 format(' dup scale') write(7,2024) 2024 format(' .05 setlinewidth') write(7,2025) 2025 format(' .5 circle white setgray fill') write(7,2026) 2026 format(' .5 circle black setgray stroke') write(7,2027) 2027 format(' .1 circle fill') write(7,2028) 2028 format(' grestore') write(7,2029) 2029 format(' } def') write(7,2030) 2030 format('/circle { /rad exch def %assumes radius is', 1 ' waiting on stack.') write(7,2031) 2031 format(' newpath') write(7,2032) 2032 format(' 0 0 rad 0 360 arc closepath') write(7,2033) 2033 format(' } def') write(7,2034) 2034 format('/mark1 { .08 72 mul mul circlemark} def') write(7,100) 100 format('/squaremark { gsave currentpoint translate') write(7,101) 101 format(' dup scale') write(7,102) 102 format(' .05 setlinewidth') write(7,103) 103 format(' 1 square white setgray fill') write(7,104) 104 format(' 1 square black setgray stroke') write(7,105) 105 format(' .1 circle fill') write(7,106) 106 format(' grestore') write(7,107) 107 format(' } def') write(7,108) 108 format('/diamndmark { gsave currentpoint translate') write(7,109) 109 format(' 45 rotate') write(7,110) 110 format(' dup scale') write(7,111) 111 format(' .05 setlinewidth') write(7,112) 112 format(' 1 square white setgray fill') write(7,113) 113 format(' 1 square black setgray stroke') write(7,114) 114 format(' .1 circle fill') write(7,115) 115 format(' grestore') write(7,116) 116 format(' } def') write(7,117) 117 format('/square { .9 mul /L exch def %assumes length of', 1 ' square waiting on stack.') write(7,118) 118 format(' /L2 {L 2 div} def') write(7,119) 119 format(' L2 neg L2 neg moveto') write(7,120) 120 format(' 0 L rlineto') write(7,121) 121 format(' L 0 rlineto') write(7,122) 122 format(' 0 L neg rlineto') write(7,123) 123 format(' closepath') write(7,124) 124 format(' } def') write(7,125) 125 format('/mark2 { .08 72 mul mul squaremark} def') write(7,126) 126 format('/mark5 { .08 72 mul mul diamndmark} def') write(7,130) 130 format('/uptrimark {gsave currentpoint translate') write(7,131) 131 format(' dup scale') write(7,132) 132 format(' .05 setlinewidth') write(7,133) 133 format(' 1 tri white setgray fill') write(7,134) 134 format(' 1 tri black setgray stroke') write(7,135) 135 format(' .1 circle fill') write(7,136) 136 format(' grestore') write(7,137) 137 format(' } def') write(7,138) 138 format('/dntrimark {gsave currentpoint translate ') write(7,139) 139 format(' dup scale') write(7,140) 140 format(' 180 rotate') write(7,141) 141 format(' .05 setlinewidth') write(7,142) 142 format(' 1 tri white setgray fill') write(7,143) 143 format(' 1 tri black setgray stroke') write(7,144) 144 format(' .1 circle fill') write(7,145) 145 format(' grestore') write(7,146) 146 format(' } def') write(7,147) 147 format('/tri { .5 mul 1.3 mul /L2 exch def') write(7,148) 148 format(' % diam of enclosing circle on stack.') write(7,149) 149 format(' /cos30 { 30 cos } def') write(7,150) 150 format(' /sin30 { 30 sin } def') write(7,151) 151 format(' 0 L2 moveto') write(7,152) 152 format(' L2 cos30 neg mul L2 sin30 neg mul lineto') write(7,153) 153 format(' L2 cos30 mul L2 sin30 neg mul lineto') write(7,154) 154 format(' closepath') write(7,155) 155 format(' } def') write(7,156) 156 format('/mark3 { .08 72 mul mul uptrimark} def') write(7,157) 157 format('/mark4 { .08 72 mul mul dntrimark} def') return end C C c********************************************************************** real*8 function mydble(a) real a character*30 chara write(chara,10)a 10 format(e30.17) read(chara,10)mydble return end c c c subroutine lc(str) c converts string 'str' to lowercase implicit none character*(*) str integer i,ich do 1 i=1,len(str) ich=ichar(str(i:i)) c note: ichar('A')=65, ichar('Z')=90 if(ich.ge.65.and.ich.le.90) then str(i:i)=char(ich+32) endif 1 continue end c