OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfuncc_ply.F File Reference
#include "implicit_f.inc"
#include "vect01_c.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "scr14_c.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine dfuncc_ply (elbuf_tab, func, 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, mat_param, nbf_pxfemg, x, stack)

Function/Subroutine Documentation

◆ dfuncc_ply()

subroutine dfuncc_ply ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
func,
integer ifunc,
integer, dimension(nparg,*) iparg,
geo,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
mass,
pm,
integer, dimension(*) el2fa,
integer nbf,
integer, dimension(*) iadp,
integer nbf_l,
ehour,
anim,
integer nbpart,
integer, dimension(nspmd,*) iadg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
thke,
err_thk_sh4,
err_thk_sh3,
type (matparam_struct_), dimension(nummat), intent(in) mat_param,
integer nbf_pxfemg,
x,
type (stack_ply) stack )

Definition at line 40 of file dfuncc_ply.F.

46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE initbuf_mod
50 USE plyxfem_mod
51 USE elbufdef_mod
52 USE stack_mod
53 USE matparam_def_mod
54 USE my_alloc_mod
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "vect01_c.inc"
63#include "mvsiz_p.inc"
64#include "com01_c.inc"
65#include "com04_c.inc"
66#include "scr14_c.inc"
67#include "param_c.inc"
68#include "task_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER IPARG(NPARG,*),IXC(NIXC,*),IXTG(NIXTG,*),EL2FA(*),
73 . IFUNC,NBF,NBF_L, NBPART,NBF_PXFEMG,
74 . IADP(*),IADG(NSPMD,*),IPM(NPROPMI,*),
75 . IGEO(NPROPGI,*)
76C REAL
77 my_real
78 . func(*), mass(*) , geo(npropg,*),
79 . ehour(*),anim(*),pm(npropm,*),thke(*),
80 . err_thk_sh4(*), err_thk_sh3(*), x(3,*)
81 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
82 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
83 TYPE (STACK_PLY) :: STACK
84C-----------------------------------------------
85C L o c a l V a r i a b l e s
86C-----------------------------------------------
87C REAL
88 my_real
89 . evar(mvsiz),
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),sige(mvsiz,5)
94 INTEGER I, NG, NEL, ISS, ISC,N, J, MLW, NUVAR, IUS,
95 . ISTRAIN,NN, K1, K2,JTURB,MT,IMID, IALEL,IPID,
96 . NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10,NF,
97 . LLL,NINTLAY,NFAIL,
98 . OFFSET,K,II,II_L,INC,KK,IHBE,
99 . NPTM,NPG, NBVU, I1, MPT, NEL5, NEL8,
100 . IPT,BUF,NPTR,NPTS,NPTT,NLAY,IR,IS,PTF,LENF,IL,
101 . IADR,IPMAT,PID(MVSIZ),MAT(MVSIZ),MATLY(MVSIZ*100),
102 . NEL_PLY,ILAYER,IFLAG,JJ(5)
103 INTEGER IE,ISHPLYXFEM,IP,JPID,IPPID,IPLY0,ILAST,ION,NUVARV,
104 . IVISC,IPMAT_IPLY,NUVARD,MAT_IPLY,
105 . MATPLY,LL,IPLYC,I3,I2
106 INTEGER PLYS,IPLY,PLYELEMS(NUMELC),ELC,NS1,MATL,
107 . IIGEO,IADI,ISUBSTACK
108 REAL R4
109 TYPE(G_BUFEL_) ,POINTER :: GBUF
110 TYPE(BUF_LAY_) ,POINTER :: BUFLY
111 TYPE(L_BUFEL_) ,POINTER :: LBUF
112 TYPE(BUF_INTLAY_) ,POINTER :: INTLAY
113 TYPE(BUF_INTLOC_) ,POINTER :: ILBUF
114 TYPE(BUF_FAIL_) ,POINTER :: FBUF
115 my_real,
116 . DIMENSION(:), POINTER :: uvar
117 REAL,DIMENSION(:),ALLOCATABLE:: WAL
118C-----------------------------------------------
119 CALL my_alloc(wal,nbf_l)
120!
121 ll = 0
122C
123 nel_ply = 0
124 DO plys = 1,nplypart
125 iply = indx_ply(plys)
126 plyelems=0
127 DO i=1,plyshell(iply)%PLYNUMSHELL
128 ipt = plyshell(iply)%SHELLIPT(i)
129 elc = plyshell(iply)%SHID(i)
130 plyelems(elc)=ipt
131 ENDDO
132C
133 nn1 = 1
134 nn3 = 1
135 nn4 = nn3 + numelq
136 nn5 = nn4 + numelc
137 nn6 = nn5 + numeltg
138 ie = 0
139 ilayer = 0
140 iflag = 0
141C
142 DO 900 ng=1,ngroup
143 CALL initbuf(iparg ,ng ,
144 2 mlw ,nel ,nft ,iad ,ity ,
145 3 npt ,jale ,ismstr ,jeul ,jturb ,
146 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
147 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
148 6 irep ,iint ,igtyp ,israt ,isrot ,
149 7 icsen ,isorth ,isorthg ,ifailure,jsms)
150 DO offset = 0,nel-1,nvsiz
151 nft = iparg(3,ng) + offset
152 lft = 1
153 llt = min(nvsiz,nel-offset)
154 ishplyxfem = iparg(50,ng)
155 isubstack = iparg(71,ng)
156C-----------------------------------------------
157C COQUES 3 N 4 N
158C-----------------------------------------------
159 IF (ishplyxfem > 0 .AND.(ity == 3.OR.ity == 7))THEN
160 gbuf => elbuf_tab(ng)%GBUF
161 npt =iparg(6,ng)
162 iss =iparg(9,ng)
163 ihbe =iparg(23,ng)
164 nptr = elbuf_tab(ng)%NPTR
165 npts = elbuf_tab(ng)%NPTS
166 nptt = elbuf_tab(ng)%NPTT
167 nlay = elbuf_tab(ng)%NLAY
168 nintlay = elbuf_tab(ng)%NINTLAY
169 npg = nptr*npts
170 mpt = iabs(npt)
171!
172 DO j=1,5
173 jj(j) = nel*(j-1)
174 ENDDO
175!
176 DO i=lft,llt
177 DO j=1,5
178 sige(i,j) = zero
179 ENDDO
180 ENDDO
181!
182c---------
183 DO i=lft,llt
184 evar(i) = zero
185 ENDDO
186c---------
187C
188C test sur un seul element du groupe
189C
190 n = 1 + nft
191 DO i=lft,llt
192 n = i + nft
193 ilayer = plyelems(n)
194 IF (ilayer > 0) iflag = 1
195 ENDDO
196C
197 IF (iflag == 0) GO TO 900
198 ilayer = iflag
199 iflag = 1
200c
201c IF(ITYP == 3) THEN
202c DO I=LFT,LLT
203c IE = IE + 1
204c FUNC(EL2FA(NEL_PLY + IE)) = ZERO
205c ENDDO
206c ENDIF
207cc GO TO 900
208cc ENDIF
209C
210cc IFLAG = 1
211c
212c---------
213 IF (ifunc == 1)THEN ! plastic strain
214c---------
215C
216 DO i=lft,llt
217C for law25, plastic work is negative
218C if the layer has reached failure-p
219 n = i + nft
220 ilayer = plyelems(n)
221 bufly => elbuf_tab(ng)%BUFLY(ilayer)
222 lbuf => elbuf_tab(ng)%BUFLY(ilayer)%LBUF(1,1,1)
223 IF(ilayer > 0) THEN
224 ! for law25, plastic work < 0 if the layer has reached failure-p
225 IF (npg > 1 .and. bufly%LY_PLAPT > 0) THEN
226 evar(i) = abs(bufly%PLAPT(i))
227 ELSEIF (npg == 1 .and. bufly%L_PLA > 0) THEN
228 evar(i) = abs(lbuf%PLA(i))
229 ENDIF
230 ENDIF
231 ENDDO
232 ELSEIF (ifunc == 3) THEN ! EINT
233 DO i=lft,llt
234c K1 = 2*(I-1)+1
235c K2 = 2*(I-1)+2
236c EVAR(I) = GBUF%EINT(K1) + GBUF%EINT(K2)
237 ENDDO
238c---------
239 ELSEIF(ifunc == 5)THEN ! THK
240c---------
241 DO i=lft,llt
242 evar(i) =zero
243 ENDDO
244c---------
245 ELSEIF(ifunc == 7)THEN ! Von Mises
246c---------available only for Batoz shell and TYPE17 PID
247 DO i=lft,llt
248 n = i + nft
249 ii = (i-1)*5
250 ilayer = plyelems(n)
251 s1 = zero
252 s2 = zero
253 s12 = zero
254 IF(ilayer > 0) THEN
255 bufly => elbuf_tab(ng)%BUFLY(ilayer)
256 DO ir=1,nptr
257 DO is=1,npts
258 lbuf => bufly%LBUF(ir,is,1)
259 s1 = s1 + lbuf%SIG(i )/npg
260 s2 = s2 + lbuf%SIG(nel + i)/npg
261 s12= s12 + lbuf%SIG(2*nel + i)/npg
262 ENDDO
263 ENDDO
264 vonm2= s1*s1 + s2*s2 - s1*s2 + three*s12*s12
265 evar(i) = sqrt(vonm2)
266 ENDIF
267 ENDDO
268c---------
269 ELSEIF (ifunc == 11)THEN
270c---------
271! IF(MLW == 25.OR.MLW == 15)THEN
272! NB13 = NB12 + 2*NEL*MAX(1,NPT)
273! NB15 = NB12 + 2*NEL*MAX(1,NPT)
274! NB12 = NB12 + 2*OFFSET*MAX(1,NPT)
275! NB13 = NB13 + 4*OFFSET*MAX(1,NPT)
276!cc DO J=1,NPT
277! N = (ILAYER - 1)*NEL
278! DO I=LFT,LLT
279! N = I + NFT
280! ILAYER = PLYELEMS(N)
281! IF(ILAYER > 0) THEN
282! N = (ILAYER - 1)*NEL
283! K1 = NB13 + N+I
284! K2 = NB15 + 2*N + 2*I-1
285! EVAR(I)=EVAR(I)+BUFEL(K1)*BUFEL(K2)
286! ENDIF
287! ENDDO
288! ENDIF
289c---------
290 ELSEIF(ifunc == 12)THEN
291c---------
292! IF(MLW == 25.OR.MLW == 15)THEN
293! nb13 = nb12 + 2*nel*max(1,npt)
294! NB15 = NB12 + 2*NEL*MAX(1,NPT)
295! NB12 = NB12 + 2*OFFSET*MAX(1,NPT)
296! NB13 = NB13 + 4*OFFSET*MAX(1,NPT)
297! DO I=LFT,LLT
298! N = I + NFT
299! ILAYER = PLYELEMS(N)
300! IF(ILAYER > 0) THEN
301! N = (ILAYER - 1)*NEL
302! K1 = NB13 + N+I
303! K2 = NB15 + 2*N+2*I
304! EVAR(I)=EVAR(I)+BUFEL(K1)*BUFEL(K2)
305! ENDIF
306! ENDDO
307! ENDIF
308c---------
309 ELSEIF(ifunc == 13)THEN ! DAM3
310c---------
311 IF(mlw == 25.OR.mlw == 15)THEN
312! IADD = NB12 + 6*NEL*MAX(1,NPT)
313! IADD = IADD + OFFSET
314! DO I=LFT,LLT
315! EVAR(I) = BUFEL(IADD+I)
316! ENDDO
317 ENDIF
318c---------
319 ELSEIF (ifunc>=14.AND.ifunc<=15) THEN
320c---------
321C
322Cit's available just for law25 and batoz shell
323 ipid = ixc(6,nft+1)
324 irep = igeo(6,ipid)
325 IF (mlw == 25.AND. irep == 1) THEN
326C +
327 IF(ity == 3)THEN
328 DO i=1,nel
329 mat(i)=ixc(1,nft+i)
330 pid(i)=ixc(6,nft+i)
331 END DO
332 ELSE
333 DO i=1,nel
334 mat(i)=ixtg(1,nft+i)
335 pid(i)=ixtg(5,nft+i)
336 END DO
337 END IF
338 ivisc = 0
339 IF(mlw == 25) THEN
340 IF(igtyp == 17)THEN
341! IIGEO = 40 + 5*(ISUBSTACK - 1)
342! IADI = IGEO(IIGEO + 3,PID(1))
343! IPPID = 2
344 ipmat = 2 + mpt
345! old stack organisation IPMAT = 300
346 nuvarv = 0
347 DO n=1,npt
348 iadr = (n-1)*nel
349 DO i=1,nel
350 matl = stack%IGEO(ipmat+n,isubstack)
351 IF (mat_param(matl)%IVISC > 0 ) ivisc = 1
352 END DO
353 END DO
354 END IF
355 ENDIF
356 ns1 = 5
357 CALL sigrota(lft ,llt ,nft ,ilayer ,nel ,
358 2 ns1 ,x ,ixc ,elbuf_tab(ng) ,
359 3 sige ,ity ,ixtg ,ihbe ,istrain ,
360 4 ivisc )
361 DO i=lft,llt
362 evar(i) = sige(i,ifunc - 13)
363 ENDDO
364 ELSEIF (mlw == 25 .AND. irep == 0) THEN
365 ius = ifunc-13
366 IF (ihbe == 11) THEN
367 lenf = nel*gbuf%G_FORPG/npg
368 DO i=lft,llt
369 evar(i) = zero
370 n = i + nft
371 ilayer = plyelems(n)
372 IF(ilayer > 0) THEN
373 DO ir=1,nptr
374 DO is=1,npts
375 k = nptr*(is-1) + ir
376 ptf = (k-1)*lenf+1
377 evar(i) = evar(i)+gbuf%FORPG(ptf+jj(ius)+i)/npg
378 ENDDO
379 ENDDO
380 ENDIF
381 ENDDO
382 ELSE
383 DO i=lft,llt
384 evar(i) = zero
385 n = i + nft
386 ilayer = plyelems(n)
387 IF(ilayer > 0) THEN
388 evar(i) = evar(i)+gbuf%FORPG(jj(ius)+i)/npg
389 ENDIF
390 ENDDO
391 ENDIF
392 ELSE
393 DO i=lft,llt
394 n = i + nft
395 ilayer = plyelems(n)
396 IF(ilayer > 0) THEN
397 evar(i) = gbuf%FORPG(jj(ius)+i)
398 ENDIF
399 ENDDO
400 ENDIF
401CCC
402c---------
403 ELSEIF(ifunc>=17.AND.ifunc<=19)THEN
404c---------
405 ius = ifunc-14
406Cit's available just for law25 and batoz shell
407 ipid = ixc(6,nft+1)
408 irep = igeo(6,ipid)
409c
410 IF (mlw == 25.AND. irep == 1) THEN
411 IF(ity == 3)THEN
412 DO i=1,nel
413 mat(i)=ixc(1,nft+i)
414 pid(i)=ixc(6,nft+i)
415 END DO
416 ELSE
417 DO i=1,nel
418 mat(i)=ixtg(1,nft+i)
419 pid(i)=ixtg(5,nft+i)
420 END DO
421 END IF
422 ivisc = 0
423 nuvarv = 0
424 IF(mlw == 25) THEN
425 IF(igtyp == 17)THEN
426!! IIGEO = 40 + 5*(ISUBSTACK - 1)
427!! IADI = IGEO(IIGEO + 3,PID(1))
428!! IPMAT = IADI + MPT
429 ipmat = 2 + mpt
430! old stack organisation IPMAT = 300
431 nuvarv = 0
432 DO n=1,npt
433 iadr = (n-1)*nel
434 DO i=1,nel
435 matl = stack%IGEO(ipmat+n,isubstack)
436 IF (mat_param(matl)%IVISC > 0 ) ivisc = 1
437 END DO
438 END DO
439 END IF
440 ENDIF
441C -
442 ns1 = 5
443 CALL sigrota(lft ,llt ,nft ,ilayer ,nel ,
444 2 ns1 ,x ,ixc ,elbuf_tab(ng) ,
445 3 sige ,ity ,ixtg ,ihbe ,istrain ,
446 4 ivisc)
447 DO i=lft,llt
448 evar(i) = sige(i,ifunc - 14)
449 ENDDO
450 ELSEIF (mlw == 25 .AND. irep == 0) THEN
451 IF (ihbe == 11) THEN
452 DO i=lft,llt
453 evar(i) = zero
454 n = i + nft
455 ilayer = plyelems(n)
456 ENDDO
457 ELSE
458c IADD = NB10 + 5 * NEL * (ILAYER - 1)
459 DO i=lft,llt
460 n = i + nft
461 ilayer = plyelems(n)
462 ENDDO
463 ENDIF
464 ELSE
465cc IADD = NB10 + 5 * NEL * (ILAYER - 1)
466 DO i=lft,llt
467 n = i + nft
468 ilayer = plyelems(n)
469 IF(ilayer > 0) THEN
470c IADD = NB10 + 5 * NEL * (ILAYER - 1)
471c EVAR(I) = BUFEL(IADD + (I-1)*5 + IFUNC - 14)
472 ENDIF
473 ENDDO
474 ENDIF
475 ELSEIF(ifunc == 26)THEN
476 DO i=lft,llt
477 evar(i) = zero
478 ENDDO
479 ELSEIF(ifunc == 2155)THEN
480c IADD = NB3
481 DO i=lft,llt
482 IF (ity == 3) THEN
483 evar(i) = zero
484 ENDIF
485 IF (ity == 7) THEN
486 evar(i) = zero
487 ENDIF
488 ENDDO
489c---------
490 ELSEIF(ifunc>=20.AND.ifunc<=24)THEN
491c USER VARIABLES from 1 to 5)THEN
492c---------
493 ius = ifunc - 20
494CCC
495 IF(ihbe == 11.AND.
496 . (mlw == 29.OR.mlw == 30.OR.mlw == 31.OR.mlw>=33))THEN
497 npg=0
498C------QBAT----
499 IF (ity == 3.AND.ihbe == 11) THEN
500 npg =4
501 fac = fourth
502 ENDIF
503C------DKT18----
504 IF (ity == 7.AND.ihbe == 11) THEN
505 npg =3
506 fac = third
507 ENDIF
508C------------------------
509 nptm = max(1,mpt)
510 nel5 = nel*5
511 nel8 = nel*8
512C-------QBAT,DKT18,
513C
514 IF (ity == 7) THEN
515 igtyp = nint(geo(12,ixtg(6,nft+1)))
516 ELSE
517 igtyp = nint(geo(12,ixc(6,nft+1)))
518 ENDIF
519 IF(mpt == 0)THEN
520 DO i = lft, llt
521 evar(i) =zero
522 ENDDO
523 ELSE
524 i1 = ius*nel
525 DO i=lft,llt
526 n = i + nft
527 IF(nuvar>=ius)THEN
528 evar(i) = zero
529 n = i + nft
530 ilayer = plyelems(n)
531 IF(ilayer > 0) THEN
532 nuvar = elbuf_tab(ng)%BUFLY(ipt)%NVAR_MAT
533 ipt = ilayer
534 DO ir = 1, nptr
535 DO is = 1, npts
536 uvar=>elbuf_tab(ng)%BUFLY(ipt)%MAT(ir,is,1)%VAR
537 evar(i) = evar(i) + uvar(i1 + i)*fac
538 ENDDO
539 ENDDO
540 ENDIF
541 ENDIF
542 ENDDO
543 ENDIF
544 ELSEIF (mlw == 29 .OR. mlw == 30.OR.
545 . mlw == 31.OR.mlw>=33) THEN
546C--- USER VARIABLES
547 ius = ifunc - 20
548 DO i=lft,llt
549 n = i + nft
550 IF (ipm(8,ixc(1,n))>ius) THEN
551 ENDIF
552 ENDDO
553 ENDIF
554c---------
555 ELSEIF(ifunc>=27.AND.ifunc<=39) THEN
556c---------
557 IF (mlw == 29.OR.mlw == 30.OR.mlw == 31.OR.mlw>=33)THEN
558 IF (mpt > 0)THEN
559 ius = ifunc - 22
560 DO i=lft,llt
561 n = i + nft
562 evar(i) = zero
563 ilayer = plyelems(n)
564 IF (ilayer > 0) THEN
565 ipt = ilayer
566 nuvar = elbuf_tab(ng)%BUFLY(ipt)%NVAR_MAT
567 i1 = ius*nel
568 IF (nuvar>=ius)THEN
569 DO ir = 1, nptr
570 DO is = 1, npts
571 uvar=>elbuf_tab(ng)%BUFLY(ipt)%MAT(ir,is,1)%VAR
572 evar(i) = evar(i) + uvar(i1 + i)*fac
573 ENDDO
574 ENDDO
575 ENDIF
576 ENDIF
577 ENDDO
578 ENDIF
579 ENDIF
580c---------
581 ELSEIF((ifunc>=40.AND.ifunc<=2039).OR.
582 . (ifunc>=2240.AND.ifunc<=10139)) THEN
583c---------
584 IF (ifunc>=40.AND.ifunc<=2039) THEN
585 ius = (ifunc - 39)/100
586 ipt = mod((ifunc - 39), 100)
587 ELSEIF (ifunc>=2240.AND.ifunc<=10139) THEN
588 ius = ((ifunc - 2239)/100) +20
589 ipt = mod((ifunc - 2239), 100)
590 ENDIF
591 IF(ipt == 0)THEN
592 ipt = 100
593 ius = ius -1
594 ENDIF
595 IF (nlay > 1) THEN
596 il = ipt
597 ipt = 1
598 ELSE
599 il = 1
600 ENDIF
601 ipt = ilayer
602 IF (mlw == 29.OR.mlw == 30.OR.mlw == 31.OR.mlw>=33)THEN
603 npg=0
604C ------QBAT----
605 IF (ity == 3.AND.ihbe == 11) THEN
606 npg =4
607 fac = fourth
608 ENDIF
609C ------DKT18----
610 IF (ity == 7.AND.ihbe == 11) THEN
611 npg =3
612 fac = third
613 ENDIF
614C -----------------------
615 IF (mpt> 0) THEN
616 DO i=lft,llt
617 n = i + nft
618 IF (ity == 7) THEN
619 nuvar = max(nuvar,ipm(8,ixtg(1,nft+1)))
620 ELSE
621 nuvar = max(nuvar,ipm(8,ixc(1,nft+1)))
622 ENDIF
623 IF (nuvar>=ius.AND.npt>=ipt)THEN
624 evar(i) = zero
625 ilayer = plyelems(n)
626 i1 = ius*nel
627 IF (ilayer > 0) THEN
628 ipt = ilayer
629 DO ir = 1, nptr
630 DO is = 1, npts
631 uvar=>elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,ipt)%VAR
632 evar(i) = evar(i) + uvar(i1 + i)*fac
633 ENDDO
634 ENDDO
635 ENDIF
636 ENDIF
637 ENDDO
638 ENDIF
639 ENDIF
640c---------
641 ELSEIF (ifunc == 10240 .OR. ifunc == 10669) THEN
642C interply damage
643c---------
644 IF (ihbe == 11) THEN
645 IF (ifunc == 10240 ) THEN
646 DO i=lft,llt
647 n = i + nft
648 ilayer = plyelems(n)
649 nfail = 0
650 IF(ilayer /= 0.AND. ilayer <= elbuf_tab(ng)%NINTLAY)
651 . nfail = elbuf_tab(ng)%INTLAY(ilayer)%NFAIL
652 IF (ilayer > 0 .AND. ilayer <= elbuf_tab(ng)%NINTLAY .AND. nfail > 0) THEN
653 nuvar = elbuf_tab(ng)%INTLAY(ilayer)%FAIL(1,1)%FLOC(1)%NVAR
654 IF (nuvar > 0) THEN
655 evar(i) = ep30
656 DO ir=1,nptr
657 DO is=1,npts
658 fbuf => elbuf_tab(ng)%INTLAY(ilayer)%FAIL(ir,is)
659 evar(i) = min(evar(i), fbuf%FLOC(1)%VAR(i))
660 ENDDO
661 ENDDO
662 ENDIF
663 ENDIF
664 ENDDO
665 ELSEIF (ifunc == 10669 ) THEN
666 DO i=lft,llt
667 n = i + nft
668 ilayer = plyelems(n)
669 nfail = 0
670 IF(ilayer /= 0.AND. ilayer <= elbuf_tab(ng)%NINTLAY)
671 . nfail = elbuf_tab(ng)%INTLAY(ilayer)%NFAIL
672 IF (ilayer > 0 .AND. ilayer <= elbuf_tab(ng)%NINTLAY .AND. nfail > 0) THEN
673 nuvar = elbuf_tab(ng)%INTLAY(ilayer)%FAIL(1,1)%FLOC(1)%NVAR
674 IF (nuvar > 0) THEN
675 DO ir=1,nptr
676 DO is=1,npts
677 fbuf => elbuf_tab(ng)%INTLAY(ilayer)%FAIL(ir,is)
678 evar(i) = max(evar(i), fbuf%FLOC(1)%VAR(i))
679 ENDDO
680 ENDDO
681 ENDIF
682 ENDIF
683 ENDDO
684 ENDIF
685 ENDIF
686c---------
687 ELSEIF((ifunc>=10241.AND.ifunc<=10243)) THEN
688C interply stress
689c---------
690 ll = ifunc - 10240
691 IF (ihbe == 11) THEN
692 DO i=lft,llt
693 n = i + nft
694 ilayer = plyelems(n)
695 IF (ilayer > 0 .and. ilayer <= elbuf_tab(ng)%NINTLAY) THEN
696 DO ir=1,nptr
697 DO is=1,npts
698 ilbuf => elbuf_tab(ng)%INTLAY(ilayer)%ILBUF(ir,is)
699 evar(i) = evar(i) + ilbuf%SIG(nel*(ll-1) + i) / npg
700 ENDDO
701 ENDDO
702 ENDIF
703 ENDDO
704 ENDIF ! interply
705c---------
706 ELSEIF((ifunc>=10244.AND.ifunc<=10246)) THEN
707C interply strain
708c---------
709 ll = ifunc - 10243
710 IF (ihbe == 11) THEN
711 DO i=lft,llt
712 n = i + nft
713 ilayer = plyelems(n)
714 IF(ilayer > 0 .and. ilayer <= elbuf_tab(ng)%NINTLAY) THEN
715 DO ir=1,nptr
716 DO is=1,npts
717 ilbuf => elbuf_tab(ng)%INTLAY(ilayer)%ILBUF(ir,is)
718 evar(i) = evar(i) + ilbuf%EPS((i-1)*3 + ll) / npg
719 ENDDO
720 ENDDO
721 ENDIF
722 ENDDO
723 ENDIF
724c---------
725 ELSEIF(ifunc == 10247) THEN
726C Internal energy
727 IF (ihbe == 11) THEN
728 DO i=lft,llt
729 n = i + nft
730 ilayer = plyelems(n)
731 IF(ilayer > 0 .and. ilayer <= elbuf_tab(ng)%NINTLAY) THEN
732 evar(i) = elbuf_tab(ng)%INTLAY(ilayer)%EINT(i)
733 ENDIF
734 ENDDO
735 ENDIF
736c---------
737 ELSEIF (ifunc == 2040) THEN ! EPSP/UPPER
738c---------
739 IF (nlay > 1) THEN
740 il = max(1,npt)
741 ipt = 1
742 ELSE
743 il = 1
744 ipt = max(1,npt)
745 ENDIF
746 bufly => elbuf_tab(ng)%BUFLY(il)
747 IF (bufly%L_PLA > 0) THEN
748 DO i=lft,llt
749 evar(i) = abs(bufly%LBUF(1,1,ipt)%PLA(i))
750 ENDDO
751 ELSE
752 DO i=lft,llt
753 evar(i) = zero
754 ENDDO
755 ENDIF
756c---------
757 ELSEIF (ifunc == 2041) THEN ! EPSP/LOWER
758c---------
759 bufly => elbuf_tab(ng)%BUFLY(1)
760 IF (bufly%L_PLA > 0) THEN
761 DO i=lft,llt
762 evar(i) = abs(bufly%LBUF(1,1,1)%PLA(i))
763 ENDDO
764 ENDIF
765c---------
766 ELSEIF(ifunc>=2042.AND.ifunc<=2141) THEN
767c---------
768 IF(mlw/=1)THEN
769 ipt = mod((ifunc - 2041), 100)
770 IF(ipt == 0)ipt = 100
771 IF(npt>=ipt)THEN
772c IADD = NB11 + LLT*(ILAYER-1)
773 DO i=lft,llt
774 ilayer = plyelems(n)
775 IF(ilayer > 0) THEN
776c IADD = NB11 + LLT*(ILAYER-1)
777c EVAR(I) = ABS(BUFEL(IADD+I))
778 ENDIF
779 END DO
780 ELSE IF(npt == 0)THEN
781c IADD=NB11
782 DO i=lft,llt
783c EVAR(I) = ABS(BUFEL(IADD+I))
784 END DO
785 END IF
786 ENDIF
787c---------
788 ELSE IF(ifunc == 2142)THEN
789c---------Thuis subroutine is used only with PID17 for Plyxfem.
790C it should be activated in this cas for this option.
791!! IF ((MLW == 25.OR.MLW == 15).AND.(IGTYP == 10.OR.IGTYP == 11)) THEN
792!! DO I=LFT,LLT
793!! DAM1(I)=ZERO
794!! DAM2(I)=ZERO
795!! WPLA(I)=ZERO
796!! FAIL(I)=ZERO
797!! END DO
798c
799!! IF (IFAILURE == 0) THEN
800!! IF (NLAY > 1) THEN
801!! IL = MAX(1,NPT)
802!! IPT = 1
803!! ELSE
804!! IL = 1
805!! IPT = MAX(1,NPT)
806!! ENDIF
807!! BUFLY => ELBUF_TAB(NG)%BUFLY(IL)
808!
809!! DO N=1,NPT
810!! LBUF => ELBUF_TAB(NG)%BUFLY(IL)%LBUF(1,1,IPT)
811!! IADR = (N-1)*NEL
812!! DO I=LFT,LLT
813!! J = IADR + I
814!! K1 = NB15 + 2*IADR+2*I-1
815!! K2 = NB15 + 2*IADR+2*I
816!! DAM1(I) = LBUF%DAM(K1)
817!! DAM2(I) = LBUF%DAM(K2)
818!! WPLA(I) = LBUF%PLA(I)
819!! DMAX(I) = PM(64,MATLY(J))
820!! WPMAX(I)= PM(41,MATLY(J))
821!! IF(DAM1(I)>=DMAX(I).OR.DAM2(I)>=DMAX(I).OR.
822!! . WPLA(I)<ZERO.OR.WPLA(I)>=WPMAX(I))
823!! . FAIL(I) = FAIL(I) + ONE
824!! ENDDO
825!! ENDDO
826!! ELSE
827!! IF(IFAILA == 1) THEN
828!! DO I=LFT,LLT
829c OFF = BUFEL(IADD+I)
830!! IF(OFF<ZERO)THEN
831!! FAIL(I)= -ONE
832!! ELSEIF(OFF>ZERO)THEN
833!! FAIL(I)= ONE
834!! ELSE
835!! FAIL(I)= ZERO
836!! END IF
837!! EVAR(I)=FAIL(I)
838!! END DO
839!! ENDIF
840!! ENDIF
841!! ELSE
842 IF(ifailure == 0 .OR.(ifailure /=0 .AND.ifaila ==1))THEN
843 DO i=lft,llt
844 off = gbuf%OFF(i)
845 IF(off < zero)THEN
846 fail(i) = -one
847 ELSEIF(off > zero)THEN
848 fail(i) = one
849 ELSE
850 fail(i) = zero
851 END IF
852 evar(i)=fail(i)
853 END DO
854 ENDIF
855!! END IF
856
857 ELSE IF(ifunc == 2156)THEN
858c
859 ENDIF
860C
861 IF(mlw == 0 .OR. mlw == 13)THEN
862 IF(ity == 3)THEN
863 ELSE
864 DO i=lft,llt
865 ilayer = plyelems(n)
866 IF(ilayer > 0) THEN
867 ie = ie + 1
868 func(el2fa(nel_ply + ie)) = zero
869 ENDIF
870 ENDDO
871 ENDIF
872 ELSEIF(ifunc == 3)THEN
873C-------------------
874C energie specifique
875C-------------------
876 IF(ity == 3)THEN
877 DO i=lft,llt
878 n = i + nft
879 ilayer = plyelems(n)
880 IF(ilayer > 0) THEN
881 ie = ie + 1
882 func(el2fa(nel_ply + ie)) = zero
883 ENDIF
884 ENDDO
885 ELSE
886 DO i=lft,llt
887 n = i + nft
888 ilayer = plyelems(n)
889 IF(ilayer > 0) THEN
890 ie = ie + 1
891 func(el2fa(nel_ply + ie)) = zero
892 ENDIF
893 ENDDO
894 ENDIF
895 ELSEIF(ifunc == 25.AND.ity == 3)THEN
896C-------------------
897C energie hourglass
898C-------------------
899 DO i=lft,llt
900 n = i + nft
901 ilayer = plyelems(n)
902 IF(ilayer > 0) THEN
903 ie = ie + 1
904 func(el2fa(nel_ply + ie)) = zero
905 ENDIF
906 ENDDO
907 ELSE
908C-------------------
909C cas general
910C-------------------
911 IF(ity == 3)THEN
912 DO i=lft,llt
913 n = i + nft
914 ilayer = plyelems(n)
915 IF(ilayer > 0) THEN
916 ie = ie + 1
917 func(el2fa(nel_ply + ie)) = evar(i)
918 ENDIF
919 ENDDO
920 ENDIF
921 ENDIF
922 ENDIF
923C-----------------------------------------------
924C FIN DE BOUCLE SUR LES OFFSET
925C-----------------------------------------------
926 END DO
927 900 CONTINUE
928C-----------------------------------------------=
929C
930 IF(iflag > 0) THEN
931 IF (nspmd == 1) THEN
932 ilast = max(nel_ply,1)
933 DO i=1,ie
934 n = el2fa(nel_ply + i)
935 r4 = func(n)
936 CALL write_r_c(r4,1)
937 ENDDO
938 ELSE
939 DO i=1,ie
940 n = el2fa(nel_ply + i)
941 wal(i+nel_ply) = func(n)
942 ENDDO
943 ENDIF
944
945 ENDIF
946 nel_ply = nel_ply + plyshell(iply)%PLYNUMSHELL
947 ENDDO
948 IF (nspmd > 1 ) THEN
949 IF (ispmd == 0) THEN
950 buf = nbf_pxfemg
951 ELSE
952 buf=1
953 ENDIF
954 CALL spmd_r4get_partn(1,nbf_l,nbpart,iadg,wal,buf)
955 ENDIF
956
957 DEALLOCATE(wal)
958 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
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
plyxfem_mod
Definition plyxfem_mod.F:31
plyxfem_mod::indx_ply
integer, dimension(:), allocatable indx_ply
Definition plyxfem_mod.F:60
plyxfem_mod::nplypart
integer nplypart
Definition plyxfem_mod.F:59
plyxfem_mod::plyshell
type(plyshells), dimension(:), allocatable plyshell
Definition plyxfem_mod.F:56
stack_mod
Definition stack_mod.F:72
sigrota
subroutine sigrota(jft, jlt, nft, ipt, nel, ns1, x, ixc, elbuf_str, sig, ity, ixtg, ihbe, istrain, ivisc)
Definition sigrota.F:37
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