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