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
42 use element_mod , only : nixs
43C-----------------------------------------------
44C I m p l i c i t T y p e s
45C-----------------------------------------------
46#include "implicit_f.inc"
47C-----------------------------------------------
48C C o m m o n B l o c k s
49C-----------------------------------------------
50#include "com04_c.inc"
51#include "units_c.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 INTEGER IBUF(*),IXS(NIXS,*), TAGNODBR(NB_NODE),
56 . NBRIC, MONVID, ILVOUT,
57 . nb_node,ibric,ityp, fvtype
58 INTEGER, DIMENSION(2, NBRIC), INTENT(INOUT) :: TBRIC
59 INTEGER, DIMENSION(12, NBRIC), INTENT(INOUT) :: TFAC
60 CHARACTER(len=nchartitle) :: TITR
61C-----------------------------------------------
62 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC
63C-----------------------------------------------
64C L o c a l V a r i a b l e s
65C-----------------------------------------------
66 INTEGER, DIMENSION(:), ALLOCATABLE :: ADSKY, ADDCNEL, CNE
67 INTEGER I, J, NG, NNO, NG2, NNF, NNF2, NNOF, NNOF2,
68 . nno2, k, kk, k2,
69 . ntype, ntype2, nodeid
70 INTEGER, TARGET :: REDIRT(4), REDIRP(6), REDIRB(8), REDIRPY(5)
71 INTEGER, DIMENSION(:), POINTER :: REDIR2, REDIR
72C
73 INTEGER, TARGET :: FAC4(3,4), FAC8(4,6), FAC6(4,5), NOD6(5)
74 INTEGER, TARGET :: FAC5(4,5), NOD5(5), NFACE(4), NNODE(4), KFACE, KFACE2, NOD8(6), NOD3(4)
75 INTEGER :: IAD, IAD1, IAD2, NNODEF(4), N1(8), N2(8), IP1(8), IP2(8), IS, NB_COMMON_NODE
76 INTEGER, DIMENSION(:, :), POINTER :: FAC, FAC2
77 INTEGER, DIMENSION(:), POINTER :: NOD, NOD2
78 integer, dimension(1,1), target :: nothing
79
80 DATA fac4 /1,5,3,
81 . 3,5,6,
82 . 6,5,1,
83 . 1,3,6/
84 DATA fac8 /1,4,3,2,
85 . 5,6,7,8,
86 . 1,2,6,5,
87 . 2,3,7,6,
88 . 3,4,8,7,
89 . 4,1,5,8/
90 DATA fac6 /1,3,2,0,
91 . 5,6,7,0,
92 . 1,2,6,5,
93 . 2,3,7,6,
94 . 3,4,8,7/
95 DATA nod6 /3,3,4,4,4/
96 DATA nod8 /4,4,4,4,4,4/
97 DATA nod3 /3,3,3,3/
98 DATA fac5 /1,2,5,0,
99 . 2,3,5,0,
100 . 3,4,5,0,
101 . 4,1,5,0,
102 . 1,4,3,2/
103 DATA nod5 /3,3,3,3,4/
104 DATA nface/6,4,5,5/
105 DATA nnode/8,4,6,5/
106 DATA nnodef/4, 3, 4, 4/
107 LOGICAL :: ERROR_RAISED, FACE_OK, FACE2_OK
108C INITIALIZE ERROR FLAG
109 error_raised = .false.
110 face_ok = .false.
111 face2_ok = .false.
112 ng = 0
113C-----------------------------------------------
114 fac2 => nothing
115 fac => nothing
116 nod2 => nothing(:,1)
117 nod => nothing(:,1)
118 redir => nothing(:,1)
119 redir2 => nothing(:,1)
120
121C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
122C TETRA indirection
123 redirt(1)=1
124 redirt(2)=3
125 redirt(3)=5
126 redirt(4)=6
127C BRICK indirection
128 DO k = 1, 8
129 redirb(k) = k
130 ENDDO
131C PENTA indirection
132 redirp(1)=1
133 redirp(2)=2
134 redirp(3)=3
135 redirp(4)=5
136 redirp(5)=6
137 redirp(6)=7
138C PYRAMIDE indirection
139 DO k = 1, 5
140 redirpy(k) = k
141 ENDDO
142
143 ALLOCATE(addcnel(nb_node + 1), adsky(nb_node + 1))
144 DO i = 1, nb_node
145 addcnel(i) = 0
146 tagnodbr(i) = 0
147 ENDDO
148
149 addcnel(nb_node + 1) = 0
150
151 IF (ilvout >=1 ) THEN
152 WRITE(istdo,'(A,I8)') ' --> FVMBAG ID: ',monvid
153 WRITE(istdo,'(8X,A)') 'BUILDING ELEMENT CONNECTIVITY'
154 ENDIF
155
156 DO i = 1, nbric
157 IF (ityp == 1) THEN
158! brick
159 ng = igrbric(ibric)%ENTITY(i)
160 ELSEIF (ityp == 2) THEN
161! tetra
162 ng = ibuf(i)
163 ENDIF
164 tfac(1:12, i) = 0
165 nno= -huge(nno)
166 ntype= -huge(ntype)
167 redir => null()
168 IF (ixs(9,ng) == ixs(6,ng).AND.ixs(8,ng) == ixs(7,ng).AND.
169 . ixs(5,ng) == ixs(4,ng).AND.ixs(3,ng) == ixs(2,ng)) THEN
170 nno=4 !TETRAEDRE
171 ntype=2
172 redir => redirt(1:4)
173 ELSEIF (ixs(9,ng) == ixs(6,ng).AND.ixs(5,ng) == ixs(2,ng)) THEN
174 nno=6 !PENTAEDRE 6 NOEUDS
175 ntype=3
176 redir => redirp(1:6)
177 ELSEIF ( ixs(6,ng) == ixs(9,ng).AND.ixs(7,ng) == ixs(9,ng).AND.
178 . ixs(8,ng) == ixs(9,ng)) THEN
179 nno=5 !PYRAMIDE
180 ntype=4
181 redir => redirpy(1:5)
182 ELSEIF( (ixs(2,ng) == ixs(6,ng).AND.ixs(5,ng) == ixs(9,ng))
183 . .OR.(ixs(2,ng) == ixs(3,ng).AND.ixs(6,ng) == ixs(7,ng))
184 . .OR.(ixs(2,ng) == ixs(6,ng).AND.ixs(3,ng) == ixs(7,ng))
185 . .OR.(ixs(3,ng) == ixs(7,ng).AND.ixs(4,ng) == ixs(8,ng))
186 . .OR.(ixs(3,ng) == ixs(4,ng).AND.ixs(7,ng) == ixs(8,ng))
187 . .OR.(ixs(4,ng) == ixs(5,ng).AND.ixs(8,ng) == ixs(9,ng))
188 . .OR.(ixs(4,ng) == ixs(8,ng).AND.ixs(5,ng) == ixs(9,ng))
189 . .OR.(ixs(6,ng) == ixs(7,ng).AND.ixs(8,ng) == ixs(9,ng))
190 . .OR.(ixs(7,ng) == ixs(8,ng).AND.ixs(6,ng) == ixs(9,ng))
191 . .OR.(ixs(2,ng) == ixs(3,ng).AND.ixs(4,ng) == ixs(5,ng))
192 . .OR.(ixs(2,ng) == ixs(5,ng).AND.ixs(3,ng) == ixs(4,ng)))THEN
193 CALL ancmsg(msgid=633,
194 . msgtype=msgerror,
195 . anmode=aninfo,
196 . i1=monvid,
197 . c1=titr)
198 ELSE
199 nno=8 !BRIQUE
200 ntype=1
201 redir => redirb(1:8)
202 ENDIF
203C Stode Brick ID and type
204 tbric(1,i) = ng
205 tbric(2,i) = ntype
206 DO k = 1, nno
207 nodeid = ixs(1 + redir(k), ng) + 1
208 tagnodbr(nodeid - 1) = 1
209 addcnel(nodeid) = addcnel(nodeid) + 1
210 ENDDO
211 ENDDO
212
213C
214 addcnel(1) = 1
215 DO i = 2, nb_node + 1
216 addcnel(i) = addcnel(i) + addcnel(i - 1)
217 ENDDO
218 DO i = 1, nb_node
219 adsky(i) = addcnel(i)
220 ENDDO
221
222C ============================
223C Node -> element connectivity
224C ============================
225 ALLOCATE(cne(addcnel(nb_node + 1)))
226
227 DO i = 1, nbric
228 ng = tbric(1, i)
229 ntype = tbric(2, i)
230 SELECT CASE(ntype)
231 CASE (1)
232C BRICK
233 DO k = 1, 8
234 nodeid = ixs(1 + redirb(k), ng)
235 cne(adsky(nodeid)) = i
236 adsky(nodeid) = adsky(nodeid) + 1
237 ENDDO
238 CASE (2)
239C TETRA
240 DO k = 1, 4
241 nodeid = ixs(1 + redirt(k), ng)
242 cne(adsky(nodeid)) = i
243 adsky(nodeid) = adsky(nodeid) + 1
244 ENDDO
245 CASE (3)
246C PENTA
247 DO k = 1, 6
248 nodeid = ixs(1 + redirp(k), ng)
249 cne(adsky(nodeid)) = i
250 adsky(nodeid) = adsky(nodeid) + 1
251 ENDDO
252 CASE (4)
253C PYRA
254 DO k = 1, 5
255 nodeid = ixs(1 + redirpy(k), ng)
256 cne(adsky(nodeid)) = i
257 adsky(nodeid) = adsky(nodeid) + 1
258 ENDDO
259 CASE DEFAULT
260C ERROR
261 END SELECT
262 ENDDO
263
264C =========================
265C Finding adjacent elements
266C =========================
267 DO i = 1, nbric
268 !IF (ILVOUT >=1 ) CALL PROGALE_C(I, NBRIC, 4) !dynamic screen output
269 ng = tbric(1, i)
270 ntype = tbric(2, i)
271 nno = nnode(ntype)
272 nnf = nface(ntype)
273 nnof = nnodef(ntype)
274 SELECT CASE (ntype)
275 CASE (1)
276 redir => redirb(1:8)
277 fac => fac8(1:4, 1:6)
278 nod => nod8(1:6)
279 CASE (2)
280 redir => redirt(1:4)
281 fac => fac4(1:3, 1:4)
282 nod => nod3(1:4)
283 CASE (3)
284 redir => redirp(1:6)
285 fac => fac6(1:4, 1:5)
286 nod => nod6(1:5)
287 CASE (4)
288 redir => redirpy(1:5)
289 fac => fac5(1:4, 1:5)
290 nod => nod5(1:5)
291 CASE DEFAULT
292C ERROR
293 END SELECT
294C Keep track of the nodes
295 DO k = 1, nno
296 n1(k) = ixs(1 + redir(k), ng)
297 ENDDO
298C Loop over the nodes
299 DO k = 1, nno
300 nodeid = n1(k)
301 iad1 = addcnel(nodeid)
302 iad2 = addcnel(nodeid+1) - 1
303C Loop over the adjacent elements
304 DO iad = iad1, iad2
305 j = cne(iad)
306 IF (j /= i) THEN
307 ng2 = tbric(1, j)
308 ntype2 = tbric(2, j)
309 nno2 = nnode(ntype2)
310 nnf2 = nface(ntype2)
311 nnof2 = nnodef(ntype2)
312 SELECT CASE (ntype2)
313 CASE (1)
314 redir2 => redirb(1:8)
315 fac2 => fac8(1:4, 1:6)
316 nod2 => nod8(1:6)
317 CASE (2)
318 redir2 => redirt(1:4)
319 fac2 => fac4(1:3, 1:4)
320 nod2 => nod3(1:4)
321 CASE (3)
322 redir2 => redirp(1:6)
323 fac2 => fac6(1:4, 1:5)
324 nod2 => nod6(1:5)
325 CASE (4)
326 redir2 => redirpy(1:5)
327 fac2 => fac5(1:4, 1:5)
328 nod2 => nod5(1:5)
329 CASE DEFAULT
330 redir2 => null()
331 fac2 => null()
332 nod2 => null()
333 END SELECT
334
335 DO k2 = 1, nno2
336 n2(k2) = ixs(1 + redir2(k2), ng2)
337 ENDDO
338 ip1(1:8) = 0
339 ip2(1:8) = 0
340 nb_common_node = 0
341 DO kk = 1, nno
342 DO k2 = 1, nno2
343 IF (n1(kk) == n2(k2)) THEN
344 nb_common_node = nb_common_node + 1
345 ip1(redir(kk)) = 1
346 ip2(redir2(k2)) = 1
347 ENDIF
348 ENDDO
349 ENDDO
350 IF (nb_common_node >= 3) THEN
351C A common neighbor has been found, now find the face number for I and J
352 DO kface = 1, nnf
353 face_ok = .false.
354 is = 0
355 DO kk = 1, nod(kface)
356 is = is + ip1(fac(kk, kface))
357 ENDDO
358 IF (is == nod(kface)) THEN
359 face_ok = .true.
360 EXIT
361 ENDIF
362 ENDDO
363 DO kface2 = 1, nnf2
364 face2_ok = .false.
365 is = 0
366 DO kk = 1, nod2(kface2)
367 is = is + ip2(fac2(kk, kface2))
368 ENDDO
369 IF (is == nod2(kface2)) THEN
370 face2_ok = .true.
371 EXIT
372 ENDIF
373 ENDDO
374 error_raised = (nod(kface) == nod2(kface2)) .AND. (nb_common_node == nod(kface))
375 error_raised = .NOT. error_raised
376 IF (fvtype /= 8) THEN
377 error_raised = .false.
378 ENDIF
379 IF (face_ok .AND. face2_ok .AND. .NOT. error_raised) THEN
380 tfac(2 * (kface - 1) + 1, i) = 1
381 tfac(2 * (kface - 1) + 2, i) = j
382 tfac(2 * (kface2 - 1) + 1, j) = 1
383 tfac(2 * (kface2 - 1) + 2, j) = i
384 ENDIF
385 IF (error_raised) THEN
386 CALL ancmsg(msgid=1625,
387 . msgtype=msgerror,
388 . anmode=aninfo_blind,
389 . i1 = monvid, c1=titr,
390 . i2 = ixs(nixs, ng), i3 = ixs(nixs, ng2))
391 ENDIF
392 ENDIF
393 ENDIF
394 ENDDO
395 ENDDO
396 ENDDO
397
398C ===================
399C Memory deallocation
400C ===================
401
402 DEALLOCATE(adsky, addcnel)
403 DEALLOCATE(cne)
404
405C ===
406C End
407C ===
408C
409 IF (error_raised) THEN
410 CALL arret(2)
411 ENDIF
412 RETURN
413 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:668
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
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:895
arret
subroutine arret(nn)
Definition arret.F:86