OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
set_failwave_nod4.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "comlock.inc"
#include "lockon.inc"
#include "lockoff.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine set_failwave_nod4 (failwave, fwave_el, ngl, nel, ixc, itab, crkdir, dir_a, nrot, xl2, xl3, xl4, yl2, yl3, yl4)

Function/Subroutine Documentation

◆ set_failwave_nod4()

subroutine set_failwave_nod4 ( type (failwave_str_) failwave,
integer, dimension(nel), intent(in) fwave_el,
integer, dimension(nel), intent(in) ngl,
integer nel,
integer, dimension(nixc,nel), intent(in) ixc,
integer, dimension(numnod), intent(in) itab,
intent(in) crkdir,
intent(in) dir_a,
integer nrot,
intent(in) xl2,
intent(in) xl3,
intent(in) xl4,
intent(in) yl2,
intent(in) yl3,
intent(in) yl4 )

Definition at line 33 of file set_failwave_nod4.F.

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