internal compiler error: in instantiate_virtual_regs_lossage, at function
c:3476
The command line is simply a "return" at the end of a subroutine (line:561). It
is followed by an "end" on the next line.
c
c
c **************************************
c ************ pltlib ******************
c **************************************
c
c
c the following collection of subroutines is designed
c to aid in constructing graphic outputs from fortran
c programs. these subroutines are designed to run on
c a sun under openwindows and drive a postscript printer.
c the user only needs to designate the destination device
c in subroutine initpt--all other routines function as
c nearly identically as possible on all devices.
c
c****************************************************************************
c
c copyright 1991,1992 by h. j. melosh. all rights reserved.
c
c this code is provided by the author to designated users for
c the purpose of cooperative research. it may not be distributed
c to other users without the express consent of the author.
c
c under no circumstances is this code to be used for commercial
c purposes without the author's written consent.
c
c ***legal notice***
c
c this code was written as part of the research of h. j. melosh and his
c collaborators. none of these authors make any warranty, express or
c implied, or assumes any legal liability or responsibility for the
c accuracy, completeness or usefulness of this code or its results,
c or represents that its use would not infringe privately owned rights.
c
c
c
c*****************************************************************************
c
c the subroutines are self documenting--the user is advised
c to study the comments in the fortran listing of each
c routine. the routines that are availabe for the user are:
c
c plotxy--draws a complete x,y plot, either line or scatter
c contur--draws a complete x,y,z contour plot
c axis--draws a labeled axis
c initpt--initializes the graphic device
c legend--writes a label or ascii string on the plot
c line--draws a continuous line between points
c newpen--chooses a pen
c number--writes a floating point number on the plot
c offset--shifts the coordinate zero and scale
c scale--scales an array in rational units. use as input
c for axis or arbgrd
c symbol--draws one of 16 symbols on the plot
c arbgrd--draws a contour plot on an irregular grid: specialized for
c finite element codes.
c
c written by h.j.melosh, july, 1985. modified for the mac ii
c october, 1987. plot routines improved january, 1989
c contouring improved march 1992
c
c adapted for the sun using pgplot by h. j. melosh, may 1992
c
c
subroutine plotxy(xl,xu,labelx,labely,xarray,yarray,
& npts,irep,isym)
c
c program to produce an x-y line or scatter plot of arrays (xarray) and
c (yarray). the user specifies the coordinates (xl(1),xl(2))
c of the bottom left corner of the plot and coordinates (xu(1),
c xu(2)) of the upper right corner. the axes are labeled,
c respectively, 'labelx' and 'labely'. (npts) is the number of
c points plotted.
c
c xarray and yarray are not altered by this routine.
c
c the switch irep has the following effects:
c
c irep=0: the coordinate axes are scaled to accomodate the full
c range of xarray and yarray. the axes are plotted,
c then the logical coordinates are shifted and scaled to
c accomodate the arrays, which are then plotted.
c scales are returned to their default values when the
c plot is complete. this is the normal mode for a
c single line or scatter plot.
c
c irep=1: same as irep=0 except that the scales are not returned
c to their default values after plotting. this is the
c normal mode for the first plot in a sequence of overlaid
c plots.
c
c irep>1: only the arrays are plotted, using a previously set
c scale. this mode is used for the second and subsequent
c plots in a sequence of overlaid plots.
c
c irep<0: same as irep>1, except that the scales are returned to
c their default values after the plot is complete. used
c to terminate a sequence of overlaid plots.
c alternatively, the user may make a call to offset
c with parameters offset(0.,0.,1.,1.) to perform this
c function after the last plot with irep>1.
c
c the zero axes are drawn as a dashed line if they fall within
c the plot area.
c
c a line plot is produced if isym=0. if isym is between 1 and 16 a
c scatter plot is generated using the symbol corresponding to isym.
c see subroutine symbol for a description of the available symbols.
c
c data on numerical labeling of axes is transmitted in the labeled
c common /ticdat/. see the description of axis for an explanation.
c data on pen number and linetype is transmitted via the labeled
c common /lindat/. these commons and /scales/ (below) may be defined
c in the calling program. if they are not defined, default values are
c assigned.
c
c user defined scale parameters may be transmitted
c through the labeled common /scales/. firsx and firsy are the values
c of the variable at the beginning of the x and y axes, respectively.
c similarly, enx and eny are the variable values at the end of each axis.
c
dimension xl(2),xu(2),zero(2),endpt(2),xarray(npts),yarray(npts)
character*(*) labelx,labely
logical flip
common/ticdat/ndecx,nticx,nlticx,ndecy,nticy,nlticy
common/lindat/ipen,iline
common/scales/firsx,enx,firsy,eny
save /ticdat/,/lindat/,/scales/
data zero/0.,0./
if(ipen.eq.0) ipen=1
if(iline.eq.0) iline=1
flip=(xu(1).lt.xl(1))
c
if(irep.eq.1) goto 100
if(irep) 200,100,200
c
100 call newpen(1)
rotx=0.
ncharx=nchar(labelx)
nchary=nchar(labely)
if(flip) then
rotx=90.
xlen=abs(xu(2)-xl(2))
ylen=abs(xu(1)-xl(1))
else
xlen=abs(xu(1)-xl(1))
ylen=abs(xu(2)-xl(2))
endif
if(enx-firsx) 300,310,300
310 call scale(xarray,npts,xlen,firstx,endx,deltax)
goto 400
300 firstx=firsx
endx=enx
deltax=xlen/(enx-firsx)
400 if(eny-firsy) 500,510,500
510 call scale(yarray,npts,ylen,firsty,endy,deltay)
goto 600
500 firsty=firsy
endy=eny
deltay=ylen/(eny-firsy)
600 if(nticx) 50,50,60
50 nticx=(ifix(xlen*40.+.0001))+1
nlab=ifix(12.*xlen)-1
if(nlab.le.0) nlab=0
if(nlab.ne.0) nlticx=nticx/nlab
if(nlab.eq.0) nlticx=nticx
ndecx=-4
60 call axis(xl(1),xl(2),labelx,ncharx,-1,rotx,xlen,firstx,endx,
& ndecx,nticx,nlticx)
roty=rotx+90.
if(nticy) 70,70,80
70 nticy=(ifix(ylen*40.+.0001))+1
nlab=ifix(12.*ylen)-1
if(nlab.le.0) nlab=0
if(nlab.ne.0) nlticy=nticy/nlab
if(nlab.eq.0) nlticy=nticy
ndecy=-4
80 call axis(xl(1),xl(2),labely,nchary,1,roty,ylen,firsty,endy,
& ndecy,nticy,nlticy)
xof=xl(1)-firstx*deltax
yof=xl(2)-firsty*deltay
call offset(xof,yof,deltax,deltay)
xof=xl(1)+firsty*deltay
yof=xl(2)-firstx*deltax
if(flip) call offset(xof,yof,-deltay,deltax)
if(firstx*endx) 10,20,20
10 endpt(1)=firsty
endpt(2)=endy
if(nlticx.ge.0) then
if(.not.flip) call line(zero,endpt,2,3)
if(flip) call line(endpt,zero,2,3)
endif
20 if(firsty*endy) 30,200,200
30 endpt(1)=firstx
endpt(2)=endx
if(nlticy.ge.0) then
if(.not.flip) call line(endpt,zero,2,3)
if(flip) call line(zero,endpt,2,3)
endif
200 call newpen(ipen)
if (isym.ne.0) goto 700
if(.not.flip) call line(xarray,yarray,npts,iline)
if(flip) call line(yarray,xarray,npts,iline)
if(irep.le.0) call offset(0.,0.,1.,1.)
return
700 if(.not.flip) call scater(xarray,yarray,npts,isym)
if(flip) call scater(yarray,xarray,npts,isym)
if(irep.le.0) call offset(0.,0.,1.,1.)
return
end
c
c
subroutine contur(xl,xu,labelx,labely,ptitle,
& xarray,yarray,zarray,nx,ny,nctrs)
c
c program to produce a contour plot of array zarray(i,j) which
c is defined at points (x,y) given in arrays xarray(i,j) and yarray(i,j).
c these arrays are handled here as vectors, assuming normal fortran
c array subscript rules.
c the user specifies the coordinates (xl(1),xl(2))
c of the bottom left corner of the plot and coordinates (xu(1),
c xu(2)) of the upper right corner. the axes are labeled,
c respectively, 'labelx' and 'labely'. nx is the maximum value of i
c and ny is the maximum value of j.
c
c nctrs is the number of coutours desired
c
c xarray, yarray and zarray are not altered by this routine.
c
c
c data on numerical labeling of axes is transmitted in the labeled
c common /ticdat/. see the description of axis for an explanation.
c data on linetype is transmitted via the labeled
c common /lindat/. these commons and /scales/ (below) may be defined
c in the calling program. if they are not defined, default values are
c assigned.
c
c user defined scale parameters may be transmitted
c through the labeled common /scales/. firsx and firsy are the values
c of the variable at the beginning of the x and y axes, respectively.
c similarly, enx and eny are the variable values at the end of each axis.
c
c the contour values are computed in the subroutine setctr. the user may
c override this subroutine by setting icontur=1 in a labeled common
c /contourdat/. the contour values are then carried in the array zc(99).
c the contour values are printed to a file named 'contour.dat'.
c
c this routine defines a scratch array ien(4,numel), where
c numel=2*(nx-1)*(ny-1). the dimensions of the array in this routine
c must be at least as large as numel.
c
dimension xl(2),xu(2),xarray(*),yarray(*),zarray(*),
& ien(4,10000),zc(99)
character*(*) labelx,labely,ptitle
character*32 title
logical flip
common/ticdat/ndecx,nticx,nlticx,ndecy,nticy,nlticy
common/lindat/ipen,iline
common/scales/firsx,enx,firsy,eny
common/grd/lgrid,xlngth,ylngth,xmin,xmax,ymin,ymax,title
common/conturdat/icontur,zc
save /ticdat/,/lindat/,/scales/,/grd/,/conturdat/
title=ptitle
lgrid=0
nfreq=50
if(iline.eq.0) iline=1
flip=(xu(1).lt.xl(1))
c
c construct ien array and temporary arrays for plotting
c
call newpen(1)
call triien(ien,nx,ny,numel)
rotx=0.
ncharx=nchar(labelx)
nchary=nchar(labely)
if(flip) then
rotx=90.
xlen=abs(xu(2)-xl(2))
ylen=abs(xu(1)-xl(1))
else
xlen=abs(xu(1)-xl(1))
ylen=abs(xu(2)-xl(2))
endif
if(enx-firsx.eq.0.) then
call scale(xarray,nx*ny,xlen,firstx,endx,deltax)
else
firstx=firsx
endx=enx
deltax=xlen/(enx-firsx)
endif
if(eny-firsy.eq.0.) then
call scale(yarray,nx*ny,ylen,firsty,endy,deltay)
else
firsty=firsy
endy=eny
deltay=ylen/(eny-firsy)
endif
if(nticx.le.0) then
nticx=(ifix(xlen*40.+.0001))+1
nlab=ifix(12.*xlen)-1
if(nlab.le.0) nlab=0
if(nlab.ne.0) nlticx=nticx/nlab
if(nlab.eq.0) nlticx=nticx
ndecx=-4
endif
call axis(xl(1),xl(2),labelx,ncharx,-1,rotx,xlen,firstx,endx,
& ndecx,nticx,nlticx)
roty=rotx+90.
if(nticy.le.0) then
nticy=(ifix(ylen*40.+.0001))+1
nlab=ifix(12.*ylen)-1
if(nlab.le.0) nlab=0
if(nlab.ne.0) nlticy=nticy/nlab
if(nlab.eq.0) nlticy=nticy
ndecy=-4
endif
call axis(xl(1),xl(2),labely,nchary,1,roty,ylen,firsty,endy,
& ndecy,nticy,nlticy)
xof=xl(1)-firstx*deltax
yof=xl(2)-firsty*deltay
call offset(xof,yof,deltax,deltay)
xof=xl(1)+firsty*deltay
yof=xl(2)-firstx*deltax
if(flip) call offset(xof,yof,-deltay,deltax)
if(.not.flip) call
& arbgrd(nx*ny,ien,numel,nctrs,nfreq,xarray,yarray,zarray,
&'contur output')
if(flip) call
& arbgrd(nx*ny,ien,numel,nctrs,nfreq,xarray,yarray,zarray,
&'contur output')
return
end
c
c
subroutine scater(xarray,yarray,npts,isym)
c
c program to produce a scatter plot of arrays xarray and yarray
c using the symbol routine.
c
dimension xarray(npts),yarray(npts)
c
do 10 i=1,npts
call symbol(xarray(i),yarray(i),-1.,0.,isym)
10 continue
return
end
c
c
c
subroutine axis(xstart,ystart,label,nents,lblpos,angle,axlen,
&firstv,alastv,ndec,ntic,nltic)
c
c program to draw a labeled axis of length (axlen) starting at
c position (xstart,ystart), all in logical units. the axis is
c plotted at (angle) degrees counterclockwise from the x-axis.
c the label is contained in the ascii string 'label' of length
c (nents). it is centered
c below the axis if (lblpos <0 ) and above it if (lblpos >0).
c
c the first and last points of the axis are ticked and labeled
c with numbers in the format specified by (ndec)--see the comments
c for subroutine number. the extreme ends of the axis are
c assigned the values (firstv)--the minimum, and (alastv)--the
c maximum. the total number of ticks is (ntic) (.ge. 2).
c however, only every (nltic)'th tick is labeled (nltic =0 or 1
c labels all tics).
c
c if (nltic) < 0 a logarithmic axis with ntic decade labels
c is drawn and labeled. intermediate short tics are drawn between
c the decades. the user must ensure that the labeled tics correspond
c to simple powers of ten.
c
dimension x(2),y(2)
character*(*) label
common/coord/x0,y0,ang,sinang,cosang
save /coord/
x0=xstart
y0=ystart
if(ntic.lt.2) ntic=2
ang=0.0174533*angle
sinang=sin(ang)
cosang=cos(ang)
c
x(2)=xstart
y(2)=ystart
call rotate(axlen,0.,x(1),y(1))
call line(x,y,2,1)
call tic(0.,0,firstv,alastv,axlen,angle,ndec,lblpos,nltic)
tpos=0.
nloop=ntic-1
if(nloop.le.0) nloop=1
nskip=nltic
if(nltic.le.0) nskip=1
deltic=axlen/float(nloop)
do 10 ii=1,nloop
i=ii
mode=mod(i,nskip)
if(i.eq.nloop) mode=0
if(nltic) 20,30,30
20 do 40 j=1,8
dtpos=tpos+deltic*alog10(float(j+1))
call tic(dtpos,1,firstv,alastv,axlen,angle,ndec,lblpos,nltic)
40 continue
30 tpos=deltic*float(i)
call tic(tpos,mode,firstv,alastv,axlen,angle,ndec,lblpos,nltic)
10 continue
c
ylb=sign(0.06,float(lblpos))
strl=0.01*float(nents)
xlb=0.5*(axlen-strl)
call rotate(xlb,ylb,x(1),y(1))
call legend(x(1),y(1),0.015,label,nents,angle)
return
end
c
c
subroutine rotate(dx,dy,rax,ray)
c
c program to apply a coordinate rotation around the center
c (x0,y0) by an angle (ang) radians counterclockwise from
c the x axis. the initial coordinates (dx,dy) are relative
c to the origin. they are converted to absolute rotated
c coordinates (rax,ray).
c
common/coord/x0,y0,ang,sinang,cosang
save /coord/
c
rax=x0+dx*cosang-dy*sinang
ray=y0+dx*sinang+dy*cosang
return
end
c
c
subroutine tic(xtic,mode,firstv,alastv,axlen,angle,ndec,
&lblpos,nltic)
c
c program to draw a tic mark at position (xtic) relative to
c the beginning of the axis. if (mode) .ne. 0 a short,
c unlabeled tic is produced. if (mode)=0 a longer, labeled
c tic is produced. lblpos controls whether the label is
c above (lblpos>0) or below (lblpos<0) the axis.
c
dimension x(2),y(2)
c
call rotate(xtic,0.,x(1),y(1))
if(mode.ne.0) ticl=0.005
if(mode.eq.0) ticl=0.01
delty=-sign(ticl,float(lblpos))
call rotate(xtic,delty,x(2),y(2))
call line(x,y,2,1)
if(mode.ne.0) return
c
prop=xtic/axlen
valtic=firstv+(alastv-firstv)*prop
if(nltic) 10,20,20
10 af=firstv
al=alastv
valtic=10.**(af+(al-af)*prop)
20 ynum=sign(0.025,float(lblpos))
xnum=xtic-0.01
call rotate(xnum,ynum,xnr,ynr)
call number(xnr,ynr,0.01,valtic,ndec,angle)
return
end
c
c
subroutine number(x,y,height,fpn,ndec,angle)
c
c program to plot a single precision floating point number
c fpn. (x,y) are the lower left coordinates of the character
c that begins the string and height is its size, all in
c logical units. the number is drawn at (angle) degrees
c counterclockwise from the x-axis.
c
c ndec is the number (0 to 6) of digits to the right of the
c decimal point. if ndec=-1 the decimal and all subsequent
c digits are suppressed. if ndec is (-2 to -8) the number
c plotted in exponential format with abs(ndec)-2 digits to
c the right of the decimal.
c
c inspired by a copyrighted hewlett-packard program
c
character numb(20),nml(10)
data nml/'0','1','2','3','4','5','6','7','8','9'/
nd=ndec
fpv=fpn
ieptr=0
iptr=1
if((nd.lt.-8).or.(nd.gt.6)) nd=-5
c
c process floating point string
c
if(fpv) 10,20,20
10 numb(iptr)='-'
iptr=iptr+1
fpv=-fpv
20 mn=-nd
if(nd+1) 200,30,40
30 mn=mn-1
40 fpv=fpv+0.5*10.**mn
i=alog10(fpv)+1.0
ilp=i
if(ilp) 60,60,70
60 numb(iptr)=nml(1)
iptr=iptr+1
goto 90
70 do 80 j=1,ilp
k=fpv*10.**(j-ilp)
numb(iptr)=nml(k+1)
iptr=iptr+1
fpv=fpv-(float(k)*10.**(ilp-j))
80 continue
90 if(nd.eq.-1) goto 300
numb(iptr)='.'
iptr=iptr+1
if(nd.eq.0) goto 300
do 100 j=1,nd
k=fpv*10.
numb(iptr)=nml(k+1)
iptr=iptr+1
fpv=fpv*10.-float(k)
100 continue
goto 300
c
c process exponent string
c
200 if(fpv) 204,201,204
201 nd=1
goto 20
204 i=alog10(fpv)
iep=i
if(i.le.0) iep=iep-1
fpv=fpv*10.**(-iep)
nd=iabs(nd)-2
mn=-nd
fpv=fpv+0.5*10.**mn
if(10.-fpv) 205,205,207
205 iep=iep+1
fpv=fpv*0.1
207 ieptr=iptr+nd+2
numb(ieptr)='e'
ieptr=ieptr+1
if(iep) 210,220,220
210 numb(ieptr)='-'
ieptr=ieptr+1
iep=-iep
220 if(iep-9) 240,240,230
230 k=(0.1*float(iep))
numb(ieptr)=nml(k+1)
ieptr=ieptr+1
iep=iep-10*k
240 numb(ieptr)=nml(iep+1)
ilp=1
goto 70
c
c print out final string
c
300 nents=iptr-1
if(ieptr.ne.0) nents=ieptr
call legend(x,y,height,numb,nents,angle)
return
end
c
c
subroutine legend(x,y,height,string,nents,angle)
c
c program to draw an ascii string contained in the array 'label'
c starting at (x,y) on the plot. the coordinates are of the lower
c left corner of the first character. height is the size of the
c character in logical units (height<0 draws a default size), angle
c is the angle the string is drawn at, reckoned in degrees counter-
c clockwise from the x-axis. Characters are always drawn with the
c default line width.
c
c
character*80 string
data ifont/1/,fjust/0.0/
if(height.lt.0.0) then
size=1.0
else
size=amax1(0.7,height*50.)
endif
c
call PGQLW(iwide)
call PGSLW(1)
call PGSCF(ifont)
call PGSCH(size)
call PGPTEXT(x,y,angle,fjust,string(1:nents))
call PGSCH(1.0)
call PGSLW(iwide)
c
return
end
c
c
subroutine symbol(xsym,ysym,size,angle,isym)
c
c program to plot one of sixteen (isym) centered symbols.
c the symbols are plotted at location (xsym,ysym), rotated
c at (angle) degrees counterclockwise from the x-axis.
c the symbol's maximum dimension is set by parameter
c (size) in logical units. if (size)<0., a default size is used.
c___________________________________________________________________
c the symbols available are:
c
c symbol# description symbol# description
c____________________________________________________________________
c
c 1 square with tic 9 hourglass
c 2 octagon with tic 10 narrow hourglass
c 3 triangle with tic 11 line segment
c 4 diamond with tic 12 plus sign
c 5 star with tic 13 asterisk
c 6 tail-centered arrow 14 letter x
c 7 head-centered arrow 15 letter y
c 8 x bridged on top 16 letter z
c_____________________________________________________________________
c
logical showpen
dimension nsym(16,24)
common/ofset/xoff,yoff,xscale,yscale,yfac
save/ofset/
c
c symbol # 1
data (nsym(1,i),i=1,24)
&/6,110,0,8,6,8,6,-8,-6,-8,-6,8,0,8,10*0/
c symbol # 2
data (nsym(2,i),i=1,24)
&/10,110,0,8,3,8,6,3,6,-3,3,-8,-3,-8,-6,-3,-6,3,-3,8,0,8,0,0/
c symbol # 3
data (nsym(3,i),i=1,24)
&/4,110,0,8,6,-8,-6,-8,0,8,14*0/
c symbol # 4
data (nsym(4,i),i=1,24)
&/5,110,0,8,6,0,0,-8,-6,0,0,8,12*0/
c symbol # 5
data (nsym(5,i),i=1,24)
&/10,110,0,8,6,-4,-6,-4,0,8,-110,6,4,110,0,-8,-6,4,6,4,4*0/
c symbol # 6
data (nsym(6,i),i=1,24)
&/4,110,0,8,2,4,-2,4,0,8,14*0/
c symbol # 7
data (nsym(7,i),i=1,24)
&/6,0,8,110,0,0,2,4,-2,4,0,0,12*0/
c symbol # 8
data (nsym(8,i),i=1,24)
&/5,6,-8,110,-6,8,6,8,-6,-8,14*0/
c symbol # 9
data (nsym(9,i),i=1,24)
&/5,110,6,8,-6,8,6,-8,-6,-8,0,0,12*0/
c symbol # 10
data (nsym(10,i),i=1,24)
&/5,110,3,8,-3,8,3,-8,-3,-8,0,0,12*0/
c symbol # 11
data (nsym(11,i),i=1,24)
&/3,0,-8,110,0,8,18*0/
c symbol # 12
data (nsym(12,i),i=1,24)
&/7,0,8,110,0,-8,-110,-6,0,110,6,0,12*0/
c symbol # 13
data (nsym(13,i),i=1,24)
&/15,0,-8,110,0,8,-110,6,8,110,-6,-8,-110,6,-8,110,-6,8,-110,-6,0
&,110,6,0/
c symbol # 14
data (nsym(14,i),i=1,24)
&/7,6,8,110,-6,-8,-110,6,-8,110,-6,8,12*0/
c symbol # 15
data (nsym(15,i),i=1,24)
&/8,6,8,110,0,0,0,-8,-110,-6,8,110,0,0,10*0/
c symbol # 16
data (nsym(16,i),i=1,24)
&/9,-6,8,110,6,8,-6,-8,6,-8,-110,3,0,110,-3,0,8*0/
c
c
radang=0.0174533*angle
csang=cos(radang)
snang=sin(radang)
hgt=size
if(size.lt.0.0) hgt=0.01
redfac=hgt/16.
nents=nsym(isym,1)
iptr=2
showpen=.false.
c
call PGMOVE(xsym,ysym)
if(nsym(isym,iptr).gt.99) then
showpen=.true.
iptr=iptr+1
endif
do 100 i=1,nents
if(nsym(isym,iptr).gt.99) then
showpen=.true.
iptr=iptr+1
else if(nsym(isym,iptr).lt.-99) then
showpen=.false.
iptr=iptr+1
else
rx=float(nsym(isym,iptr))
ry=float(nsym(isym,iptr+1))
rx=redfac*rx/xscale
ry=redfac*ry*yfac/yscale
temp=rx
rx=rx*csang-ry*snang
ry=temp*snang+ry*csang
if(showpen) call PGDRAW(xsym+rx,ysym+ry)
if(.not.showpen) call PGMOVE(xsym+rx,ysym+ry)
iptr=iptr+2
endif
100 continue
return
end
c
c
subroutine initpt(idev)
c
c program to initialize the graphic device and set up
c its initial parameters. The paramter idev determines
c which device will be used. Currently available devices
c are:
c
c idev = -1 prompt user at runtime
c idev = 0 null device (for debugging)
c idev = 1 postscript printer, landscape mode
c idev = 2 postscript printer, portrait mode
c idev = 3 xwindows screen
c
c
c
character*8 devlst(5)
common/exec/kexec
common/devices/iidev
save /exec/,/devices/
data devlst/'?','/NULL','/PS','/VPS','/XWINDOW'/
c
c make a call to PGBEGIN on first plot only
c
iidev=idev
if((idev.lt.-1).or.(idev.gt.3)) iidev=-1
if(kexec.ne.1) then
call PGBEGIN(0,devlst(iidev+2),1,1)
kexec=1
endif
c
c reset window at each call to initpt
c
call PGPAGE
call PGVSTAND
call offset(0.,0.,1.,1.)
return
end
c
c
subroutine newpen(ipen)
c
c program to set the width of the line drawn.
c the default width is 1. pen 1 is twice as wide
c
if(ipen.eq.0) return
ipwide=1
if(ipen.eq.1) ipwide=2
call PGSLW(ipwide)
return
end
c
c
subroutine offset(xof,yof,xscl,yscl)
c
c program to shift plotting zero and scale coordinates for
c subsequent plotting.
c
dimension ratio(5)
common/devices/iidev
common/ofset/xoff,yoff,xscale,yscale,yfac
save /ofset/,/devices/
data ratio/1.0,1.0,0.681,1.12,0.726/
c
yfac=ratio(iidev+2)
xoff=xof
yoff=yof
xscale=xscl
yscale=yscl
xmin=-xoff/xscale
xmax=(1.0-xoff)/xscale
ymin=-yoff/yscale
ymax=(yfac-yoff)/yscale
call PGWINDOW(xmin,xmax,ymin,ymax)
return
end
c
c
c
subroutine line(xarray,yarray,npts,iline)
c
c program to draw a line of specified type, iline(1-5) connecting
c the npts pairs of points contained in (xarray,yarray).
c
c if npts = 1 nothing is drawn.
c
c the currently available line types are:
c
c iline
c
c 1 solid
c 2 dashed
c 3 dot-dash-dot-dash
c 4 dotted
c 5 dash-dot-dot-dot
c
dimension xarray(npts),yarray(npts)
lintyp=iline
if((lintyp.lt.1).or.(lintyp.gt.5)) lintyp=2
call PGSLS(lintyp)
call PGLINE(npts,xarray,yarray)
call PGSLS(1)
return
end
c
c
subroutine scale(array,npts,axlen,firstv,alastv,deltav)
c
c program to establish scaling factors for a vector array
c containing npts values. the user specifies the axis
c length axlen in logical units (0. to 1.0) and the program
c returns a rationalized beginning value for the axis,
c firstv and its last value, alastv, in the same units
c as array, and a scaling factor deltav that compresses
c all values in array into the axis length.
c
c values of array are not altered by this routine.
c
c patterned after a copyrighted hewlett-packard program in
c hpispp.
c
dimension array(npts),save(7)
data save/1.,2.,4.,5.,8.,10.,20./
fad=0.01
c
axl=axlen
if (axl .le. 0.0) axl=0.1
if (axl .gt. 0.98) axl=0.98
c
y0=array(1)
yn=y0
c
c**** find minimum and maximum values among data points to be scaled
c
do 40 i = 1,npts
ys=array(i)
if (y0-ys) 20,20,10
10 y0=ys
go to 40
20 if (ys-yn) 40,40,30
30 yn=ys
40 continue
firstv=y0
if (y0) 50,60,60
50 fad=fad-1.0
c
c**** calculate the number of data units per logical unit
c
60 deltav=(yn-firstv)/axl
if (deltav) 180,180,70
70 i=alog(deltav)*0.4343+1000.0
p=10.0**(i-1000)
deltav=deltav/p-0.01
do 80 i = 1,6
is=i
if (save(i)-deltav) 80,90,90
80 continue
c
c**** calculate the adjusted delta value
c
90 deltav=save(is)*p
firstv=deltav*aint(y0/deltav+fad)
t=firstv+(axl+0.01)*deltav
if (t-yn) 100,120,120
c
c**** calculate the adjusted minimum value
c
100 firstv=p*aint(y0/p+fad)
t=firstv+(axl+.01)*deltav
if (t-yn) 110,120,120
110 is=is+1
go to 90
120 firstv=firstv-aint((axl+(firstv-yn)/deltav)/2.0)*deltav
if (y0*firstv) 130,130,140
130 firstv=0.0
140 alastv=firstv+deltav*axlen
deltav=1./deltav
return
c
180 deltav=2.0*firstv
deltav=abs(deltav/axl)+1.
go to 70
end
c
c
subroutine arbgrd(numnp,ien,numel,nctrs,nfreq,xx,yy,zz,pname)
c
c program to produce a contour map on an irregular grid.
c designed to work with finite element routines, it requires
c a mesh of coordinates where the contoured function is known
c and a connectivity matrix ien(number of elements,4).
c
c originally written by p. jungels at caltech to drive a
c calcomp plotter. modified by h. j. melosh, april,1986.
c
c numnp = number of points at which data is supplied
c numel = number of elements (3 or 4 node) connecting points
c nctrs = number of contours plotted
c nfreq = interval between plotting contour labels
c xx(numnp) = x coordinates of node points
c yy(numnp) = y coordinates of node points
c zz(numnp) = values to be contoured at each point
c ien(4,numel) = node numbers in each element, numbered
c counterclockwise around element.
c if ien(3,n)=ien(4,n), then element has 3 nodes
c lgrid = 0, no grid lines are plotted
c = 1, grid lines are plotted in addition to contours
c /grd/ = labeled common with data on grid dimensions.
c must be defined in the calling program
c /window/ = labeled common defining a window outside of
c which contour points are ignored. if not user
c defined, default values (maximum open) are used.
c
c note that contour values may be defined by the user by altering the
c routine setctr
c
dimension ien(4,numel),xx(*),yy(*),zz(*),zc(99)
character title*32,pname*70
c
common/grd/lgrid,xlngth,ylngth,xmin,xmax,ymin,ymax,title
common/window/xwmin,xwmax,ywmin,ywmax
common/conturdat/icontur,zc
common/lindat/ipen,iline
save /lindat/,/grd/,/window/,/conturdat/
c
if(((xwmin-xwmax).eq.0.).or.((ywmin-ywmax).eq.0.)) then
xwmin=-1.7e38
xwmax= 1.7e38
ywmin=xwmin
ywmax=xwmax
endif
if (lgrid .ne. 0) then
c
c draw the grid if requested
c
call newpen(4)
iline=1
do 120 i = 1,numel
do 110 j = 1,4
jj=j
k = ien(j,i)
l = mod(jj,4)+1
l = ien(l,i)
if(k.eq.l) goto 110
call draw(xx(k),yy(k),xx(l),yy(l))
110 continue
120 continue
endif
c
c define the contour values and send them to a file named
c "contour.dat"
c
open(12,file="contour.dat")
if(icontur.eq.0) call setctr(numnp,xx,yy,zz,nctrs,zc)
write(12,100) pname
write(12,300) title
write(12,510) (i,zc(i), i = 1,nctrs)
write(12,200)
100 format(//1x,a70)
200 format(///)
300 format(/1x,a32)
510 format(/1x,'legends for contour values'//(1x,'k = ', i2,2x,
&'c = ',1pe12.4))
c
c draw the contours
c
call newpen(3)
call contr(xx,yy,zz,zc,nctrs,nfreq,icontur,ien,numel,numnp)
return
end
c
c
subroutine contr(xx,yy,zz,zc,nctrs,nfreq,icontur,ien,numel,numnp)
c
c program to locate the contours, plot and label them
c
common/grd/lgrid,xlngth,ylngth,xmin,xmax,ymin,ymax,title(8)
common/lindat/ipen,iline
save /lindat/,/grd/
dimension xx(1),yy(1),zz(1),ien(4,numel)
dimension xl(4),yl(4),zl(4),zc(1)
nn=0
if(zc(2).eq.zc(1)) goto 90
c
c loop over elements
c
do 70 i=1,numel
c
c localize nodal coordinates
c
ii=i
nenp=4
if(ien(3,ii).eq.ien(4,ii)) nenp=3
do 101 j=1,nenp
nnode=ien(j,ii)
xl(j)=xx(nnode)
yl(j)=yy(nnode)
zl(j)=zz(nnode)
101 continue
c
do 70 n=1,nctrs
mn=n
c
c plot the contours that fall in an element
c
call detcon(xl,yl,zl,zc(n),nn,mn,nenp,nfreq)
c
70 continue
iline=1
c
c label plot with max and min values
c only print contour interval for values generated
c by setcontr
c
90 continue
call newpen(2)
call offset (0.,0.,1.,1.)
dc = zc(2) - zc(1)
call legend(.12,.651,.015,title,32,0.)
call legend(.06,.01,.01,'cmin= ',6,0.)
call number(.15,.01,.01,zc(1),-6,0.)
call legend(.37,.01,.01,'cmax= ',6,0.)
call number(.46,.01,.01,zc(nctrs),-6,0.)
if(icontur.eq.0) call legend(.63,.01,.01,'delc= ',6,0.)
if(icontur.eq.0) call number(.72,.01,.01,dc,-6,0.)
return
end
c
c
subroutine detcon(x,y,z,zc,nn,mm,nenp,nfreq)
c
c seek contours in a given element and draw them
c
common/lindat/ipen,iline
save /lindat/
dimension x(4), y(4), z(4), xc(4), yc(4)
iline=1
if(zc.lt.0.0) iline=2
l = 0
do 30 n = 1,nenp
i = n
j = mod(i,nenp) + 1
if(zc .ge. z(i)) go to 20
if(zc .ge. z(j)) go to 25
go to 30
20 if(zc.le. z(j)) go to 25
go to 30
c
c interpolate
c
25 l = l + 1
call zint(i,j,xcs,ycs,x,y,z,zc)
xc(l)=xcs
yc(l)=ycs
30 continue
if (l.eq. 0) go to 50
c
c plot interpolated points
c
do 40 n = 1,l
np=n
nn = nn + 1
j = mod(np,l) + 1
call draw(xc(n),yc(n),xc(j),yc(j))
if(mod(nn,nfreq).eq.0) call lblcon(xc(n),yc(n),mm)
if(l.eq. 2) go to 50
40 continue
50 return
end
c
c
subroutine draw(x1,y1,x2,y2)
c
c draw a line from one point to another
c
dimension xnn(2),ynn(2)
common/window/xwmin,xwmax,ywmin,ywmax
common/lindat/ipen,iline
save /window/,/lindat/
if((x1.lt.xwmin).or.(x1.gt.xwmax)) return
if((x2.lt.xwmin).or.(x2.gt.xwmax)) return
if((y2.lt.ywmin).or.(y2.gt.ywmax)) return
if((y1.lt.ywmin).or.(y1.gt.ywmax)) return
xnn(1)=x1
xnn(2)=x2
ynn(1)=y1
ynn(2)=y2
call line(xnn,ynn,2,iline)
return
end
c
c
subroutine lblcon(x,y,k)
c
c label the contours
c
common/window/xwmin,xwmax,ywmin,ywmax
save /window/
if((x.lt.xwmin).or.(x.gt.xwmax)) return
if((y.lt.ywmin).or.(y.gt.ywmax)) return
ak=float(k)
call number(x,y,.008,ak,-1,0.)
return
end
c
c
subroutine setctr(numnp,xx,yy,zz,nctrs,zc)
c
c define contour values inside the window--this routine
c may be altered by the user to obtain desired contour
c intervals
c
common/window/xwmin,xwmax,ywmin,ywmax
save /window/
dimension xx(1),yy(1),zz(1),zc(1)
zmin=1.e32
zmax=-1.e32
do 30 j=1,numnp
if((xx(j).lt.xwmin).or.(xx(j).gt.xwmax)) goto 30
if((yy(j).lt.ywmin).or.(yy(j).gt.ywmax)) goto 30
if(zz(j).gt.zmax) zmax=zz(j)
if(zz(j).lt.zmin) zmin=zz(j)
30 continue
if(nctrs.lt.2) go to 50
dc = (zmax-zmin)/float(nctrs+1)
do 40 i = 1,nctrs
zc(i) = zmin+dc*float(i)
40 continue
50 return
end
c
c
subroutine zint(i,j,xc,yc,x,y,z,zc)
c
c
c do linear interpolation to find point where
c contour line crosses side i,j.
c
dimension x(4),y(4),z(4)
if(z(i) .eq. z(j)) go to 10
zsl=(zc-z(i))/(z(j)-z(i))
xc=x(i)+(x(j)-x(i))*zsl
yc=y(i)+(y(j)-y(i))*zsl
return
10 xc = x(i)
yc = y(i)
return
end
c
c
subroutine triien(ien,nx,ny,numel)
c
c program to construct the ien array for a rectangular grid
c nx points long and ny points high. assumes three node triangular
c elements. this routine also returns numel, the number of
c elements for use in the contouring routine. the use of
c triangular elements resolves any ambiguity in contour positions.
c
c note: numel=2*(nx-1)*(ny-1) and the node number nn for x(nn) is
c determined from an array xx(i,j) is nn = i+(j-1)*nx
c (normal fortran storage order)
c
c
dimension ien(4,*)
numel=0
do 100 j=1,ny-1
do 100 i=1,nx-1
numel=numel+1
ncornr=i+(j-1)*nx
ien(1,numel)=ncornr
ien(2,numel)=ncornr+nx+1
ien(3,numel)=ncornr+nx
ien(4,numel)=ien(3,numel)
numel=numel+1
ien(1,numel)=ncornr
ien(2,numel)=ncornr+1
ien(3,numel)=ncornr+nx+1
ien(4,numel)=ien(3,numel)
100 continue
return
end
c
c
function nchar(string)
c
c determines the minimum nonblank length of a string
c
character*(*) string
character blank
data blank/' '/
nmax=len(string)
nchar=0
do 10 i=1,nmax
itest=nmax-i+1
if(string(itest:itest).ne.blank) then
nchar=itest
return
endif
10 continue
return
end
c
c
function nnblnk(string)
c
c determines the position of the first nonblank entry
c of a string (returns 1 if the first character is
c not blank)
c
character*(*) string
character blank
data blank/' '/
nmax=len(string)
nnblnk=nmax
do 10 i=1,nmax
if(string(i:i).ne.blank) then
nnblnk=i
return
endif
10 continue
return
end
c
c
block data inital
c
c program to initialize labeled commons in pltlib
c
common/ticdat/ndecx,nticx,nlticx,ndecy,nticy,nlticy
common/lindat/ipen,iline
common/scales/firsx,enx,firsy,eny
common/grd/lgrid,xlngth,ylngth,xmin,xmax,ymin,ymax,title(8)
common/window/xwmin,xwmax,ywmin,ywmax
common/exec/kexec
common/conturdat/icontur,zc(99)
save /ticdat/,/lindat/,/scales/,/grd/,/window/
data ndecx,nticx,nlticx,ndecy,nticy,nlticy/6*0/
data ipen,iline/2*0/
data kexec/0/,icontur/0/
data firsx,enx,firsy,eny/4*0.e0/
data lgrid,xlngth,ylngth,xmin,xmax,ymin,ymax,title
& /0,14*0.e0/
data xwmin,xwmax,ywmin,ywmax/-1.e32,1.e32,-1.e32,1.e32/
end
--
Summary: internal compiler error: in
instantiate_virtual_regs_lossage ERROR 1
Product: gcc
Version: 4.0.1
Status: UNCONFIRMED
Severity: normal
Priority: P3
Component: libfortran
AssignedTo: unassigned at gcc dot gnu dot org
ReportedBy: hcolella at gmail dot com
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=42763
