diff options
Diffstat (limited to 'Dragon/src/PSPXCG.f')
| -rw-r--r-- | Dragon/src/PSPXCG.f | 295 |
1 files changed, 295 insertions, 0 deletions
diff --git a/Dragon/src/PSPXCG.f b/Dragon/src/PSPXCG.f new file mode 100644 index 0000000..7b64d4f --- /dev/null +++ b/Dragon/src/PSPXCG.f @@ -0,0 +1,295 @@ +*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 |