summaryrefslogtreecommitdiff
path: root/Dragon/src/NXTCVS.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/NXTCVS.f')
-rw-r--r--Dragon/src/NXTCVS.f255
1 files changed, 255 insertions, 0 deletions
diff --git a/Dragon/src/NXTCVS.f b/Dragon/src/NXTCVS.f
new file mode 100644
index 0000000..94f3e24
--- /dev/null
+++ b/Dragon/src/NXTCVS.f
@@ -0,0 +1,255 @@
+*DECK NXTCVS
+ SUBROUTINE NXTCVS(IPTRK ,IPRINT,NDIM ,ITYPBC,NBOCEL,
+ > NFSUR ,NFREG ,MXGSUR,MXGREG,MRGMIX,
+ > KEYMRG,MATALB,SURVOL)
+*
+*----------
+*
+*Purpose:
+* To compute final surfaces and volumes for geometry
+* and to create the EXCELL type MATALB and KEYMRG vector.
+*
+*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 print level.
+* NDIM problem dimensions.
+* ITYPBC type of boundary conditions where:
+* =0 for geometry with Cartesian boundaries;
+* =1 for geometry with annular boundary;
+* =2 for geometry with hexagonal boundary.
+* NBOCEL number of cells in original geometry.
+* NFSUR final number of surfaces.
+* NFREG final number of regions.
+* MXGSUR maximum number of surfaces for any geometry.
+* MXGREG maximum number of region for any geometry.
+* MRGMIX option to merge by mixtures. Activated when MRGMIX is 1.
+*
+*Parameters: output
+* KEYMRG global merging vector.
+* MATALB global mixture/albedo identification vector (including HMIX).
+* SURVOL global surface volume vector.
+*
+*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 IPTRK
+ INTEGER IPRINT,NDIM,ITYPBC,
+ > NBOCEL,NFSUR,NFREG,MXGSUR,MXGREG
+ INTEGER KEYMRG(-NFSUR:NFREG),MATALB(-NFSUR:NFREG,2)
+ DOUBLE PRECISION SURVOL(-NFSUR:NFREG)
+*----
+* Local parameters
+*----
+ INTEGER IOUT
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NAMSBR='NXTCVS')
+ INTEGER NSTATE
+ PARAMETER (NSTATE=40)
+ DOUBLE PRECISION DZERO,DONE,DTWO
+ PARAMETER (DZERO=0.0D0,DONE=1.0D0,DTWO=2.0D0)
+*----
+* Local variables
+*----
+ INTEGER ICEL,ICLS,ILEV,ISV,IGEO
+ INTEGER NREG,NSUR,NBGCLS,IGCLS,NUNK,MXRUNK
+ INTEGER IEDIMX(NSTATE),IEDIMP(NSTATE)
+ CHARACTER NAMREC*12
+ DOUBLE PRECISION DFACC,DFACP
+*----
+* Update for MERGMIX
+*----
+ INTEGER MRGMIX,MAXMIX,KMIX,IMIX
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IDMER
+*----
+* Allocatable arrays
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IDREG,IDSUR,MIX,MIXH
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDXSR
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SVSGEO
+*----
+* Data
+*----
+ CHARACTER CLEV(2)*1
+ SAVE CLEV
+ DATA CLEV /'C','P'/
+*----
+* Processing starts:
+* print routine openning output header if required
+* and initialize various parameters.
+*----
+ IF(IPRINT .GE. 10) THEN
+ WRITE(IOUT,6000) NAMSBR
+ ENDIF
+ NUNK=NFSUR+NFREG+1
+ MXRUNK=MXGSUR+MXGREG+1
+ SURVOL(-NFSUR:NFREG)=DZERO
+ MATALB(-NFSUR:NFREG,:2)=0
+*----
+* Here there are no merge
+*----
+ DO ICEL=1,NBOCEL
+ ILEV=1
+ IGEO=ICEL
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'DIM'
+ IEDIMX(:NSTATE)=0
+ CALL LCMGET(IPTRK,NAMREC,IEDIMX)
+ NREG=IEDIMX(8)
+ NSUR=IEDIMX(9)
+ NBGCLS=IEDIMX(16)
+ IGCLS=IEDIMX(17)-1
+*----
+* Get MIXTURE
+*----
+ ALLOCATE(MIX(NREG),MIXH(NREG),INDXSR(5,-NSUR:NREG))
+ ALLOCATE(IDREG(NREG),IDSUR(NSUR))
+ ALLOCATE(SVSGEO(2*(NSUR+NREG+1)))
+
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'MIX'
+ CALL LCMGET(IPTRK,NAMREC,MIX)
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'HOM'
+ CALL LCMGET(IPTRK,NAMREC,MIXH)
+*----
+* Get INDEX and SURVOL for pin
+*----
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSI'
+ CALL LCMGET(IPTRK,NAMREC,INDXSR)
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSE'
+ CALL LCMGET(IPTRK,NAMREC,SVSGEO)
+*----
+* Get IDREG and IDSUR
+*----
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'RID'
+ CALL LCMGET(IPTRK,NAMREC,IDREG)
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID'
+ CALL LCMGET(IPTRK,NAMREC,IDSUR)
+ DFACC=DBLE(IEDIMX(19))
+ CALL NXTAVS(IPRINT,NDIM ,ITYPBC,NFSUR ,NFREG ,NSUR ,
+ > NREG ,MIX ,MIXH ,INDXSR,IDSUR ,IDREG ,
+ > SVSGEO,DFACC ,MATALB,SURVOL)
+ DEALLOCATE(SVSGEO,IDSUR,IDREG,INDXSR,MIXH,MIX)
+ IF(NBGCLS .NE. 0) THEN
+ ILEV=2
+ DO ICLS=1,NBGCLS
+ IGEO=IGCLS+ICLS
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'DIM'
+ IEDIMP(:NSTATE)=0
+ CALL LCMGET(IPTRK,NAMREC,IEDIMP)
+ NREG=IEDIMP(8)
+ NSUR=IEDIMP(9)
+ ALLOCATE(MIX(NREG),MIXH(NREG),INDXSR(5,-NSUR:NREG))
+ ALLOCATE(IDREG(NREG),IDSUR(NSUR))
+ ALLOCATE(SVSGEO(2*(NSUR+NREG+1)))
+*----
+* Get MIXTURE
+*----
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'MIX'
+ CALL LCMGET(IPTRK,NAMREC,MIX)
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'HOM'
+ CALL LCMGET(IPTRK,NAMREC,MIXH)
+*----
+* Get INDEX and SURVOL for cell
+*----
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSI'
+ CALL LCMGET(IPTRK,NAMREC,INDXSR)
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'VSE'
+ CALL LCMGET(IPTRK,NAMREC,SVSGEO)
+*----
+* Get IDREG and IDSUR
+*----
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'RID'
+ CALL LCMGET(IPTRK,NAMREC,IDREG)
+ WRITE(NAMREC,'(A1,I8.8,A3)') CLEV(ILEV),IGEO,'SID'
+ CALL LCMGET(IPTRK,NAMREC,IDSUR)
+ DFACP=DFACC*DBLE(IEDIMP(17))
+ CALL NXTAVS(IPRINT,NDIM ,ITYPBC,NFSUR ,NFREG ,NSUR ,
+ > NREG ,MIX ,MIXH ,INDXSR,IDSUR ,IDREG ,
+ > SVSGEO,DFACP ,MATALB,SURVOL)
+ DEALLOCATE(SVSGEO,IDSUR,IDREG,INDXSR,MIXH,MIX)
+ ENDDO
+ ENDIF
+ ENDDO
+*----
+* Save records on IPTRK
+*----
+ IF(MRGMIX .EQ. 0 ) THEN
+ DO ISV=-NFSUR,NFREG
+ KEYMRG(ISV)=ISV
+ ENDDO
+ ELSE
+* Find maximum MIXTURE number
+ MAXMIX=0
+ DO ISV=1,NFREG
+ MAXMIX=MAX(MAXMIX,MATALB(ISV,1))
+ ENDDO
+ ALLOCATE(IDMER(0:MAXMIX))
+ IDMER(0:MAXMIX)=0
+ KMIX=0
+ DO IMIX=0,MAXMIX
+ DO ISV=1,NFREG
+ IF(MATALB(ISV,1) .EQ. IMIX) THEN
+ KMIX=KMIX+1
+ IDMER(IMIX)=KMIX
+ GO TO 100
+ ENDIF
+ ENDDO
+ 100 CONTINUE
+ ENDDO
+ IF(IPRINT .GE. 10) THEN
+ WRITE(IOUT,6100)
+ DO IMIX=0,MAXMIX
+ IF(IDMER(IMIX).NE.0) THEN
+ WRITE(IOUT,6101) IMIX,IDMER(IMIX)
+ ENDIF
+ ENDDO
+ ENDIF
+ DO ISV=-NFSUR,0
+ KEYMRG(ISV)=ISV
+ ENDDO
+ DO ISV=1,NFREG
+ IMIX=MATALB(ISV,1)
+ KEYMRG(ISV)=IDMER(IMIX)
+ ENDDO
+ DEALLOCATE(IDMER)
+ ENDIF
+ CALL LCMPUT(IPTRK ,'KEYMRG ',NUNK ,1,KEYMRG)
+ CALL LCMPUT(IPTRK ,'MATALB ',NUNK ,1,MATALB(-NFSUR,1))
+ CALL LCMPUT(IPTRK ,'HOMMATALB ',NUNK ,1,MATALB(-NFSUR,2))
+ CALL LCMPUT(IPTRK ,'SAreaRvolume',NUNK,4,SURVOL)
+*----
+* Processing finished:
+* print routine closing output header if required
+* and return
+*----
+ 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 *)')
+ 6100 FORMAT('Relation between mixture and region indices for MERGMIX')
+ 6101 FORMAT(' Mixture ',I0,' is associated to region',I10)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 15:16:25 +0000