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 41 of file dfuncc_ply.F.

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