OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_s_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 "vect01_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_s_fail (elbuf_tab, iparg, ipm, igeo, ixs, wa, wap0, iparts, ipart_state, stat_indxs, ipart, sizp0, nummat, mat_param)

Function/Subroutine Documentation

◆ stat_s_fail()

subroutine stat_s_fail ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixs,*) ixs,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) iparts,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxs,
integer, dimension(lipart1,*) ipart,
integer sizp0,
integer, intent(in) nummat,
type (matparam_struct_), dimension(nummat), intent(in) mat_param )

Definition at line 39 of file stat_s_fail.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE initbuf_mod
46 USE mat_elem_mod
47 USE elbufdef_mod
48 USE my_alloc_mod
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "param_c.inc"
58#include "units_c.inc"
59#include "task_c.inc"
60#include "scr14_c.inc"
61#include "scr16_c.inc"
62#include "vect01_c.inc"
63#include "scr17_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER ,INTENT(IN) :: NUMMAT
68 INTEGER SIZLOC,SIZP0
69 INTEGER IXS(NIXS,*),
70 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
71 . IPARTS(*), IPART_STATE(*), STAT_INDXS(*),IPART(LIPART1,*)
72 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
73 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
74 double precision WA(*),WAP0(*)
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER I,N,J,K,JJ,LEN,ISOLNOD,IUS,NLAY,NPTR,NPTS,NPTT,NPTG,
79 . NG, NEL, MLW,ID, IPRT0, IPRT, NPG,IPG,IPT,IE,
80 . IL,IR,IS,IT,PID,NVARF,NFAIL,IRUPT,IRUPT_TYPE,NVAR_RUPT,
81 . NV,IMAT,IOFF
82 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
83 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
84 CHARACTER*100 DELIMIT,LINE
85 DATA delimit(1:60)
86 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
87 DATA delimit(61:100)
88 ./'----7----|----8----|----9----|----10---|'/
89C----
90 TYPE(L_BUFEL_) ,POINTER :: LBUF
91 TYPE(G_BUFEL_) ,POINTER :: GBUF
92 TYPE(BUF_MAT_) ,POINTER :: MBUF
93 TYPE(BUF_FAIL_),POINTER :: FBUF
94 my_real,
95 . DIMENSION(:), POINTER :: uvarf,dfmax
96C-----------------------------------------------
97C 8 NODES BRICK
98C======================================================================|
99 CALL my_alloc(ptwa,stat_numels)
100 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
101C-----------------------------------------------
102 jj = 0
103 ie = 0
104 IF(stat_numels==0) GOTO 200
105 DO ng=1,ngroup
106 ity =iparg(5,ng)
107 isolnod = iparg(28,ng)
108 mlw =iparg(1,ng)
109 nel =iparg(2,ng)
110 nft =iparg(3,ng)
111 iad =iparg(4,ng)
112 lft=1
113 llt = nel
114 iprt=iparts(lft+nft)
115 pid = ipart(2,iprt)
116c
117 IF (ity == 1) THEN
118 CALL initbuf(iparg ,ng ,
119 2 mlw ,nel ,nft ,iad ,ity ,
120 3 npt ,jale ,ismstr ,jeul ,jtur ,
121 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
122 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
123 6 irep ,iint ,igtyp ,israt ,isrot ,
124 7 icsen ,isorth ,isorthg ,ifailure,jsms )
125 iprt=iparts(lft+nft)
126 pid = ipart(2,iprt)
127 jhbe = igeo(10,pid)
128 gbuf => elbuf_tab(ng)%GBUF
129 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
130 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
131 nlay = elbuf_tab(ng)%NLAY
132 nptr = elbuf_tab(ng)%NPTR
133 npts = elbuf_tab(ng)%NPTS
134 nptt = elbuf_tab(ng)%NPTT
135 npt = nptr * npts * nptt * nlay
136c
137 DO i=lft,llt
138 n = i + nft
139 iprt=iparts(n)
140 IF (ipart_state(iprt)==0) cycle
141 wa(jj+1) = gbuf%VOL(i)
142 wa(jj+2) = iprt
143 wa(jj+3) = ixs(nixs,n)
144 wa(jj+4) = nlay
145 wa(jj+5) = nptr
146 wa(jj+6) = npts
147 wa(jj+7) = nptt
148 wa(jj+8) = isolnod
149 wa(jj+9) = gbuf%OFF(i)
150 jj = jj + 9
151 DO il = 1,nlay
152 nfail = elbuf_tab(ng)%BUFLY(il)%NFAIL
153 wa(jj+1) = nfail
154 jj = jj + 1
155 imat = elbuf_tab(ng)%BUFLY(il)%IMAT
156 wa(jj+1) = ipm(1,imat)
157 jj = jj + 1
158 DO ius = 1,nfail
159 irupt = mat_param(imat)%FAIL(ius)%FAIL_ID
160 wa(jj+1) = irupt
161 jj = jj + 1
162 irupt_type = mat_param(imat)%FAIL(ius)%IRUPT
163 wa(jj+1) = irupt_type
164 jj = jj + 1
165 fbuf => elbuf_tab(ng)%BUFLY(il)%FAIL(1,1,1)
166 nvar_rupt = fbuf%FLOC(ius)%NVAR
167 wa(jj+1) = nvar_rupt + 1
168 jj = jj + 1
169!
170 IF (irupt == 0) cycle
171!
172 DO ir=1,nptr
173 DO is=1,npts
174 DO it=1,nptt
175 uvarf => fbuf%FLOC(ius)%VAR
176 dfmax => fbuf%FLOC(ius)%DAMMX
177 jj = jj + 1
178 wa(jj) = dfmax(i)
179 DO nv=1,nvar_rupt
180 wa(jj + 1) = uvarf((nv-1)*llt+i)
181 jj = jj +1
182 ENDDO
183c
184 ENDDO
185 ENDDO
186 ENDDO
187 ENDDO
188 ENDDO
189 ie=ie+1
190C pointeur de fin de zone dans WA
191 ptwa(ie)=jj
192 ENDDO ! I=LFT,LLT
193 ENDIF ! ITY = 1
194 ENDDO
195 200 CONTINUE
196c------------------------------------------------------------
197 IF(nspmd == 1)THEN
198C recopies inutiles pour simplification du code.
199 ptwa_p0(0)=0
200 DO n=1,stat_numels
201 ptwa_p0(n)=ptwa(n)
202 END DO
203 len=jj
204 DO j=1,len
205 wap0(j)=wa(j)
206 END DO
207 ELSE
208C construit les pointeurs dans le tableau global WAP0
209 CALL spmd_stat_pgather(ptwa,stat_numels,ptwa_p0,stat_numels_g)
210 len = 0
211 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
212 END IF
213c------------------------------------------------------------
214 IF(ispmd==0.AND.len>0) THEN
215 iprt0=0
216 DO n=1,stat_numels_g
217C retrouve le nieme elt dans l'ordre d'id croissant
218 k=stat_indxs(n)
219C retrouve l'adresse dans WAP0
220 j=ptwa_p0(k-1)
221 iprt = nint(wap0(j + 2))
222 ioff = nint(wap0(j + 9))
223 IF (ioff >= 1) THEN
224 IF(iprt /= iprt0)THEN
225 IF (izipstrs == 0) THEN
226 WRITE(iugeo,'(A)') delimit
227 WRITE(iugeo,'(A)')'/INIBRI/FAIL'
228 WRITE(iugeo,'(A)')
229 .'#------------------------ REPEAT --------------------------'
230 WRITE(iugeo,'(A)')
231 .'# BRICKID NLAY NPTR NPTS
232 . NPTT ILAY IRUPT IRUPT_TYP NUVAR IMAT'
233 WRITE(iugeo,'(A/A/A)')
234 .'# REPEAT K=1,NPTR,NPTS ',
235 .'# UVAR(1,I) ............. ',
236 .'# ............... UVAR(NUVAR,I) '
237 WRITE(iugeo,'(A)')
238 .'#---------------------- END REPEAT ------------------------'
239 WRITE(iugeo,'(A)') delimit
240 ELSE
241 WRITE(line,'(A)') delimit
242 CALL strs_txt50(line,100)
243 WRITE(line,'(A)')'/INIBRI/FAIL'
244 CALL strs_txt50(line,100)
245 WRITE(line,'(A)')
246 .'#------------------------ REPEAT --------------------------'
247 CALL strs_txt50(line,100)
248 WRITE(line,'(A)')
249 .'# BRICKID NLAY NPTR NPTS
250 . NPTT ILAY IRUPT IRUPT_TYP NUVAR IMAT'
251 CALL strs_txt50(line,100)
252 WRITE(line,'(A)')
253 .'# REPEAT K=1,NPTR,NPTS*NPTT*NLAY '
254 CALL strs_txt50(line,100)
255 WRITE(line,'(A)')
256 .'# UVAR(1,I) ............. '
257 CALL strs_txt50(line,100)
258 WRITE(line,'(A)')
259 .'# ............... UVAR(NUVAR,I) '
260 CALL strs_txt50(line,100)
261 WRITE(line,'(A)')
262 .'#---------------------- END REPEAT ------------------------'
263 CALL strs_txt50(line,100)
264 WRITE(line,'(A)') delimit
265 CALL strs_txt50(line,100)
266 END IF
267 iprt0=iprt
268 END IF
269c
270 id = nint(wap0(j+3))
271 nlay = nint(wap0(j+4))
272 nptr = nint(wap0(j+5))
273 npts = nint(wap0(j+6))
274 nptt = nint(wap0(j+7))
275 isolnod= nint(wap0(j+8))
276 j = j + 9
277c
278 DO il=1,nlay
279 nfail = nint(wap0(j+1))
280 j = j + 1
281 imat = nint(wap0(j+1))
282 j = j + 1
283 DO ius=1,nfail
284 irupt = wap0(j+1)
285 j = j + 1
286 irupt_type = wap0(j+1)
287 j = j + 1
288 nvar_rupt = wap0(j+1)
289 j = j + 1
290!
291 IF (irupt == 0) cycle
292!
293 IF (irupt /= 0) THEN
294 IF (izipstrs == 0) THEN
295 WRITE(iugeo,'(10I10)') id,nlay,nptr,npts,nptt,
296 . il,irupt,irupt_type,nvar_rupt,
297 . imat
298 ELSE
299 WRITE(line,'(10I10)') id,nlay,nptr,npts,nptt,
300 . il,irupt,irupt_type,nvar_rupt,
301 . imat
302 CALL strs_txt50(line,100)
303 ENDIF
304 ENDIF
305 IF (izipstrs == 0) THEN
306 DO ir=1,nptr
307 DO is=1,npts
308 DO it=1,nptt
309 IF (irupt /= 0) WRITE(iugeo,'(1P3E20.13)')
310 . (wap0(j + k),k=1,nvar_rupt)
311 j = j + nvar_rupt
312 ENDDO
313 ENDDO
314 ENDDO
315 ELSE
316 DO ir=1,nptr
317 DO is=1,npts
318 DO it=1,nptt
319 IF (irupt /= 0)
320 . CALL tab_strs_txt50(wap0(1),nvar_rupt,j,sizp0,3)
321 j = j + nvar_rupt
322 ENDDO
323 ENDDO
324 ENDDO
325 ENDIF
326 ENDDO
327 ENDDO
328 ENDIF ! IF (IOFF == 1)
329 ENDDO
330 ENDIF
331c-----------
332 DEALLOCATE(ptwa)
333 DEALLOCATE(ptwa_p0)
334c-----------
335 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
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
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