OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_c_fail.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "mvsiz_p.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_c_fail (elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, sizp0, nummat, mat_param)

Function/Subroutine Documentation

◆ stat_c_fail()

subroutine stat_c_fail ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartc,
integer, dimension(*) iparttg,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxc,
integer, dimension(*) stat_indxtg,
integer sizp0,
integer, intent(in) nummat,
type (matparam_struct_), dimension(nummat), intent(in) mat_param )

Definition at line 36 of file stat_c_fail.F.

40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE mat_elem_mod
44 USE my_alloc_mod
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "com01_c.inc"
53#include "param_c.inc"
54#include "units_c.inc"
55#include "task_c.inc"
56#include "scr14_c.inc"
57#include "scr16_c.inc"
58#include "mvsiz_p.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER SIZLOC,SIZP0
63 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
64 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
65 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
66 . STAT_INDXC(*), STAT_INDXTG(*)
67 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
68 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
69 double precision WA(*),WAP0(*)
70C-----------------------------------------------
71C L o c a l V a r i a b l e s
72C-----------------------------------------------
73 INTEGER ,INTENT(IN) :: NUMMAT
74 INTEGER I,N,J,K,L,II,JJ,ID,IE,LEN,NG,NEL,NFT,ITY,LFT,LLT,NPT,
75 . MLW,IGTYP,IPRT0,IPRT,IVAR,IMAT,
76 . NPG,IPG,NLAY,NPTR,NPTS,NPTT,IL,IR,IS,IT,IPT,IC,IFAIL,NV,
77 . NFAIL,NVAR_RUPT,NPTG,IRUPT,IRUPT_TYPE,ISUBSTACK
78 INTEGER MAT(MVSIZ), PID(MVSIZ)
79 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
80 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
81 double precision
82 . THK, EM, EB, H1, H2, H3
83 CHARACTER*100 DELIMIT,LINE
84C----
85 TYPE(L_BUFEL_) ,POINTER :: LBUF
86 TYPE(G_BUFEL_) ,POINTER :: GBUF
87 TYPE(BUF_MAT_) ,POINTER :: MBUF
88 TYPE(BUF_FAIL_),POINTER :: FBUF
89 my_real,
90 . DIMENSION(:), POINTER :: uvarf,dfmax
91C----
92 DATA delimit(1:60)
93 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
94 DATA delimit(61:100)
95 ./'----7----|----8----|----9----|----10---|'/
96C=======================================================================
97C 4-NODE SHELLS
98C-----------------------------------------------
99 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
100 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
101C-----------------------------------------------
102 jj = 0
103 isubstack = 0
104 IF (stat_numelc==0) GOTO 200
105C
106 ie=0
107 DO ng=1,ngroup
108 ity = iparg(5,ng)
109 IF (ity == 3) THEN
110 mlw =iparg(1,ng)
111 nel =iparg(2,ng)
112 nft =iparg(3,ng)
113 lft=1
114 llt=nel
115C
116c DO I=1,NEL
117c MAT(I) = IXC(1,I)
118c PID(I) = IXC(6,I)
119c ENDDO
120C
121 gbuf => elbuf_tab(ng)%GBUF
122 nlay = elbuf_tab(ng)%NLAY
123 nptr = elbuf_tab(ng)%NPTR
124 npts = elbuf_tab(ng)%NPTS
125c NPTT = ELBUF_TAB(NG)%NPTT
126c NPT = NPTT * NLAY
127 npg = nptr*npts
128 isubstack = iparg(71,ng)
129c
130c-------------------------------------------------------
131c
132 DO i=lft,llt
133 n = i+nft
134 iprt=ipartc(n)
135 IF (ipart_state(iprt)==0) cycle
136C
137 jj = jj + 1
138 IF (mlw /= 0 .AND. mlw /= 13) THEN
139 wa(jj) = gbuf%OFF(i)
140 ELSE
141 wa(jj) = zero
142 ENDIF
143 jj = jj + 1
144 wa(jj) = iprt
145 jj = jj + 1
146 wa(jj) = ixc(nixc,n)
147 jj = jj + 1
148 wa(jj) = nlay
149cc JJ = JJ + 1
150cc WA(JJ) = NPTT
151 jj = jj + 1
152 wa(jj) = npg
153c
154 DO il = 1,nlay
155 nfail = elbuf_tab(ng)%BUFLY(il)%NFAIL
156 imat = elbuf_tab(ng)%BUFLY(il)%IMAT
157 fbuf => elbuf_tab(ng)%BUFLY(il)%FAIL(1,1,1)
158 nptt = elbuf_tab(ng)%BUFLY(il)%NPTT
159 jj = jj + 1
160 wa(jj) = nfail
161 jj = jj + 1
162 imat = elbuf_tab(ng)%BUFLY(il)%IMAT
163 wa(jj) = ipm(1,imat)
164 jj = jj + 1
165 wa(jj) = nptt
166c
167 DO ifail = 1,nfail
168 irupt = mat_param(imat)%FAIL(ifail)%FAIL_ID
169 irupt_type = mat_param(imat)%FAIL(ifail)%IRUPT
170 nvar_rupt = fbuf%FLOC(ifail)%NVAR
171 jj = jj + 1
172 wa(jj) = nvar_rupt + 1
173 jj = jj + 1
174 wa(jj) = irupt
175 jj = jj + 1
176 wa(jj) = irupt_type
177!
178 IF (irupt == 0) cycle
179!
180 DO it=1,nptt
181 DO is=1,npts
182 DO ir=1,nptr
183 fbuf => elbuf_tab(ng)%BUFLY(il)%FAIL(ir,is,it)
184 uvarf => fbuf%FLOC(ifail)%VAR
185 dfmax => fbuf%FLOC(ifail)%DAMMX
186 jj = jj + 1
187 wa(jj) = dfmax(i)
188 DO nv=1,nvar_rupt
189 jj = jj + 1
190 wa(jj) = uvarf((nv-1)*llt+i)
191 ENDDO
192 ENDDO
193 ENDDO
194 ENDDO
195 ENDDO ! IFAIL = 1,NFAIL
196c
197 ENDDO ! IL = 1,NLAY
198c
199 ie=ie+1
200C pointeur de fin de zone
201 ptwa(ie)=jj
202 ENDDO ! I=LFT,LLT
203c--------------
204 ENDIF ! ITY == 3
205 ENDDO ! NG = 1,NGROUP
206C
207 200 CONTINUE
208c
209c-----------------------------------------------------------------------
210c
211 IF (nspmd == 1) THEN
212 ptwa_p0(0)=0
213 DO n=1,stat_numelc
214 ptwa_p0(n)=ptwa(n)
215 ENDDO
216 len=jj
217 DO j=1,len
218 wap0(j)=wa(j)
219 ENDDO
220 ELSE
221C construit les pointeurs dans le tableau global WAP0
222 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
223 len = 0
224 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
225 ENDIF
226c
227c-----------------------------------------------------------------------
228c
229 IF (ispmd == 0.AND.len > 0) THEN
230 iprt0=0
231 DO n=1,stat_numelc_g
232C retrouve le nieme elt dans l'ordre d'id croissant
233 k=stat_indxc(n)
234C retrouve l'adresse dans WAP0
235 j=ptwa_p0(k-1)
236 iprt = nint(wap0(j + 2))
237 IF (iprt /= iprt0) THEN
238 IF (izipstrs == 0) THEN
239 WRITE(iugeo,'(A)') delimit
240 WRITE(iugeo,'(A)')'/INISHE/FAIL'
241 WRITE(iugeo,'(A)')
242 .'#------------------------ REPEAT --------------------------'
243 WRITE(iugeo,'(A)')
244 .'# SHELLID NLAY NPG NPTT ILAY IRUPT IRUPT_TYP NUVAR IMAT'
245 WRITE(iugeo,'(A/A/A)')
246 .'# REPEAT K=1,NPG ',
247 .'# UVAR(1,I) ............. ',
248 .'# ............... UVAR(NUVAR,I) '
249 WRITE(iugeo,'(A)')
250 .'#---------------------- END REPEAT ------------------------'
251 WRITE(iugeo,'(A)') delimit
252 ELSE
253 WRITE(line,'(A)') delimit
254 CALL strs_txt50(line,100)
255 WRITE(line,'(A)')'/INISHE/FAIL'
256 CALL strs_txt50(line,100)
257 WRITE(line,'(A)')
258 .'#------------------------ REPEAT --------------------------'
259 CALL strs_txt50(line,100)
260 WRITE(line,'(A)')
261 .'# SHELLID NLAY NPG NPTT ILAY IRUPT IRUPT_TYP NUVAR IMAT'
262 CALL strs_txt50(line,100)
263 WRITE(line,'(A)')
264 .'# REPEAT K=1,NPG '
265 CALL strs_txt50(line,100)
266 WRITE(line,'(A)')
267 .'# UVAR(1,I) ............. '
268 CALL strs_txt50(line,100)
269 WRITE(line,'(A)')
270 .'# ............... UVAR(NUVAR,I) '
271 CALL strs_txt50(line,100)
272 WRITE(line,'(A)')
273 .'#---------------------- END REPEAT ------------------------'
274 CALL strs_txt50(line,100)
275 WRITE(line,'(A)') delimit
276 CALL strs_txt50(line,100)
277 ENDIF ! IF (IZIPSTRS == 0)
278 iprt0=iprt
279 ENDIF ! IF (IPRT /= IPRT0)
280c
281 id = nint(wap0(j+3))
282 nlay = nint(wap0(j+4))
283cc NPTT = NINT(WAP0(J+5))
284 nptg = nint(wap0(j+5))
285 j = j + 5
286c
287 DO il=1,nlay
288 ic = nint(wap0(j+1))
289 j = j + 1
290 imat = nint(wap0(j+1))
291 j = j + 1
292 nptt = nint(wap0(j+1))
293 j = j + 1
294 DO ii=1,ic
295 nvar_rupt = nint(wap0(j+1))
296 j = j + 1
297 irupt = nint(wap0(j+1))
298 j = j + 1
299 irupt_type = nint(wap0(j+1))
300 j = j + 1
301!
302 IF (irupt == 0) cycle
303!
304 IF (izipstrs == 0) THEN
305 WRITE(iugeo,'(9I10)') id,nlay,nptg,nptt,il,irupt,irupt_type,nvar_rupt,
306 . imat
307 ELSE
308 WRITE(line,'(9I10)') id,nlay,nptg,nptt,il,irupt,irupt_type,nvar_rupt,
309 . imat
310 CALL strs_txt50(line,100)
311 ENDIF
312 IF (irupt /= 0 .AND. nvar_rupt /= 0) THEN
313 IF (izipstrs == 0) THEN
314 DO it=1,nptt
315 DO ipg=1,nptg
316 WRITE(iugeo,'(1P3E20.13)')(wap0(j + l),l=1,nvar_rupt)
317 j = j + nvar_rupt
318 ENDDO
319 ENDDO
320 ELSE
321 DO it=1,nptt
322 DO ipg=1,nptg
323 CALL tab_strs_txt50(wap0(1),nvar_rupt,j,sizp0,3)
324 j = j + nvar_rupt
325 ENDDO
326 ENDDO
327 ENDIF ! IF (IZIPSTRS == 0)
328 ENDIF ! IF (IRUPT /= 0 .AND. NVAR_RUPT /= 0)
329 ENDDO ! DO II=1,IC
330 ENDDO ! DO IL=1,NLAY
331 ENDDO ! DO N=1,STAT_NUMELC_G
332 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
333C-----------------------------------------------
334C 3-NODE SHELLS
335C-----------------------------------------------
336 jj = 0
337 isubstack = 0
338 IF (stat_numeltg==0) GOTO 300
339C
340 ie=0
341 DO ng=1,ngroup
342 ity =iparg(5,ng)
343 IF (ity == 7) THEN
344 mlw =iparg(1,ng)
345 nel =iparg(2,ng)
346 nft =iparg(3,ng)
347 lft=1
348 llt=nel
349C
350c DO I=1,NEL
351c MAT(I) = IXTG(1,I)
352c PID(I) = IXTG(6,I)
353c ENDDO
354C
355 gbuf => elbuf_tab(ng)%GBUF
356 nlay = elbuf_tab(ng)%NLAY
357 nptr = elbuf_tab(ng)%NPTR
358 npts = elbuf_tab(ng)%NPTS
359c NPTT = ELBUF_TAB(NG)%NPTT
360c NPT = NPTT * NLAY
361 npg = nptr*npts
362 isubstack = iparg(71,ng)
363c
364c-------------------------------------------------------
365c
366 DO i=lft,llt
367 n = i+nft
368 iprt=iparttg(n)
369 IF (ipart_state(iprt)==0) cycle
370C
371 jj = jj + 1
372 IF (mlw /= 0 .AND. mlw /= 13) THEN
373 wa(jj) = gbuf%OFF(i)
374 ELSE
375 wa(jj) = zero
376 ENDIF
377 jj = jj + 1
378 wa(jj) = iprt
379 jj = jj + 1
380 wa(jj) = ixtg(nixtg,n)
381 jj = jj + 1
382 wa(jj) = nlay
383cc JJ = JJ + 1
384cc WA(JJ) = NPTT
385 jj = jj + 1
386 wa(jj) = npg
387c
388 DO il = 1,nlay
389 nfail = elbuf_tab(ng)%BUFLY(il)%NFAIL
390 imat = elbuf_tab(ng)%BUFLY(il)%IMAT
391 fbuf => elbuf_tab(ng)%BUFLY(il)%FAIL(1,1,1)
392 nptt = elbuf_tab(ng)%BUFLY(il)%NPTT
393 jj = jj + 1
394 wa(jj) = nfail
395 jj = jj + 1
396 imat = elbuf_tab(ng)%BUFLY(il)%IMAT
397 wa(jj) = ipm(1,imat)
398 jj = jj + 1
399 wa(jj) = nptt
400c
401 DO ifail = 1,nfail
402 irupt = mat_param(imat)%FAIL(ifail)%FAIL_ID
403 irupt_type = mat_param(imat)%FAIL(ifail)%IRUPT
404 nvar_rupt = fbuf%FLOC(ifail)%NVAR
405 jj = jj + 1
406 wa(jj) = nvar_rupt + 1
407 jj = jj + 1
408 wa(jj) = irupt
409 jj = jj + 1
410 wa(jj) = irupt_type
411!
412 IF (irupt == 0) cycle
413!
414 DO it = 1,nptt
415 DO is=1,npts
416 DO ir=1,nptr
417 fbuf => elbuf_tab(ng)%BUFLY(il)%FAIL(ir,is,it)
418 uvarf => fbuf%FLOC(ifail)%VAR
419 dfmax => fbuf%FLOC(ifail)%DAMMX
420 jj = jj + 1
421 wa(jj) = dfmax(i)
422 DO nv=1,nvar_rupt
423 jj = jj + 1
424 wa(jj) = uvarf((nv-1)*llt+i)
425 ENDDO
426 ENDDO
427 ENDDO
428 ENDDO ! IT = 1,NPTT
429 ENDDO ! IFAIL = 1,NFAIL
430 ENDDO ! IL = 1,NLAY
431c
432 ie=ie+1
433C pointeur de fin de zone
434 ptwa(ie)=jj
435 ENDDO ! I=LFT,LLT
436c--------------
437 ENDIF ! ITY == 7
438 ENDDO ! NG = 1,NGROUP
439C
440 300 CONTINUE
441c
442c-----------------------------------------------------------------------
443c
444 IF (nspmd == 1) THEN
445 ptwa_p0(0)=0
446 DO n=1,stat_numeltg
447 ptwa_p0(n)=ptwa(n)
448 ENDDO
449 len=jj
450 DO j=1,len
451 wap0(j)=wa(j)
452 ENDDO
453 ELSE
454C construit les pointeurs dans le tableau global WAP0
455 CALL spmd_stat_pgather(ptwa,stat_numeltg,ptwa_p0,stat_numeltg_g)
456 len = 0
457 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
458 ENDIF
459c
460c-----------------------------------------------------------------------
461c
462 IF (ispmd == 0.AND.len > 0) THEN
463 iprt0=0
464 DO n=1,stat_numeltg_g
465C retrouve le nieme elt dans l'ordre d'id croissant
466 k=stat_indxtg(n)
467C retrouve l'adresse dans WAP0
468 j=ptwa_p0(k-1)
469 iprt = nint(wap0(j + 2))
470 IF (iprt /= iprt0) THEN
471 IF (izipstrs == 0) THEN
472 WRITE(iugeo,'(A)') delimit
473 WRITE(iugeo,'(A)')'/INISH3/FAIL'
474 WRITE(iugeo,'(A)')
475 .'#------------------------ REPEAT --------------------------'
476 WRITE(iugeo,'(A)')
477 .'# SHELLID NLAY NPG NPTT ILAY IRUPT IRUPT_TYP NUVAR IMAT'
478 WRITE(iugeo,'(A/A/A)')
479 .'# REPEAT K=1,NPG ',
480 .'# UVAR(1,I) ............. ',
481 .'# ............... UVAR(NUVAR,I) '
482 WRITE(iugeo,'(A)')
483 .'#---------------------- END REPEAT ------------------------'
484 WRITE(iugeo,'(A)') delimit
485 ELSE
486 WRITE(line,'(A)') delimit
487 CALL strs_txt50(line,100)
488 WRITE(line,'(A)')'/INISH3/FAIL'
489 CALL strs_txt50(line,100)
490 WRITE(line,'(A)')
491 .'#------------------------ REPEAT --------------------------'
492 CALL strs_txt50(line,100)
493 WRITE(line,'(A)')
494 .'# SHELLID NLAY NPG NPTT ILAY IRUPT IRUPT_TYP NUVAR IMAT'
495 CALL strs_txt50(line,100)
496 WRITE(line,'(A)')
497 .'# REPEAT K=1,NPG '
498 CALL strs_txt50(line,100)
499 WRITE(line,'(A)')
500 .'# UVAR(1,I) ............. '
501 CALL strs_txt50(line,100)
502 WRITE(line,'(A)')
503 .'# ............... UVAR(NUVAR,I) '
504 CALL strs_txt50(line,100)
505 WRITE(line,'(A)')
506 .'#---------------------- END REPEAT ------------------------'
507 CALL strs_txt50(line,100)
508 WRITE(line,'(A)') delimit
509 CALL strs_txt50(line,100)
510 ENDIF ! IF (IZIPSTRS == 0)
511 iprt0=iprt
512 ENDIF ! IF (IPRT /= IPRT0)
513c
514 id = nint(wap0(j+3))
515 nlay = nint(wap0(j+4))
516cc NPTT = NINT(WAP0(J+5))
517 nptg = nint(wap0(j+5))
518 j = j + 5
519c
520 DO il=1,nlay
521 ic = nint(wap0(j+1))
522 j = j + 1
523 imat = nint(wap0(j+1))
524 j = j + 1
525 nptt = nint(wap0(j+1))
526 j = j + 1
527 DO ii=1,ic
528 nvar_rupt = nint(wap0(j+1))
529 j = j + 1
530 irupt = nint(wap0(j+1))
531 j = j + 1
532 irupt_type = nint(wap0(j+1))
533 j = j + 1
534!
535 IF (irupt == 0) cycle
536!
537 IF (izipstrs == 0) THEN
538 WRITE(iugeo,'(9I10)') id,nlay,nptg,nptt,il,irupt,irupt_type,nvar_rupt,
539 . imat
540 ELSE
541 WRITE(line,'(9I10)') id,nlay,nptg,nptt,il,irupt,irupt_type,nvar_rupt,
542 . imat
543 CALL strs_txt50(line,100)
544 ENDIF
545 IF (irupt /= 0 .AND. nvar_rupt /= 0) THEN
546 IF (izipstrs == 0) THEN
547 DO it=1,nptt
548 DO ipg=1,nptg
549 WRITE(iugeo,'(1P3E20.13)')(wap0(j + l),l=1,nvar_rupt)
550 j = j + nvar_rupt
551 ENDDO
552 ENDDO
553 ELSE
554 DO it=1,nptt
555 DO ipg=1,nptg
556 CALL tab_strs_txt50(wap0(1),nvar_rupt,j,sizp0,3)
557 j = j + nvar_rupt
558 ENDDO
559 ENDDO
560 ENDIF
561 ENDIF ! IF (IRUPT /= 0 .AND. NVAR_RUPT /= 0)
562 ENDDO ! DO II=1,IC
563 ENDDO ! DO IL=1,NLAY
564 ENDDO ! DO N=1,STAT_NUMELTG_G
565 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
566C
567c-----------
568 DEALLOCATE(ptwa)
569 DEALLOCATE(ptwa_p0)
570c-----------
571 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
spmd_rgather9_dp
subroutine spmd_rgather9_dp(v, len, vp0, lenp0, iad)
Definition spmd_outp.F:1015
spmd_stat_pgather
subroutine spmd_stat_pgather(ptv, ptlen, ptv_p0, ptlen_p0)
Definition spmd_stat.F:53
strs_txt50
subroutine strs_txt50(text, length)
Definition sta_txt.F:87
tab_strs_txt50
subroutine tab_strs_txt50(wap0, cpt, j, sizp0, nbpline)
Definition sta_txt.F:127