subroutine iniplt(iunit, xsize, ysize) c c this routine initializes the plot. xsize and ysize denote the c size of the total plotting surface in inches. no plotting is c permitted outside this area. iunit is the logical unit c number of the plot. for iunit = 6, the plot is sent directly c to the plotter. c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c common /pagsiz/ xbond, ybond c common /world/ xmin, xmax, ymin, ymax c byte vtbufr(128), mes(8) integer vtpos, vtbufl common / vtbuf/ vtbufr, vtpos, vtbufl c data mes / ';', ':', 'H', 'O', 'U', 'A', 'L', '0' / common /penpos/ iupdwn c lunplt = iunit vtbufl = 128 vtpos = 0 iupdwn = 0 if ( iunit .eq. 7 ) call plton call writch(mes, 8 ) c scrx = 200. scry = 200. c xbond = xsize ybond = ysize ixbond = ifix(scrx * xsize) iybond = ifix(scry * ysize) dxb = .5 * ixbond dyb = .5 * iybond xmid = dxb ymid = dyb c c set default values c ixorig = 0 iyorig = 0 iascr = 0 ibscr = ixbond icscr = 0 idscr = iybond c xslope = ixbond xconst = 0. yslope = iybond yconst = 0. c xmin = 0. xmax = 1. ymin = 0. ymax = 1. c do 10 i = 1 , 5 ichar(i) = 6 * 2 ** i 10 continue c return end subroutine endplt c c this routine ends plotting by deselecting the plotter and c dumping the buffer c byte mes(4) data mes / 'P', '0', 'H', '@' / common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c call writch(mes, 4 ) if ( lunplt .eq. 7 ) call pltoff call dmpplt c return end subroutine pendwn c c this routine puts the pen down so it will draw c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c common /penpos/ iupdwn byte mes(2) data mes / 'D', ' ' / c if( iupdwn .eq. 0 ) call writch(mes, 2) iupdwn = 1 return end subroutine penup c c this routine puts the pen up c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c common /penpos/ iupdwn byte mes(2) data mes / 'U', ' ' / c if( iupdwn .eq. 1 )call writch(mes,2) iupdwn = 0 return end subroutine wrtstr(str, len, irot, isize) c c subroutine "write string" c len is the length of the string c irot determines the rotation of the string (1 - 4), 1 is c right side up, 2 is rotated 90 degrees clockwise, etc. c string is checked to see if in is in bounds c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c byte str(len), mes(84) c c check to see if in bounds c isz = max0(isize, 1) isz = min0(isz, 5) ix = 2 ** (isz - 1) iy = 14 * ix ix = 12 * ix * len irt = mod(irot - 1, 4) + 1 isx = iabs(irt - 3) - 1 isy = iabs(irt - 2) - 1 ixl = isx * ix - isy * iy + ixcur iyl = isx * iy + isy * ix + iycur if( abs(ixl - xmid) .gt. dxb )goto 100 if( abs(iyl - ymid) .gt. dyb )goto 100 c c plot string c encode( 4, 3, mes ) irt, isz minlen = min0( len, 79 ) do 10 i = 1, len mes(i + 4 ) = str(i) 10 continue mes( len + 5 ) = '_' numch = 2 * ( ( len + 6 ) / 2 ) if ( mod( len , 2 ) .eq. 0 ) mes( len + 6 ) = ' ' call writch(mes, numch) return c c string is out of bounds c 100 if ( lunplt .eq. 7 ) call pltoff type 1, (str(i), i = 1, len) type 2 if ( lunplt .eq. 7 ) call plton c return 1 format('$WARNING string ', 100a1) 2 format(' is out of bounds and will not be plotted') 3 format( 'S', 2i1, 1X ) end subroutine marker(mrknum, isize) c c places a marker at the current coordinates c byte mes(4) common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c isz = min0(isize, 5) isz = max0(isz, 1) mrk = max0(mrknum, 0) mrk = min0(mrk, 5) encode( 4, 1, mes ) isz, mrk call writch(mes, 4) 1 format('M', i1, 1x, i1) return end subroutine coltyp (icol) c c this subroutine sets the line color c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c byte mes(2) itype = icol + 1 itype = min0(itype, 8) itype = max0(itype, 1) mes(1) = 'P' mes(2) = itype + 48 call writch(mes, 2) return end subroutine plot(ixo, iyo, i) c c this routine moves to the screen coordinates ix, iy. c if i = 0, the pen is put up before moving, if i = 1, the c pen is put down before moving. checks to see if within c surface boundary. c byte mes(10) common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c if(i .eq. 0)call penup if(i .ne. 0)call pendwn ix = ixo iy = iyo c c check to see if in bounds c delx = ix - xmid if(abs(delx) .le. dxb)goto 100 xsc = xmid + sign(dxb, delx) xsl = 1. if ( ix .ne. ixcur ) xsl = ( xsc - ixcur ) / float(ix - ixcur) xsl = (iy - iycur) * xsl ix = xsc iy = xsl + iycur c 100 dely = iy - ymid if(abs(dely) .le. dyb)goto 200 ysc = ymid + sign(dyb, dely) ysl = 1. if ( iy .ne. iycur ) ysl = ( ysc - iycur ) / float(iy - iycur) ysl = (ix - ixcur) * ysl ix = ysl + ixcur iy = ysc c c plot point c 200 encode( 10, 1, mes ) ix, iy call writch(mes, 10) c c save current coordinates c ixcur = ix iycur = iy c 1 format( i4, ',', i4, 1x ) return end subroutine plotin(x, y, i) c c plots the point x, y where x and y are given in inches. c if i = 0, pen is put up before plotting, else pen is put down. c ix = ifix(200 * x) iy = ifix(200 * y) call plot(ix, iy, i) return end subroutine erase c c this is a do-nothing subroutine supplied for compatibility with c the GRINELL version of the software. return end subroutine plton c common /zgraph/ iunit, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c byte esc(6) data esc/ 27, '[', '?', '7', 'i', ' '/ call writch(esc,6) return end subroutine pltoff c common /zgraph/ iunit, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c byte esc(6) data esc/ 27, '[', '?', '6', 'i', ' '/ call writch(esc,6) return end subroutine writch(ch, n) c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c byte vtbufr(128) integer vtpos, vtbufl common / vtbuf/ vtbufr, vtpos, vtbufl c byte ch(n) c if( vtpos + n .gt. vtbufl ) call dmpplt do 10 i = 1, n vtpos = vtpos + 1 vtbufr(vtpos) = ch(i) 10 continue if ( vtpos .ge. vtbufl ) call dmpplt 1 format( 1x, i2, 80a1 ) c return end subroutine dmpplt c common /zgraph/ lunplt, iascr, ibscr, icscr, idscr, 1 xm, ym, dx, dy, dxb, dyb, ixcur, iycur, xmid, ymid, 1 xslope, yslope, xconst, yconst, scrx, scry, ichar(5), 1 ixorig, iyorig c byte vtbufr(128) integer vtpos, vtbufl common / vtbuf/ vtbufr, vtpos, vtbufl c write(lunplt, 1) ( vtbufr(i), i = 1, vtpos ) vtpos = 0 c return 1 format( 1x, 128a1 ) end