/* .\pgcell.f -- translated by f2c (version 20000704).
   You must link the resulting object file with the libraries:
	-lf2c -lm   (in that order)
*/

#ifdef WIN
#pragma warning (disable: 4715) // disable warning for not all paths returning a value
#pragma warning (disable: 4716) // disable warning for not returning a value
#endif /* WIN */

#include "f2c.h"

/* Common Block Declarations */

struct {
    integer grcide, grgtyp, grstat[8];
    logical grpltd[8];
    integer grunit[8], grfnln[8], grtype[8], grxmxa[8], grymxa[8];
    real grxmin[8], grymin[8], grxmax[8], grymax[8];
    integer grwidt[8], grccol[8], grstyl[8];
    real grxpre[8], grypre[8], grxorg[8], gryorg[8], grxscl[8], gryscl[8], 
	    grcscl[8], grcfac[8];
    logical grdash[8];
    real grpatn[64]	/* was [8][8] */, grpoff[8];
    integer gripat[8], grcfnt[8], grcmrk[8];
    real grpxpi[8], grpypi[8];
    logical gradju[8];
    integer grmnci[8], grmxci[8];
} grcm00_;

#define grcm00_1 grcm00_

struct {
    char grfile[720], grgcap[88];
} grcm01_;

#define grcm01_1 grcm01_

/* Table of constant values */

static integer c__9 = 9;
static integer c__1 = 1;
static integer c__4 = 4;
static integer c__26 = 26;

/* CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC */

/* Subroutine */ int pgcell_(a, idim, jdim, i1, i2, j1, j2, fg, bg, tr, ncols,
	 r__, g, b)
real *a;
integer *idim, *jdim, *i1, *i2, *j1, *j2;
real *fg, *bg, *tr;
integer *ncols;
real *r__, *g, *b;
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    real r__1;

    /* Builtin functions */
    integer s_cmp(), s_wsle(), do_lio(), e_wsle(), i_nint(), i_len();

    /* Local variables */
    static real dcol;
    static integer icol, lchr, nbuf;
    static real rbuf;
    static char type__[16];
    static integer i__;
    static real dicol;
    extern /* Subroutine */ int pgqci_(), pgsci_();
    static integer iclow;
    extern /* Subroutine */ int pgscr_();
    static integer ib[256];
    static real bl;
    static integer ig[256], nc;
    static real gl, ascale;
    static integer ir[256];
    static real rl;
    extern /* Subroutine */ int pgbbuf_(), grbpic_();
    static integer icsave;
    extern /* Subroutine */ int grexec_(), pgebuf_();
    static logical lcolor;
    extern /* Subroutine */ int pgqinf_(), pgqcol_();
    static integer ic1;
    extern logical pgnoto_();
    static integer ic2;
    extern /* Subroutine */ int pgclps_(), pgclpx_();
    static char chr[16];
    static real col;
    static logical lps;

    /* Fortran I/O blocks */
    static cilist io___8 = { 0, 6, 0, 0, 0 };
    static cilist io___26 = { 0, 6, 0, 0, 0 };


/*     --------------------------------------------------------------- */


/* ----------------------------------------------------------------------- */
/*            Include file for GRPCKG */
/* Modifications: */
/*   29-Jan-1985 - add HP2648 (KS/TJP). */
/*   16-Sep-1985 - remove tabs (TJP). */
/*   30-Dec-1985 - add PS, VPS (TJP). */
/*   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, */
/*                 HP7221, GRINL (TJP). */
/*    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). */
/*   11-Jun-1987 - remove remaining built-in devices (TJP). */
/*    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. */
/*   16-Aug-1987 - remove obsolete variables. */
/*    9-Sep-1989 - add SAVE statement. */
/*   26-Nov-1990 - remove GRCTYP. */
/*    5-Jan-1993 - add GRADJU. */
/*    1-Sep-1994 - add GRGCAP. */
/*   21-Dec-1995 - increase GRIMAX to 8. */
/*   30-Apr-1997 - remove GRC{XY}SP */
/* ----------------------------------------------------------------------- */

/* Parameters: */
/*   GRIMAX : maximum number of concurrent devices */
/*   GRFNMX : maximum length of file names */
/*   GRCXSZ : default width of chars (pixels) */
/*   GRCYSZ : default height of chars (pixels) */


/* Common blocks: */
/*   GRCIDE : identifier of current plot */
/*   GRGTYP : device type of current plot */
/* The following are qualified by a plot id: */
/*   GRSTAT : 0 => workstation closed */
/*            1 => workstation open */
/*            2 => picture open */
/*   GRPLTD : */
/*   GRDASH : software dashing in effect? */
/*   GRUNIT : unit associated with id */
/*   GRFNLN : length of filename */
/*   GRTYPE : device type */
/*   GRXMXA : x size of plotting surface */
/*   GRYMXA : y size of plotting surface */
/*   GRXMIN : blc of plotting window */
/*   GRYMIN : ditto */
/*   GRXMAX : trc of plotting window */
/*   GRYMAX : ditto */
/*   GRSTYL : line style (integer code) */
/*   GRWIDT : line width (integer code) */
/*   GRCCOL : current color index (integer code) */
/*   GRMNCI : minimum color index on this device */
/*   GRMXCI : maximum color index on this device */
/*   GRCMRK : marker number */
/*   GRXPRE : previous (current) pen position (x) */
/*   GRYPRE : ditto (y) */
/*   GRXORG : transformation variables (GRTRAN) */
/*   GRYORG : ditto */
/*   GRXSCL : ditto */
/*   GRYSCL : ditto */
/*   GRCSCL : character scaling factor */
/*   GRCFAC : */
/*   GRCFNT : character font */
/*   GRFILE : file name (character) */
/*   GRGCAP : device capabilities (character) */
/*   GRPXPI : pixels per inch in x */
/*   GRPYPI : pixels per inch in y */
/*   GRADJU : TRUE if GRSETS (PGPAP) has been called */


/* ----------------------------------------------------------------------- */

/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Purpose */
/*      This subroutine is designed to do the job of CELL_ARRAY in GKS; */
/*   that is, it shades elements of a rectangular array with the */
/*   appropriate colours passed down in the RGB colour-table. Essentially, */
/*   it is a colour version of PGGRAY. */
/*      The colour-index used for particular array pixel is given by: */
/*         Colour Index = NINT{[A(i,j)-BG/(FG-BG)]*FLOAT(NCOLS-1)} , */
/*   with truncation at 0 and NCOLS-1, as necessary. */
/*      The transform matrix TR is used to calculate the (bottom left) */
/*   world coordinates of the cell which represents each array element: */
/*         X = TR(1) + TR(2)*I + TR(3)*J */
/*         Y = TR(4) + TR(5)*I + TR(6)*J  . */

/* Parameters */
/*   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION */
/*    A        R*4    I   IDIMxJDIM  The array to be plotted. */
/*    IDIM     I*4    I       -      The first dimension of array A. */
/*    JDIM     I*4    I       -      The second dimension of array A. */
/*    I1,I2    I*4    I       -      The inclusive range of the first */
/*                                   index (I) to be plotted. */
/*    J1,J2    I*4    I       -      The inclusive range of the second */
/*                                   index (J) to be plotted. */
/*    FG       R*4    I       -      The array value which is to appear */
/*                                   with shade 1 ("foreground"). */
/*    BG       R*4    I       -      The array value which is to appear */
/*                                   with shade 0 ("background"). */
/*    TR       R*4    I       6      Transformation matrix between array */
/*                                   grid and world coordinates. */
/*    NCOLS    I*4    I       -      Number of colours in colour-table. */
/*    R        R*4    I      NCOLS   Red intensity for colour-table. */
/*    G        R*4    I      NCOLS   Green intensity for colour-table. */
/*    B        R*4    I      NCOLS   Blue intensity for colour-table. */

/* Globals */
/*    GRPCKG1.INC */

/* External Calls */
/*   SUBROUTINE   DESCRIPTION */
/*     PGNOTO     Logical function to test if a PGPLOT device is open. */
/*     GRBPIC     Sends a "begin picture" command to the device driver. */
/*     PGQCOL     Inquires about the colour capability. */
/*     PGQCI      Inquires about the current colour index. */
/*     PGQINF     Inquires about general PGPLOT information. */
/*     PGBBUF     Recommended initial call (to start a PGPLOT buffer). */
/*     PGEBUF     Recommended final call (to end a PGPLOT buffer). */
/*     PGCLPX     Pixel-device support subroutine for PGCELL. */
/*     PGCLPS     PostScript support subroutine for PGCELL. */
/*     GREXEC     Dispatches command to appropriate device driver. */
/*     DSQINF     Inquires about viewport and window dimensions. */

/* History */
/*   D. S. Sivia       3 Jul 1992  Initial release. */
/*   D. S. Sivia       6 Feb 1995  Now uses GRGRAY approach instead of */
/*                                 PGPOLY, and linearly interpolates. */
/*   D. S. Sivia       6 Mar 1995  Slight changes for Postscript output. */
/*   D. S. Sivia       1 Aug 1996  Replaced pgplot.inc with DSQINF! */
/*   D. S. Sivia      21 Oct 1997  Made slightly friendlier for NT. */
/*   D. S. Sivia      16 Jul 1999  Added a couple of PGPLOT calls to */
/*                                 force proper initialisation. */
/* ----------------------------------------------------------------------- */

/* A PGPLOT initialisation precaution. */

    /* Parameter adjustments */
    a_dim1 = *idim;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --tr;

    /* Function Body */
    if (pgnoto_("PGCELL", (ftnlen)6)) {
	return 0;
    }
    if (! grcm00_1.grpltd[grcm00_1.grcide - 1]) {
	grbpic_();
    }

/* Find out device-type. If not Postscript, then (i) return if less than */
/* 16 shades available; (ii) save initial colour index (and hope it's */
/* less than ICLOW). */

    nc = 256;
    lps = TRUE_;
    pgqinf_("TYPE", type__, &lchr, (ftnlen)4, (ftnlen)16);
    if (s_cmp(type__, "PS", (ftnlen)16, (ftnlen)2) == 0 || s_cmp(type__, 
	    "VPS", (ftnlen)16, (ftnlen)3) == 0) {
	lcolor = FALSE_;
    } else if (s_cmp(type__, "CPS", (ftnlen)16, (ftnlen)3) == 0 || s_cmp(
	    type__, "VCPS", (ftnlen)16, (ftnlen)4) == 0) {
	lcolor = TRUE_;
    } else {
	lps = FALSE_;
	pgqcol_(&ic1, &ic2);
	nc = ic2 - ic1 + 1;
	if (nc < 16) {
	    s_wsle(&io___8);
	    do_lio(&c__9, &c__1, " *** Not enough colours available on this \
device!", (ftnlen)49);
	    e_wsle();
	    return 0;
	} else {
	    iclow = 4;
	    if (nc >= 96) {
		iclow = 16;
	    }
	    ic1 += iclow;
	    nc -= iclow;
	}
	pgqci_(&icsave);
	if (icsave >= ic1) {
	    icsave = ic1 + 1;
	}
    }
    pgbbuf_();

/* Activate the colour table. If NCOLS is less than the number of colours */
/* available, simply assign NCOLS; otherwise, use a linear interpolation. */

    if (*ncols <= nc) {
	nc = *ncols;
	i__1 = *ncols - 1;
	for (i__ = 0; i__ <= i__1; ++i__) {
	    i__2 = ic1 + i__;
	    pgscr_(&i__2, &r__[i__], &g[i__], &b[i__]);
	    r__1 = r__[i__] * (float)255.;
	    ir[i__] = i_nint(&r__1);
	    r__1 = g[i__] * (float)255.;
	    ig[i__] = i_nint(&r__1);
	    r__1 = b[i__] * (float)255.;
	    ib[i__] = i_nint(&r__1);
/* L10: */
	}
    } else {
	col = (float)0.;
	dcol = (real) (*ncols - 1) * (float).999 / (real) (nc - 1);
	i__1 = nc - 1;
	for (i__ = 0; i__ <= i__1; ++i__) {
	    icol = (integer) col;
	    dicol = col - (real) icol;
	    rl = r__[icol] + dicol * (r__[icol + 1] - r__[icol]);
	    gl = g[icol] + dicol * (g[icol + 1] - g[icol]);
	    bl = b[icol] + dicol * (b[icol + 1] - b[icol]);
	    i__2 = ic1 + i__;
	    pgscr_(&i__2, &rl, &gl, &bl);
	    r__1 = rl * (float)255.;
	    ir[i__] = i_nint(&r__1);
	    r__1 = gl * (float)255.;
	    ig[i__] = i_nint(&r__1);
	    r__1 = bl * (float)255.;
	    ib[i__] = i_nint(&r__1);
	    col += dcol;
/* L20: */
	}
    }
    ascale = (real) (nc - 1) / (*fg - *bg);

/* Check to see whether a pixel device or Postscript is being used, and */
/* call the appropriate PGCELL support subrotuine. */

    if (lps) {
	pgclps_(&a[a_offset], idim, jdim, i1, i2, j1, j2, bg, &tr[1], &ascale,
		 ir, ig, ib, &nc, &lcolor);
    } else {
	nbuf = 0;
	lchr = i_len(chr, (ftnlen)16);
	grexec_(&grcm00_1.grgtyp, &c__4, &rbuf, &nbuf, chr, &lchr, (ftnlen)16)
		;
	if (*(unsigned char *)&chr[6] == 'P') {
	    pgclpx_(&a[a_offset], idim, jdim, i1, i2, j1, j2, bg, &tr[1], &
		    ascale, &ic1, &nc);
	} else {
	    s_wsle(&io___26);
	    do_lio(&c__9, &c__1, " Sorry, PGCELL does not support this devic\
e!", (ftnlen)44);
	    e_wsle();
	}
    }

/* Reset the initial colour index. */

    if (! lps) {
	pgsci_(&icsave);
    }
    pgebuf_();
} /* pgcell_ */


/* Subroutine */ int pgclpx_(a, idim, jdim, i1, i2, j1, j2, bg, tr, ascale, 
	ic1, nc)
real *a;
integer *idim, *jdim, *i1, *i2, *j1, *j2;
real *bg, *tr, *ascale;
integer *ic1, *nc;
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    real r__1;

    /* Builtin functions */
    integer i_nint();

    /* Local variables */
    static real xblc, yblc;
    static integer lchr;
    static real xoff, yoff, xlen, ylen;
    static integer npix;
    static real xorg, xtrc, yorg, ytrc;
    static integer i__, j, k;
    static real x, y, x1, y1;
    static integer ii, jj;
    static real dx, dy, xi;
    static integer ix, jy;
    static real yj, buffer[2050];
    extern /* Subroutine */ int grexec_();
    static real xscale, yscale;
    extern /* Subroutine */ int dsqinf_();
    static real xperin, yperin;
    static integer ix1, ix2, jy1, jy2;
    static real xi1, yj1;
    static char chr[16];
    static real det, tr11, tr12, tr21, tr22, axy, dxx, dxy, dyx, dyy;

/*     -------------------------------------------------------------- */

/* Light-up the device pixels, with colours determined by a linearly */
/* interpolating array A. */

/* ----------------------------------------------------------------------- */
/*            Include file for GRPCKG */
/* Modifications: */
/*   29-Jan-1985 - add HP2648 (KS/TJP). */
/*   16-Sep-1985 - remove tabs (TJP). */
/*   30-Dec-1985 - add PS, VPS (TJP). */
/*   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, */
/*                 HP7221, GRINL (TJP). */
/*    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). */
/*   11-Jun-1987 - remove remaining built-in devices (TJP). */
/*    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. */
/*   16-Aug-1987 - remove obsolete variables. */
/*    9-Sep-1989 - add SAVE statement. */
/*   26-Nov-1990 - remove GRCTYP. */
/*    5-Jan-1993 - add GRADJU. */
/*    1-Sep-1994 - add GRGCAP. */
/*   21-Dec-1995 - increase GRIMAX to 8. */
/*   30-Apr-1997 - remove GRC{XY}SP */
/* ----------------------------------------------------------------------- */

/* Parameters: */
/*   GRIMAX : maximum number of concurrent devices */
/*   GRFNMX : maximum length of file names */
/*   GRCXSZ : default width of chars (pixels) */
/*   GRCYSZ : default height of chars (pixels) */


/* Common blocks: */
/*   GRCIDE : identifier of current plot */
/*   GRGTYP : device type of current plot */
/* The following are qualified by a plot id: */
/*   GRSTAT : 0 => workstation closed */
/*            1 => workstation open */
/*            2 => picture open */
/*   GRPLTD : */
/*   GRDASH : software dashing in effect? */
/*   GRUNIT : unit associated with id */
/*   GRFNLN : length of filename */
/*   GRTYPE : device type */
/*   GRXMXA : x size of plotting surface */
/*   GRYMXA : y size of plotting surface */
/*   GRXMIN : blc of plotting window */
/*   GRYMIN : ditto */
/*   GRXMAX : trc of plotting window */
/*   GRYMAX : ditto */
/*   GRSTYL : line style (integer code) */
/*   GRWIDT : line width (integer code) */
/*   GRCCOL : current color index (integer code) */
/*   GRMNCI : minimum color index on this device */
/*   GRMXCI : maximum color index on this device */
/*   GRCMRK : marker number */
/*   GRXPRE : previous (current) pen position (x) */
/*   GRYPRE : ditto (y) */
/*   GRXORG : transformation variables (GRTRAN) */
/*   GRYORG : ditto */
/*   GRXSCL : ditto */
/*   GRYSCL : ditto */
/*   GRCSCL : character scaling factor */
/*   GRCFAC : */
/*   GRCFNT : character font */
/*   GRFILE : file name (character) */
/*   GRGCAP : device capabilities (character) */
/*   GRPXPI : pixels per inch in x */
/*   GRPYPI : pixels per inch in y */
/*   GRADJU : TRUE if GRSETS (PGPAP) has been called */


/* ----------------------------------------------------------------------- */

    /* Parameter adjustments */
    a_dim1 = *idim;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --tr;

    /* Function Body */
    dsqinf_(&xoff, &xlen, &xorg, &xscale, &xperin, &xblc, &xtrc, &yoff, &ylen,
	     &yorg, &yscale, &yperin, &yblc, &ytrc);
    ix1 = i_nint(&xoff);
    r__1 = xoff + xlen;
    ix2 = i_nint(&r__1);
    jy1 = i_nint(&yoff);
    r__1 = yoff + ylen;
    jy2 = i_nint(&r__1);
    det = tr[2] * tr[6] - tr[3] * tr[5];
    tr11 = tr[6] / det;
    tr12 = -tr[3] / det;
    tr21 = -tr[5] / det;
    tr22 = tr[2] / det;
    dx = (float)1. / xscale;
    dy = (float)1. / yscale;
    x1 = (xoff - xorg) * dx - tr[1];
    y1 = (yoff - yorg) * dy - tr[4];
    dxx = tr11 * dx;
    dxy = tr12 * dy;
    dyx = tr21 * dx;
    dyy = tr22 * dy;
    xi1 = tr11 * x1 + tr12 * y1;
    yj1 = tr21 * x1 + tr22 * y1;
    i__1 = jy2;
    for (jy = jy1; jy <= i__1; ++jy) {
	xi = xi1;
	yj = yj1;
	buffer[1] = (real) jy;
	npix = 2;
	i__2 = ix2;
	for (ix = ix1; ix <= i__2; ++ix) {
	    i__ = (integer) xi;
	    j = (integer) yj;
	    if (i__ >= *i1 && i__ < *i2 && j >= *j1 && j < *j2) {
		if (npix == 2) {
		    buffer[0] = (real) ix;
		}
		ii = i__ + 1;
		jj = j + 1;
		x = xi - (real) i__;
		y = yj - (real) j;
		axy = ((float)1. - x) * (a[i__ + j * a_dim1] + y * (a[i__ + 
			jj * a_dim1] - a[i__ + j * a_dim1])) + x * (a[ii + j *
			 a_dim1] + y * (a[ii + jj * a_dim1] - a[ii + j * 
			a_dim1]));
		r__1 = (axy - *bg) * *ascale;
		k = i_nint(&r__1);
		if (k < 0) {
		    k = 0;
		}
		if (k >= *nc) {
		    k = *nc - 1;
		}
		++npix;
		buffer[npix - 1] = (real) (k + *ic1);
	    }
	    xi += dxx;
	    yj += dyx;
/* L30: */
	}
	grexec_(&grcm00_1.grgtyp, &c__26, buffer, &npix, chr, &lchr, (ftnlen)
		16);
	xi1 += dxy;
	yj1 += dyy;
/* L40: */
    }
} /* pgclpx_ */


/* Subroutine */ int pgclps_(a, idim, jdim, i1, i2, j1, j2, bg, tr, ascale, 
	ir, ig, ib, nc, lcolor)
real *a;
integer *idim, *jdim, *i1, *i2, *j1, *j2;
real *bg, *tr, *ascale;
integer *ir, *ig, *ib, *nc;
logical *lcolor;
{
    /* Format strings */
    static char fmt_100[] = "(i6,i6,\002 moveto \002,i6,\002 0 rlineto  0\
 \002,i6,\002 rlineto \002,i6,\002 0 rlineto\002)";
    static char fmt_110[] = "(2i4,\002 8 [\002,6(1pe10.3,\002 \002),\002]\
\002)";
    static char fmt_120[] = "(33z2.2)";

    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
    real r__1;

    /* Builtin functions */
    integer s_wsfi(), i_nint(), do_fio(), e_wsfi();

    /* Local variables */
    static real xblc, yblc, xoff, yoff, xlen, ylen, xorg, xtrc, yorg, ytrc;
    static integer i__, j, k, l;
    static real x, y;
    extern /* Subroutine */ int gresc_();
    static integer value[33], ndots, ic, ii, jj;
    static real at, bt, ct, dt;
    static integer jp, ip;
    static real xi, yj;
    static char inline__[80];
    static real xscale, yscale, tx;
    extern /* Subroutine */ int dsqinf_();
    static real ty, xperin, yperin;
    extern /* Subroutine */ int grterm_();
    static real det, dxi, dyj, tr11, tr12, tr21, tr22, axy;
    static integer nxp, nyp;

    /* Fortran I/O blocks */
    static icilist io___91 = { 0, inline__, 0, fmt_100, 80, 1 };
    static icilist io___108 = { 0, inline__, 0, "(A,I5,A)", 80, 1 };
    static icilist io___109 = { 0, inline__, 0, fmt_110, 80, 1 };
    static icilist io___124 = { 0, inline__, 0, fmt_120, 80, 1 };
    static icilist io___126 = { 0, inline__, 0, fmt_120, 80, 1 };


/*     ----------------------------------------------------------------- */

/* Postscript support subroutine for PGCELL. */

/* ----------------------------------------------------------------------- */
/*            Include file for GRPCKG */
/* Modifications: */
/*   29-Jan-1985 - add HP2648 (KS/TJP). */
/*   16-Sep-1985 - remove tabs (TJP). */
/*   30-Dec-1985 - add PS, VPS (TJP). */
/*   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, */
/*                 HP7221, GRINL (TJP). */
/*    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). */
/*   11-Jun-1987 - remove remaining built-in devices (TJP). */
/*    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. */
/*   16-Aug-1987 - remove obsolete variables. */
/*    9-Sep-1989 - add SAVE statement. */
/*   26-Nov-1990 - remove GRCTYP. */
/*    5-Jan-1993 - add GRADJU. */
/*    1-Sep-1994 - add GRGCAP. */
/*   21-Dec-1995 - increase GRIMAX to 8. */
/*   30-Apr-1997 - remove GRC{XY}SP */
/* ----------------------------------------------------------------------- */

/* Parameters: */
/*   GRIMAX : maximum number of concurrent devices */
/*   GRFNMX : maximum length of file names */
/*   GRCXSZ : default width of chars (pixels) */
/*   GRCYSZ : default height of chars (pixels) */


/* Common blocks: */
/*   GRCIDE : identifier of current plot */
/*   GRGTYP : device type of current plot */
/* The following are qualified by a plot id: */
/*   GRSTAT : 0 => workstation closed */
/*            1 => workstation open */
/*            2 => picture open */
/*   GRPLTD : */
/*   GRDASH : software dashing in effect? */
/*   GRUNIT : unit associated with id */
/*   GRFNLN : length of filename */
/*   GRTYPE : device type */
/*   GRXMXA : x size of plotting surface */
/*   GRYMXA : y size of plotting surface */
/*   GRXMIN : blc of plotting window */
/*   GRYMIN : ditto */
/*   GRXMAX : trc of plotting window */
/*   GRYMAX : ditto */
/*   GRSTYL : line style (integer code) */
/*   GRWIDT : line width (integer code) */
/*   GRCCOL : current color index (integer code) */
/*   GRMNCI : minimum color index on this device */
/*   GRMXCI : maximum color index on this device */
/*   GRCMRK : marker number */
/*   GRXPRE : previous (current) pen position (x) */
/*   GRYPRE : ditto (y) */
/*   GRXORG : transformation variables (GRTRAN) */
/*   GRYORG : ditto */
/*   GRXSCL : ditto */
/*   GRYSCL : ditto */
/*   GRCSCL : character scaling factor */
/*   GRCFAC : */
/*   GRCFNT : character font */
/*   GRFILE : file name (character) */
/*   GRGCAP : device capabilities (character) */
/*   GRPXPI : pixels per inch in x */
/*   GRPYPI : pixels per inch in y */
/*   GRADJU : TRUE if GRSETS (PGPAP) has been called */


/* ----------------------------------------------------------------------- */

/* Set clipping rectangle in device. */

    /* Parameter adjustments */
    a_dim1 = *idim;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --tr;

    /* Function Body */
    dsqinf_(&xoff, &xlen, &xorg, &xscale, &xperin, &xblc, &xtrc, &yoff, &ylen,
	     &yorg, &yscale, &yperin, &yblc, &ytrc);
    s_wsfi(&io___91);
    i__1 = i_nint(&xoff);
    do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
    i__2 = i_nint(&yoff);
    do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
    i__3 = i_nint(&xlen);
    do_fio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
    i__4 = i_nint(&ylen);
    do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
    i__5 = -i_nint(&xlen);
    do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
    e_wsfi();
    grterm_();
    gresc_(" newpath ", (ftnlen)9);
    gresc_(inline__, (ftnlen)80);
    gresc_(" closepath ", (ftnlen)11);

/* Work out the nunmber of X and Y pixels for PS image, with NDOTS per */
/* inch, and build an image transformation matrix. */

    ndots = 100;
/*      IF (LCOLOR) NDOTS=50 */
    r__1 = (real) ndots * xlen / xperin;
    nxp = i_nint(&r__1);
    r__1 = (real) ndots * ylen / yperin;
    nyp = i_nint(&r__1);
    dxi = (real) (*i2 - *i1) / (real) nxp;
    dyj = (real) (*j2 - *j1) / (real) nyp;
    det = tr[2] * tr[6] - tr[3] * tr[5];
    tr11 = tr[6] / det;
    tr12 = -tr[3] / det;
    tr21 = -tr[5] / det;
    tr22 = tr[2] / det;
    at = tr11 / (xscale * dxi);
    bt = tr21 / (xscale * dyj);
    ct = tr12 / (yscale * dxi);
    dt = tr22 / (yscale * dyj);
    tx = -(tr11 * (xorg / xscale + tr[1]) + tr12 * (yorg / yscale + tr[4]) + *
	    i1) / dxi;
    ty = -(tr21 * (xorg / xscale + tr[1]) + tr22 * (yorg / yscale + tr[4]) + *
	    j1) / dyj;

/* Use a PostScript "image" operator. */

    s_wsfi(&io___108);
    do_fio(&c__1, "/picstr ", (ftnlen)8);
    do_fio(&c__1, (char *)&nxp, (ftnlen)sizeof(integer));
    do_fio(&c__1, " string def", (ftnlen)11);
    e_wsfi();
    gresc_(inline__, (ftnlen)80);
    s_wsfi(&io___109);
    do_fio(&c__1, (char *)&nxp, (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&nyp, (ftnlen)sizeof(integer));
    do_fio(&c__1, (char *)&at, (ftnlen)sizeof(real));
    do_fio(&c__1, (char *)&bt, (ftnlen)sizeof(real));
    do_fio(&c__1, (char *)&ct, (ftnlen)sizeof(real));
    do_fio(&c__1, (char *)&dt, (ftnlen)sizeof(real));
    do_fio(&c__1, (char *)&tx, (ftnlen)sizeof(real));
    do_fio(&c__1, (char *)&ty, (ftnlen)sizeof(real));
    e_wsfi();
    gresc_(inline__, (ftnlen)80);
    gresc_("{ currentfile picstr readhexstring pop}", (ftnlen)39);
    if (*lcolor) {
	gresc_("  false 3 colorimage", (ftnlen)20);
    } else {
	gresc_("  image", (ftnlen)7);
    }

/* Write out the image array in hexadecimal. */

    *ascale = *ascale * (float)255. / (real) (*nc - 1);
    yj = (real) (*j1);
    i__1 = nyp;
    for (jp = 1; jp <= i__1; ++jp) {
	j = (integer) yj;
	y = yj - (real) j;
	jj = j + 1;
	if (jj > *j2) {
	    jj = *j2;
	}
	xi = (real) (*i1);
	l = 0;
	i__2 = nxp;
	for (ip = 1; ip <= i__2; ++ip) {
	    ++l;
	    i__ = (integer) xi;
	    x = xi - (real) i__;
	    ii = i__ + 1;
	    if (ii > *i2) {
		ii = *i2;
	    }
	    axy = ((float)1. - x) * (a[i__ + j * a_dim1] + y * (a[i__ + jj * 
		    a_dim1] - a[i__ + j * a_dim1])) + x * (a[ii + j * a_dim1] 
		    + y * (a[ii + jj * a_dim1] - a[ii + j * a_dim1]));
	    r__1 = (axy - *bg) * *ascale;
	    ic = i_nint(&r__1);
	    if (ic < 0) {
		ic = 0;
	    }
	    if (ic >= *nc) {
		ic = *nc - 1;
	    }
	    if (*lcolor) {
		value[l - 1] = ir[ic];
		value[l] = ig[ic];
		value[l + 1] = ib[ic];
		l += 2;
	    } else {
		value[l - 1] = (ir[ic] + ig[ic] + ib[ic]) / 3;
	    }
	    if (l == 33) {
		s_wsfi(&io___124);
		for (k = 1; k <= 33; ++k) {
		    do_fio(&c__1, (char *)&value[k - 1], (ftnlen)sizeof(
			    integer));
		}
		e_wsfi();
		gresc_(inline__, (ftnlen)66);
		l = 0;
	    }
	    xi += dxi;
/* L10: */
	}
	if (l != 0) {
	    s_wsfi(&io___126);
	    i__2 = l;
	    for (k = 1; k <= i__2; ++k) {
		do_fio(&c__1, (char *)&value[k - 1], (ftnlen)sizeof(integer));
	    }
	    e_wsfi();
	    gresc_(inline__, l << 1);
	}
	yj += dyj;
/* L20: */
    }
    gresc_(" newpath ", (ftnlen)9);
    grterm_();
} /* pgclps_ */

