OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fvbric0.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| fvbric0 ../starter/source/airbag/fvbric0.F
25!||--- called by ------------------------------------------------------
26!|| init_monvol ../starter/source/airbag/init_monvol.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| arret ../starter/source/system/arret.F
30!||--- uses -----------------------------------------------------
31!|| message_mod ../starter/share/message_module/message_mod.F
32!||====================================================================
33 SUBROUTINE fvbric0(IBUF ,IXS ,ITYP ,NBRIC ,
34 . MONVID ,ILVOUT ,TITR ,TAGNODBR,
35 . TBRIC ,TFAC ,NB_NODE ,IGRBRIC,IBRIC,FVTYPE)
36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE message_mod
40 USE groupdef_mod
41 USE names_and_titles_mod , ONLY : nchartitle
42C-----------------------------------------------
43C I m p l i c i t T y p e s
44C-----------------------------------------------
45#include "implicit_f.inc"
46C-----------------------------------------------
47C C o m m o n B l o c k s
48C-----------------------------------------------
49#include "com04_c.inc"
50#include "units_c.inc"
51C-----------------------------------------------
52C D u m m y A r g u m e n t s
53C-----------------------------------------------
54 INTEGER IBUF(*),IXS(NIXS,*), TAGNODBR(NB_NODE),
55 . NBRIC, MONVID, ILVOUT,
56 . nb_node,ibric,ityp, fvtype
57 INTEGER, DIMENSION(2, NBRIC), INTENT(INOUT) :: TBRIC
58 INTEGER, DIMENSION(12, NBRIC), INTENT(INOUT) :: TFAC
59 CHARACTER(len=nchartitle) :: TITR
60C-----------------------------------------------
61 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC
62C-----------------------------------------------
63C L o c a l V a r i a b l e s
64C-----------------------------------------------
65 INTEGER, DIMENSION(:), ALLOCATABLE :: ADSKY, ADDCNEL, CNE
66 INTEGER I, J, NG, NNO, NG2, NNF, NNF2, NNOF, NNOF2,
67 . nno2, k, kk, k2,
68 . ntype, ntype2, nodeid
69 INTEGER, TARGET :: REDIRT(4), REDIRP(6), REDIRB(8), REDIRPY(5)
70 INTEGER, DIMENSION(:), POINTER :: REDIR2, REDIR
71C
72 INTEGER, TARGET :: FAC4(3,4), FAC8(4,6), FAC6(4,5), NOD6(5)
73 INTEGER, TARGET :: FAC5(4,5), NOD5(5), NFACE(4), NNODE(4), KFACE, KFACE2, NOD8(6), NOD3(4)
74 INTEGER :: IAD, IAD1, IAD2, NNODEF(4), N1(8), N2(8), IP1(8), IP2(8), IS, NB_COMMON_NODE
75 INTEGER, DIMENSION(:, :), POINTER :: FAC, FAC2
76 INTEGER, DIMENSION(:), POINTER :: NOD, NOD2
77 integer, dimension(1,1), target :: nothing
78
79 DATA fac4 /1,5,3,
80 . 3,5,6,
81 . 6,5,1,
82 . 1,3,6/
83 DATA fac8 /1,4,3,2,
84 . 5,6,7,8,
85 . 1,2,6,5,
86 . 2,3,7,6,
87 . 3,4,8,7,
88 . 4,1,5,8/
89 DATA fac6 /1,3,2,0,
90 . 5,6,7,0,
91 . 1,2,6,5,
92 . 2,3,7,6,
93 . 3,4,8,7/
94 DATA nod6 /3,3,4,4,4/
95 DATA nod8 /4,4,4,4,4,4/
96 DATA nod3 /3,3,3,3/
97 DATA fac5 /1,2,5,0,
98 . 2,3,5,0,
99 . 3,4,5,0,
100 . 4,1,5,0,
101 . 1,4,3,2/
102 DATA nod5 /3,3,3,3,4/
103 DATA nface/6,4,5,5/
104 DATA nnode/8,4,6,5/
105 DATA nnodef/4, 3, 4, 4/
106 LOGICAL :: ERROR_RAISED, FACE_OK, FACE2_OK
107C INITIALIZE ERROR FLAG
108 error_raised = .false.
109 face_ok = .false.
110 face2_ok = .false.
111 ng = 0
112C-----------------------------------------------
113 fac2 => nothing
114 fac => nothing
115 nod2 => nothing(:,1)
116 nod => nothing(:,1)
117 redir => nothing(:,1)
118 redir2 => nothing(:,1)
119
120C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
121C TETRA indirection
122 redirt(1)=1
123 redirt(2)=3
124 redirt(3)=5
125 redirt(4)=6
126C BRICK indirection
127 DO k = 1, 8
128 redirb(k) = k
129 ENDDO
130C PENTA indirection
131 redirp(1)=1
132 redirp(2)=2
133 redirp(3)=3
134 redirp(4)=5
135 redirp(5)=6
136 redirp(6)=7
137C PYRAMIDE indirection
138 DO k = 1, 5
139 redirpy(k) = k
140 ENDDO
141
142 ALLOCATE(addcnel(nb_node + 1), adsky(nb_node + 1))
143 DO i = 1, nb_node
144 addcnel(i) = 0
145 tagnodbr(i) = 0
146 ENDDO
147
148 addcnel(nb_node + 1) = 0
149
150 IF (ilvout >=1 ) THEN
151 WRITE(istdo,'(A,I8)') ' --> FVMBAG ID: ',monvid
152 WRITE(istdo,'(8X,A)') 'BUILDING ELEMENT CONNECTIVITY'
153 ENDIF
154
155 DO i = 1, nbric
156 IF (ityp == 1) THEN
157! brick
158 ng = igrbric(ibric)%ENTITY(i)
159 ELSEIF (ityp == 2) THEN
160! tetra
161 ng = ibuf(i)
162 ENDIF
163 tfac(1:12, i) = 0
164 nno= -huge(nno)
165 ntype= -huge(ntype)
166 redir => null()
167 IF (ixs(9,ng) == ixs(6,ng).AND.ixs(8,ng) == ixs(7,ng).AND.
168 . ixs(5,ng) == ixs(4,ng).AND.ixs(3,ng) == ixs(2,ng)) THEN
169 nno=4 !TETRAEDRE
170 ntype=2
171 redir => redirt(1:4)
172 ELSEIF (ixs(9,ng) == ixs(6,ng).AND.ixs(5,ng) == ixs(2,ng)) THEN
173 nno=6 !PENTAEDRE 6 NOEUDS
174 ntype=3
175 redir => redirp(1:6)
176 ELSEIF ( ixs(6,ng) == ixs(9,ng).AND.ixs(7,ng) == ixs(9,ng).AND.
177 . ixs(8,ng) == ixs(9,ng)) THEN
178 nno=5 !PYRAMIDE
179 ntype=4
180 redir => redirpy(1:5)
181 ELSEIF( (ixs(2,ng) == ixs(6,ng).AND.ixs(5,ng) == ixs(9,ng))
182 . .OR.(ixs(2,ng) == ixs(3,ng).AND.ixs(6,ng) == ixs(7,ng))
183 . .OR.(ixs(2,ng) == ixs(6,ng).AND.ixs(3,ng) == ixs(7,ng))
184 . .OR.(ixs(3,ng) == ixs(7,ng).AND.ixs(4,ng) == ixs(8,ng))
185 . .OR.(ixs(3,ng) == ixs(4,ng).AND.ixs(7,ng) == ixs(8,ng))
186 . .OR.(ixs(4,ng) == ixs(5,ng).AND.ixs(8,ng) == ixs(9,ng))
187 . .OR.(ixs(4,ng) == ixs(8,ng).AND.ixs(5,ng) == ixs(9,ng))
188 . .OR.(ixs(6,ng) == ixs(7,ng).AND.ixs(8,ng) == ixs(9,ng))
189 . .OR.(ixs(7,ng) == ixs(8,ng).AND.ixs(6,ng) == ixs(9,ng))
190 . .OR.(ixs(2,ng) == ixs(3,ng).AND.ixs(4,ng) == ixs(5,ng))
191 . .OR.(ixs(2,ng) == ixs(5,ng).AND.ixs(3,ng) == ixs(4,ng)))THEN
192 CALL ancmsg(msgid=633,
193 . msgtype=msgerror,
194 . anmode=aninfo,
195 . i1=monvid,
196 . c1=titr)
197 ELSE
198 nno=8 !BRIQUE
199 ntype=1
200 redir => redirb(1:8)
201 ENDIF
202C Stode Brick ID and type
203 tbric(1,i) = ng
204 tbric(2,i) = ntype
205 DO k = 1, nno
206 nodeid = ixs(1 + redir(k), ng) + 1
207 tagnodbr(nodeid - 1) = 1
208 addcnel(nodeid) = addcnel(nodeid) + 1
209 ENDDO
210 ENDDO
211
212C
213 addcnel(1) = 1
214 DO i = 2, nb_node + 1
215 addcnel(i) = addcnel(i) + addcnel(i - 1)
216 ENDDO
217 DO i = 1, nb_node
218 adsky(i) = addcnel(i)
219 ENDDO
220
221C ============================
222C Node -> element connectivity
223C ============================
224 ALLOCATE(cne(addcnel(nb_node + 1)))
225
226 DO i = 1, nbric
227 ng = tbric(1, i)
228 ntype = tbric(2, i)
229 SELECT CASE(ntype)
230 CASE (1)
231C BRICK
232 DO k = 1, 8
233 nodeid = ixs(1 + redirb(k), ng)
234 cne(adsky(nodeid)) = i
235 adsky(nodeid) = adsky(nodeid) + 1
236 ENDDO
237 CASE (2)
238C TETRA
239 DO k = 1, 4
240 nodeid = ixs(1 + redirt(k), ng)
241 cne(adsky(nodeid)) = i
242 adsky(nodeid) = adsky(nodeid) + 1
243 ENDDO
244 CASE (3)
245C PENTA
246 DO k = 1, 6
247 nodeid = ixs(1 + redirp(k), ng)
248 cne(adsky(nodeid)) = i
249 adsky(nodeid) = adsky(nodeid) + 1
250 ENDDO
251 CASE (4)
252C PYRA
253 DO k = 1, 5
254 nodeid = ixs(1 + redirpy(k), ng)
255 cne(adsky(nodeid)) = i
256 adsky(nodeid) = adsky(nodeid) + 1
257 ENDDO
258 CASE DEFAULT
259C ERROR
260 END SELECT
261 ENDDO
262
263C =========================
264C Finding adjacent elements
265C =========================
266 DO i = 1, nbric
267 !IF (ILVOUT >=1 ) CALL PROGALE_C(I, NBRIC, 4) !dynamic screen output
268 ng = tbric(1, i)
269 ntype = tbric(2, i)
270 nno = nnode(ntype)
271 nnf = nface(ntype)
272 nnof = nnodef(ntype)
273 SELECT CASE (ntype)
274 CASE (1)
275 redir => redirb(1:8)
276 fac => fac8(1:4, 1:6)
277 nod => nod8(1:6)
278 CASE (2)
279 redir => redirt(1:4)
280 fac => fac4(1:3, 1:4)
281 nod => nod3(1:4)
282 CASE (3)
283 redir => redirp(1:6)
284 fac => fac6(1:4, 1:5)
285 nod => nod6(1:5)
286 CASE (4)
287 redir => redirpy(1:5)
288 fac => fac5(1:4, 1:5)
289 nod => nod5(1:5)
290 CASE DEFAULT
291C ERROR
292 END SELECT
293C Keep track of the nodes
294 DO k = 1, nno
295 n1(k) = ixs(1 + redir(k), ng)
296 ENDDO
297C Loop over the nodes
298 DO k = 1, nno
299 nodeid = n1(k)
300 iad1 = addcnel(nodeid)
301 iad2 = addcnel(nodeid+1) - 1
302C Loop over the adjacent elements
303 DO iad = iad1, iad2
304 j = cne(iad)
305 IF (j /= i) THEN
306 ng2 = tbric(1, j)
307 ntype2 = tbric(2, j)
308 nno2 = nnode(ntype2)
309 nnf2 = nface(ntype2)
310 nnof2 = nnodef(ntype2)
311 SELECT CASE (ntype2)
312 CASE (1)
313 redir2 => redirb(1:8)
314 fac2 => fac8(1:4, 1:6)
315 nod2 => nod8(1:6)
316 CASE (2)
317 redir2 => redirt(1:4)
318 fac2 => fac4(1:3, 1:4)
319 nod2 => nod3(1:4)
320 CASE (3)
321 redir2 => redirp(1:6)
322 fac2 => fac6(1:4, 1:5)
323 nod2 => nod6(1:5)
324 CASE (4)
325 redir2 => redirpy(1:5)
326 fac2 => fac5(1:4, 1:5)
327 nod2 => nod5(1:5)
328 CASE DEFAULT
329 redir2 => null()
330 fac2 => null()
331 nod2 => null()
332 END SELECT
333
334 DO k2 = 1, nno2
335 n2(k2) = ixs(1 + redir2(k2), ng2)
336 ENDDO
337 ip1(1:8) = 0
338 ip2(1:8) = 0
339 nb_common_node = 0
340 DO kk = 1, nno
341 DO k2 = 1, nno2
342 IF (n1(kk) == n2(k2)) THEN
343 nb_common_node = nb_common_node + 1
344 ip1(redir(kk)) = 1
345 ip2(redir2(k2)) = 1
346 ENDIF
347 ENDDO
348 ENDDO
349 IF (nb_common_node >= 3) THEN
350C A common neighbor has been found, now find the face number for I and J
351 DO kface = 1, nnf
352 face_ok = .false.
353 is = 0
354 DO kk = 1, nod(kface)
355 is = is + ip1(fac(kk, kface))
356 ENDDO
357 IF (is == nod(kface)) THEN
358 face_ok = .true.
359 EXIT
360 ENDIF
361 ENDDO
362 DO kface2 = 1, nnf2
363 face2_ok = .false.
364 is = 0
365 DO kk = 1, nod2(kface2)
366 is = is + ip2(fac2(kk, kface2))
367 ENDDO
368 IF (is == nod2(kface2)) THEN
369 face2_ok = .true.
370 EXIT
371 ENDIF
372 ENDDO
373 error_raised = (nod(kface) == nod2(kface2)) .AND. (nb_common_node == nod(kface))
374 error_raised = .NOT. error_raised
375 IF (fvtype /= 8) THEN
376 error_raised = .false.
377 ENDIF
378 IF (face_ok .AND. face2_ok .AND. .NOT. error_raised) THEN
379 tfac(2 * (kface - 1) + 1, i) = 1
380 tfac(2 * (kface - 1) + 2, i) = j
381 tfac(2 * (kface2 - 1) + 1, j) = 1
382 tfac(2 * (kface2 - 1) + 2, j) = i
383 ENDIF
384 IF (error_raised) THEN
385 CALL ancmsg(msgid=1625,
386 . msgtype=msgerror,
387 . anmode=aninfo_blind,
388 . i1 = monvid, c1=titr,
389 . i2 = ixs(nixs, ng), i3 = ixs(nixs, ng2))
390 ENDIF
391 ENDIF
392 ENDIF
393 ENDDO
394 ENDDO
395 ENDDO
396
397C ===================
398C Memory deallocation
399C ===================
400
401 DEALLOCATE(adsky, addcnel)
402 DEALLOCATE(cne)
403
404C ===
405C End
406C ===
407C
408 IF (error_raised) THEN
409 CALL arret(2)
410 ENDIF
411 RETURN
412 END
fvbric0
subroutine fvbric0(ibuf, ixs, ityp, nbric, monvid, ilvout, titr, tagnodbr, tbric, tfac, nb_node, igrbric, ibric, fvtype)
Definition fvbric0.F:36
groupdef_mod
Definition groupdef_mod.F:662
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87