OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_s_eref.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "com01_c.inc"
#include "com04_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"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_s_eref (elbuf_tab, iparg, ipm, igeo, ixs, ixs10, ixs16, ixs20, x, dr, wa, wap0, iparts, ipart_state, stat_indxs, ipart, sizp0)
subroutine getconfig (ift, ilt, npe, ismstr, x0, y0, z0, sav, nel)

Function/Subroutine Documentation

◆ getconfig()

subroutine getconfig ( integer ift,
integer ilt,
integer npe,
integer ismstr,
x0,
y0,
z0,
double precision, dimension(nel,*) sav,
integer nel )

Definition at line 336 of file stat_s_eref.F.

337C-----------------------------------------------
338C I m p l i c i t T y p e s
339C-----------------------------------------------
340#include "implicit_f.inc"
341C-----------------------------------------------
342C G l o b a l P a r a m e t e r s
343C-----------------------------------------------
344#include "mvsiz_p.inc"
345C-----------------------------------------------
346C D u m m y A r g u m e n t s
347C-----------------------------------------------
348 INTEGER NPE,NEL,IFT,ILT,ISMSTR
349 my_real
350 . x0(mvsiz,*), y0(mvsiz,*), z0(mvsiz,*)
351 DOUBLE PRECISION
352 . SAV(NEL,*)
353C-----------------------------------------------
354C L o c a l V a r i a b l e s
355C-----------------------------------------------
356 INTEGER I,NPE1,N,N2,N3
357C-----------------------------------------------
358C
359 npe1=npe-1
360 IF (ismstr==1.AND.npe<10) THEN
361 DO n=1,npe1
362 n2 = 3*(n -1) +1
363 DO i=ift,ilt
364 x0(i,n)=sav(i,n2)
365 y0(i,n)=sav(i,n2+1)
366 z0(i,n)=sav(i,n2+2)
367 ENDDO
368 ENDDO
369 ELSEIF (npe<10) THEN
370 DO n=1,npe1
371 n2 = n + npe1
372 n3 = n2 + npe1
373 DO i=ift,ilt
374 x0(i,n)=sav(i,n)
375 y0(i,n)=sav(i,n2)
376 z0(i,n)=sav(i,n3)
377 ENDDO
378 ENDDO
379 END IF
380C---------diff stockage for quadratic elements
381 IF (npe>=10) THEN
382 DO n=1,npe
383 n2 = n + npe
384 n3 = n2 + npe
385 DO i=ift,ilt
386 x0(i,n) =sav(i,n)
387 y0(i,n) =sav(i,n2)
388 z0(i,n) =sav(i,n3)
389 ENDDO
390 ENDDO
391 ELSE
392 DO i=ift,ilt
393 x0(i,npe)=zero
394 y0(i,npe)=zero
395 z0(i,npe)=zero
396 ENDDO
397 END IF !(NPE==10) THEN
398C
399 RETURN
my_real
#define my_real
Definition cppsort.cpp:32

◆ stat_s_eref()

subroutine stat_s_eref ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
x,
dr,
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 )

Definition at line 40 of file stat_s_eref.F.

44C-----------------------------------------------
45C M o d u l e s
46C-----------------------------------------------
47 USE initbuf_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 G l o b a l P a r a m e t e r s
57C-----------------------------------------------
58#include "mvsiz_p.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "com01_c.inc"
63#include "com04_c.inc"
64#include "param_c.inc"
65#include "units_c.inc"
66#include "task_c.inc"
67#include "scr14_c.inc"
68#include "scr16_c.inc"
69#include "vect01_c.inc"
70#include "scr17_c.inc"
71#include "tabsiz_c.inc"
72C-----------------------------------------------
73C D u m m y A r g u m e n t s
74C-----------------------------------------------
75 INTEGER SIZP0
76 INTEGER IXS(NIXS,*),IXS10(6,*),IXS16(8,*),IXS20(12,*),
77 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
78 . IPARTS(*), IPART_STATE(*), STAT_INDXS(*),IPART(LIPART1,*)
79 my_real
80 . x(3,*), dr(sdr)
81 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
82 double precision WA(*),WAP0(*)
83C-----------------------------------------------
84C L o c a l V a r i a b l e s
85C-----------------------------------------------
86 INTEGER I, N, J, K, JJ, LEN, ISOLNOD0,
87 . ISOLNOD,ISTRAIN,NG, NEL, MLW, ID, IPRT0, IPRT,IE,
88 . NPG,IPG,IPT,IL,IR,IS,IT,IPID,PID,IOFF,KK(8),NC(20),
89 . NN1,NN,NSROT
90 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
91 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
92 my_real x0(mvsiz,20), y0(mvsiz,20), z0(mvsiz,20)
93 CHARACTER*100 DELIMIT,LINE
94 DATA delimit(1:60)
95 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
96 DATA delimit(61:100)
97 ./'----7----|----8----|----9----|----10---|'/
98C----
99
100 TYPE(G_BUFEL_) ,POINTER :: GBUF
101C======================================================================|
102 CALL my_alloc(ptwa,stat_numels)
103 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
104C-----------------------------------------------
105 jj = 0
106 IF(stat_numels==0) GOTO 200
107
108 ie=0
109C----- not output all solid element
110 DO ng=1,ngroup
111 ity =iparg(5,ng)
112 isolnod = iparg(28,ng)
113 mlw =iparg(1,ng)
114 nel =iparg(2,ng)
115 nft =iparg(3,ng)
116 iad =iparg(4,ng)
117 istrain = iparg(44,ng)
118 lft = 1
119 llt = nel
120!
121 DO i=1,8 ! length max of GBUF%G_STRA = 8
122 kk(i) = nel*(i-1)
123 ENDDO
124!
125 IF (ity == 1) THEN
126 CALL initbuf(iparg ,ng ,
127 2 mlw ,nel ,nft ,iad ,ity ,
128 3 npt ,jale ,ismstr ,jeul ,jtur ,
129 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
130 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
131 6 irep ,iint ,igtyp ,israt ,isrot ,
132 7 icsen ,isorth ,isorthg ,ifailure,jsms )
133 IF (jhbe==17.AND.iint==2) jhbe = 18
134 IF (jhbe==1.AND.iint==3) jhbe = 5
135 isolnod0 = isolnod
136 nsrot = 0
137 IF (isolnod0==4 .AND. isrot==1) THEN
138 isolnod=10
139 nsrot = 4
140 END IF
141 gbuf => elbuf_tab(ng)%GBUF
142 iprt=iparts(lft+nft)
143 pid = ipart(2,iprt)
144c------
145 IF(ismstr==1.OR.ismstr>=10) THEN
146 CALL getconfig(lft,llt,isolnod,ismstr,x0,y0,z0,
147 1 gbuf%SMSTR,nel)
148 END IF
149 DO i=lft,llt
150 n = i + nft
151 iprt=iparts(n)
152 IF(ipart_state(iprt)==0)cycle
153 wa(jj+ 1)= iprt
154 wa(jj+ 2)= ixs(nixs,n)
155 wa(jj+ 3)= isolnod
156 wa(jj+ 4)= jhbe
157 wa(jj+ 5)= ismstr
158 wa(jj+ 6)= gbuf%OFF(i)
159 wa(jj+ 7)= nsrot
160 jj = jj + 7
161 IF(ismstr==1.OR.ismstr>=10) THEN
162 IF(isolnod == 8)THEN
163 DO j = 1,isolnod
164 nc(j) = ixs(j+1,n)
165 ENDDO
166 ELSEIF(isolnod0== 4)THEN
167 nc(1)=ixs(2,n)
168 nc(2)=ixs(4,n)
169 nc(3)=ixs(7,n)
170 nc(4)=ixs(6,n)
171 ELSEIF(isolnod == 6)THEN
172 nc(1)=ixs(2,n)
173 nc(2)=ixs(3,n)
174 nc(3)=ixs(4,n)
175 nc(4)=ixs(6,n)
176 nc(5)=ixs(7,n)
177 nc(6)=ixs(8,n)
178 ELSEIF(isolnod0== 10)THEN
179 nc(1)=ixs(2,n)
180 nc(2)=ixs(4,n)
181 nc(3)=ixs(7,n)
182 nc(4)=ixs(6,n)
183 nn1 = n - numels8
184 DO j=1,6
185 nc(j+4) = ixs10(j,nn1)
186 ENDDO
187 ELSEIF(isolnod == 16)THEN
188 nc(1:8) = ixs(2:9,n)
189 nn1 = n - (numels8+numels10+numels20)
190 DO j=1,8
191 nc(j+8) = ixs16(j,nn1)
192 ENDDO
193 ELSEIF(isolnod == 20)THEN
194 nc(1:8) = ixs(2:9,n)
195 nn1 = n - (numels8+numels10)
196 DO j=1,12
197 nc(j+8) = ixs20(j,nn1)
198 ENDDO
199 ENDIF
200 DO j= 1, isolnod
201 jj = jj + 1
202 wa(jj)= x0(i,j)
203 jj = jj + 1
204 wa(jj)= y0(i,j)
205 jj = jj + 1
206 wa(jj)= z0(i,j)
207 END DO
208 DO j= 1, nsrot
209 nn = 3*(nc(j)-1)
210 jj = jj + 1
211 wa(jj)= dr(1+nn)
212 jj = jj + 1
213 wa(jj)= dr(2+nn)
214 jj = jj + 1
215 wa(jj)= dr(3+nn)
216 END DO
217 END IF ! ISMSTR==1.OR.ISMSTR>=10
218 ie=ie+1
219C end-of-zone pointer in wa
220 ptwa(ie)=jj
221 END DO
222C
223 ENDIF ! ITY == 1
224 ENDDO ! NG=1,NGROUP
225 200 CONTINUE
226c-----------------------------------------------------------
227 IF(nspmd == 1)THEN
228C unnecessary copies for code simplification
229 ptwa_p0(0)=0
230 DO n=1,stat_numels
231 ptwa_p0(n)=ptwa(n)
232 END DO
233 len=jj
234 DO j=1,len
235 wap0(j)=wa(j)
236 END DO
237 ELSE
238C builds the pointers in the global array wap0
239 CALL spmd_stat_pgather(ptwa,stat_numels,ptwa_p0,stat_numels_g)
240 len = 0
241 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
242 END IF
243c-----------------------------------------------------------
244 IF(ispmd == 0.AND.len>0) THEN
245
246 iprt0=0
247 DO n=1,stat_numels_g
248
249C find the nieme elt in the order of an increasing id
250 k=stat_indxs(n)
251C Find the address in WAP0
252 j=ptwa_p0(k-1)
253 ioff = nint(wap0(j + 6))
254 iprt = nint(wap0(j + 1))
255 ismstr = nint(wap0(j + 5))
256 IF (ioff >= 1.AND.(ismstr==1.OR.ismstr>=10)) THEN
257 IF(iprt /= iprt0)THEN
258 IF (izipstrs == 0) THEN
259 WRITE(iugeo,'(A)') delimit
260 WRITE(iugeo,'(A)')'/INIBRI/EREF'
261 WRITE(iugeo,'(A)')
262 . '#------------------------ REPEAT -------------------------'
263 WRITE(iugeo,'(A)')
264 . '# BRICKID ISOLNOD ISOLID ISMSTR NSROT'
265 WRITE(iugeo,'(A/A)')
266 . '# REPEAT K=1,ISOLNOD ',
267 . '# X, Y, Z'
268 WRITE(iugeo,'(A)')
269 . '#------------------------ REPEAT -------------------------'
270 WRITE(iugeo,'(A)') delimit
271 ELSE
272 WRITE(line,'(A)') delimit
273 CALL strs_txt50(line,100)
274 WRITE(line,'(A)')'/INIBRI/EREF'
275 CALL strs_txt50(line,100)
276 WRITE(line,'(A)')
277 . '#------------------------ REPEAT -------------------------'
278 CALL strs_txt50(line,100)
279 WRITE(line,'(A)')
280 . '# BRICKID ISOLNOD ISOLID ISMSTR NSROT'
281 CALL strs_txt50(line,100)
282 WRITE(line,'(A)')
283 . '# REPEAT K=1,ISOLNOD '
284 CALL strs_txt50(line,100)
285 WRITE(line,'(A)')'# X, Y, Z'
286 CALL strs_txt50(line,100)
287 WRITE(line,'(A)')
288 . '# REPEAT K=1,NSROT '
289 CALL strs_txt50(line,100)
290 WRITE(line,'(A)')'# RX, RY, RZ'
291 CALL strs_txt50(line,100)
292 WRITE(line,'(A)')
293 . '#------------------------ REPEAT -------------------------'
294 CALL strs_txt50(line,100)
295 WRITE(line,'(A)') delimit
296 CALL strs_txt50(line,100)
297 END IF
298 iprt0=iprt
299 END IF
300 id = nint(wap0(j + 2))
301 isolnod = nint(wap0(j + 3))
302 jhbe = nint(wap0(j + 4))
303 nsrot = nint(wap0(j + 7))
304c
305 j = j + 7
306c------------------------------------------------
307 IF (izipstrs == 0) THEN
308 WRITE(iugeo,'(I10,10X,4I10)') id,isolnod,jhbe,ismstr,nsrot
309 ELSE
310 WRITE(line,'(I10,10X,4I10)') id,isolnod,jhbe,ismstr,nsrot
311 CALL strs_txt50(line,100)
312 ENDIF
313 DO ipt = 1, isolnod+nsrot
314 IF (izipstrs == 0) THEN
315 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
316 ELSE
317 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
318 ENDIF
319 j = j + 3
320 ENDDO
321 ENDIF ! IF (IOFF == 1)
322c---
323 ENDDO
324 ENDIF
325c-----------
326 DEALLOCATE(ptwa)
327 DEALLOCATE(ptwa_p0)
328c-----------
329 RETURN
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
getconfig
subroutine getconfig(ift, ilt, npe, ismstr, x0, y0, z0, sav, nel)
Definition stat_s_eref.F:337