*DECK PSPNXT
      SUBROUTINE PSPNXT(IPRINT,ISPSP ,ICOLR ,IPTRK ,ITYPBC,MAXMSH,
     >                  NDIM  ,NFSUR ,NFREG ,NUCELL,NBUCEL,
     >                  MXGREG,MAXPIN,COLREG,IUNFLD,MATALB,DGMESH)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To generate the graphics for a 2-D NXT geometry.
*
*Copyright:
* Copyright (C) 2006 Ecole Polytechnique de Montreal.
*
*Author(s):
* G. Marleau
*
*Update(s):
* None.
*
*Parameters: input
* IPRINT  print level.
* ISPSP   pointer to the POSTSCRIPT file.
* ICOLR   color set used where:
*         =-4 HSB filling with no contour;
*         =-3 CYMK filling with no contour;
*         =-2 RGB filling with no contour;
*         =-1 BW filling with no contour;
*         = 0 no filling with contour;
*         = 1 BW filling with contour;
*         = 2 RGB filling with contour;
*         = 3 CMYK filling with contour;
*         = 4 HSB filling with  contour;
* IPTRK   pointer to the TRACKING data structure in
*         update or creation mode.
* ITYPBC  type of cell boundary.
* MAXMSH  maximum number of elements in MESH array.
* NDIM    dimension of the problem.
* NFSUR   number of surfaces.
* NFREG   number of regions.
* NUCELL  number of cell after unfolding in
*         $X$, $Y$ and $Z$ directions.
* NBUCEL  number of cells in unfolded geometry.
* MXGREG  maximum number of region for any geometry.
* MAXPIN  maximum number of pins in a cell.
* COLREG  region color.
* IUNFLD  description of unfolded geometry.
* MATALB  global mixture/albedo identification vector.
* DGMESH  meshing vector for global geometry.
*
*----------
*
      USE              GANLIB
      IMPLICIT         NONE
*----
*  Subroutine arguments
*----
      TYPE(C_PTR)      IPTRK
      INTEGER          IPRINT,ISPSP,ICOLR,ITYPBC,MAXMSH,
     >                 NDIM,NFSUR,NFREG,NUCELL(3),NBUCEL,
     >                 MXGREG,MAXPIN
      REAL             COLREG(4,NFREG)
      INTEGER          IUNFLD(2,NBUCEL),
     >                 MATALB(-NFSUR:NFREG)
      DOUBLE PRECISION DGMESH(0:MAXMSH,4)
*----
*  Local parameters
*----
      INTEGER          IOUT
      CHARACTER        NAMSBR*6
      PARAMETER       (IOUT=6,NAMSBR='PSPNXT')
      DOUBLE PRECISION DZERO,DONE,DTWO
      PARAMETER       (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0)
      DOUBLE PRECISION DIMX,DIMY
      PARAMETER       (DIMX=3.5D0,DIMY=3.5D0)
*----
*  Local variables
*----
      INTEGER          KPSP(7)
      CHARACTER        NAMREC*12
      INTEGER          IDIR,ILPD,IX,IY,ICELL,ICEL,ITRN,ILONG,ITYLCM
      DOUBLE PRECISION RCIRC,ABSC(2),OFFC(2),FACT,CELLPO(2,2)
      REAL             XYPOS(2,4)
      DOUBLE PRECISION SIDEH,CENTH,DHMAX
*----
*  Allocatable arrays
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IDREG,ITPIN,NBPTS,REGI,EVENT
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DCMESH,DRAPIN,
     > POSTRI,COOR
*----
*  Data
*----
      CHARACTER        CDIR(4)*1
      SAVE             CDIR
      DATA             CDIR /'X','Y','Z','R'/
*----
*  Processing starts:
*  print routine openning output header if required
*  and initialize various parameters.
*----
      IF(IPRINT .GE. 100) THEN
        WRITE(IOUT,6000) NAMSBR
      ENDIF
*----
*  Initialize ICOL for color treatment
*  and ICONT for contour
*  KPSP(1)=ICONT
*  KPSP(2)=ICOL
*  KPSP(3)=IWLFAC (0->1.0,1->2.5)
*  KPSP(4)=KFS
*  KPSP(5)=KFR
*  KPSP(6)=KSS
*  KPSP(7)=KSR
*-----
      ILPD=MATALB(0)
      KPSP(1)=1
      KPSP(2)=ABS(ICOLR)
      KPSP(3)=0
      KPSP(4)=0
      KPSP(5)=0
      KPSP(6)=0
      KPSP(7)=0
      IF(ICOLR .EQ. 0) THEN
        KPSP(3)=1
      ELSE IF(ICOLR .LT. 0) THEN
        KPSP(1)=0
      ELSE
        KPSP(4)=1
        KPSP(7)=1
      ENDIF
      RCIRC=1.0D0
*----
*  Read global mesh for geometry
*  and determine graphics size
*----
      IF(ITYPBC .EQ. 0) THEN
*----
*  Cartesian
*----
        DO IDIR=1,NDIM
          NAMREC='G00000001SM'//CDIR(IDIR)
          ILPD=NUCELL(IDIR)
          CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR))
          ABSC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)-DGMESH(0,IDIR))
          OFFC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)+DGMESH(0,IDIR))
        ENDDO
        RCIRC=DZERO
        DO IDIR=1,NDIM
          RCIRC=MAX(RCIRC,ABSC(IDIR))
        ENDDO
      ELSE IF(ITYPBC .EQ. 1) THEN
*----
*  Annular
*----
        DO IDIR=1,NDIM
          NAMREC='G00000001SM'//CDIR(IDIR)
          ILPD=NUCELL(IDIR)
          CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR))
          ABSC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)-DGMESH(0,IDIR))
          OFFC(IDIR)=0.5D0*(DGMESH(ILPD,IDIR)+DGMESH(0,IDIR))
        ENDDO
        IDIR=4
        NAMREC='G00000001SM'//CDIR(IDIR)
        CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR))
        RCIRC=DGMESH(1,IDIR)
      ELSE IF(ITYPBC .EQ. 2) THEN
*----
*  Hexagonal
*----
        DO IDIR=1,2
          NAMREC='G00000001SM'//CDIR(IDIR)
          CALL LCMGET(IPTRK,NAMREC,DGMESH(0,IDIR))
          SIDEH=DGMESH(0,IDIR)
          CENTH=DGMESH(1,IDIR)
          OFFC(IDIR)=CENTH
          DHMAX=DZERO
          DO ICELL=2,NUCELL(IDIR)
            DHMAX=MAX(DHMAX,ABS(DGMESH(ICELL,IDIR)-CENTH))
          ENDDO
          ABSC(IDIR)=DHMAX+SIDEH
        ENDDO
        RCIRC=DZERO
        DO IDIR=1,NDIM
          RCIRC=MAX(RCIRC,ABSC(IDIR))
        ENDDO
      ELSE
        CALL XABORT(NAMSBR//
     >  ': Invalid geometry boundary types for PSP')
      ENDIF
*----
*  Locate pen at center of page
*----
      XYPOS(1,1)=DIMX
      XYPOS(2,1)=DIMY
      CALL PSMOVE(ISPSP,XYPOS,-3)
      FACT=DIMX/RCIRC
      ALLOCATE(IDREG(MXGREG),ITPIN(3*(MAXPIN)))
      ALLOCATE(DCMESH(4*(MAXMSH+2)),DRAPIN(6*(MAXPIN)))
*----
*  Scan over all Cartesian cells
*  1) Mesh in $Y$ direction
*----
      IF(ITYPBC .EQ. 0) THEN
        ICELL=0
        DO IY=1,NUCELL(2)
          CELLPO(2,1)=(DGMESH(IY-1,2)-OFFC(2))
          CELLPO(2,2)=(DGMESH(IY,2)-OFFC(2))
*----
*  2) Mesh in $X$ direction
*----
          DO IX=1,NUCELL(1)
            CELLPO(1,1)=(DGMESH(IX-1,1)-OFFC(1))
            CELLPO(1,2)=(DGMESH(IX,1)-OFFC(1))
            ICELL=ICELL+1
            ICEL=IUNFLD(1,ICELL)
            ITRN=IUNFLD(2,ICELL)
            IF(ITRN .EQ. 1) THEN
              CALL PSPTCR(IPTRK ,ISPSP ,IPRINT,ICEL  ,NDIM  ,NFREG ,
     >                    MAXMSH,MXGREG,MAXPIN,KPSP  ,COLREG,FACT  ,
     >                    CELLPO,IDREG ,ITPIN ,DCMESH,DRAPIN)
            ENDIF
          ENDDO
        ENDDO
      ELSE IF(ITYPBC .EQ. 2) THEN
        ALLOCATE(NBPTS(MXGREG),POSTRI(2*4*MXGREG))
        DO ICELL=1,NUCELL(1)
*----
*  Scan over all hexagonal cells
*----
          CELLPO(2,1)=(DGMESH(ICELL,2)-OFFC(2))
          CELLPO(2,2)=(DGMESH(ICELL,2)-OFFC(2))
          CELLPO(1,1)=(DGMESH(ICELL,1)-OFFC(1))
          CELLPO(1,2)=(DGMESH(ICELL,1)-OFFC(1))
          ICEL=IUNFLD(1,ICELL)
          ITRN=IUNFLD(2,ICELL)
          IF(ITRN .EQ. 1) THEN
            CALL PSPTHR(IPTRK ,ISPSP ,IPRINT,ICEL  ,NDIM  ,NFREG ,
     >                  MAXMSH,MXGREG,MAXPIN,KPSP  ,COLREG,FACT  ,
     >                  CELLPO,IDREG ,ITPIN ,
     >                  DCMESH,DRAPIN,NBPTS ,POSTRI)
          ENDIF
        ENDDO
        DEALLOCATE(POSTRI,NBPTS)
      ENDIF 
      DEALLOCATE(DRAPIN,ITPIN,DCMESH,IDREG)
      IF(IPRINT .GE. 100) THEN
        WRITE(IOUT,6001) NAMSBR
      ENDIF
*----
*  plot MC: neutron paths if present
*----
      CALL LCMLEN(IPTRK,'MCpoints',ILONG,ITYLCM)
      IF (ITYLCM.EQ.0) THEN
         CALL LCMSIX(IPTRK,'MCpoints',1)
         CALL LCMLEN(IPTRK,'REGI',ILONG,ITYLCM)
         ALLOCATE(REGI(ILONG),EVENT(ILONG))
         ALLOCATE(COOR(3*ILONG))
         CALL LCMGET(IPTRK,'COORD',COOR)
         CALL LCMGET(IPTRK,'REGI',REGI)
         CALL LCMGET(IPTRK,'EVENT',EVENT)
         CALL PSPMCP(ISPSP,OFFC,FACT,ILONG,COOR,REGI,EVENT)
         DEALLOCATE(EVENT,REGI) 
         DEALLOCATE(COOR)
         CALL LCMSIX(IPTRK,' ',2)
      ENDIF
*----
*  Save track normalisation vector
*----
      RETURN
*----
*  Output formats
*----
 6000 FORMAT('(* Output from --',A6,'-- follows ')
 6001 FORMAT('   Output from --',A6,'-- completed *)')
      END
