summaryrefslogtreecommitdiff
path: root/Dragon/src/PSPLEG.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/PSPLEG.f')
-rw-r--r--Dragon/src/PSPLEG.f311
1 files changed, 311 insertions, 0 deletions
diff --git a/Dragon/src/PSPLEG.f b/Dragon/src/PSPLEG.f
new file mode 100644
index 0000000..f445106
--- /dev/null
+++ b/Dragon/src/PSPLEG.f
@@ -0,0 +1,311 @@
+*DECK PSPLEG
+ SUBROUTINE PSPLEG(IPRINT,ISPSP ,ITYPE ,ICOLR ,NSUR ,NVOL ,
+ > NAMLEG,NUNKNO,FLUX ,NREGT ,
+ > MATALB,KEYMRG,KEYFLX,COLREG)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Associate a color to a region and print legend.
+*
+*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.
+* ITYPE type of graphic:
+* = 0 color per region number;
+* = 1 color per material;
+* = 2 color for flux (one group);
+* = 3 color for flux (multigroup);
+* = 4 color per material for homogenization (HMIX).
+* 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.
+* NSUR number of outer surface.
+* NVOL maximum number of regions.
+* NAMLEG legend name.
+* NUNKNO number of unknowns.
+* FLUX unknown vector.
+* NREGT dimension of KEYFLX vector.
+* MATALB albedo-material of regions.
+* KEYMRG merge index.
+* KEYFLX flux location.
+* COLREG region color.
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+ INTEGER IOUT
+ CHARACTER NAMSBR*6
+ REAL WLINE
+ PARAMETER (IOUT=6,WLINE=0.002,NAMSBR='PSPLEG')
+*----
+* ROUTINE PARAMETERS
+*----
+ INTEGER IPRINT,ISPSP,ITYPE,ICOLR,NSUR,NVOL,
+ > NUNKNO,NREGT
+ INTEGER MATALB(NSUR:NVOL),KEYMRG(NSUR:NVOL),
+ > KEYFLX(NVOL)
+ REAL FLUX(NUNKNO),COLREG(4,NVOL)
+ REAL COLTMP(4)
+ CHARACTER NAMLEG*24
+*----
+* LOCAL PARAMETERS
+*----
+ CHARACTER COLNAM*4,LEGTXT*48,FLXTXT*80
+ INTEGER MXMIX,MREG,IVOL,IMX,IRG,ICOLA,
+ > ILEG,IFRM,MXCOL,ICOLF,IKEY
+ INTEGER KMX,ICT
+ REAL XYPOS(2),POSL,POSB,DELX,DELY,DELXC,DELYC,
+ > XYPTS(2,4),FLXMIN,FLXMAX,DELFLX,COLFLX(4)
+ INTEGER KFS,KFR,KSS,KSR
+*----
+* INITIALIZE LEGEND
+*----
+ KFS=0
+ KFR=0
+ KSS=0
+ KSR=0
+ ICOLA=ABS(ICOLR)
+ IF(ICOLA .GT. 0) THEN
+ KFS=1
+ KSR=1
+ ENDIF
+ IF(ICOLA .GE. 2) THEN
+ LEGTXT='Color by '//NAMLEG
+ ELSE
+ LEGTXT='Graylevel by '//NAMLEG
+ ENDIF
+ ILEG=1
+ IF(IPRINT .LE. 0) THEN
+ ILEG=0
+ ENDIF
+*----
+* GENERATE RANDOM COLOR
+* FOR RGB USE ALL THREE COLORS
+* FOR BW USE ONLY FIRST COLOR
+* SKIP FOR NONE
+*----
+ IF(ICOLA .GT. 0) THEN
+ POSL=0.0
+ POSB=10.0
+ XYPOS(1)=POSL
+ XYPOS(2)=POSB
+ IF(ILEG .EQ. 1) THEN
+ CALL PSTEXT(ISPSP,6,'Legend',
+ > XYPOS,0.1,0,0.0)
+ ENDIF
+ IF(ITYPE .EQ. 0) THEN
+*----
+* COMPUTE NUMBER OF REGIONS AFTER MERGE
+*----
+ MREG=0
+ DO 100 IVOL=1,NVOL
+ MREG=MAX(MREG,KEYMRG(IVOL))
+ 100 CONTINUE
+*----
+* GENERATE ONE COLOR PER REGION
+*----
+ POSB=POSB-0.2
+ XYPOS(2)=POSB
+ IF(ILEG .EQ. 1) THEN
+ CALL PSTEXT(ISPSP,48,LEGTXT,XYPOS,0.1,0,0.0)
+ ENDIF
+ POSB=POSB-0.2
+ IF(MREG .GT. 10000) THEN
+ ILEG=0
+ ENDIF
+ DELX=0.2
+ DELY=DELX/2.0
+ DELXC=DELY
+ DELYC=DELXC/4.0
+ DO 110 IRG=1,MREG
+ IFRM=0
+ IF(MOD(IRG-1,30) .EQ. 0 .AND. ILEG .EQ. 1) THEN
+ POSB=POSB-DELY
+ ENDIF
+ DO 111 IVOL=1,NVOL
+ IF(KEYMRG(IVOL) .EQ. IRG) THEN
+ CALL PSPCOL(ICOLA,MREG,IRG,COLREG(1,IVOL))
+ IF(IFRM .EQ. 0 .AND. ILEG .EQ.1) THEN
+ IFRM=IFRM+1
+ POSL=MOD(IRG-1,30)*DELX
+ XYPTS(1,1)=POSL
+ XYPTS(2,1)=POSB
+ XYPTS(1,2)=POSL+DELX
+ XYPTS(2,2)=POSB
+ XYPTS(1,3)=POSL+DELX
+ XYPTS(2,3)=POSB+DELY
+ XYPTS(1,4)=POSL
+ XYPTS(2,4)=POSB+DELY
+ CALL PSDREG(ISPSP,4,XYPTS)
+ IF(ICOLA .GT. 0) THEN
+ CALL PSFILL(ISPSP,ICOLA,COLREG(1,IVOL),KFS,KFR)
+ ENDIF
+ CALL PSSTRK(ISPSP,WLINE,KSS,KSR)
+ WRITE(COLNAM,'(I4)') IRG
+ XYPOS(1)=POSL+DELXC
+ XYPOS(2)=POSB+DELYC
+ CALL PSTEXT(ISPSP,4,COLNAM,XYPOS,0.05,1,0.0)
+ ENDIF
+ ENDIF
+ 111 CONTINUE
+ 110 CONTINUE
+ ELSE IF(ITYPE .EQ. 1 .OR. ITYPE .EQ. 4) THEN
+*----
+* COMPUTE NUMBER OF MIXTURES
+*----
+ MXMIX=0
+ DO 120 IVOL=1,NVOL
+ MXMIX=MAX(MXMIX,MATALB(IVOL))
+ 120 CONTINUE
+ POSB=POSB-0.2
+ XYPOS(2)=POSB
+ IF(ILEG .EQ. 1) THEN
+ CALL PSTEXT(ISPSP,32,LEGTXT,XYPOS,0.1,0,0.0)
+ ENDIF
+ POSB=POSB-0.2
+ IF(MXMIX .GT. 10000) THEN
+ ILEG=0
+ ENDIF
+ KMX=0
+ DELX=0.2
+ DELY=DELX/2.0
+ DELXC=DELY
+ DELYC=DELXC/4.0
+*----
+* GENERATE ONE COLOR PER MIXTURE
+*----
+ DO 130 IMX=0,MXMIX
+ KMX=KMX+1
+ IFRM=0
+ IF(MOD(KMX-1,30).EQ.0 .AND. ILEG .EQ. 1) THEN
+ POSB=POSB-DELY
+ ENDIF
+ CALL PSPCOL(ICOLA,MXMIX,IMX,COLTMP(1))
+ IF (ILEG.EQ.1) THEN
+ POSL=MOD(KMX-1,30)*DELX
+ XYPTS(1,1)=POSL
+ XYPTS(2,1)=POSB
+ XYPTS(1,2)=POSL+DELX
+ XYPTS(2,2)=POSB
+ XYPTS(1,3)=POSL+DELX
+ XYPTS(2,3)=POSB+DELY
+ XYPTS(1,4)=POSL
+ XYPTS(2,4)=POSB+DELY
+ CALL PSDREG(ISPSP,4,XYPTS)
+ IF(ICOLA .GT. 0) THEN
+ CALL PSFILL(ISPSP,ICOLA,COLTMP(1),KFS,KFR)
+ ENDIF
+ CALL PSSTRK(ISPSP,WLINE,KSS,KSR)
+ WRITE(COLNAM,'(I4)') IMX
+ XYPOS(1)=POSL+DELXC
+ XYPOS(2)=POSB+DELYC
+ CALL PSTEXT(ISPSP,4,COLNAM,XYPOS,0.05,1,0.0)
+ ENDIF
+*----
+* ASSOCIATE MIXTURE COLOR WITH REGION
+*----
+ DO 131 IVOL=1,NVOL
+ IF(MATALB(IVOL) .EQ. IMX) THEN
+ DO 132 ICT=1,4
+ COLREG(ICT,IVOL)=COLTMP(ICT)
+ 132 CONTINUE
+ ENDIF
+ 131 CONTINUE
+ 130 CONTINUE
+ ELSE IF(ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 .OR.
+ > ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN
+*----
+* COMPUTE NUMBER OF REGIONS AFTER MERGE
+*----
+ POSB=POSB-0.2
+ XYPOS(2)=POSB
+ IF(ILEG .EQ. 1) THEN
+ CALL PSTEXT(ISPSP,32,LEGTXT,XYPOS,0.1,0,0.0)
+ ENDIF
+ POSB=POSB-0.2
+*----
+* FIND MAXIMUM AND MINIMUM FLUX
+*----
+ FLXMAX=FLUX(KEYFLX(1))
+ FLXMIN=FLUX(KEYFLX(1))
+ DO 150 IRG=2,NREGT
+ IKEY=KEYFLX(IRG)
+ FLXMAX=MAX(FLXMAX,FLUX(IKEY))
+ FLXMIN=MIN(FLXMIN,FLUX(IKEY))
+ 150 CONTINUE
+ MXCOL=20
+ DELFLX=(FLXMAX-FLXMIN)/REAL(MXCOL)
+ WRITE(FLXTXT,5000) FLXMIN,DELFLX,FLXMIN,DELFLX
+ XYPOS(2)=POSB
+ IF(ILEG .EQ. 1) THEN
+ CALL PSTEXT(ISPSP,80,FLXTXT,XYPOS,0.1,0,0.0)
+ ENDIF
+ POSB=POSB-0.2
+ DELX=0.2
+ DELY=DELX/2.0
+ DELXC=DELY
+ DELYC=DELXC/4.0
+*----
+* GENERATE ONE COLOR PER FLUX LEVEL
+* COLOR I IS GIVEN BY:
+* I=MIN(INT((FLUX-FLXMIN)/DELFLX)+1,MXCOL)
+*----
+ POSB=POSB-DELY
+ DO 160 ICOLF=1,MXCOL
+ CALL PSPCOL(ICOLA,MXCOL,ICOLF,COLFLX(1))
+ POSL=MOD(ICOLF-1,30)*DELX
+ XYPTS(1,1)=POSL
+ XYPTS(2,1)=POSB
+ XYPTS(1,2)=POSL+DELX
+ XYPTS(2,2)=POSB
+ XYPTS(1,3)=POSL+DELX
+ XYPTS(2,3)=POSB+DELY
+ XYPTS(1,4)=POSL
+ XYPTS(2,4)=POSB+DELY
+ CALL PSDREG(ISPSP,4,XYPTS)
+ IF(ICOLA .GT. 0) THEN
+ CALL PSFILL(ISPSP,ICOLA,COLFLX(1),KFS,KFR)
+ ENDIF
+ CALL PSSTRK(ISPSP,WLINE,KSS,KSR)
+ WRITE(COLNAM,'(I4)') ICOLF
+ XYPOS(1)=POSL+DELXC
+ XYPOS(2)=POSB+DELYC
+ CALL PSTEXT(ISPSP,4,COLNAM,XYPOS,0.05,1,0.0)
+ 160 CONTINUE
+ DO 170 IRG=1,NREGT
+ IKEY=KEYFLX(IRG)
+ ICOLF=INT((FLUX(IKEY)-FLXMIN)/DELFLX)+1
+ ICOLF=MIN(ICOLF,MXCOL)
+ DO 171 IVOL=1,NVOL
+ IF(KEYMRG(IVOL) .EQ. IRG) THEN
+ CALL PSPCOL(ICOLA,MXCOL,ICOLF,COLREG(1,IVOL))
+ ENDIF
+ 171 CONTINUE
+ 170 CONTINUE
+ ENDIF
+ ENDIF
+ RETURN
+*----
+* FORMAT
+*----
+ 5000 FORMAT(1P,E9.2,'+(i-1)*',E9.2,
+ > ' < Flux(i) <= ',E9.2,'+i*',E9.2)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:17:24 +0000