diff options
Diffstat (limited to 'Dragon/src/PSPTRK.f')
| -rw-r--r-- | Dragon/src/PSPTRK.f | 283 |
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 |