OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
set_failwave_nod4.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!|| set_failwave_nod4 ../engine/source/materials/fail/failwave/set_failwave_nod4.F
25!||--- called by ------------------------------------------------------
26!|| cforc3 ../engine/source/elements/shell/coque/cforc3.F
27!|| czforc3 ../engine/source/elements/shell/coquez/czforc3.F
28!||--- calls -----------------------------------------------------
29!|| seg_intersect ../engine/source/materials/fail/failwave/seg_intersect.F
30!||--- uses -----------------------------------------------------
31!|| element_mod ../common_source/modules/elements/element_mod.F90
32!|| failwave_mod ../common_source/modules/failwave_mod.F
33!||====================================================================
34 SUBROUTINE set_failwave_nod4(FAILWAVE ,FWAVE_EL ,NGL ,
35 . NEL ,IXC ,ITAB ,CRKDIR ,DIR_A ,
36 . NROT ,XL2 ,XL3 ,XL4 ,YL2 ,
37 . YL3 ,YL4 )
38c-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE failwave_mod
42 use element_mod , only : nixc
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"
52#include "comlock.inc"
53C-----------------------------------------------
54C D u m m y A r g u m e n t s
55C-----------------------------------------------
56 INTEGER NEL,NROT
57 INTEGER ,DIMENSION(NIXC,NEL) ,INTENT(IN) :: IXC
58 INTEGER ,DIMENSION(NUMNOD) ,INTENT(IN) :: ITAB
59 INTEGER ,DIMENSION(NEL) ,INTENT(IN) :: NGL,FWAVE_EL
60C
61 my_real ,DIMENSION(NEL,NROT) ,INTENT(IN) :: dir_a
62 my_real ,DIMENSION(NEL,2) ,INTENT(IN) :: crkdir
63 my_real ,DIMENSION(NEL) ,INTENT(IN) :: xl2,xl3,xl4,yl2,yl3,yl4
64 TYPE (FAILWAVE_STR_) :: FAILWAVE
65C-----------------------------------------------
66C L o c a l V a r i a b l e s
67C-----------------------------------------------
68 INTEGER I, II, K, N1, N2, N3, N4, INTERSECTION, NEWCRK1, NEWCRK2, NCURR,
69 . MAXLEV,IDEBUG
70 INTEGER ,DIMENSION(NEL) :: INDX1,INDX2
71 INTEGER ,DIMENSION(4) :: IDF1,IDF2,NOD_ID,NOD_NN
72c
73 my_real :: dir11,dir22,cosx,sinx,cosy,siny,lmax,xm,ym,
74 . x1,y1,x2,y2,x3,y3,x4,y4,x5,y5,x6,y6,x7,y7,x8,y8,dx1,dy1,dx2,dy2,
75 . xint,yint,rat1,rat2,rx,ry
76
77 INTEGER SEG_INTERSECT
78 EXTERNAL SEG_INTERSECT
79c-----------------------------------------------
80c damaged elements will set nodal frontwave values to propagate crack info
81C=======================================================================
82 idebug = 0
83c
84c---------------
85 SELECT CASE (failwave%WAVE_MOD)
86c---------------
87 CASE (1) ! isotropic propagation
88c---------------
89 DO i=1,nel
90 IF (fwave_el(i) < 0) THEN
91 n1 = failwave%IDXI(ixc(2,i))
92 n2 = failwave%IDXI(ixc(3,i))
93 n3 = failwave%IDXI(ixc(4,i))
94 n4 = failwave%IDXI(ixc(5,i))
95 failwave%FWAVE_NOD_STACK(1,n1,1) = 1
96 failwave%FWAVE_NOD_STACK(1,n2,1) = 1
97 failwave%FWAVE_NOD_STACK(1,n3,1) = 1
98 failwave%FWAVE_NOD_STACK(1,n4,1) = 1
99 failwave%MAXLEV_STACK(n1) = 1
100 failwave%MAXLEV_STACK(n2) = 1
101 failwave%MAXLEV_STACK(n3) = 1
102 failwave%MAXLEV_STACK(n4) = 1
103 ENDIF
104 ENDDO
105c---------------
106 CASE (2) ! directional propagation through edges only
107c---------------
108 newcrk1 = 0
109 newcrk2 = 0
110 DO i=1,nel
111 IF (fwave_el(i) == -1) THEN ! Dir 1 comes from Cracker
112 newcrk1 = newcrk1 + 1
113 indx1(newcrk1) = i
114 ELSEIF (fwave_el(i) == -2) THEN ! Dir 2 comes from Cracker
115 newcrk2 = newcrk2 + 1
116 indx2(newcrk2) = i
117 ELSEIF (fwave_el(i) == -3) THEN ! Two directions have just cracker
118 newcrk1 = newcrk1 + 1
119 newcrk2 = newcrk2 + 1
120 indx1(newcrk1) = i
121 indx2(newcrk2) = i
122 ENDIF
123 ENDDO
124c
125 IF (newcrk1 + newcrk2 > 0) THEN
126c
127c------------------------------------------------
128c Propagation in first direction
129c------------------------------------------------
130 DO ii=1,newcrk1
131 i = indx1(ii)
132 n1 = ixc(2,i)
133 n2 = ixc(3,i)
134 n3 = ixc(4,i)
135 n4 = ixc(5,i)
136 nod_nn(1) = failwave%IDXI(n1)
137 nod_nn(2) = failwave%IDXI(n2)
138 nod_nn(3) = failwave%IDXI(n3)
139 nod_nn(4) = failwave%IDXI(n4)
140 nod_id(1) = itab(n1)
141 nod_id(2) = itab(n2)
142 nod_id(3) = itab(n3)
143 nod_id(4) = itab(n4)
144 idf1(:) = 0
145 idf2(:) = 0
146c
147 IF (nrot == 0) THEN
148 dir11 = -crkdir(i,2)
149 dir22 = crkdir(i,1)
150 ELSE
151 cosx = dir_a(i,1)
152 sinx = dir_a(i,2)
153 cosy =-crkdir(i,2)
154 siny = crkdir(i,1)
155 dir11 = cosx*cosy - sinx*siny
156 dir22 = cosx*siny + sinx*cosy
157 ENDIF
158 xm = (xl2(i) + xl3(i) + xl4(i)) * fourth
159 ym = (yl2(i) + yl3(i) + yl4(i)) * fourth
160 lmax = sqrt(xm**2 + ym**2)*five
161
162 dx1 = xm - dir11 * lmax
163 dy1 = ym - dir22 * lmax
164 dx2 = xm + dir11 * lmax
165 dy2 = ym + dir22 * lmax
166c
167 x1 = zero
168 y1 = zero
169 x2 = xl2(i)
170 y2 = yl2(i)
171 x3 = xl3(i)
172 y3 = yl3(i)
173 x4 = xl4(i)
174 y4 = yl4(i)
175c
176c edges N1-N2 and N3-N4
177 intersection = seg_intersect(x1,y1,x2,y2,dx1,dy1,dx2,dy2,xint,yint,idebug)
178 IF (intersection == 1) THEN
179 idf1(1) = nod_id(2)
180 idf1(2) = nod_id(1)
181 idf1(3) = nod_id(4)
182 idf1(4) = nod_id(3)
183 END IF
184 IF (intersection == 0) THEN
185c edges N2-N3 and N4-N1
186 intersection = seg_intersect(x2,y2,x3,y3,dx1,dy1,dx2,dy2,xint,yint,idebug)
187 IF (intersection == 1) THEN
188 idf1(1) = nod_id(4)
189 idf1(2) = nod_id(3)
190 idf1(3) = nod_id(2)
191 idf1(4) = nod_id(1)
192 ENDIF
193 ENDIF
194 IF (intersection == 0) THEN
195c edge N3-N4
196 intersection = seg_intersect(x3,y3,x4,y4,dx1,dy1,dx2,dy2,xint,yint,idebug)
197 IF (intersection == 1) THEN
198 idf1(1) = nod_id(2)
199 idf1(2) = nod_id(1)
200 idf1(3) = nod_id(4)
201 idf1(4) = nod_id(3)
202 END IF
203 END IF
204 IF (intersection == 0) THEN
205c edge N4-N1
206 intersection = seg_intersect(x4,y4,x1,y1,dx1,dy1,dx2,dy2,xint,yint,idebug)
207 IF (intersection == 1) THEN
208 idf1(1) = nod_id(4)
209 idf1(2) = nod_id(3)
210 idf1(3) = nod_id(2)
211 idf1(4) = nod_id(1)
212 ENDIF
213 ENDIF
214c
215 IF (intersection == 1) THEN
216 DO k=1,4
217 ncurr = nod_nn(k)
218 maxlev = failwave%MAXLEV_STACK(ncurr)
219c--------------------------------------------------------------------
220!$OMP ATOMIC CAPTURE
221 failwave%MAXLEV_STACK(ncurr) = failwave%MAXLEV_STACK(ncurr) + 1
222 maxlev = failwave%MAXLEV_STACK(ncurr)
223!$OMP END ATOMIC
224c--------------------------------------------------------------------
225 IF (maxlev > failwave%SIZE) THEN
226#include "lockon.inc"
227 WRITE(iout,*) 'ERROR IN FAILWAVE PROPAGATION: ELEMENT =',ngl(i),
228 . 'LEVEL=',maxlev
229#include "lockoff.inc"
230 maxlev = failwave%SIZE
231 failwave%MAXLEV_STACK(ncurr) = maxlev
232 ENDIF
233 failwave%FWAVE_NOD_STACK(1,ncurr,maxlev) = idf1(k)
234c
235 END DO
236
237 ELSE ! NO intersection found
238c
239#include "lockon.inc"
240 WRITE(iout,*) 'ERROR ADVANCING CRACK IN ELEMENT, 1st DIR ',ngl(i)
241#include "lockoff.inc"
242 ENDIF
243c
244 ENDDO ! NEWCRK1
245c--------------------------------------
246c Propagation in second direction
247c--------------------------------------
248 DO ii=1,newcrk2
249 i = indx2(ii)
250 n1 = ixc(2,i)
251 n2 = ixc(3,i)
252 n3 = ixc(4,i)
253 n4 = ixc(5,i)
254 nod_nn(1) = failwave%IDXI(n1)
255 nod_nn(2) = failwave%IDXI(n2)
256 nod_nn(3) = failwave%IDXI(n3)
257 nod_nn(4) = failwave%IDXI(n4)
258 nod_id(1) = itab(n1)
259 nod_id(2) = itab(n2)
260 nod_id(3) = itab(n3)
261 nod_id(4) = itab(n4)
262 idf1(:) = 0
263 idf2(:) = 0
264c
265 IF (nrot == 0) THEN
266 dir11 = crkdir(i,1)
267 dir22 = crkdir(i,2)
268 ELSE
269 cosx = dir_a(i,1)
270 sinx = dir_a(i,2)
271 cosy = crkdir(i,1)
272 siny = crkdir(i,2)
273 dir11 = cosx*cosy - sinx*siny
274 dir22 = cosx*siny + sinx*cosy
275 ENDIF
276c
277 xm = (xl2(i) + xl3(i) + xl4(i)) * fourth
278 ym = (yl2(i) + yl3(i) + yl4(i)) * fourth
279 lmax = sqrt(xm**2 + ym**2)*five
280
281 dx1 = xm - dir11 * lmax
282 dy1 = ym - dir22 * lmax
283 dx2 = xm + dir11 * lmax
284 dy2 = ym + dir22 * lmax
285c
286 x1 = zero
287 y1 = zero
288 x2 = xl2(i)
289 y2 = yl2(i)
290 x3 = xl3(i)
291 y3 = yl3(i)
292 x4 = xl4(i)
293 y4 = yl4(i)
294c
295c edge N1-N2
296 intersection = seg_intersect(x1,y1,x2,y2,dx1,dy1,dx2,dy2,xint,yint,idebug)
297 IF (intersection == 1) THEN
298 idf1(1) = nod_id(2)
299 idf1(2) = nod_id(1)
300 idf1(3) = nod_id(4)
301 idf1(4) = nod_id(3)
302 END IF
303 IF (intersection == 0) THEN
304c edge N2-N3
305 intersection = seg_intersect(x2,y2,x3,y3,dx1,dy1,dx2,dy2,xint,yint,idebug)
306 IF (intersection == 1) THEN
307 idf1(1) = nod_id(4)
308 idf1(2) = nod_id(3)
309 idf1(3) = nod_id(2)
310 idf1(4) = nod_id(1)
311 ENDIF
312 ENDIF
313c edge N3-N4
314 IF (intersection == 0) THEN
315 intersection = seg_intersect(x3,y3,x4,y4,dx1,dy1,dx2,dy2,xint,yint,idebug)
316 IF (intersection == 1) THEN
317 idf1(1) = nod_id(2)
318 idf1(2) = nod_id(1)
319 idf1(3) = nod_id(4)
320 idf1(4) = nod_id(3)
321 END IF
322 END IF
323 IF (intersection == 0) THEN
324c edge N4-N1
325 intersection = seg_intersect(x4,y4,x1,y1,dx1,dy1,dx2,dy2,xint,yint,idebug)
326 IF (intersection == 1) THEN
327 idf1(1) = nod_id(4)
328 idf1(2) = nod_id(3)
329 idf1(3) = nod_id(2)
330 idf1(4) = nod_id(1)
331 ENDIF
332 ENDIF
333c
334 IF (intersection == 1) THEN
335 DO k=1,4
336 ncurr = nod_nn(k)
337 maxlev = failwave%MAXLEV_STACK(ncurr)
338c--------------------------------------------------------------------
339!$OMP ATOMIC CAPTURE
340 failwave%MAXLEV_STACK(ncurr) = failwave%MAXLEV_STACK(ncurr) + 1
341 maxlev = failwave%MAXLEV_STACK(ncurr)
342!$OMP END ATOMIC
343c--------------------------------------------------------------------
344 IF (maxlev > failwave%SIZE) THEN
345#include "lockon.inc"
346 WRITE(iout,*) 'ERROR IN FAILWAVE PROPAGATION: ELEMENT =',ngl(i),
347 . 'LEVEL=',maxlev
348#include "lockoff.inc"
349 maxlev = failwave%SIZE
350 failwave%MAXLEV_STACK(ncurr) = maxlev
351 ENDIF
352 failwave%FWAVE_NOD_STACK(1,ncurr,maxlev) = idf1(k)
353c
354 END DO
355
356 ELSE ! No intersection found
357c
358#include "lockon.inc"
359 WRITE(iout,*) 'ERROR ADVANCING CRACK IN ELEMENT, 2nd DIR ',ngl(i)
360#include "lockoff.inc"
361 ENDIF
362c
363 ENDDO ! NEWCRK2
364 ENDIF ! NEWCRK1 + NEWCRK2 > 0
365c
366c---------------
367 CASE (3) ! directional propagation through edges and diagonals
368c---------------
369c
370 newcrk1 = 0
371 newcrk2 = 0
372 DO i=1,nel
373 IF (fwave_el(i) == -1) THEN ! Dir 1 comes from Cracker
374 newcrk1 = newcrk1 + 1
375 indx1(newcrk1) = i
376 ELSEIF (fwave_el(i) == -2) THEN ! Dir 2 comes from Cracker
377 newcrk2 = newcrk2 + 1
378 indx2(newcrk2) = i
379 ELSEIF (fwave_el(i) == -3) THEN ! Two directions have just cracker
380 newcrk1 = newcrk1 + 1
381 newcrk2 = newcrk2 + 1
382 indx1(newcrk1) = i
383 indx2(newcrk2) = i
384 ENDIF
385 ENDDO
386c
387 IF (newcrk1 + newcrk2 > 0) THEN
388c
389 rat1 = half * tan(pi/eight)
390 rat2 = one - rat1
391c------------------------------------------------
392c Propagation in first direction
393c------------------------------------------------
394 DO ii=1,newcrk1
395 i = indx1(ii)
396 n1 = ixc(2,i)
397 n2 = ixc(3,i)
398 n3 = ixc(4,i)
399 n4 = ixc(5,i)
400c
401 nod_nn(1) = failwave%IDXI(n1)
402 nod_nn(2) = failwave%IDXI(n2)
403 nod_nn(3) = failwave%IDXI(n3)
404 nod_nn(4) = failwave%IDXI(n4)
405c
406 nod_id(1) = itab(n1)
407 nod_id(2) = itab(n2)
408 nod_id(3) = itab(n3)
409 nod_id(4) = itab(n4)
410 idf1(:) = 0
411 idf2(:) = 0
412c
413 IF (nrot == 0) THEN
414 dir11 = -crkdir(i,2)
415 dir22 = crkdir(i,1)
416 ELSE
417 cosx = dir_a(i,1)
418 sinx = dir_a(i,2)
419 cosy =-crkdir(i,2)
420 siny = crkdir(i,1)
421 dir11 = cosx*cosy - sinx*siny
422 dir22 = cosx*siny + sinx*cosy
423 ENDIF
424c------------------------
425 xm = (xl2(i) + xl3(i) + xl4(i)) * fourth
426 ym = (yl2(i) + yl3(i) + yl4(i)) * fourth
427 lmax = sqrt(xm**2 + ym**2)*five
428c
429 dx1 = xm - dir11 * lmax
430 dy1 = ym - dir22 * lmax
431 dx2 = xm + dir11 * lmax
432 dy2 = ym + dir22 * lmax
433c
434 x1 = xl2(i)*rat1
435 y1 = yl2(i)*rat1
436 x2 = xl2(i)*rat2
437 y2 = yl2(i)*rat2
438 rx = xl3(i) - xl2(i)
439 ry = yl3(i) - yl2(i)
440 x3 = xl2(i) + rx * rat1
441 y3 = yl2(i) + ry * rat1
442 x4 = xl2(i) + rx * rat2
443 y4 = yl2(i) + ry * rat2
444 rx = xl4(i) - xl3(i)
445 ry = yl4(i) - yl3(i)
446 x5 = xl3(i) + rx * rat1
447 y5 = yl3(i) + ry * rat1
448 x6 = xl3(i) + rx * rat2
449 y6 = yl3(i) + ry * rat2
450 x7 = xl4(i) * rat2
451 y7 = yl4(i) * rat2
452 x8 = xl4(i) * rat1
453 y8 = yl4(i) * rat1
454c---------------------------------
455c edge P1-P2
456 intersection = seg_intersect(x1,y1,x2,y2,dx1,dy1,dx2,dy2,xint,yint,idebug)
457 IF (intersection == 1) THEN
458 idf1(1) = nod_id(2)
459 idf1(2) = nod_id(1)
460 idf1(3) = nod_id(4)
461 idf1(4) = nod_id(3)
462 ENDIF
463c diagonal P2-P3
464 IF (intersection == 0) THEN
465 intersection = seg_intersect(x2,y2,x3,y3,dx1,dy1,dx2,dy2,xint,yint,idebug)
466 IF (intersection == 1) THEN
467 idf1(2) = nod_id(1)
468 idf2(2) = nod_id(3)
469 idf1(4) = nod_id(3)
470 idf2(4) = nod_id(1)
471 ENDIF
472 ENDIF
473c edge P3-P4
474 IF (intersection == 0) THEN
475 intersection = seg_intersect(x3,y3,x4,y4,dx1,dy1,dx2,dy2,xint,yint,idebug)
476 IF (intersection == 1) THEN
477 idf1(1) = nod_id(4)
478 idf1(2) = nod_id(3)
479 idf1(3) = nod_id(2)
480 idf1(4) = nod_id(1)
481 ENDIF
482 ENDIF
483c diagonal P4-P5
484 IF (intersection == 0) THEN
485 intersection = seg_intersect(x4,y4,x5,y5,dx1,dy1,dx2,dy2,xint,yint,idebug)
486 IF (intersection == 1) THEN
487 idf1(1) = nod_id(4)
488 idf2(1) = nod_id(2)
489 idf1(3) = nod_id(2)
490 idf2(3) = nod_id(4)
491 ENDIF
492 ENDIF
493c edge P5-P6
494 IF (intersection == 0) THEN
495 intersection = seg_intersect(x5,y5,x6,y6,dx1,dy1,dx2,dy2,xint,yint,idebug)
496 IF (intersection == 1) THEN
497 idf1(1) = nod_id(2)
498 idf1(2) = nod_id(1)
499 idf1(3) = nod_id(4)
500 idf1(4) = nod_id(3)
501 ENDIF
502 ENDIF
503c diagonal P6-P7
504 IF (intersection == 0) THEN
505 intersection = seg_intersect(x6,y6,x7,y7,dx1,dy1,dx2,dy2,xint,yint,idebug)
506 IF (intersection == 1) THEN
507 idf1(2) = nod_id(1)
508 idf2(2) = nod_id(3)
509 idf1(4) = nod_id(3)
510 idf2(4) = nod_id(1)
511 ENDIF
512 ENDIF
513c edge P7-P8
514 IF (intersection == 0) THEN
515 intersection = seg_intersect(x7,y7,x8,y8,dx1,dy1,dx2,dy2,xint,yint,idebug)
516 IF (intersection == 1) THEN
517 idf1(1) = nod_id(4)
518 idf1(2) = nod_id(3)
519 idf1(3) = nod_id(2)
520 idf1(4) = nod_id(1)
521 ENDIF
522 ENDIF
523c diagonal P8-P1
524 IF (intersection == 0) THEN
525 intersection = seg_intersect(x8,y8,x1,y1,dx1,dy1,dx2,dy2,xint,yint,idebug)
526 IF (intersection == 1) THEN
527 idf1(1) = nod_id(4)
528 idf2(1) = nod_id(2)
529 idf1(3) = nod_id(2)
530 idf2(3) = nod_id(4)
531 ENDIF
532 ENDIF
533c
534 IF (intersection == 1) THEN
535 DO k=1,4
536 ncurr = nod_nn(k)
537c--------------------------------------------------------------------
538!$OMP ATOMIC CAPTURE
539 failwave%MAXLEV_STACK(ncurr) = failwave%MAXLEV_STACK(ncurr) + 1
540 maxlev = failwave%MAXLEV_STACK(ncurr)
541!$OMP END ATOMIC
542c--------------------------------------------------------------------
543 IF (maxlev > failwave%SIZE) THEN
544#include "lockon.inc"
545 WRITE(iout,*) 'ERROR IN FAILWAVE PROPAGATION: ELEMENT =',ngl(i),
546 . 'LEVEL=',maxlev
547#include "lockoff.inc"
548 maxlev = failwave%SIZE
549 failwave%MAXLEV_STACK(ncurr) = maxlev
550 ENDIF
551 failwave%FWAVE_NOD_STACK(1,ncurr,maxlev) = idf1(k)
552 failwave%FWAVE_NOD_STACK(2,ncurr,maxlev) = idf2(k)
553c
554 END DO
555
556 ELSE ! NO intersection founs
557c
558#include "lockon.inc"
559 WRITE(iout,*) 'ERROR ADVANCING CRACK IN ELEMENT, 1st DIR ',ngl(i)
560#include "lockoff.inc"
561 ENDIF
562c
563 ENDDO ! II=1,NEWCRK1
564c--------------------------------------
565c Propagation in second direction
566c--------------------------------------
567c
568 DO ii=1,newcrk2
569 i = indx2(ii)
570 n1 = ixc(2,i)
571 n2 = ixc(3,i)
572 n3 = ixc(4,i)
573 n4 = ixc(5,i)
574 nod_nn(1) = failwave%IDXI(n1)
575 nod_nn(2) = failwave%IDXI(n2)
576 nod_nn(3) = failwave%IDXI(n3)
577 nod_nn(4) = failwave%IDXI(n4)
578 nod_id(1) = itab(n1)
579 nod_id(2) = itab(n2)
580 nod_id(3) = itab(n3)
581 nod_id(4) = itab(n4)
582 idf1(:) = 0
583 idf2(:) = 0
584c
585 IF (nrot == 0) THEN
586 dir11 = crkdir(i,1)
587 dir22 = crkdir(i,2)
588 ELSE
589 cosx = dir_a(i,1)
590 sinx = dir_a(i,2)
591 cosy = crkdir(i,1)
592 siny = crkdir(i,2)
593 dir11 = cosx*cosy - sinx*siny
594 dir22 = cosx*siny + sinx*cosy
595 ENDIF
596c------------------------------------------------
597 xm = (xl2(i) + xl3(i) + xl4(i)) * fourth
598 ym = (yl2(i) + yl3(i) + yl4(i)) * fourth
599 lmax = sqrt(xm**2 + ym**2)*five
600
601 dx1 = xm - dir11 * lmax
602 dy1 = ym - dir22 * lmax
603 dx2 = xm + dir11 * lmax
604 dy2 = ym + dir22 * lmax
605c
606 x1 = xl2(i)*rat1
607 y1 = yl2(i)*rat1
608 x2 = xl2(i)*rat2
609 y2 = yl2(i)*rat2
610 rx = xl3(i) - xl2(i)
611 ry = yl3(i) - yl2(i)
612 x3 = xl2(i) + rx * rat1
613 y3 = yl2(i) + ry * rat1
614 x4 = xl2(i) + rx * rat2
615 y4 = yl2(i) + ry * rat2
616 rx = xl4(i) - xl3(i)
617 ry = yl4(i) - yl3(i)
618 x5 = xl3(i) + rx * rat1
619 y5 = yl3(i) + ry * rat1
620 x6 = xl3(i) + rx * rat2
621 y6 = yl3(i) + ry * rat2
622 x7 = xl4(i) * rat2
623 y7 = yl4(i) * rat2
624 x8 = xl4(i) * rat1
625 y8 = yl4(i) * rat1
626c---------------------------------
627c edge P1-P2
628 intersection = seg_intersect(x1,y1,x2,y2,dx1,dy1,dx2,dy2,xint,yint,idebug)
629 IF (intersection == 1) THEN
630 idf1(1) = nod_id(2)
631 idf1(2) = nod_id(1)
632 idf1(3) = nod_id(4)
633 idf1(4) = nod_id(3)
634 ENDIF
635c diagonal P2-P3
636 IF (intersection == 0) THEN
637 intersection = seg_intersect(x2,y2,x3,y3,dx1,dy1,dx2,dy2,xint,yint,idebug)
638 IF (intersection == 1) THEN
639 idf1(2) = nod_id(1)
640 idf2(2) = nod_id(3)
641 idf1(4) = nod_id(3)
642 idf2(4) = nod_id(1)
643 ENDIF
644 ENDIF
645c edge P3-P4
646 IF (intersection == 0) THEN
647 intersection = seg_intersect(x3,y3,x4,y4,dx1,dy1,dx2,dy2,xint,yint,idebug)
648 IF (intersection == 1) THEN
649 idf1(1) = nod_id(4)
650 idf1(2) = nod_id(3)
651 idf1(3) = nod_id(2)
652 idf1(4) = nod_id(1)
653 ENDIF
654 ENDIF
655c diagonal P4-P5
656 IF (intersection == 0) THEN
657 intersection = seg_intersect(x4,y4,x5,y5,dx1,dy1,dx2,dy2,xint,yint,idebug)
658 IF (intersection == 1) THEN
659 idf1(1) = nod_id(4)
660 idf2(1) = nod_id(2)
661 idf1(3) = nod_id(2)
662 idf2(3) = nod_id(4)
663 ENDIF
664 ENDIF
665c edge P5-P6
666 IF (intersection == 0) THEN
667 intersection = seg_intersect(x5,y5,x6,y6,dx1,dy1,dx2,dy2,xint,yint,idebug)
668 IF (intersection == 1) THEN
669 idf1(1) = nod_id(2)
670 idf1(2) = nod_id(1)
671 idf1(3) = nod_id(4)
672 idf1(4) = nod_id(3)
673 ENDIF
674 ENDIF
675c diagonal P6-P7
676 IF (intersection == 0) THEN
677 intersection = seg_intersect(x6,y6,x7,y7,dx1,dy1,dx2,dy2,xint,yint,idebug)
678 IF (intersection == 1) THEN
679 idf1(2) = nod_id(1)
680 idf2(2) = nod_id(3)
681 idf1(4) = nod_id(3)
682 idf2(4) = nod_id(1)
683 ENDIF
684 ENDIF
685c edge P7-P8
686 IF (intersection == 0) THEN
687 intersection = seg_intersect(x7,y7,x8,y8,dx1,dy1,dx2,dy2,xint,yint,idebug)
688 IF (intersection == 1) THEN
689 idf1(1) = nod_id(4)
690 idf1(2) = nod_id(3)
691 idf1(3) = nod_id(2)
692 idf1(4) = nod_id(1)
693 ENDIF
694 ENDIF
695c diagonal P8-P1
696 IF (intersection == 0) THEN
697 intersection = seg_intersect(x8,y8,x1,y1,dx1,dy1,dx2,dy2,xint,yint,idebug)
698 IF (intersection == 1) THEN
699 idf1(1) = nod_id(4)
700 idf2(1) = nod_id(2)
701 idf1(3) = nod_id(2)
702 idf2(3) = nod_id(4)
703 ENDIF
704 ENDIF
705c
706 IF (intersection == 1) THEN
707 DO k=1,4
708 ncurr = nod_nn(k)
709c--------------------------------------------------------------------
710!$OMP ATOMIC CAPTURE
711 failwave%MAXLEV_STACK(ncurr) = failwave%MAXLEV_STACK(ncurr) + 1
712 maxlev = failwave%MAXLEV_STACK(ncurr)
713!$OMP END ATOMIC
714c--------------------------------------------------------------------
715 IF (maxlev > failwave%SIZE) THEN
716#include "lockon.inc"
717 WRITE(iout,*) 'ERROR IN FAILWAVE PROPAGATION: ELEMENT =',ngl(i),
718 . 'LEVEL=',maxlev
719#include "lockoff.inc"
720 maxlev = failwave%SIZE
721 failwave%MAXLEV_STACK(ncurr) = maxlev
722 ENDIF
723 failwave%FWAVE_NOD_STACK(1,ncurr,maxlev) = idf1(k)
724 failwave%FWAVE_NOD_STACK(2,ncurr,maxlev) = idf2(k)
725c
726 END DO ! K=1,4
727
728 ELSE ! NO intersection found
729c
730#include "lockon.inc"
731 WRITE(iout,*) 'ERROR ADVANCING CRACK IN ELEMENT, 2nd DIR ',ngl(i)
732#include "lockoff.inc"
733 ENDIF
734c
735 ENDDO ! NEWCRK2
736c-------
737 ENDIF ! NEWCRK1 + NEWCRK2 > 0
738c
739c---------------
740 END SELECT
741c---------------
742 RETURN
743 END
my_real
#define my_real
Definition cppsort.cpp:32
failwave_mod
Definition failwave_mod.F:61
set_failwave_nod4
subroutine set_failwave_nod4(failwave, fwave_el, ngl, nel, ixc, itab, crkdir, dir_a, nrot, xl2, xl3, xl4, yl2, yl3, yl4)
Definition set_failwave_nod4.F:38