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 37 of file stat_c_fail.F.

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