OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfuncc_crk.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!|| dfuncc_crk ../engine/source/output/anim/generate/dfuncc_crk.F
25!||--- called by ------------------------------------------------------
26!|| genani ../engine/source/output/anim/generate/genani.F
27!||--- calls -----------------------------------------------------
28!|| initbuf ../engine/share/resol/initbuf.F
29!|| spmd_r4get_partn ../engine/source/mpi/anim/spmd_r4get_partn.F
30!|| write_r_c ../common_source/tools/input_output/write_routtines.c
31!||--- uses -----------------------------------------------------
32!|| crackxfem_mod ../engine/share/modules/crackxfem_mod.F
33!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
34!|| initbuf_mod ../engine/share/resol/initbuf.F
35!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
36!||====================================================================
37 SUBROUTINE dfuncc_crk(
38 . ELBUF_TAB ,LEN , IFUNC ,IPARG ,GEO ,
39 . IXC ,IXTG , MASS ,PM ,EL2FA ,
40 . NBF ,IADP , NBF_L ,EHOUR ,ANIM ,
41 . NBPART ,IADG , IPM ,IGEO ,THKE ,
42 . ERR_THK_SH4 ,ERR_THK_SH3,XFEM_TAB,IEL_CRK,INDX_CRK,
43 . NBF_CRKXFEMG,EL2FA0 ,CRKEDGE )
44C-----------------------------------------------
45C M o d u l e s
46C-----------------------------------------------
47 USE initbuf_mod
48 USE crackxfem_mod
49 USE elbufdef_mod
50 USE my_alloc_mod
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
54#include "implicit_f.inc"
55C-----------------------------------------------
56C C o m m o n B l o c k s
57C-----------------------------------------------
58#include "vect01_c.inc"
59#include "mvsiz_p.inc"
60#include "com01_c.inc"
61#include "com04_c.inc"
62#include "com_xfem1.inc"
63#include "param_c.inc"
64#include "task_c.inc"
65C-----------------------------------------------
66C D u m m y A r g u m e n t s
67C-----------------------------------------------
68 INTEGER IFUNC,NBF,LEN,NBF_L, NBPART,NBF_CRKXFEMG
69 INTEGER IPARG(NPARG,*),IXC(NIXC,*),IXTG(NIXTG,*),EL2FA(*),
70 . IADP(*),IADG(NSPMD,*),IPM(NPROPMI,*),INDX_CRK(*),
71 . IGEO(NPROPGI,*),EL2FA0(*),IEL_CRK(*)
72C REAL
73 my_real
74 . mass(*),geo(npropg,*),
75 . ehour(*),anim(*),pm(npropm,*),thke(*),
76 . err_thk_sh4(*), err_thk_sh3(*)
77 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
78 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP,NXEL), TARGET :: XFEM_TAB
79 TYPE (XFEM_EDGE_) , DIMENSION(*) :: CRKEDGE
80C-----------------------------------------------
81C L o c a l V a r i a b l e s
82C-----------------------------------------------
83C REAL
84 REAL,DIMENSION(:),ALLOCATABLE:: WAL
85 INTEGER,DIMENSION(:),ALLOCATABLE::MATLY
86 my_real
87 . EVAR(MVSIZ),FUNC(LEN),
88 . OFF, P, VONM2, VONM, S1, S2, S12, S3, VALUE,
89 . A1,B1,B2,B3,YEQ,F1,M1,M2,M3, FAC, DAM1(MVSIZ),DAM2(MVSIZ),
90 . wpla(mvsiz), dmax(mvsiz),wpmax(mvsiz),
91 . fail(mvsiz),thk0,thke0(mvsiz)
92 INTEGER I,NG,NEL,ISC,N,J,MLW,NUVAR,
93 . ISTRAIN,NN,K1,K2,MT,IMID,IPID,
94 . NN1,NN2,NN3,NN4,NN5,NN6,NF,
95 . OFFSET,K,II,KK,IHBE,I1,MPT,IPT,BUF,NUVARR,
96 . IPMAT,PID(MVSIZ),MAT(MVSIZ),
97 . IEXPAN,NEL_CRK,NLEVXF,NI,JTURB,
98 . nlay,nptt,ixel,ilay,il,ius,jj(5)
99 INTEGER IXFEM,IP,JPID,CRKS,ICRK,ILAYCRK,ELCRK,NPT0
100 INTEGER NELCRK(NCRKPART),IE(NCRKPART)
101 REAL R4
102C
103 TYPE(BUF_LAY_) ,POINTER :: BUFLY
104 TYPE(G_BUFEL_) ,POINTER :: GBUF
105 TYPE(l_bufel_) ,POINTER :: LBUF
106C
107 TYPE(g_bufel_) ,POINTER :: XGBUF
108 TYPE(L_BUFEL_) ,POINTER :: XLBUF
109C=======================================================================
110 CALL my_alloc(wal,nbf_l)
111 CALL my_alloc(matly,mvsiz*100)
112 nel_crk = 0
113 func(1:len) = zero
114c
115 DO crks = 1,ncrkpart
116 icrk = indx_crk(crks)
117 nelcrk(crks) = nel_crk
118 nel_crk = nel_crk + crkshell(icrk)%CRKNUMSHELL
119 ie(icrk) = 0
120 ENDDO
121C
122 nn1 = 1
123 nn3 = 1
124 nn4 = nn3 + numelq
125 nn5 = nn4 + numelc
126 nn6 = nn5 + numeltg
127C
128 DO ng=1,ngroup
129C---
130 ixfem = iparg(54,ng)
131 IF (ixfem /= 1 .AND. ixfem /= 2) cycle
132C---
133 CALL initbuf(iparg ,ng ,
134 2 mlw ,nel ,nft ,iad ,ity ,
135 3 npt ,jale ,ismstr ,jeul ,jturb ,
136 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
137 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
138 6 irep ,iint ,igtyp ,israt ,isrot ,
139 7 icsen ,isorth ,isorthg ,ifailure,jsms)
140C---
141 IF (ity /= 3 .AND. ity /= 7) cycle
142 IF (mlw /= 13) THEN
143 DO offset = 0,nel-1,nvsiz
144 nft =iparg(3,ng) + offset
145 lft=1
146 llt=min(nvsiz,nel-offset)
147 npt = iparg(6,ng)
148 ihbe = iparg(23,ng)
149 IF (ihbe == 11) cycle
150 nuvar = 0
151!
152 DO i=1,5
153 jj(i) = nel*(i-1)
154 ENDDO
155!
156C-----------------------------------------------
157C SHELLS 3-N, 4-N
158C-----------------------------------------------
159 mpt = iabs(npt)
160 npt0 = npt
161C-----------------------------------------
162C-----------------------------------------
163 IF (ixfem == 1) npt = 1 ! multlayer xfem
164C-----------------------------------------
165C-----------------------------------------
166 gbuf => elbuf_tab(ng)%GBUF
167C
168 IF (ity == 3) THEN
169 ni = nft
170 ELSE
171 ni = nft + numelc
172 ENDIF
173C-----------------------------------------
174C-----------------------------------------
175C LOOP OVER PHANTOM ELEMENTS
176C-----------------------------------------
177C-----------------------------------------
178 DO ixel=1,nxel
179 xgbuf => xfem_tab(ng,ixel)%GBUF
180 nlay = xfem_tab(ng,ixel)%NLAY
181 DO ilay=1,nlay
182C---
183 icrk = nxel*(ilay-1) + ixel
184C---
185 IF (nlay > 1) THEN
186 lbuf => elbuf_tab(ng)%BUFLY(ilay)%LBUF(1,1,1)
187 xlbuf => xfem_tab(ng,ixel)%BUFLY(ilay)%LBUF(1,1,1)
188 ELSE
189 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,ilay)
190 xlbuf => xfem_tab(ng,ixel)%BUFLY(1)%LBUF(1,1,ilay)
191 ENDIF
192 xgbuf => xfem_tab(ng,ixel)%GBUF
193cc BUFLY => XFEM_TAB(NG,IXEL)%BUFLY(ILAY)
194cc BUFLY => ELBUF_TAB(NG)%BUFLY(ILAY)
195C---
196 nuvar = 0
197C---------------------
198 DO i=lft,llt
199 evar(i) = zero ! Init to zero in all cases !
200 ENDDO
201C---------------------
202C
203 IF (mlw == 0 .OR. mlw == 13) THEN
204 CONTINUE
205c---
206 ELSE IF (ifunc == 1) THEN ! plastic strain
207 IF (nlay > 1) THEN ! multi
208cc IPT = INT((1+NPT)/2) ! NPT = 1
209 ipt = ilay
210 IF (elbuf_tab(ng)%BUFLY(ipt)%L_PLA > 0) THEN
211 lbuf => elbuf_tab(ng)%BUFLY(ipt)%LBUF(1,1,1)
212 xlbuf => xfem_tab(ng,ixel)%BUFLY(ipt)%LBUF(1,1,1)
213 DO i=lft,llt
214 n = i + ni
215 elcrk = iel_crk(n)
216 IF (elcrk > 0) THEN
217 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
218 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
219 evar(i) = abs(lbuf%PLA(i)) ! for law25, plastic work < 0 if the layer has reached failure-p
220 ELSE ! cracked layer
221 evar(i) = abs(xlbuf%PLA(i)) ! for law25, plastic work < 0 if the layer has reached failure-p
222 ENDIF
223 ENDIF
224 ENDDO
225 ENDIF ! IF (L_PLA > 0)
226 ELSEIF (gbuf%G_PLA > 0 ) THEN ! mono
227 ipt = max(1,int((1+npt)/2))
228 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,ipt)
229 xlbuf => xfem_tab(ng,ixel)%BUFLY(1)%LBUF(1,1,ipt)
230 DO i=lft,llt
231 n = i + ni
232 elcrk = iel_crk(n)
233 IF (elcrk > 0) THEN
234 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
235 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
236 evar(i) = abs(lbuf%PLA(i)) ! for law25, plastic work < 0 if the layer has reached failure-p
237 ELSE ! cracked layer
238 evar(i) = abs(xlbuf%PLA(i)) ! for law25, plastic work < 0 if the layer has reached failure-p
239 ENDIF
240 ENDIF
241 ENDDO
242 ENDIF ! IF (NLAY > 1)
243 ELSEIF (ifunc == 3) THEN ! EINT
244 IF (nlay > 1) THEN ! multi
245 DO i=lft,llt
246 n = i + ni
247 elcrk = iel_crk(n)
248 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
249 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
250 evar(i) = gbuf%EINT(i) + gbuf%EINT(i+llt)
251 ELSE ! cracked layer
252 evar(i) = xlbuf%EINT(i) + xlbuf%EINT(i+llt)
253 ENDIF
254 ENDDO
255 ELSE ! mono
256 DO i=lft,llt
257 n = i + ni
258 elcrk = iel_crk(n)
259 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
260 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
261 evar(i) = gbuf%EINT(i) + gbuf%EINT(i+llt)
262 ELSE ! cracked layer
263 evar(i) = xgbuf%EINT(i) + xgbuf%EINT(i+llt)
264 ENDIF
265 ENDDO
266 ENDIF ! IF (NLAY > 1)
267 ELSEIF (ifunc == 5) THEN ! THK
268 IF (nlay > 1) THEN ! multi
269 DO i=lft,llt
270 evar(i) = xlbuf%THK(i)
271 ENDDO
272 ELSE ! mono
273 DO i=lft,llt
274 evar(i) = xgbuf%THK(i)
275 ENDDO
276 ENDIF
277 ELSEIF (ifunc == 7) THEN ! Von Mises
278 IF (nlay > 1) THEN ! multi
279 DO i=lft,llt
280 n = i + ni
281 elcrk = iel_crk(n)
282 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
283 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
284 s1 = gbuf%FOR(jj(1)+i)
285 s2 = gbuf%FOR(jj(2)+i)
286 s12= gbuf%FOR(jj(3)+i)
287 ELSE ! cracked layer
288 s1 = xlbuf%FOR(jj(1)+i)
289 s2 = xlbuf%FOR(jj(2)+i)
290 s12= xlbuf%FOR(jj(3)+i)
291 ENDIF
292 vonm2= s1*s1 + s2*s2 - s1*s2 + three*s12*s12
293 evar(i) = sqrt(vonm2)
294 ENDDO
295 ELSE ! mono
296 DO i=lft,llt
297 n = i + ni
298 elcrk = iel_crk(n)
299 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
300 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
301 s1 = gbuf%FOR(jj(1)+i)
302 s2 = gbuf%FOR(jj(2)+i)
303 s12= gbuf%FOR(jj(3)+i)
304 ELSE ! cracked layer
305 s1 = xgbuf%FOR(jj(1)+i)
306 s2 = xgbuf%FOR(jj(2)+i)
307 s12= xgbuf%FOR(jj(3)+i)
308 ENDIF
309 vonm2= s1*s1 + s2*s2 - s1*s2 + three*s12*s12
310 evar(i) = sqrt(vonm2)
311 ENDDO
312 ENDIF ! IF (NLAY > 1)
313c---
314 ELSEIF (ifunc >= 14 .AND. ifunc <= 15) THEN
315c--- Sigx, Sigy
316 ius = ifunc-13
317 IF (nlay > 1) THEN ! multi
318 DO i=lft,llt
319 n = i + ni
320 elcrk = iel_crk(n)
321 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
322 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
323 evar(i) = gbuf%FOR(jj(ius)+i)
324 ELSE ! cracked layer
325 evar(i) = xlbuf%FOR(jj(ius)+i)
326 ENDIF
327 ENDDO
328 ELSE ! mono
329 DO i=lft,llt
330 n = i + ni
331 elcrk = iel_crk(n)
332 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
333 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
334 evar(i) = gbuf%FOR(jj(ius)+i)
335 ELSE ! cracked layer
336 evar(i) = xgbuf%FOR(jj(ius)+i)
337 ENDIF
338 ENDDO
339 ENDIF ! IF (NLAY > 1)
340c---
341 ELSEIF (ifunc >= 17 .AND. ifunc <= 19) THEN
342c--- Sigyx
343 ius = ifunc-14
344 IF (nlay > 1) THEN ! multi
345 DO i=lft,llt
346 n = i + ni
347 elcrk = iel_crk(n)
348 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
349 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
350 evar(i) = gbuf%FOR(jj(ius)+i)
351 ELSE ! cracked layer
352 evar(i) = xgbuf%FOR(jj(ius)+i)
353 ENDIF
354 ENDDO
355 ELSE ! mono
356 DO i=lft,llt
357 n = i + ni
358 elcrk = iel_crk(n)
359 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
360 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
361 evar(i) = gbuf%FOR(jj(ius)+i)
362 ELSE ! cracked layer
363 evar(i) = xgbuf%FOR(jj(ius)+i)
364 ENDIF
365 ENDDO
366 ENDIF ! IF (NLAY > 1)
367c---
368 ELSEIF (ifunc == 26 .and. gbuf%G_EPSD > 0) THEN
369 IF (nlay > 1) THEN ! multi
370 DO i=lft,llt
371 n = i + ni
372 elcrk = iel_crk(n)
373 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
374 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
375 evar(i) = gbuf%EPSD(i)
376 ELSE ! cracked layer
377 evar(i) = xlbuf%EPSD(i)
378 ENDIF
379 ENDDO
380 ELSE ! mono
381 DO i=lft,llt
382 n = i + ni
383 elcrk = iel_crk(n)
384 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
385 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
386 evar(i) = gbuf%EPSD(i)
387 ELSE ! cracked layer
388 evar(i) = xgbuf%EPSD(i)
389 ENDIF
390 ENDDO
391 ENDIF ! IF (NLAY > 1)
392c---
393 ELSEIF (ifunc == 2155) THEN
394C
395 IF (ity == 3) THEN
396 DO i=lft,llt
397 pid(i) = ixc(6,nft+1)
398 ENDDO
399 ELSEIF (ity == 7) THEN
400 DO i=lft,llt
401 pid(i) = ixtg(5,nft+1)
402 ENDDO
403 ENDIF
404C
405 DO i=lft,llt
406 n = i + ni
407 thke0(i) = thke(n) * geo(300+ilay,pid(i))
408 ENDDO
409C
410 IF (nlay > 1) THEN ! multi
411 DO i=lft,llt
412 n = i + ni
413 elcrk = iel_crk(n)
414 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
415 thk0 = thke0(i)
416 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
417C EVAR(I) = HUNDRED *(THKE(N) - GBUF%THK(I))/THKE(N)
418 evar(i) = hundred *(thk0 - xlbuf%THK(i))/thk0
419 ELSE ! cracked layer
420 evar(i) = hundred *(thk0 - xlbuf%THK(i))/thk0
421 ENDIF
422 ENDDO
423 ELSE ! mono
424 DO i=lft,llt
425 n = i + ni
426 elcrk = iel_crk(n)
427 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
428 thk0 = thke(n)
429 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
430 evar(i) = hundred *(thk0 - gbuf%THK(i))/thk0
431 ELSE ! cracked layer
432 evar(i) = hundred *(thk0 - xgbuf%THK(i))/thk0
433 ENDIF
434 ENDDO
435 ENDIF ! IF (NLAY > 1)
436C---
437 ELSEIF (ifunc == 2040) THEN ! EPSP/UPPER
438 IF (nlay > 1) THEN
439 il = max(1,npt)
440 ipt = 1
441 ELSE
442 il = 1
443 ipt = max(1,npt)
444 ENDIF
445
446 IF (elbuf_tab(ng)%BUFLY(il)%L_PLA > 0) THEN
447 IF (nlay > 1) THEN ! multi
448 DO i=lft,llt
449 n = i + ni
450 elcrk = iel_crk(n)
451 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
452 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
453 evar(i) = abs(
454 . elbuf_tab(ng)%BUFLY(il)%LBUF(1,1,ipt)%PLA(i))
455 ELSE ! cracked layer
456 evar(i) = abs(
457 . xfem_tab(ng,ixel)%BUFLY(ilay)%LBUF(1,1,ipt)%PLA(i))
458 ENDIF
459 ENDDO
460 ELSE ! mono
461 DO i=lft,llt
462 n = i + ni
463 elcrk = iel_crk(n)
464 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
465 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
466 evar(i) = abs(
467 . elbuf_tab(ng)%BUFLY(il)%LBUF(1,1,ipt)%PLA(i))
468 ELSE ! cracked layer
469 evar(i) = abs(
470 . xfem_tab(ng,ixel)%BUFLY(il)%LBUF(1,1,ipt)%PLA(i))
471 ENDIF
472 ENDDO
473 ENDIF ! IF (NLAY > 1)
474 ELSE
475 DO i=lft,llt
476 evar(i) = zero
477 ENDDO
478 ENDIF ! IF (BUFLY%L_PLA > 0)
479c------------------------------------
480 ELSEIF (ifunc == 2041) THEN ! EPSP/LOWER
481c------------------------------------
482 IF (nlay > 1) THEN
483 il = max(1,npt)
484 ipt = 1
485 ELSE
486 il = 1
487 ipt = max(1,npt)
488 ENDIF
489 IF (elbuf_tab(ng)%BUFLY(il)%L_PLA > 0) THEN
490 il = 1
491 IF (nlay > 1) il = ilay
492 DO i=lft,llt
493 n = i + ni
494 elcrk = iel_crk(n)
495 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
496 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
497 evar(i) = abs(
498 . elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)%PLA(i))
499 ELSE ! cracked layer
500 evar(i) = abs(
501 . xfem_tab(ng,ixel)%BUFLY(il)%LBUF(1,1,1)%PLA(i))
502 ENDIF
503 ENDDO
504 ELSE
505 DO i=lft,llt
506 evar(i) = zero
507 ENDDO
508 ENDIF
509c------------------------------------
510 ELSEIF (ifunc >= 2042 .AND. ifunc <= 2141) THEN
511c------------------------------------
512 IF (npt == 0) THEN
513 il = 1
514 ipt = 1
515 ELSEIF (nlay > 1) THEN
516 il = mod((ifunc - 2041), 100)
517 ipt = 1
518 IF (il == 0) il = 100
519 ELSE
520 il = 1
521 ipt = mod((ifunc - 2041), 100)
522 IF (ipt == 0) ipt = 100
523 ENDIF
524 IF (elbuf_tab(ng)%BUFLY(il)%L_PLA > 0) THEN
525 IF (nlay > 1) THEN ! multi
526 DO i=lft,llt
527 n = i + ni
528 elcrk = iel_crk(n)
529 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
530 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
531 evar(i) = abs(
532 . elbuf_tab(ng)%BUFLY(il)%LBUF(1,1,ipt)%PLA(i))
533 ELSE ! cracked layer
534 evar(i) = abs(
535 . xfem_tab(ng,ixel)%BUFLY(ilay)%LBUF(1,1,ipt)%PLA(i))
536 ENDIF
537 ENDDO
538 ELSE ! mono
539 DO i=lft,llt
540 n = i + ni
541 elcrk = iel_crk(n)
542 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
543 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
544 evar(i) = abs(
545 . elbuf_tab(ng)%BUFLY(il)%LBUF(1,1,ipt)%PLA(i))
546 ELSE ! cracked layer
547 evar(i) = abs(
548 . xfem_tab(ng,ixel)%BUFLY(il)%LBUF(1,1,ipt)%PLA(i))
549 ENDIF
550 ENDDO
551 ENDIF ! IF (NLAY > 1)
552 ELSE
553 DO i=lft,llt
554 evar(i) = zero
555 ENDDO
556 ENDIF
557 ENDIF ! IFUNC
558C----------------------
559 IF(mlw == 0 .OR. mlw == 13)THEN
560 DO i=lft,llt
561 n = i + ni
562 IF(iel_crk(n) > 0) THEN
563 ie(icrk) = ie(icrk) + 1
564 func(el2fa(nelcrk(icrk) + ie(icrk))) = zero
565 ENDIF
566 ENDDO
567C-------------------
568 ELSEIF (ifunc == 3) THEN
569C energie specifique
570C-------------------
571 IF (ity == 3) THEN
572 DO i=lft,llt
573 n = i + ni
574 IF (iel_crk(n) > 0) THEN
575 ie(icrk) = ie(icrk) + 1
576 func(el2fa(nelcrk(icrk) + ie(icrk))) = evar(i)/
577 . max(em30,mass(el2fa0(nn4+i+nft)))
578 ENDIF
579 ENDDO
580 ELSEIF (ity == 7) THEN
581 DO i=lft,llt
582 n = i + ni
583 IF (iel_crk(n) > 0) THEN
584 ie(icrk) = ie(icrk) + 1
585 func(el2fa(nelcrk(icrk) + ie(icrk))) = evar(i)/
586 . max(em30,mass(el2fa0(nn5+i+nft)))
587 ENDIF
588 ENDDO
589 ENDIF
590C-------------------
591 ELSEIF (ifunc == 25 .AND. ity == 3) THEN
592C energie hourglass
593C-------------------
594 DO i=lft,llt
595 n = i + nft
596 IF (iel_crk(n) > 0) THEN
597 ie(icrk) = ie(icrk) + 1
598 func(el2fa(nelcrk(icrk) + ie(icrk))) = ehour(n+numels)/
599 . max(em30,mass(el2fa0(nn4+n)))
600 ENDIF
601 ENDDO
602C-------------------
603 ELSE ! IFUNC SHELLS
604C cas general
605C-------------------
606 DO i=lft,llt
607 n = i + ni
608 IF (iel_crk(n) > 0) THEN
609 ie(icrk) = ie(icrk) + 1
610 func(el2fa(nelcrk(icrk) + ie(icrk))) = evar(i)
611 ENDIF
612 ENDDO
613 ENDIF ! IFUNC
614C-----------------------------------------------
615C FIN DE BOUCLE SUR LES OFFSET
616C-----------------------------------------------
617 ENDDO ! DO ILAY=1,NLAY
618 ENDDO ! DO IXEL=1,NXEL
619 ENDDO ! DO OFFSET
620 ENDIF ! MLW /= 13
621 ENDDO ! DO NG=1,NGROUP
622C-----------------------------------------------=
623 DO crks = 1,ncrkpart
624 icrk = indx_crk(crks)
625C
626 nel_crk = nelcrk(icrk)
627C
628 IF (nspmd == 1) THEN
629 DO i=1,ie(icrk)
630 n = el2fa(nel_crk + i)
631 r4 = func(n)
632 CALL write_r_c(r4,1)
633 ENDDO
634 ELSE
635 DO i=1,ie(icrk)
636 n = el2fa(nel_crk + i)
637 wal(i+nel_crk) = func(n)
638 ENDDO
639 ENDIF
640 ENDDO
641C
642 IF (nspmd > 1 ) THEN
643 IF (ispmd == 0) THEN
644 buf = nbf_crkxfemg
645 ELSE
646 buf=1
647 ENDIF
648 CALL spmd_r4get_partn(1,nbf_l,nbpart,iadg,wal,buf)
649 ENDIF
650C
651 DEALLOCATE(matly)
652 DEALLOCATE(wal)
653 RETURN
654 END
dfuncc_crk
subroutine dfuncc_crk(elbuf_tab, len, ifunc, iparg, geo, ixc, ixtg, mass, pm, el2fa, nbf, iadp, nbf_l, ehour, anim, nbpart, iadg, ipm, igeo, thke, err_thk_sh4, err_thk_sh3, xfem_tab, iel_crk, indx_crk, nbf_crkxfemg, el2fa0, crkedge)
Definition dfuncc_crk.F:44
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
crackxfem_mod
Definition crackxfem_mod.F:121
crackxfem_mod::crkshell
type(xfem_shell_), dimension(:), allocatable crkshell
Definition crackxfem_mod.F:190
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
spmd_r4get_partn
subroutine spmd_r4get_partn(size, nbf_l, nbpart, iadg, wal, buf)
Definition spmd_r4get_partn.F:47
write_r_c
void write_r_c(float *w, int *len)
Definition write_routtines.c:519