Initial commit from Polytechnique Montreal

1 files changed, 283 insertions, 0 deletions

diff --git a/Dragon/src/PSPTRK.f b/Dragon/src/PSPTRK.f
new file mode 100644
index 0000000..4f6b059
--- /dev/null
+++ b/Dragon/src/PSPTRK.f
@@ -0,0 +1,283 @@
+*DECK PSPTRK
+      SUBROUTINE PSPTRK(IPRINT,ISPSP ,ITYPE ,ICOLR ,IPTRKT,NAMFIL,
+     >                  NAMLEG,NUNKNO,FLUX  )
+*
+*----------
+*
+*Purpose:
+* To generate a POSTSCRIPT file containing a graphical description
+* of a 2-D geometry from an EXCELL generated
+* tracking data structure.
+*
+*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   POSTSCRIPT file index.
+* ITYPE   identifier for the type of graphics where:
+*         =0 when the geometry is colored by region;
+*         =1 when the geometry is colored by mixture;
+*         =2 when the geometry is colored by flux
+*            (one group);
+*         =3 when the geometry is colored by flux
+*            (multigroup);
+*         =4 when the geometry is colored by mixture for
+*            homogenization.
+* 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.
+* IPTRKT  pointer to the TRACKING data structure.
+* NAMFIL  geometry file name.
+* NAMLEG  legend name.
+* NUNKNO  number of flux unknowns.
+*
+*Parameters: temporary storage
+* FLUX    flux storage array.
+*
+*----------
+*
+      USE          GANLIB
+      IMPLICIT     NONE
+*----
+*  Subroutine arguments
+*----
+      TYPE(C_PTR)  IPTRKT
+      INTEGER      IPRINT,ISPSP,ITYPE,ICOLR,NUNKNO
+      CHARACTER    NAMFIL*12,NAMLEG*24
+      REAL         FLUX(NUNKNO)
+*----
+*  Local parameters
+*----
+      INTEGER      IOUT
+      CHARACTER    NAMSBR*6
+      PARAMETER   (IOUT=6,NAMSBR='PSPTRK')
+      INTEGER      NSTATE
+      PARAMETER   (NSTATE=40)
+      INTEGER      ILCMUP,ILCMDN
+      PARAMETER   (ILCMUP=1,ILCMDN=2)
+*----
+*  Local variables
+*----
+      INTEGER      ISTATE(NSTATE),IPARAM(NSTATE),ITROP,
+     >             NDIM,NVOL,NSUR,NSURX,NBAN,NUNK,NRT,MSROD,
+     >             MAROD,NTOTCL,MAXR,NUNKT,NREGT,NNSUR
+      REAL         COTE
+      INTEGER      IEDIMG(NSTATE),ITYPBC,NBUCEL,NUCELL(3),
+     >             MAXMSH,MAXMDH,MAXREG,NBTCLS,MAXPIN,MAXMSP,
+     >             MAXRSP,NFSUR,NFREG,MXGREG
+*----
+*  Allocatable arrays
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYFLX,KEYMRG,MATALB,IUNFLD,
+     > NRODS,NRODR,NRINFO,NXRI,MINDIM,MAXDIM,INDEX
+      REAL, ALLOCATABLE, DIMENSION(:) :: COLRG,RAN,RODS,RODR,REMSH
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DGMESH
+*----
+*  Processing starts:
+*  print routine openning output header if required
+*  and initialize various parameters.
+*----
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,6000) NAMSBR
+        WRITE(IOUT,6002) NAMFIL
+      ENDIF
+*----
+*  Get state vector from tracking
+*  and check if a graphical description
+*  of the geometry is possible.
+*----
+      ISTATE(:NSTATE)=0
+      CALL LCMGET(IPTRKT,'STATE-VECTOR',ISTATE)
+      IF(ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 .OR.
+     >   ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN
+        NREGT=ISTATE(1)
+        NUNKT=ISTATE(2)
+        IF(NUNKNO .NE. NUNKT) CALL XABORT(NAMSBR//
+     >  ': Tracking is not consistent with fluxes')
+        ALLOCATE(KEYFLX(NREGT))
+        CALL LCMGET(IPTRKT,'KEYFLX      ',KEYFLX)
+      ELSE
+        NREGT=1
+        ALLOCATE(KEYFLX(NREGT))
+        KEYFLX=0
+      ENDIF
+      ITROP=ISTATE(7)
+      IF(ITROP .EQ. 4) THEN
+*----
+*  NXT processed geometry
+*----
+        CALL LCMSIX(IPTRKT,'NXTRecords  ',ILCMUP)
+        CALL LCMGET(IPTRKT,'G00000001DIM',IEDIMG)
+        NDIM=IEDIMG( 1)
+        ITYPBC   =IEDIMG( 2)
+        NBUCEL   =IEDIMG( 5)
+        NUCELL(1)=IEDIMG(13)
+        NUCELL(2)=IEDIMG(14)
+        NUCELL(3)=IEDIMG(15)
+        MAXMSH   =IEDIMG(16)
+        MAXREG   =IEDIMG(17)
+        NBTCLS   =IEDIMG(18)
+        MAXPIN   =IEDIMG(19)
+        MAXMSP   =IEDIMG(20)
+        MAXRSP   =IEDIMG(21)
+        NFSUR    =IEDIMG(22)
+        NFREG    =IEDIMG(23)
+        MXGREG   =IEDIMG(25)
+        NSUR=NFSUR
+        NVOL=NFREG
+        NNSUR=-NSUR
+        NUNK=NSUR+NVOL+1
+        ALLOCATE(COLRG(4*NVOL))
+        ALLOCATE(KEYMRG(NUNK),MATALB(NUNK))
+        IEDIMG(:NSTATE)=0
+        IF(NDIM .EQ. 2) THEN
+          IF(ITYPE .EQ. 4) THEN
+            CALL LCMGET(IPTRKT,'HOMMATALB   ',MATALB)
+          ELSE
+            CALL LCMGET(IPTRKT,'MATALB      ',MATALB)
+          ENDIF
+          CALL LCMGET(IPTRKT,'KEYMRG      ',KEYMRG)
+*----
+*  Produce legend
+*----
+          CALL PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NNSUR ,NVOL  ,
+     >                NAMLEG,NUNKNO,FLUX  ,NREGT ,
+     >                MATALB,KEYMRG,KEYFLX,
+     >                COLRG)
+*----
+*  Produce graphical description of geometry
+*----
+          NUNK=NFSUR+NFREG+1
+          MAXMDH=MAX(MAXMSH,MAXMSP,MAXREG)
+          ALLOCATE(IUNFLD(2*NBUCEL),DGMESH((MAXMDH+2)*4))
+          CALL LCMGET(IPTRKT,'G00000001CUF',IUNFLD)
+          CALL PSPNXT(IPRINT,ISPSP ,ICOLR ,IPTRKT,ITYPBC,MAXMDH,
+     >                NDIM  ,NFSUR ,NFREG ,NUCELL,NBUCEL,
+     >                MXGREG,MAXPIN,COLRG, IUNFLD,MATALB,DGMESH)
+          DEALLOCATE(DGMESH,IUNFLD)
+        ELSE
+          WRITE(IOUT,9000)
+        ENDIF
+        CALL LCMSIX(IPTRKT,'NXTRecords  ',ILCMDN)
+      ELSE
+        CALL LCMSIX(IPTRKT,'EXCELL      ',1)
+        IPARAM(:NSTATE)=0
+        CALL LCMGET(IPTRKT,'STATE-VECTOR',IPARAM)
+        NDIM=IPARAM(1)
+        NSUR=-IPARAM(2)
+        NVOL=IPARAM(3)
+        NSURX=IPARAM(4)
+        NBAN=IPARAM(5)
+        NUNK=IPARAM(6)
+        ALLOCATE(COLRG(4*NVOL))
+        ALLOCATE(KEYMRG(NUNK),MATALB(NUNK))
+        CALL LCMGET(IPTRKT,'MATALB      ',MATALB)
+        CALL LCMGET(IPTRKT,'KEYMRG      ',KEYMRG)
+        IF(ITROP .EQ. 3) THEN
+*----
+*  EXCELL based CLUSTER geometries
+*----
+          NRT=IPARAM(7)
+          MSROD=IPARAM(8)
+          MAROD=IPARAM(9)
+          ALLOCATE(NRODS(3*NRT),NRODR(NRT),NRINFO(2*NBAN),
+     >    NXRI(NRT*NBAN))
+          ALLOCATE(RAN(NBAN),RODS(2*NRT),RODR(MSROD*NRT))
+          CALL LCMGET(IPTRKT,'RAN         ',RAN)
+          IF(NSURX .EQ. 4)
+     >    CALL LCMGET(IPTRKT,'COTE        ',COTE)
+          CALL LCMGET(IPTRKT,'NRODS       ',NRODS)
+          CALL LCMGET(IPTRKT,'RODS        ',RODS)
+          CALL LCMGET(IPTRKT,'NRODR       ',NRODR)
+          CALL LCMGET(IPTRKT,'RODR        ',RODR)
+          CALL LCMGET(IPTRKT,'NRINFO      ',NRINFO)
+          CALL LCMGET(IPTRKT,'NXRI        ',NXRI)
+*----
+*  Produce legend
+*----
+          CALL PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NSUR  ,NVOL  ,
+     >                NAMLEG,NUNKNO,FLUX  ,NREGT ,
+     >                MATALB,KEYMRG,KEYFLX,COLRG)
+*----
+*  Produce graphical description of geometry
+*----
+          CALL PSPXCG(IPRINT,ISPSP ,ICOLR ,NBAN  ,NRT   ,MSROD ,
+     >                NSURX ,NSUR  ,NVOL  ,COTE  ,
+     >                RAN   ,NRODS ,RODS  ,RODR  ,NRINFO,NRODR ,
+     >                NXRI  ,KEYMRG,COLRG)
+          DEALLOCATE(RODR,RODS,RAN)
+          DEALLOCATE(NXRI,NRINFO,NRODR,NRODS)
+        ELSE IF(ITROP .EQ. 2 ) THEN
+*----
+*  EXCELL based hexagonal geometries
+*  Not available yet
+*----
+*          CALL PSPXHX(IPRINT,IPTRKT,TITREC)
+          WRITE(IOUT,6001)
+        ELSE IF(ITROP .EQ. 1 ) THEN
+*----
+*  EXCELL based Cartesian geometries
+*----
+          NTOTCL=NSURX
+          MAXR=NBAN
+          ALLOCATE(MINDIM(NTOTCL),MAXDIM(NTOTCL),INDEX(4*NUNK))
+          ALLOCATE(REMSH(MAXR))
+          CALL LCMGET(IPTRKT,'MINDIM      ',MINDIM)
+          CALL LCMGET(IPTRKT,'MAXDIM      ',MAXDIM)
+          CALL LCMGET(IPTRKT,'INDEX       ',INDEX)
+          CALL LCMGET(IPTRKT,'REMESH      ',REMSH)
+          IF(NDIM .EQ. 2) THEN
+*----
+*  Produce legend
+*----
+            CALL PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NSUR  ,NVOL  ,
+     >                  NAMLEG,NUNKNO,FLUX  ,NREGT ,
+     >                  MATALB,KEYMRG,KEYFLX,COLRG)
+*----
+*  Produce graphical description of geometry
+*----
+            CALL PSPXEL(IPRINT,ISPSP ,ICOLR ,NDIM  ,NSUR  ,NVOL  ,
+     >                  NTOTCL,MAXR  ,MINDIM,MAXDIM,KEYMRG,
+     >                  INDEX ,REMSH,COLRG)
+          ELSE
+            WRITE(IOUT,9000)
+          ENDIF
+          DEALLOCATE(REMSH)
+          DEALLOCATE(INDEX,MAXDIM,MINDIM)
+        ENDIF
+        CALL LCMSIX(IPTRKT,'EXCELL      ',2)
+      ENDIF
+      DEALLOCATE(MATALB,KEYMRG,COLRG,KEYFLX)
+*----
+*  Processing finished:
+*  print routine closing output header if required
+*  and return
+*----
+      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 *)')
+ 6002 FORMAT('   Processing geometry ',A12)
+ 9000 FORMAT(' PSP: does not work yet for 3-D',
+     >       ' Cartesian geometries')
+      END