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 40 of file stat_s_fail.F.

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