OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_s_auxf.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_auxf (elbuf_tab, iparg, ipm, igeo, ixs, wa, wap0, iparts, ipart_state, stat_indxs, ipart, sizp0)

Function/Subroutine Documentation

◆ stat_s_auxf()

subroutine stat_s_auxf ( 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 )

Definition at line 39 of file stat_s_auxf.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE initbuf_mod
46 USE elbufdef_mod
47 USE my_alloc_mod
48 use element_mod , only : nixs
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 SIZP0
68 INTEGER IXS(NIXS,*),
69 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
70 . IPARTS(*), IPART_STATE(*), STAT_INDXS(*),IPART(LIPART1,*)
71 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
72 double precision WA(*),WAP0(*)
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER I,N,J,K,JJ,LEN,ISOLNOD,IUS,NLAY,NPTR,NPTS,NPTT,NPTG,
77 . NG, NEL, MLW,ID, IPRT0, IPRT,IPT, NUVAR,IE,
78 . IL,IR,IS,IT,PID,IOFF
79 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
80 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
81 CHARACTER*100 DELIMIT,LINE
82 DATA delimit(1:60)
83 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
84 DATA delimit(61:100)
85 ./'----7----|----8----|----9----|----10---|'/
86C----
87 TYPE(L_BUFEL_) ,POINTER :: LBUF
88 TYPE(G_BUFEL_) ,POINTER :: GBUF
89 TYPE(BUF_MAT_) ,POINTER :: MBUF
90C-----------------------------------------------
91C 8 NODES BRICK
92C======================================================================|
93 CALL my_alloc(ptwa,stat_numels)
94 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
95C-----------------------------------------------
96 jj = 0
97 ie = 0
98 IF(stat_numels==0) GOTO 200
99 DO ng=1,ngroup
100 ity =iparg(5,ng)
101 isolnod = iparg(28,ng)
102 mlw =iparg(1,ng)
103 nel =iparg(2,ng)
104 nft =iparg(3,ng)
105 iad =iparg(4,ng)
106 lft=1
107 llt = nel
108 iprt=iparts(lft+nft)
109 pid = ipart(2,iprt)
110c
111 IF (ity == 1) THEN
112 CALL initbuf(iparg ,ng ,
113 2 mlw ,nel ,nft ,iad ,ity ,
114 3 npt ,jale ,ismstr ,jeul ,jtur ,
115 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
116 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
117 6 irep ,iint ,igtyp ,israt ,isrot ,
118 7 icsen ,isorth ,isorthg ,ifailure,jsms )
119 iprt=iparts(lft+nft)
120 pid = ipart(2,iprt)
121C JHBE = IGEO(10,PID)
122 gbuf => elbuf_tab(ng)%GBUF
123 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
124 mbuf => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)
125 nlay = elbuf_tab(ng)%NLAY
126 nptr = elbuf_tab(ng)%NPTR
127 npts = elbuf_tab(ng)%NPTS
128 nptt = elbuf_tab(ng)%NPTT
129 npt = nptr * npts * nptt * nlay
130 IF (jhbe==17.AND.iint==2) jhbe = 18
131 IF (jhbe==1.AND.iint==3) jhbe = 5
132 IF (mlw < 28) THEN
133 nuvar = 0
134 ELSEIF (mlw == 112) THEN
135 nuvar = 3
136 ELSE
137 nuvar = ipm(8,ixs(1,nft+1))
138 ENDIF
139c-------------------------------
140 IF (isolnod == 16) THEN
141c
142 DO i=lft,llt
143 n = i + nft
144 iprt=iparts(n)
145 IF (ipart_state(iprt)==0) cycle
146 wa(jj+1) = gbuf%VOL(i)
147 wa(jj+2) = iprt
148 wa(jj+3) = ixs(nixs,n)
149 wa(jj+4) = nlay
150 wa(jj+5) = nptr
151 wa(jj+6) = npts
152 wa(jj+7) = nptt
153 wa(jj+8) = isolnod
154 wa(jj+9) = nuvar
155 wa(jj+10)= jhbe
156 wa(jj+11) = gbuf%OFF(i)
157 jj = jj + 11
158 is = 1
159 DO it=1,nptt
160 DO il=1,nlay
161 DO ir=1,nptr
162 IF (mlw == 112) THEN
163 DO ius = 1,3
164 wa(jj + 1) = elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%PLA(i + ius*nel)
165 jj = jj +1
166 ENDDO
167 ELSE
168 mbuf => elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,it)
169 DO ius = 1,nuvar
170 wa(jj + 1) = mbuf%VAR(i + (ius-1)*nel)
171 jj = jj +1
172 ENDDO
173 ENDIF
174 ENDDO
175 ENDDO
176 ENDDO
177 ie=ie+1
178C end-of-zone pointer in wa
179 ptwa(ie)=jj
180 ENDDO ! I=LFT,LLT
181 ELSE
182 DO i=lft,llt
183 n = i + nft
184 iprt=iparts(n)
185 IF (ipart_state(iprt)==0) cycle
186 wa(jj+1) = gbuf%VOL(i)
187 wa(jj+2) = iprt
188 wa(jj+3) = ixs(nixs,n)
189 wa(jj+4) = nlay
190 wa(jj+5) = nptr
191 wa(jj+6) = npts
192 wa(jj+7) = nptt
193 wa(jj+8) = isolnod
194 wa(jj+9) = nuvar
195 wa(jj+10)= jhbe
196 wa(jj+11) = gbuf%OFF(i)
197 jj = jj + 11
198 DO il=1,nlay
199 DO it=1,nptt
200 DO is=1,npts
201 DO ir=1,nptr
202 IF (mlw == 112) THEN
203 DO ius = 1,3
204 wa(jj + 1) = elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%PLA(i + ius*nel)
205 jj = jj +1
206 ENDDO
207 ELSE
208 mbuf => elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,it)
209 DO ius = 1,nuvar
210 wa(jj + 1) = mbuf%VAR(i + (ius-1)*nel)
211 jj = jj +1
212 ENDDO
213 ENDIF
214 ENDDO
215 ENDDO
216 ENDDO
217 ENDDO
218 ie=ie+1
219C end-of-zone pointer in wa
220 ptwa(ie)=jj
221 ENDDO ! I=LFT,LLT
222 ENDIF ! ISOLNOD == 16
223 ENDIF ! ITY = 1
224 ENDDO
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 iprt0=0
246 DO n=1,stat_numels_g
247C find the nieme elt in the order of an increasing id
248 k=stat_indxs(n)
249C Find the address in WAP0
250 j=ptwa_p0(k-1)
251 iprt = nint(wap0(j + 2))
252 ioff = nint(wap0(j + 11))
253 IF (ioff >= 1) THEN
254 IF(iprt /= iprt0)THEN
255 IF (izipstrs == 0) THEN
256 WRITE(iugeo,'(A)') delimit
257 WRITE(iugeo,'(A)')'/INIBRI/AUX'
258 WRITE(iugeo,'(A)')
259 .'#------------------------ REPEAT --------------------------'
260 WRITE(iugeo,'(A)')
261 . '# BRICKID NPT'
262 WRITE(iugeo,'(A/A/A)')
263 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
264 .'# S1, S2, S3',
265 .'# S12, S23, S31'
266 WRITE(iugeo,'(A)')
267 .'#---------------------- END REPEAT ------------------------'
268 WRITE(iugeo,'(A)') delimit
269 ELSE
270 WRITE(line,'(A)') delimit
271 CALL strs_txt50(line,100)
272 WRITE(line,'(A)')'/INIBRI/AUX'
273 CALL strs_txt50(line,100)
274 WRITE(line,'(A)')
275 .'#------------------------ REPEAT --------------------------'
276 CALL strs_txt50(line,100)
277 WRITE(line,'(A)')
278 . '# BRICKID NPT'
279 CALL strs_txt50(line,100)
280 WRITE(line,'(A)')
281 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
282 CALL strs_txt50(line,100)
283 WRITE(line,'(A)')'# S1, S2, S3'
284 CALL strs_txt50(line,100)
285 WRITE(line,'(A)')'# S12, S23, S31'
286 CALL strs_txt50(line,100)
287 WRITE(line,'(A)')
288 .'#---------------------- END REPEAT ------------------------'
289 CALL strs_txt50(line,100)
290 WRITE(line,'(A)') delimit
291 CALL strs_txt50(line,100)
292 END IF
293 iprt0=iprt
294 END IF
295c
296 id = nint(wap0(j + 3))
297 nlay = nint(wap0(j+4))
298 nptr = nint(wap0(j+5))
299 npts = nint(wap0(j+6))
300 nptt = nint(wap0(j+7))
301 isolnod= nint(wap0(j+8))
302 nuvar = nint(wap0(j+9))
303 jhbe = nint(wap0(j+10))
304 nptg = nlay*nptr*npts*nptt
305 j = j + 11
306c
307 IF(isolnod==8.AND.jhbe==14 )THEN
308 IF (izipstrs == 0) THEN
309 WRITE(iugeo,'(7I10)') id,nptg,isolnod,jhbe,0,0,nuvar
310 ELSE
311 WRITE(line,'(7I10)') id,nptg,isolnod,jhbe,0,0,nuvar
312 CALL strs_txt50(line,100)
313 ENDIF
314 IF (nuvar /= 0) THEN
315 IF (izipstrs == 0) THEN
316 DO ipt=1,nptg
317 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,nuvar)
318 j = j + nuvar
319 ENDDO
320 ELSE
321 DO ipt=1,nptg
322 CALL tab_strs_txt50(wap0(1),nuvar,j,sizp0,3)
323 j = j + nuvar
324 ENDDO
325 ENDIF
326 ENDIF
327 ELSEIF(isolnod==8 .OR. isolnod==6 .OR. isolnod==4 .OR.
328 . isolnod==10 .OR. isolnod==16 .OR. isolnod==20)THEN
329 IF (izipstrs == 0) THEN
330 WRITE(iugeo,'(7I10)') id,nptg,isolnod,jhbe,0,0,nuvar
331 ELSE
332 WRITE(line,'(7I10)') id,nptg,isolnod,jhbe,0,0,nuvar
333 CALL strs_txt50(line,100)
334 ENDIF
335 IF (nuvar /= 0) THEN
336 IF (izipstrs == 0) THEN
337 DO ipt=1,nptg
338 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,nuvar)
339 j = j + nuvar
340 ENDDO
341 ELSE
342 DO ipt=1,nptg
343 CALL tab_strs_txt50(wap0(1),nuvar,j,sizp0,3)
344 j = j + nuvar
345 ENDDO
346 ENDIF
347 ENDIF
348 ENDIF
349 ENDIF ! IF (IOFF == 1)
350 ENDDO
351 ENDIF
352c-----------
353 DEALLOCATE(ptwa)
354 DEALLOCATE(ptwa_p0)
355c-----------
356 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