diff options
Diffstat (limited to 'Dragon/src/NXTRPS.f')
| -rw-r--r-- | Dragon/src/NXTRPS.f | 190 |
1 files changed, 190 insertions, 0 deletions
diff --git a/Dragon/src/NXTRPS.f b/Dragon/src/NXTRPS.f new file mode 100644 index 0000000..8770e26 --- /dev/null +++ b/Dragon/src/NXTRPS.f @@ -0,0 +1,190 @@ +*DECK NXTRPS + SUBROUTINE NXTRPS(IPTRK ,IPRINT,ITYPG ,IGEO ,ILEV , + > NREG ,NSUR ,NSURN ,IDFEX , + > INDXSR,DHPIN ,DCMESH,NASUR ,IDSUR ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Renumber pin cluster surfaces. +* +*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. +* IPRINT intermediate printing level for output. +* ITYPG type of geometry. +* IGEO geometry number. +* ILEV geometry level. +* NREG maximum number of regions in split geometry. +* NSUR maximum number of surfaces in split geometry. +* NSURN number of surfaces in splitted geometry after symmetry. +* IDFEX flag to identify surface to consider. +* INDXSR local indexing of surfaces/regions. +* DHPIN pins height. +* DCMESH cell dimensions. +* +*Parameters: input/output +* NASUR last surcace number considered. +* IDSUR surface identifier after symmetry. +* +*Reference: +* G. Marleau, +* New Geometries Processing in DRAGON: The NXT: Module, +* Report IGE-260, Polytechnique Montreal, +* Montreal, 2005. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* Subroutine arguments +*---- + TYPE(C_PTR) IPTRK + INTEGER IPRINT,ITYPG,IGEO,ILEV, + > NREG,NSUR,NSURN + INTEGER IDFEX(0:8),INDXSR(5,-NSUR:NREG) + DOUBLE PRECISION DHPIN,DCMESH(3,2) + INTEGER NASUR,IDSUR(NSUR) +*---- +* Local parameters +*---- + INTEGER IOUT + CHARACTER NAMSBR*6 + PARAMETER (IOUT=6,NAMSBR='NXTRPS') + DOUBLE PRECISION DZERO,DONE,DTWO + PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0) +*---- +* Local variables +*---- + INTEGER IDGPP,IAS(2),IDIRS(2),ISUR,ID,IND, + > IDIRC,INV,LSTSUR,IDS,INS + CHARACTER NAMREC*12 + DOUBLE PRECISION DCTOP,DCBOT,DOFF,DPBOT,DPTOP +*---- +* Allocatable arrays +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: INREN +*---- +* Data +*---- + CHARACTER CLEV(2)*1 + SAVE CLEV + DATA CLEV /'C','P'/ +*---- +* Processing starts: +* print routine openning output header if required +* and initialize various parameters. +*---- + ALLOCATE(INREN(NSURN)) + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6000) NAMSBR + WRITE(IOUT,6012) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + ENDIF +*---- +* Select main pin direction +*---- + IDGPP=3 + IF(ITYPG .EQ. 10 .OR. ITYPG .EQ. 21) THEN + IDGPP=1 + ELSE IF(ITYPG .EQ. 11 .OR. ITYPG .EQ. 22) THEN + IDGPP=2 + ENDIF +*---- +* Find if pin reaches bottom or top surface +*---- + DCTOP=DCMESH(IDGPP,1)/DTWO + DCBOT=-DCTOP + DOFF=DCMESH(IDGPP,2) + DPBOT=DCMESH(IDGPP,2)-DHPIN/DTWO + DPTOP=DPBOT+DHPIN + IAS(1)=0 + IF(DPBOT .LE. DCBOT .AND. DPTOP .GE. DCBOT) IAS(1)=1 + IAS(2)=0 + IF(DPBOT .LE. DCTOP .AND. DPTOP .GE. DCTOP) IAS(2)=1 + IDIRS(2)=2*IDGPP + IDIRS(1)=IDIRS(2)-1 +*---- +* get rid of radial surfaces +*---- + DO ISUR=1,NSUR + IF(INDXSR(4,-ISUR) .EQ. -2) THEN + IDSUR(ISUR)=0 + ENDIF + ENDDO +*---- +* Get rid of botton and top surfaces if not used +*---- + DO ID=1,2 + IND=-ID + IDIRC=IDIRS(ID) + IF(IAS(ID) .EQ. 0 .OR. IDFEX(IDIRC) .EQ. 0) THEN + DO ISUR=1,NSUR + IF(INDXSR(IDGPP,-ISUR) .EQ. IND) THEN + IDSUR(ISUR)=0 + ENDIF + ENDDO + ENDIF + ENDDO +*---- +* Renumber surfaces +*---- + INREN(:NSURN)=0 + INV=0 + DO ISUR=1,NSUR + IND=IDSUR(ISUR) + IF(IND .GT. 0) THEN + INV=INV+1 + INREN(IND)=INV + ENDIF + ENDDO + LSTSUR=INV+NASUR + DO ISUR=1,NSUR + IDS=IDSUR(ISUR) + IF(IDS .NE. 0) THEN + INS=INREN(ABS(IDS)) + IF(INS .NE. 0) INS=INS+NASUR + IF(IDS .LT. 0) THEN + IDSUR(ISUR)=-INS + ELSE + IDSUR(ISUR)=INS + ENDIF + ENDIF + ENDDO + NASUR=LSTSUR + WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID' + CALL LCMPUT(IPTRK,NAMREC,NSUR,1,IDSUR) +*---- +* Processing finished: +* print routine closing output header if required +* and return +*---- + IF(IPRINT .GE. 100) THEN + WRITE(IOUT,6013) + WRITE(IOUT,6014) (IDSUR(IDS),IDS=1,NSUR) + WRITE(IOUT,6001) NAMSBR + ENDIF + DEALLOCATE(INREN) + RETURN +*---- +* FORMATS +*---- +*---- +* Output formats +*---- + 6000 FORMAT('(* Output from --',A6,'-- follows ') + 6001 FORMAT(' Output from --',A6,'-- completed *)') + 6012 FORMAT(' Original surfaces ID') + 6013 FORMAT(' Final surfaces ID') + 6014 FORMAT(5I15) + END |