OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
tensorc_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!|| tensorc_crk ../engine/source/output/anim/generate/tensorc_crk.F
25!||--- called by ------------------------------------------------------
26!|| genani ../engine/source/output/anim/generate/genani.F
27!||--- calls -----------------------------------------------------
28!|| sigrota_xfe ../engine/source/output/anim/generate/sigrota_xfe.F
29!|| spmd_r4get_partn ../engine/source/mpi/anim/spmd_r4get_partn.F
30!|| urotov ../engine/source/airbag/uroto.F
31!|| write_r_c ../common_source/tools/input_output/write_routines.c
32!||--- uses -----------------------------------------------------
33!|| crackxfem_mod ../engine/share/modules/crackxfem_mod.F
34!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
35!|| element_mod ../common_source/modules/elements/element_mod.F90
36!|| matparam_def_mod ../common_source/modules/mat_elem/matparam_def_mod.F90
37!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
38!||====================================================================
39 SUBROUTINE tensorc_crk(ELBUF_TAB,XFEM_TAB,IPARG ,IPM ,
40 1 ITENS ,INVERT ,EL2FA ,NBF ,
41 2 LEN ,EPSDOT ,IADP ,NBF_L ,
42 3 NBPART ,IADG ,X ,IXC ,
43 4 IGEO ,IXTG ,IEL_CRK ,IADC_CRK,
44 5 CRKEDGE ,INDX_CRK,MAT_PARAM )
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE my_alloc_mod
49 USE crackxfem_mod
50 USE elbufdef_mod
51 USE matparam_def_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 "mvsiz_p.inc"
61C-----------------------------------------------
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 IPARG(NPARG,*),ITENS,INVERT(*),INDX_CRK(*),
71 . EL2FA(*),IXC(NIXC,*),IGEO(NPROPGI,*),
72 . NBF,IADP(*),NBF_L,NBPART,IADG(NSPMD,*),
73 . IXTG(NIXTG,*),LEN,IEL_CRK(*),IADC_CRK(*),
74 . IPM(NPROPMI,*)
75C REAL
76 my_real
77 . epsdot(6,*),x(3,*)
78 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
79 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP,NXEL), TARGET :: XFEM_TAB
80 TYPE (XFEM_EDGE_) , DIMENSION(*) :: CRKEDGE
81 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85C REAL
86 my_real
87 . a1,a2,a3,thk,sige(mvsiz,5)
88 my_real, DIMENSION(:,:),ALLOCATABLE :: tens
89 REAL R4(18)
90 INTEGER I,NI,NG,NEL,NFT,ITY,LFT,NPT,IPT,
91 . n,j,llt,mlw,istrain,
92 . ipid,istre,nni,n0,
93 . ihbe,irep,buf,nel_crk,
94 . nlay,ixel,ilay,nuvarv,ivisc,
95 . ipmat,igtyp,matly,nlevxf,npg,icrk,jj(8)
96C
97 INTEGER IXFEM, CRKS, ITG, NN1, NN2,
98 . NN3,NN4,NN5,NN6
99 REAL, DIMENSION(:,:), ALLOCATABLE :: WA
100 INTEGER, DIMENSION(:), ALLOCATABLE :: NELCRK
101 INTEGER, DIMENSION(:), ALLOCATABLE :: IE
102 INTEGER ILAYCRK,ELCRK,NPT0
103 INTEGER PID(MVSIZ),MAT(MVSIZ)
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 my_real,
113 . DIMENSION(:), POINTER :: dir_a
114C=======================================================================
115!
116 CALL my_alloc(tens,3,len)
117 CALL my_alloc(wa,3,nbf_l)
118 CALL my_alloc(nelcrk,ncrkpart)
119 CALL my_alloc(ie,ncrkpart)
120
121 nel_crk = 0
122 itg = 1 + 4*ecrkxfec
123 tens = zero
124c
125 DO crks = 1,ncrkpart
126 icrk = indx_crk(crks)
127 nelcrk(crks) = nel_crk
128 nel_crk = nel_crk + crkshell(icrk)%CRKNUMSHELL
129 ie(icrk) = 0
130 ENDDO
131C
132 DO j=1,18
133 r4(j) = zero
134 ENDDO
135C
136 nn1 = 1
137 nn2 = nn1
138 nn3 = nn2
139 nn4 = nn3 + numelq
140 nn5 = nn4 + numelc
141 nn6 = nn5 + numeltg
142C
143
144 DO ng=1,ngroup
145 mlw = iparg(1,ng)
146 nel = iparg(2,ng)
147 nft = iparg(3,ng)
148 ity = iparg(5,ng)
149 npt = iabs(iparg(6,ng))
150 istrain= iparg(44,ng)
151 ihbe = iparg(23,ng)
152 igtyp = iparg(38,ng)
153 ixfem = iparg(54,ng)
154 nlevxf = iparg(65,ng)
155 lft=1
156 llt=nel
157!
158 DO i=1,8 ! length max of GBUF%G_STRA = 8
159 jj(i) = nel*(i-1)
160 ENDDO
161!
162 DO i=lft,llt
163 DO j=1,5
164 sige(i,j) = zero
165 ENDDO
166 ENDDO
167!
168 IF (ihbe == 11) cycle
169 IF (ixfem /= 1 .AND. ixfem /= 2) cycle
170 IF (ity /= 3 .AND. ity /= 7) cycle
171C-----------------------------------------------
172C COQUES 3N, 4N
173C-----------------------------------------------
174 gbuf => elbuf_tab(ng)%GBUF
175cc NLAY = ELBUF_TAB(NG)%NLAY
176cc NPTT = ELBUF_TAB(NG)%NPTT
177cc NXEL = ELBUF_TAB(NG)%NXEL
178 IF (ity == 3) THEN
179 n0 = 0
180 nni = nn4
181 ni = nft
182 ELSE
183 n0 = numelc
184 nni = nn5
185 ni = nft + numelc
186 ENDIF
187C
188 npg = 0
189 npt0 = npt ! save global NPT
190C-----------------------------------------
191C-----------------------------------------
192 IF (ixfem == 1) npt = 1 ! multlayer xfem
193C-----------------------------------------
194C-----------------------------------------
195 a1 = zero
196 a2 = zero
197 a3 = zero
198 istre = 1
199C
200C------------------------
201C STRESS
202C------------------------
203 IF (itens == 1) THEN
204 a1 = one
205 a2 = zero
206 ELSEIF (itens == 2) THEN
207 a1 = zero
208 a2 = one
209 ELSEIF (itens == 3) THEN
210 IF (mlw == 1) THEN
211 a1 = one
212 a2 = six
213 ELSEIF (mlw == 2 .OR. mlw == 19 .OR.
214 . mlw == 15 .OR.
215 . mlw == 22 .OR. mlw == 25 .OR.
216 . mlw == 27 .OR. mlw == 32 .OR.
217 . mlw >= 28) THEN
218 a1 = one
219 a2 = zero
220 ipt = npt
221 ELSEIF (mlw == 3 .OR. mlw == 23) THEN
222 a1 = one
223 a2 = zero
224 ENDIF
225 ELSEIF (itens == 4) THEN
226 IF (mlw == 1) THEN
227 a1 = one
228 a2 = -six
229 ELSEIF (mlw == 2 .OR. mlw == 19 .OR.
230 . mlw == 15 .OR.
231 . mlw == 22 .OR. mlw == 25.OR.
232 . mlw == 27 .OR. mlw == 32.OR.
233 . mlw >= 28) THEN
234 ipt = 1
235 a1 = one
236 a2 = zero
237 ELSEIF (mlw == 3 .OR. mlw == 23) THEN
238 a1 = one
239 a2 = zero
240 ENDIF
241 ELSEIF (itens >= 101 .AND. itens <= 200) THEN
242 IF (mlw == 1 .OR. mlw == 3 .OR. mlw == 23) THEN
243 a1 = one
244 a2 = zero
245 ELSEIF (mlw == 2 .OR. mlw == 19 .OR.
246 . mlw == 15 .OR.
247 . mlw == 22 .OR. mlw == 25 .OR.
248 . mlw == 27 .OR. mlw == 32 .OR.
249 . mlw >= 28) THEN
250 ipt = min(npt,itens-100)
251 a1 = one
252 a2 = zero
253 ENDIF
254C------------------------
255C STRAIN
256C------------------------
257 ELSEIF (itens == 5) THEN
258 istre = 0
259 a1 = zero
260 a2 = zero
261 IF (istrain == 1) THEN
262 a1 = one
263 ENDIF
264 ELSEIF (itens == 6) THEN
265 istre = 0
266 a1 = zero
267 a2 = zero
268 IF (istrain == 1) THEN
269 a2 = one
270 ENDIF
271 ELSEIF (itens == 7) THEN
272 istre = 0
273 a1 = zero
274 a2 = zero
275 IF (istrain == 1) THEN
276 a1 = one
277 a2 = half
278 ENDIF
279 ELSEIF (itens == 8) THEN
280 istre = 0
281 a1 = zero
282 a2 = zero
283 IF (istrain == 1) THEN
284 a1 = one
285 a2 = -half
286 ENDIF
287 ELSEIF (itens >= 201 .AND. itens <= 300) THEN
288 istre = 0
289 a1 = zero
290 a2 = zero
291 IF (istrain == 1 .AND. npt /= 0) THEN
292 ipt = min(npt,itens - 200)
293 a1 = one
294c A2 = HALF*(((2*ILAY-ONE)/NPT0)-ONE)
295 a2 = half*(((2*ipt-one)/npt)-one)
296 ENDIF
297C------------------------
298C STRAIN RATE
299C------------------------
300 ELSEIF (itens == 91) THEN
301 istre = 2
302 a1 = one
303 a2 = zero
304 ELSEIF (itens == 92) THEN
305 istre = 2
306 a1 = zero
307 a2 = one
308 ELSEIF (itens == 93) THEN
309 istre = 2
310 a1 = one
311 a2 = half
312 ELSEIF (itens == 94) THEN
313 istre = 2
314 a1 = one
315 a2 = -half
316 ELSEIF (itens >= 301 .AND. itens <= 400) THEN
317 IF (npt /= 0) THEN
318 istre = 2
319 ipt = min(npt,itens - 300)
320 a1 = one
321c A2 = HALF*(((2*ILAY-ONE)/NPT0)-ONE)
322 a2 = half*(((2*ipt-one)/npt)-one)
323 ELSE
324 istre = 2
325 a1 = one
326 a2 = zero
327 ENDIF
328 ENDIF ! IF (ITENS == 1)
329C-----------------------------------------
330C-----------------------------------------
331C LOOP OVER PHANTOM ELEMENTS
332C-----------------------------------------
333C-----------------------------------------
334 DO ixel=1,nxel
335 xgbuf => xfem_tab(ng,ixel)%GBUF
336 nlay = xfem_tab(ng,ixel)%NLAY
337 DO ilay=1,nlay
338C---
339 icrk = nxel*(ilay-1) + ixel
340C---
341 IF (mlw == 0) THEN
342 DO i=lft,llt
343 n = i + ni
344 IF (iel_crk(n) > 0) THEN
345 ie(icrk) = ie(icrk) + 1
346 tens(1,el2fa(nelcrk(icrk) + ie(icrk))) = zero
347 tens(2,el2fa(nelcrk(icrk) + ie(icrk))) = zero
348 tens(3,el2fa(nelcrk(icrk) + ie(icrk))) = zero
349 ENDIF
350 ENDDO
351 cycle
352 ENDIF
353C---
354 IF (istre == 1) THEN
355C------------------------
356C STRESS
357C------------------------
358 IF (ity == 3) THEN
359 ipid = ixc(6,nft+1)
360 igtyp = igeo(11,ixc(6,nft+1))
361 DO i=lft,llt
362 mat(i)=ixc(1,nft+i)
363 pid(i)=ixc(6,nft+i)
364 ENDDO
365 ELSE ! ITY == 7
366 ipid = ixtg(5,nft+1)
367 igtyp = igeo(11,ixtg(5,nft+1))
368 DO i=lft,llt
369 mat(i)=ixtg(1,nft+i)
370 pid(i)=ixtg(5,nft+i)
371 ENDDO
372 ENDIF
373c
374 irep = igeo(6,ipid)
375 ivisc = 0
376 nuvarv = 0
377 IF (mlw == 25) THEN
378 IF (igtyp == 11) THEN
379 ipmat = 100
380 DO i=1,nel
381 matly = igeo(ipmat+ilay,pid(i))
382 IF (mat_param(matly)%IVISC > 0 ) ivisc = 1
383 ENDDO
384c ELSEIF (IGTYP == 9 .OR. IGTYP == 10) THEN
385c ELSEIF (IGTYP == 17) THEN
386 ENDIF
387 ENDIF ! mlw == 25
388C----------
389 IF (((itens >= 101.AND.itens <= 200).OR.itens==3.OR.itens==4)
390 . .AND.(mlw == 25.OR.mlw == 15.OR.(mlw>=28 .AND.
391 . igtyp==11)).AND.irep == 1) THEN
392 CALL sigrota_xfe(elbuf_tab(ng),xfem_tab(ng,ixel),
393 1 lft ,llt ,nft ,ilay ,nel ,
394 2 ity ,iel_crk,iadc_crk,iadc_crk(itg),ixfem,
395 3 icrk ,nlay ,sige ,ivisc ,crkedge )
396 DO i=lft,llt
397 n = i + ni
398 IF (iel_crk(n) > 0) THEN
399 ie(icrk) = ie(icrk) + 1
400 DO j = 1,3
401 r4(j) = sige(i,j)
402 ENDDO
403cc R4(3) = R4(3) * INVERT(EL2FA(NEL_CRK + IE(ICRK)))
404 tens(1,el2fa(nelcrk(icrk) + ie(icrk))) = r4(1)
405 tens(2,el2fa(nelcrk(icrk) + ie(icrk))) = r4(2)
406 tens(3,el2fa(nelcrk(icrk) + ie(icrk))) = r4(3)
407 ENDIF
408 ENDDO
409 ELSEIF (((itens >= 101.AND.itens <= 200).OR.itens==3.OR.
410 . itens==4).AND.(mlw == 25.OR.mlw == 15.OR.(mlw>=28 .AND.
411 . igtyp==11)).AND.irep == 0) THEN
412C stesses
413 IF (nlay > 1) THEN
414 lbuf => elbuf_tab(ng)%BUFLY(ilay)%LBUF(1,1,1)
415 xlbuf => xfem_tab(ng,ixel)%BUFLY(ilay)%LBUF(1,1,1)
416 ELSE
417 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,ilay)
418 xlbuf => xfem_tab(ng,ixel)%BUFLY(1)%LBUF(1,1,ilay)
419 ENDIF
420C
421 DO i=lft,llt
422 n = i + ni
423 elcrk = iel_crk(n)
424 IF (elcrk > 0) THEN
425 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
426 IF (ilaycrk == 0 .OR.abs(ilaycrk) == 1) THEN ! uncracked layer
427 IF (nlay > 1) THEN
428 DO j=1,5
429 sige(i,j) = gbuf%FOR(jj(j)+i) ! global from standard elem
430 ENDDO
431 ELSEIF (nlay == 1) THEN
432 DO j=1,5
433 sige(i,j) = gbuf%FOR(jj(j)+i) ! global from standard elem
434 ENDDO
435 ENDIF
436 ELSE ! cracked layer
437 IF (nlay > 1) THEN
438 DO j=1,5
439 sige(i,j) = xlbuf%FOR(jj(j)+i)
440 ENDDO
441 ELSEIF (nlay == 1) THEN
442 DO j=1,5
443 sige(i,j) = xgbuf%FOR(jj(j)+i)
444 ENDDO
445 ENDIF
446 ENDIF
447 ENDIF
448 ENDDO
449C visc
450 IF (ivisc > 0) THEN
451 DO i=lft,llt
452 n = i + ni
453 elcrk = iel_crk(n)
454 IF (elcrk > 0) THEN
455 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
456 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
457 DO j=1,5
458 sige(i,j) = sige(i,j) + lbuf%VISC(jj(j)+i)
459 ENDDO
460 ELSE ! cracked layer
461 DO j=1,5
462 sige(i,j) = sige(i,j) + xlbuf%VISC(jj(j)+i)
463 ENDDO
464 ENDIF
465 ENDIF
466 ENDDO
467 ENDIF ! IF (IVISC > 0)
468C directions - a revoir - if uncracked
469c DO I=LFT,LLT
470c I1 = (I-1) * NS1
471c N = I + NI
472c ELCRK = IEL_CRK(N)
473c IF (ELCRK > 0) THEN
474c ILAYCRK = CRKEDGE(ILAY)%LAYCUT(ELCRK)
475c IF (ILAYCRK == 0 .OR.ABS(ILAYCRK) == 1) THEN ! uncracked layer
476c IF (NLAY > 1) THEN
477c DIR_A => ELBUF_TAB(NG)%BUFLY(ILAY)%DIRA
478c ELSE
479c DIR_A => ELBUF_TAB(NG)%BUFLY(1)%DIRA
480c ENDIF
481c ELSE ! cracked layer
482c IF (NLAY > 1) THEN
483c DIR_A => XFEM_TAB(NG,IXEL)%BUFLY(ILAY)%DIRA
484c ELSE
485c DIR_A => XFEM_TAB(NG,IXEL)%BUFLY(1)%DIRA
486c ENDIF
487c ENDIF
488c CALL UROTO(LFT,LLT,SIGE,DIR_A)
489c ENDIF
490c ENDDO
491 IF (nlay > 1) THEN
492 dir_a => xfem_tab(ng,ixel)%BUFLY(ilay)%DIRA
493 ELSE
494 dir_a => xfem_tab(ng,ixel)%BUFLY(1)%DIRA
495 ENDIF
496 CALL urotov(lft,llt,sige,dir_a,nel)
497!! temporary replaced by (the same) UROTOV() in order to do not affect
498!! the other multidimensional buffer ARRAYS which are still not modified
499!! CALL UROTO(LFT,LLT,SIGE,DIR_A)
500C
501 DO i=lft,llt
502 n = i + ni
503 IF (iel_crk(n) > 0) THEN
504 ie(icrk) = ie(icrk) + 1
505 DO j = 1,3
506 r4(j) = sige(i,j)
507 ENDDO
508 tens(1,el2fa(nelcrk(icrk) + ie(icrk))) = r4(1)
509 tens(2,el2fa(nelcrk(icrk) + ie(icrk))) = r4(2)
510 tens(3,el2fa(nelcrk(icrk) + ie(icrk))) = r4(3)
511 ENDIF
512 ENDDO
513C----------
514 ELSE ! ITENS
515 IF (nlay > 1) THEN
516 xlbuf => xfem_tab(ng,ixel)%BUFLY(ilay)%LBUF(1,1,1)
517 ELSE
518 xlbuf => xfem_tab(ng,ixel)%BUFLY(1)%LBUF(1,1,ilay)
519 ENDIF
520 DO i=lft,llt
521 n = i + ni
522 elcrk = iel_crk(n)
523 ie(icrk) = ie(icrk) + 1
524 IF (elcrk > 0) THEN
525 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
526 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
527 DO j=1,3
528 r4(j) = a1 * gbuf%FOR(jj(j)+i) + a2 * gbuf%MOM(jj(j)+i) ! global from standard elem
529 ENDDO
530 ELSE ! cracked layer
531 IF (nlay > 1) THEN
532 DO j=1,3
533 r4(j) = a1 * xlbuf%FOR(jj(j)+i) + a2 * xlbuf%MOM(jj(j)+i)
534 ENDDO
535 ELSEIF (nlay == 1) THEN
536 DO j=1,3
537 r4(j) = a1 * xgbuf%FOR(jj(j)+i) + a2 * xgbuf%MOM(jj(j)+i)
538 ENDDO
539 ENDIF
540 ENDIF
541 ENDIF
542 tens(1,el2fa(nelcrk(icrk) + ie(icrk))) = r4(1)
543 tens(2,el2fa(nelcrk(icrk) + ie(icrk))) = r4(2)
544 tens(3,el2fa(nelcrk(icrk) + ie(icrk))) = r4(3)
545 ENDDO
546 ENDIF ! IF (((ITENS >= 101 ...)
547 ELSEIF (istre == 0 .AND. gbuf%G_STRA > 0) THEN
548C------------------------
549C STRAIN
550C------------------------
551 IF (nlay > 1) THEN
552 xlbuf => xfem_tab(ng,ixel)%BUFLY(ilay)%LBUF(1,1,1)
553 ELSE
554 xlbuf => xfem_tab(ng,ixel)%BUFLY(1)%LBUF(1,1,ilay)
555 ENDIF
556 DO i=lft,llt
557 n = i + ni
558 elcrk = iel_crk(n)
559 IF (elcrk > 0) THEN
560 ilaycrk = crkedge(ilay)%LAYCUT(elcrk)
561 IF (ilaycrk == 0 .OR. abs(ilaycrk) == 1) THEN ! uncracked layer
562 thk = gbuf%THK(i)
563 IF (itens /= 6) THEN
564 DO j=1,3
565 r4(j) = a1 * gbuf%STRA(jj(j)+i) +
566 . a2 * gbuf%STRA(jj(j)+i) * thk
567 ENDDO
568 ELSE
569 DO j=1,3
570 r4(j) = gbuf%STRA(jj(j)+i)
571 ENDDO
572 ENDIF
573 ELSE ! cracked layer
574 IF (itens /= 6) THEN
575 IF (nlay > 1) THEN
576 thk = xlbuf%THK(i)
577 DO j=1,3
578 r4(j) = a1 * xlbuf%STRA(jj(j)+i) +
579 . a2 * xlbuf%STRA(jj(j)+i) * thk
580 ENDDO
581 ELSEIF (nlay == 1) THEN
582 thk = xgbuf%THK(i)
583 DO j=1,3
584 r4(j) = a1 * xgbuf%STRA(jj(j)+i) +
585 . a2 * xgbuf%STRA(jj(j)+i) * thk
586 ENDDO
587 ENDIF
588 ELSE
589 IF (nlay > 1) THEN
590 DO j=1,3
591 r4(j) = xlbuf%STRA(jj(j)+i)
592 ENDDO
593 ELSEIF (nlay == 1) THEN
594 DO j=1,3
595 r4(j) = xgbuf%STRA(jj(j)+i)
596 ENDDO
597 ENDIF
598 ENDIF
599 ENDIF
600C
601 ie(icrk) = ie(icrk) + 1
602cc R4(3) = R4(3) * INVERT(EL2FA(NELCRK(ICRK) + IE(ICRK))) * HALF
603 r4(3) = r4(3) * half
604 tens(1,el2fa(nelcrk(icrk) + ie(icrk))) = r4(1)
605 tens(2,el2fa(nelcrk(icrk) + ie(icrk))) = r4(2)
606 tens(3,el2fa(nelcrk(icrk) + ie(icrk))) = r4(3)
607 ENDIF ! IF (ELCRK > 0)
608 ENDDO ! DO I=LFT,LLT
609 ELSEIF (istre == 2) THEN
610C------------------------
611C STRAIN RATE
612C------------------------
613 DO i=lft,llt
614 n = i + ni
615 IF (iel_crk(n) > 0) THEN
616 thk = gbuf%THK(i)
617 IF (itens /= 92) THEN
618 DO j=1,3
619 r4(j) = a1*epsdot(j,n+n0) + a2*epsdot(j+3,n+n0)*thk
620 ENDDO
621 ELSE
622 DO j = 1,3
623 r4(j) = epsdot(j+3,n+n0)
624 ENDDO
625 ENDIF
626cc R4(3) = R4(3) * INVERT(EL2FA(NEL_CRK + IE)) * HALF
627 r4(3) = r4(3) * half
628 ie(icrk) = ie(icrk) + 1
629 tens(1,el2fa(nelcrk(icrk) + ie(icrk))) = r4(1)
630 tens(2,el2fa(nelcrk(icrk) + ie(icrk))) = r4(2)
631 tens(3,el2fa(nelcrk(icrk) + ie(icrk))) = r4(3)
632 ENDIF
633 ENDDO
634 ENDIF ! IF (ISTRE == 1)
635C-----------------------------------------------
636 ENDDO ! DO ILAY=1,NLAY
637 ENDDO ! DO IXEL=1,NXEL
638 ENDDO ! DO NG=1,NGROUP
639C----------------------------------------------
640 DO crks = 1,ncrkpart
641 icrk = indx_crk(crks)
642C
643 nel_crk = nelcrk(icrk)
644C
645 IF (nspmd == 1)THEN
646 DO i=1,ie(icrk)
647 n = el2fa(nel_crk + i)
648 r4(1) = tens(1,n)
649 r4(2) = tens(2,n)
650 r4(3) = tens(3,n)
651 CALL write_r_c(r4,3)
652 ENDDO
653 ELSE
654 DO i=1,ie(icrk)
655 n = el2fa(nel_crk + i)
656 wa(1,i+nel_crk) = tens(1,n)
657 wa(2,i+nel_crk) = tens(2,n)
658 wa(3,i+nel_crk) = tens(3,n)
659 ENDDO
660 ENDIF
661 ENDDO
662C
663 IF (nspmd > 1) THEN
664 IF (ispmd == 0) THEN
665 buf = nbf*3
666 ELSE
667 buf = 1
668 ENDIF
669 CALL spmd_r4get_partn(3,3*nbf_l,ncrkpart,iadg,wa,buf)
670 ENDIF
671C---
672 IF (ALLOCATED(tens)) DEALLOCATE(tens)
673 IF (ALLOCATED(wa)) DEALLOCATE(wa)
674 IF (ALLOCATED(nelcrk)) DEALLOCATE(nelcrk)
675 IF (ALLOCATED(ie)) DEALLOCATE(ie)
676 RETURN
677 END
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
crackxfem_mod
Definition crackxfem_mod.F:121
crackxfem_mod::crkshell
type(xfem_shell_), dimension(:), allocatable crkshell
Definition crackxfem_mod.F:190
sigrota_xfe
subroutine sigrota_xfe(elbuf_str, xfem_str, jft, jlt, nft, ilay, nel, ity, iel_crk, iadc_crk, iadtg_crk, ixfem, icrk, nlay, sig, ivisc, crkedge)
Definition sigrota_xfe.F:37
spmd_r4get_partn
subroutine spmd_r4get_partn(size, nbf_l, nbpart, iadg, wal, buf)
Definition spmd_r4get_partn.F:47
tensorc_crk
subroutine tensorc_crk(elbuf_tab, xfem_tab, iparg, ipm, itens, invert, el2fa, nbf, len, epsdot, iadp, nbf_l, nbpart, iadg, x, ixc, igeo, ixtg, iel_crk, iadc_crk, crkedge, indx_crk, mat_param)
Definition tensorc_crk.F:45
urotov
subroutine urotov(jft, jlt, sig, dir, nel)
Definition uroto.F:79
write_r_c
void write_r_c(float *w, int *len)
Definition write_routines.c:519