Initial commit from Polytechnique Montreal

1 files changed, 200 insertions, 0 deletions

diff --git a/Dragon/src/PSPXEL.f b/Dragon/src/PSPXEL.f
new file mode 100644
index 0000000..c09c113
--- /dev/null
+++ b/Dragon/src/PSPXEL.f
@@ -0,0 +1,200 @@
+*DECK PSPXEL
+      SUBROUTINE PSPXEL(IPRINT,ISPSP ,ICOLR ,NDIM  ,NSUR  ,NVOL  ,
+     >                  NTOTCL,MAXR  ,
+     >                  MINDIM,MAXDIM,KEYMRG,INDEX ,REMESH,COLREG)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Graphics for 2-D cluster geometry.
+*
+*Copyright:
+* Copyright (C) 1999 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s):
+* G. Marleau
+*
+*Parameters: input
+* IPRINT  print level.
+* ISPSP   psp file unit.
+* ICOLR   color set used:
+*         = -4 fill hsb with no-contour;
+*         = -3 fill cmyk with no-contour;
+*         = -2 fill rgb with no-contour;
+*         = -1 fill bw with no-contour;
+*         =  0 no fill contour only;
+*         =  1 fill bw and contour;
+*         =  2 fill rgb and contour;
+*         =  3 fill cmyk and contour;
+*         =  4 fill hsb and contour.
+* NDIM    number of dimensions.
+* NSUR    number of surfaces.
+* NVOL    number of regions.
+* NTOTCL  number of cylinders.
+* MAXR    dimension of REMESH vector.
+* MINDIM  min index values for axes.
+* MAXDIM  max index values for axes.
+* KEYMRG  merge index.
+* INDEX   numbering of surfaces and zones.
+* REMESH  meshing.
+* COLREG  region color.
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT         NONE
+      INTEGER          IOUT,NPTS,MXDIM,NXY,NINT
+      CHARACTER        NAMSBR*6
+      REAL             PI,DIMX,DIMY,WLINE
+      PARAMETER       (IOUT=6,NPTS=4,MXDIM=3,NXY=2,NINT=16,
+     >                 PI=3.1415926535897932,
+     >                 DIMX=3.5,DIMY=3.5,WLINE=0.002,NAMSBR='PSPXEL')
+*----
+*  ROUTINE PARAMETERS
+*----
+      INTEGER          IPRINT,ISPSP,ICOLR,NDIM,
+     >                 NSUR,NVOL,NTOTCL,MAXR
+      INTEGER          MINDIM(NTOTCL),MAXDIM(NTOTCL),
+     >                 KEYMRG(NSUR:NVOL),INDEX(4,NSUR:NVOL)
+      REAL             REMESH(MAXR),COLREG(4,NVOL)
+*----
+*  LOCAL PARAMETERS
+*----
+      INTEGER          ICOL,ICONT,IDIR,IVOL,IMRG,
+     >                 IX,IY,IR,ICL,NSEG,IORDER(NINT)
+      REAL             WLFAC,RCIRC,OFFDIR(MXDIM),XYPOS(NXY,NPTS),
+     >                 FACT,CENTER(NXY),RADANG(NXY,NINT)
+      INTEGER          KFS,KFR,KSS,KSR
+*----
+*  INITIALIZE
+*    ICOL  FOR COLOR   (NONE, BW, RGB)
+*    ICONT FOR CONTOUR (WITH OR WITHOUT CONTOUR)
+*----
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,6000) NAMSBR
+      ENDIF
+      KFS=0
+      KFR=0
+      KSS=0
+      KSR=0
+      ICONT=1
+      WLFAC=1.0
+      ICOL=ABS(ICOLR)
+      IF(ICOLR .EQ. 0) THEN
+        WLFAC=2.5
+      ELSE IF(ICOLR .LT. 0) THEN
+        ICONT=0
+      ELSE
+        KFS=1
+        KSR=1
+      ENDIF
+*----
+*  COMPUTE THE CIRCUMSCRIBED RADIUS
+*  THE COORDINATE FOR THE TRUE CENTER OF THE CELL
+*----
+      RCIRC= 0.0
+      DO 100 IDIR=1,NDIM
+        OFFDIR(IDIR)=0.5
+     >              *(REMESH(MAXDIM(IDIR))+REMESH(MINDIM(IDIR)))
+        RCIRC=MAX(RCIRC,
+     >            0.5*(REMESH(MAXDIM(IDIR))-REMESH(MINDIM(IDIR))))
+ 100  CONTINUE
+*----
+*  LOCATE PEN AT CENTER OF CELL
+*  DETERMINE DIMENSION OF GRAPH USING CELL LIMIT
+*  FOR HEXAGONAL CELL PRINT HEXAGONAL REGION
+*  FOR CARTESIAN CELL PRINT CARTESIAN REGION
+*----
+      XYPOS(1,1)=DIMX
+      XYPOS(2,1)=DIMY
+      CALL PSMOVE(ISPSP,XYPOS(1,1),-3)
+      FACT=DIMX/RCIRC
+*----
+*  SCAN ALL REGIONS AND LOCATE POSITION
+*  REGION NUMBER FROM INSIDE ANNULUS
+*  TO EXTERIOR CARTESIAN
+*----
+      DO 110 IVOL=NVOL,1,-1
+        IMRG=KEYMRG(IVOL)
+        IF(IMRG .NE. 0) THEN
+*----
+*  CARTESIAN CELL POSITION IN X AND Y
+*----
+          IX=INDEX(1,IVOL)
+          IY=INDEX(2,IVOL)
+          XYPOS(1,1)=FACT*(REMESH(IX)-OFFDIR(1))
+          XYPOS(2,1)=FACT*(REMESH(IY)-OFFDIR(2))
+          XYPOS(1,2)=FACT*(REMESH(IX+1)-OFFDIR(1))
+          XYPOS(2,2)=XYPOS(2,1)
+          XYPOS(1,3)=XYPOS(1,2)
+          XYPOS(2,3)=FACT*(REMESH(IY+1)-OFFDIR(2))
+          XYPOS(1,4)=XYPOS(1,1)
+          XYPOS(2,4)=XYPOS(2,3)
+          IF(INDEX(4,IVOL) .EQ. 0) THEN
+*----
+*  CARTESIAN POSITION GEOMETRY LOCATED
+*  COLOR AND TRACE IT
+*----
+            CALL PSDREG(ISPSP,NPTS,XYPOS)
+            IF(ICOL. GT. 0) THEN
+              CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR)
+            ENDIF
+            IF(ICONT.EQ.1) THEN
+              CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
+            ENDIF
+          ELSE
+*----
+*  CARTESIAN GEOMETRY CONTAINS ANNULAR SUBDIVISION
+*  DETERMINE WHICH ANNULUS
+*----
+            DO 111 ICL=4,NTOTCL
+              IR=INDEX(4,IVOL)
+              IF( IR .GE. MINDIM(ICL)-1 .AND.
+     >            IR .LT. MAXDIM(ICL)      ) THEN
+*----
+*  ANNULUS IS DETERMINED
+*  LOCATE ANNULAR/CARTESIAN AND ORDER CARTESIAN POINTS
+*  FOR GEOMETRY TRACING
+*----
+                CENTER(1)=FACT*(REMESH(MINDIM(ICL)-2)-OFFDIR(1))
+                CENTER(2)=FACT*(REMESH(MINDIM(ICL)-1)-OFFDIR(2))
+                RCIRC=FACT*SQRT(REMESH(IR+1))
+                CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC,
+     >                      NSEG,IORDER,RADANG)
+*----
+*  COLOR AND TRACE RESULT
+*----
+                CALL PSMOVE(ISPSP,CENTER(1),-3)
+                CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG)
+                IF(ICOL. GT. 0) THEN
+                  CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR)
+                ENDIF
+                IF(ICONT.EQ.1) THEN
+                  CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
+                ENDIF
+                CENTER(1)=-CENTER(1)
+                CENTER(2)=-CENTER(2)
+                CALL PSMOVE(ISPSP,CENTER(1),-3)
+                GO TO 115
+              ENDIF
+ 111        CONTINUE
+ 115        CONTINUE
+          ENDIF
+        ENDIF
+ 110  CONTINUE
+      XYPOS(1,1)=-DIMX
+      XYPOS(2,1)=-DIMY
+      CALL PSMOVE(ISPSP,XYPOS(1,1),-3)
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,6001) NAMSBR
+      ENDIF
+      RETURN
+*----
+*  Output formats
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT('   Output from --',A6,'-- completed *)')
+      END