*DECK PSPXCG SUBROUTINE PSPXCG(IPRINT,ISPSP ,ICOLR ,NBAN ,NRT ,MSROD , > NSURX ,NSUR ,NVOL ,COTE , > RAN ,NRODS ,RODS ,RODR ,NRINFO,NRODR , > NXRI ,KEYMRG,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. * NBAN number of concentric regions. * NRT number of rod types. * MSROD maximum number of subrods per rod. * NSURX number of surfaces. * NSUR number of surfaces. * NVOL number of regions. * COTE Y dimension for rectangle. * RAN radius/lattice side of region. * NRODS integer description of rod type: * NRODS(1,IRT) = number of rod; * NRODS(2,IRT) = number of subrods in rod; * NRODS(3,IRT) = associated annulus. * RODS description of rod of a given type: * RODS(1,IRT) = rod center radius; * RODS(2,IRT) = angle position of one rod. * RODR subrod radii. * NRINFO annular region content: * NRINFO(1,IAN) = new region number; * NRINFO(2,IAN) = associated cluster; * = 0 no cluster. * NRODR subrod region. * NXRI annular region content multi-rod. * KEYMRG merge index. * COLREG region color. * *----------------------------------------------------------------------- * IMPLICIT NONE INTEGER IOUT,NPTS REAL PI,DIMX,DIMY,WLINE CHARACTER NAMSBR*6 PARAMETER (IOUT=6,NPTS=6,PI=3.1415926535897932, > DIMX=3.5,DIMY=3.5,WLINE=0.002,NAMSBR='PSPXCG') *---- * ROUTINE PARAMETERS *---- INTEGER IPRINT,ISPSP,ICOLR,NBAN,NRT,MSROD,NSURX, > NSUR,NVOL INTEGER NRODS(3,NRT),NRINFO(2,NBAN),NRODR(NRT), > NXRI(NRT,NBAN),KEYMRG(NSUR:NVOL) REAL COTE,RAN(NBAN),RODS(2,NRT), > RODR(MSROD,NRT),COLREG(4,NVOL) *---- * LOCAL PARAMETERS *---- INTEGER ICOL,ICONT,IVOL,IMRG,NTAN,IPT,IRT, > NPROD,NINRD,IROD,ISBR,IAN,NSEG,KRT,JRT REAL XYPOS(2,NPTS),RADEQ,FACT,ANGD,ANGR(2), > DANGR,RPIN,RROD,XINT,ANGA, > WLFAC 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 *---- * 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,-3) IF(NSURX.EQ.6) THEN RADEQ=RAN(NBAN) FACT=DIMX/RADEQ RADEQ=DIMX NTAN=NBAN-1 *---- * POSITION OF POINTS DEFINING THE HEXAGONAL SHAPE TO FILL *---- ANGD=0.0 DO 100 IPT=1,NSURX XYPOS(1,IPT)=COS(ANGD)*RADEQ XYPOS(2,IPT)=SIN(ANGD)*RADEQ ANGD=ANGD+PI/3.0 100 CONTINUE IVOL=NRINFO(1,NBAN) IMRG=KEYMRG(IVOL) *---- * FILL IF REQUIRED *---- CALL PSDREG(ISPSP,NSURX,XYPOS) IF(ICOL. GT. 0) THEN CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) ENDIF *---- * STROKE CONTOUR IF REQUIRED *---- IF(ICONT .EQ. 1) THEN CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) ENDIF ELSE IF(NSURX.EQ.4) THEN RADEQ=0.5*MAX(RAN(NBAN),COTE) FACT=DIMX/RADEQ NTAN=NBAN-1 XYPOS(1,1)=FACT*RAN(NBAN)/2 XYPOS(2,1)=FACT*COTE/2 XYPOS(1,2)=-XYPOS(1,1) XYPOS(2,2)=XYPOS(2,1) XYPOS(1,3)=XYPOS(1,2) XYPOS(2,3)=-XYPOS(2,2) XYPOS(1,4)=XYPOS(1,1) XYPOS(2,4)=XYPOS(2,3) IVOL=NRINFO(1,NBAN) IMRG=KEYMRG(IVOL) *---- * FILL IF REQUIRED *---- CALL PSDREG(ISPSP,NSURX,XYPOS) IF(ICOL. GT. 0) THEN CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) ENDIF *---- * STROKE CONTOUR IF REQUIRED *---- IF(ICONT .EQ. 1) THEN CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) ENDIF ELSE FACT=DIMX/RAN(NBAN) NTAN=NBAN ENDIF *---- * ANNULAR REGIONS *---- DO 110 IAN=NTAN,1,-1 RADEQ=FACT*RAN(IAN) XYPOS(1,1)=0.0 XYPOS(2,1)=0.0 IVOL=NRINFO(1,IAN) IMRG=KEYMRG(IVOL) *---- * FILL IF REQUIRED *---- IF(ICOL. GT. 0) THEN CALL PSDCIR(ISPSP,XYPOS,RADEQ) CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),0,0) ENDIF *---- * STROKE CONTOUR IF REQUIRED *---- IF(ICONT .EQ. 1) THEN IF(NRINFO(2,IAN) .NE. 0) THEN NSEG=0 DO 111 KRT=NRINFO(2,IAN),1,-1 JRT=NXRI(KRT,IAN) IF(JRT .GT. 1000000 .AND. JRT .LT. 3000000) THEN IRT=MOD(JRT,1000000) NSEG=NSEG+1 *---- * IF ANNULAR REGION CUT BY PINS * DRAW ARC SEGMENT *---- NPROD=NRODS(1,IRT) NINRD=NRODS(2,IRT) DANGR=2.*PI/FLOAT(NPROD) ANGD=RODS(2,IRT) RROD=FACT*RODR(NINRD,IRT) RPIN=FACT*RODS(1,IRT) *---- * ANNULUS INTERSECT RODS * 1) FIND X (XINT) AND Y (YINT) INTERSECTION * XINT=(RADEQ**2+RPIN**2-RROD**2)/(2*RPIN) * YINT=SQRT(RAN**2-XINT**2) * 2) FIND OPENNING ANGLE FOR VOLUME LIMITED BY * ANNULUS (ANGA) * ANGA=ACOS(XINT/RADEQ) *---- XINT=(RADEQ**2+RPIN**2-RROD**2) > /(2.0*RPIN) ANGA=ACOS(XINT/RADEQ) DO 112 IROD=1,NPROD ANGR(1)=180.0*(ANGD+ANGA)/PI ANGD=ANGD+DANGR ANGR(2)=180.0*(ANGD-ANGA)/PI CALL PSLINW(ISPSP,WLFAC*WLINE) CALL PSSARC(ISPSP,XYPOS,RADEQ,ANGR) 112 CONTINUE ENDIF 111 CONTINUE IF(NSEG .EQ. 0) THEN CALL PSDCIR(ISPSP,XYPOS,RADEQ) CALL PSSTRK(ISPSP,WLFAC*WLINE,0,0) ENDIF ELSE *---- * IF ANNULAR REGION NOT CUT BY PINS * STROKE CIRCLES *---- CALL PSDCIR(ISPSP,XYPOS,RADEQ) CALL PSSTRK(ISPSP,WLFAC*WLINE,0,0) ENDIF ENDIF 110 CONTINUE *---- * ROD CLUSTER *---- DO 120 IRT=NRT,1,-1 NPROD=NRODS(1,IRT) NINRD=NRODS(2,IRT) DANGR=2.*PI/FLOAT(NPROD) ANGD=RODS(2,IRT) RPIN=FACT*RODS(1,IRT) DO 121 IROD=1,NPROD XYPOS(1,1)=RPIN*COS(ANGD) XYPOS(2,1)=RPIN*SIN(ANGD) ANGD=ANGD+DANGR DO 122 ISBR=NINRD,1,-1 IVOL=NRODR(IRT)-NINRD+ISBR IMRG=KEYMRG(IVOL) RADEQ=FACT*RODR(ISBR,IRT) *---- * FILL IF REQUIRED *---- CALL PSDCIR(ISPSP,XYPOS,RADEQ) IF(ICOL. GT. 0) THEN CALL PSFILL(ISPSP,ICOL,COLREG(1,IVOL),KFS,KFR) ENDIF *---- * STROKE IF REQUIRED *---- IF(ICONT .EQ. 1) THEN CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR) ENDIF 122 CONTINUE 121 CONTINUE 120 CONTINUE XYPOS(1,1)=-DIMX XYPOS(2,1)=-DIMY CALL PSMOVE(ISPSP,XYPOS,-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