summaryrefslogtreecommitdiff
path: root/Dragon/src/PSPTCR.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/PSPTCR.f')
-rw-r--r--Dragon/src/PSPTCR.f331
1 files changed, 331 insertions, 0 deletions
diff --git a/Dragon/src/PSPTCR.f b/Dragon/src/PSPTCR.f
new file mode 100644
index 0000000..d9e6968
--- /dev/null
+++ b/Dragon/src/PSPTCR.f
@@ -0,0 +1,331 @@
+*DECK PSPTCR
+ SUBROUTINE PSPTCR(IPTRK ,ISPSP ,IPRINT,ICEL ,NDIM ,NFREG ,
+ > MAXMSH,MXGREG,MAXPIN,KPSP ,COLREG,FACT ,
+ > CELLPO,IDREG ,ITPIN ,DCMESH,DRAPIN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To draw a Cartesian cell according to its explicit
+* position in the assembly.
+*
+*Copyright:
+* Copyright (C) 2005 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
+* IPTRK pointer to the TRACKING data structure in
+* update or creation mode.
+* ISPSP POSTSCRIPT file index.
+* IPRINT print level.
+* ICEL cell number.
+* NDIM problem dimensions.
+* NFREG number of regions.
+* MAXMSH maximum number of elements in MESH array.
+* MXGREG maximum number of region for any geometry.
+* MAXPIN maximum number of pins in a cell.
+* KPSP PSP plot options.
+* FACT scale factor for drawing.
+* CELLPO global cell position in space.
+* COLREG region color.
+*
+*Parameters: temporary storage
+* IDREG local region identifier.
+* ITPIN pin type identifier.
+* DCMESH meshing vector for geometries.
+* DRAPIN pin position identifier.
+*
+*----------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* Subroutine arguments
+*----
+ TYPE(C_PTR) IPTRK
+ INTEGER ISPSP
+ INTEGER IPRINT,ICEL,NDIM,NFREG,MAXMSH,MXGREG,MAXPIN
+ INTEGER KPSP(7)
+ REAL COLREG(4,NFREG)
+ DOUBLE PRECISION FACT,CELLPO(2,2)
+ INTEGER IDREG(MXGREG),ITPIN(3,MAXPIN)
+ DOUBLE PRECISION DCMESH(-1:MAXMSH,4),DRAPIN(-1:4,MAXPIN)
+*----
+* Local parameters
+*----
+ INTEGER IOUT
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NAMSBR='PSPTCR')
+ INTEGER NSTATE
+ PARAMETER (NSTATE=40)
+ REAL WLINE
+ PARAMETER (WLINE=0.002)
+ DOUBLE PRECISION DZERO,DONE,DTWO
+ PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0)
+*----
+* Functions
+*----
+ DOUBLE PRECISION XDRCST,PI
+*----
+* Local variables
+*----
+ INTEGER ILEV,ICONT,ICOL,KFS,KFR,KSS,KSR,NPTS,NSEG,NINT
+ INTEGER IEDIMC(NSTATE),IEDIMP(NSTATE)
+ INTEGER ITYPG,MESHC(4),NREGC,NTPIN
+ INTEGER IDIR,ILXY,NBR,IY,IX,IR,ILOC,IREG,IORDER(16)
+ REAL WLFAC,XYPOS(2,4),CENTER(2),RCIRC,RADANG(2,16),
+ > OFFX,OFFY
+ CHARACTER NAMCEL*9,NAMREC*12
+ REAL COLWHI(4),CENTEP(2),CENTED(2),CENTEB(2)
+ INTEGER IWCOL,IPIN,ISEG,NBRP,MESHP(4)
+ DOUBLE PRECISION ROTAX,COSDIR(3)
+*----
+* Data
+*----
+ CHARACTER CDIR(4)*1
+ SAVE CDIR
+ CHARACTER CLEV(2)*1
+ SAVE CLEV
+ DATA CDIR /'X','Y','Z','R'/
+ DATA CLEV /'C','P'/
+*----
+* Processing starts:
+* print routine openning output header if required
+* and initialize various parameters.
+*----
+ IF(IPRINT .GE. 100) THEN
+ WRITE(IOUT,6000) NAMSBR
+ ENDIF
+ IF(NDIM .GE. 3) CALL XABORT(NAMSBR//
+ >': PSP cannot treat 3D geometries')
+ PI=XDRCST('Pi',' ')
+ IDIR=NDIM
+ ILEV=1
+ IWCOL=1
+ COLWHI(:4)=1.0
+*----
+* PSP print control
+*----
+ WLFAC=1.0
+ ICONT=KPSP(1)
+ ICOL=KPSP(2)
+ IF(KPSP(3) .EQ. 1) WLFAC=2.5
+ KFS=KPSP(4)
+ KFR=KPSP(5)
+ KSS=KPSP(6)
+ KSR=KPSP(7)
+ NPTS=4
+ NINT=16
+*----
+* Read cell information
+*----
+ WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ICEL
+ NAMREC=NAMCEL//'DIM'
+ IEDIMC(:NSTATE)=0
+ CALL LCMGET(IPTRK,NAMREC,IEDIMC)
+ ITYPG=IEDIMC(1)
+ MESHC(1)=IEDIMC(3)
+ MESHC(2)=IEDIMC(4)
+ MESHC(3)=IEDIMC(5)
+ MESHC(4)=IEDIMC(2)
+ NREGC=IEDIMC(8)
+ NTPIN=IEDIMC(18)
+ NAMREC=NAMCEL//'RID'
+ CALL LCMGET(IPTRK,NAMREC,IDREG)
+ DO IDIR=1,4
+ NAMREC=NAMCEL//'SM'//CDIR(IDIR)
+ IF(MESHC(IDIR) .GT. 0) THEN
+ CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR))
+ ENDIF
+ ENDDO
+ IF(NTPIN .GT .0) THEN
+ NAMREC=NAMCEL//'PIN'
+ CALL LCMGET(IPTRK,NAMREC,DRAPIN)
+ NAMREC=NAMCEL//'PNT'
+ CALL LCMGET(IPTRK,NAMREC,ITPIN)
+ ENDIF
+*----
+* Plot each region
+*----
+ ILXY=0
+ NBR=MESHC(4)+1
+ OFFX=-REAL(CELLPO(1,1)-DCMESH(0,1))
+ OFFY=-REAL(CELLPO(2,1)-DCMESH(0,2))
+ CENTER(1)=REAL(FACT*(DCMESH(-1,1)-OFFX))
+ CENTER(2)=REAL(FACT*(DCMESH(-1,2)-OFFY))
+ CENTEB(1)=-CENTER(1)
+ CENTEB(2)=-CENTER(2)
+ DO IY=MESHC(2),1,-1
+ DO IX=MESHC(1),1,-1
+ ILXY=((IY-1)*MESHC(1)+(IX-1))*NBR
+ ILOC=ILXY+NBR
+ IREG=ABS(IDREG(ILOC))
+*----
+* Cartesian region
+*----
+ XYPOS(1,1)=REAL(FACT*(DCMESH(IX-1,1)-OFFX))
+ XYPOS(2,1)=REAL(FACT*(DCMESH(IY-1,2)-OFFY))
+ XYPOS(1,2)=REAL(FACT*(DCMESH(IX,1)-OFFX))
+ XYPOS(2,2)=XYPOS(2,1)
+ XYPOS(1,3)=XYPOS(1,2)
+ XYPOS(2,3)=REAL(FACT*(DCMESH(IY,2)-OFFY))
+ XYPOS(1,4)=XYPOS(1,1)
+ XYPOS(2,4)=XYPOS(2,3)
+ IF(IREG .NE. 0) THEN
+*----
+* Color and trace result
+*----
+ CALL PSDREG(ISPSP,4,XYPOS)
+ IF(ICOL. GT. 0) THEN
+ CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR)
+ ENDIF
+ IF(ICONT.EQ.1) THEN
+ CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
+ ENDIF
+ ENDIF
+ DO IR=MESHC(4),1,-1
+ ILOC=ILXY+IR
+ IREG=ABS(IDREG(ILOC))
+*----
+* Annular region
+*----
+ IF(IREG .NE. 0) THEN
+ RCIRC=REAL(FACT*DCMESH(IR,4))
+*----
+* Move cursor to center of annulus
+*----
+ CALL PSMOVE(ISPSP,CENTER,-3)
+*----
+* Color and trace result
+*----
+ CALL PSPRAI(NINT,NPTS,XYPOS,CENTER,RCIRC,
+ > NSEG,IORDER,RADANG)
+ CALL PSDRAI(ISPSP,NSEG,IORDER,CENTER,RADANG)
+ IF(ICOL. GT. 0) THEN
+ CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR)
+ ENDIF
+ IF(ICONT.EQ.1) THEN
+ CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
+ ENDIF
+*----
+* Return cursor to original position
+*----
+ CALL PSMOVE(ISPSP,CENTEB,-3)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+*----
+* Pins
+*----
+ IF(NTPIN .GT. 0) THEN
+ ILEV=2
+ MESHP(1)=1
+ MESHP(2)=1
+ MESHP(3)=1
+ MESHP(4)=1
+ CENTEP(1)=0.0
+ CENTEP(2)=0.0
+ DO IPIN=1,NTPIN
+*----
+* Locate pin position
+*----
+ COSDIR(1)=DRAPIN(0,IPIN)*COS(DRAPIN(-1,IPIN))
+ COSDIR(2)=DRAPIN(0,IPIN)*SIN(DRAPIN(-1,IPIN))
+ CENTED(1)=REAL(CENTER(1)+FACT*COSDIR(1))
+ CENTED(2)=REAL(CENTER(2)+FACT*COSDIR(2))
+ RCIRC=REAL(FACT*DRAPIN(4,IPIN))
+ ROTAX=PI/DTWO-DRAPIN(-1,IPIN)
+*----
+* Move cursor to center of pin
+*----
+ CALL PSMOVE(ISPSP,CENTED,-3)
+*----
+* Read pin information
+*----
+ WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ITPIN(2,IPIN)
+ NAMREC=NAMCEL//'DIM'
+ IEDIMP(:NSTATE)=0
+ CALL LCMGET(IPTRK,NAMREC,IEDIMP)
+ ITYPG=IEDIMP(1)
+ MESHP(1)=IEDIMP(3)
+ MESHP(2)=IEDIMP(4)
+ MESHP(3)=IEDIMP(5)
+ MESHP(4)=IEDIMP(2)
+ NBRP=MESHP(4)
+ NAMREC=NAMCEL//'RID'
+ CALL LCMGET(IPTRK,NAMREC,IDREG)
+ DO IDIR=1,4
+ NAMREC=NAMCEL//'SM'//CDIR(IDIR)
+ IF(MESHP(IDIR) .GT. 0) THEN
+ CALL LCMGET(IPTRK,NAMREC,DCMESH(-1,IDIR))
+ ENDIF
+ ENDDO
+ DO IY=MESHP(2),1,-1
+ DO IX=MESHP(1),1,-1
+ ILXY=((IY-1)*MESHP(1)+(IX-1))*NBRP
+*----
+* Cartesian region
+*----
+ XYPOS(1,1)=REAL(FACT*(DCMESH(IX-1,1)))
+ XYPOS(2,1)=REAL(FACT*(DCMESH(IY-1,2)))
+ XYPOS(1,2)=REAL(FACT*(DCMESH(IX,1)))
+ XYPOS(2,2)=XYPOS(2,1)
+ XYPOS(1,3)=XYPOS(1,2)
+ XYPOS(2,3)=REAL(FACT*(DCMESH(IY,2)))
+ XYPOS(1,4)=XYPOS(1,1)
+ XYPOS(2,4)=XYPOS(2,3)
+ DO IR=MESHP(4),1,-1
+ ILOC=ILXY+IR
+ IREG=ABS(IDREG(ILOC))
+ RCIRC=REAL(FACT*DCMESH(IR,4))
+*----
+* Annular pin regions
+*----
+ IF(IREG .NE. 0) THEN
+ CALL PSPRAI(NINT,NPTS,XYPOS,CENTEP,RCIRC,
+ > NSEG,IORDER,RADANG)
+*----
+* Rotate pins intersection points
+*----
+ DO ISEG=1,NSEG
+ RADANG(2,ISEG)=RADANG(2,ISEG)-REAL(ROTAX)
+ ENDDO
+*----
+* Color and trace result
+*----
+ CALL PSDRAI(ISPSP,NSEG,IORDER,CENTEP,RADANG)
+ IF(ICOL. GT. 0) THEN
+ CALL PSFILL(ISPSP,ICOL,COLREG(1,IREG),KFS,KFR)
+ ENDIF
+ IF(ICONT.EQ.1) THEN
+ CALL PSSTRK(ISPSP,WLFAC*WLINE,KSS,KSR)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+*----
+* Return cursor to original position
+*----
+ CENTED(1)=-CENTED(1)
+ CENTED(2)=-CENTED(2)
+ CALL PSMOVE(ISPSP,CENTED,-3)
+ ENDDO
+ ENDIF
+ IF(IPRINT .GE. 100) THEN
+ WRITE(IOUT,6001) NAMSBR
+ ENDIF
+ RETURN
+*----
+* Output formats
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT(' Output from --',A6,'-- completed *)')
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:17:29 +0000