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 38 of file stat_s_auxf.F.

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