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