1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
*DECK NXTCVM
SUBROUTINE NXTCVM(IFTRK ,IPRINT,NFREG ,NFSUR ,NEREG ,NESUR ,
> MATALB,SURVOL,KEYMRG)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To compress VOLSUR and MATALB according to KEYMRG
* and save on IFTRK.
*
*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
* IFTRK pointer to the TRACKING file in creation mode.
* IPRINT print level.
* NFREG number of regions (geometry).
* NFSUR number of surfaces (geometry).
* NEREG number of regions (compress).
* NESUR number of surfaces (compress).
* MATALB global mixture/albedo identification vector (geometry).
* SURVOL global surface volume vector (geometry).
* KEYMRG index array for surface and volume renumbering.
*
*Reference:
* G. Marleau,
* New Geometries Processing in DRAGON: The NXT: Module,
* Report IGE-260, Polytechnique Montreal,
* Montreal, 2005.
*
*----------
*
IMPLICIT NONE
*----
* Subroutine arguments
*----
INTEGER IFTRK,IPRINT
INTEGER NFREG,NFSUR,NEREG,NESUR
INTEGER MATALB(-NFSUR:NFREG),KEYMRG(-NFSUR:NFREG)
DOUBLE PRECISION SURVOL(-NFSUR:NFREG)
*----
* Local parameters
*----
INTEGER IOUT
CHARACTER NAMSBR*6
PARAMETER (IOUT=6,NAMSBR='NXTCVM')
*----
* Local variables
*----
INTEGER IREG,JREG,IMIX,ITST,JJ
DOUBLE PRECISION DVR
*----
* Allocatable arrays
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: ALBMAT
REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR
*----
* Scratch storage allocation
* ALBMAT global mixture/albedo identification vector (compress).
* VOLSUR global surface volume vector (compress).
*----
ALLOCATE(ALBMAT(-NESUR:NEREG),VOLSUR(-NESUR:NEREG))
*----
* Processing starts:
* print routine opening header if required
* and initialize various parameters.
*----
IF(IPRINT .GE. 100) THEN
WRITE(IOUT,6000) NAMSBR
WRITE(IOUT,*) 'Surface Merge',NFSUR
WRITE(IOUT,'(5I10)') (KEYMRG(JREG),JREG=-1,-NFSUR,-1)
WRITE(IOUT,*) 'Region Merge',NFREG
WRITE(IOUT,'(5I10)') (KEYMRG(JREG),JREG=1,NFREG)
ENDIF
*----
* Compress regions
*----
ALBMAT(0)=0
DVR=0.0D0
IMIX=0
VOLSUR(0)=0.0
DO IREG=1,NEREG
ITST=-1
DO JREG=1,NFREG
* write(6,*) 'Merging regions',IREG,JREG,KEYMRG(JREG)
IF(KEYMRG(JREG) .EQ. IREG) THEN
IF(ITST .EQ. -1) THEN
IMIX=MATALB(JREG)
DVR=SURVOL(JREG)
ITST=1
ELSE
IF(IMIX .NE. MATALB(JREG) ) CALL XABORT(NAMSBR//
>': Merging region with different mixtures not permitted')
DVR=DVR+SURVOL(JREG)
ENDIF
ENDIF
ENDDO
IF(ITST .EQ. -1) CALL XABORT(NAMSBR//
>': One merge region not defined')
VOLSUR(IREG)=REAL(DVR)
ALBMAT(IREG)=IMIX
ENDDO
*----
* Compress surfaces
*----
DO IREG=-1,-NESUR,-1
ITST=-1
DO JREG=-1,-NFSUR,-1
* write(6,*) 'Merging surfaces',IREG,JREG,KEYMRG(JREG)
IF(KEYMRG(JREG) .EQ. IREG) THEN
IF(ITST .EQ. -1) THEN
IMIX=MATALB(JREG)
DVR=SURVOL(JREG)
ITST=1
ELSE
IF(IMIX .NE. MATALB(JREG) ) CALL XABORT(NAMSBR//
>': Merging surfaces with different albedos not permitted')
DVR=DVR+SURVOL(JREG)
ENDIF
ENDIF
ENDDO
IF(ITST .EQ. -1) CALL XABORT(NAMSBR//
>': One merge surface not defined')
VOLSUR(IREG)=REAL(DVR/4.0D0)
ALBMAT(IREG)=IMIX
ENDDO
WRITE(IFTRK) (VOLSUR(JJ),JJ=-NESUR,NEREG)
WRITE(IFTRK) (ALBMAT(JJ),JJ=-NESUR,NEREG)
*----
* Processing finished:
* print routine closing output header if required
* and return
*----
IF(IPRINT .GE. 100) THEN
WRITE(IOUT,6001) NAMSBR
ENDIF
*----
* Scratch storage deallocation
*----
DEALLOCATE(VOLSUR,ALBMAT)
RETURN
*----
* Output formats
*----
6000 FORMAT('(* Output from --',A6,'-- follows ')
6001 FORMAT(' Output from --',A6,'-- completed *)')
END
|
