OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_r_full.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr16_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_r_full (elbuf_tab, iparg, geo, igeo, ixr, wa, wap0, ipartr, ipart_state, stat_indxr, sizp0)

Function/Subroutine Documentation

◆ stat_r_full()

subroutine stat_r_full ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
geo,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixr,*) ixr,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartr,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxr,
integer sizp0 )

Definition at line 34 of file stat_r_full.F.

38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE elbufdef_mod
42 use element_mod , only : nixr
43C-----------------------------------------------
44C I m p l i c i t T y p e s
45C-----------------------------------------------
46#include "implicit_f.inc"
47C-----------------------------------------------
48C C o m m o n B l o c k s
49C-----------------------------------------------
50#include "com01_c.inc"
51#include "param_c.inc"
52#include "units_c.inc"
53#include "task_c.inc"
54#include "scr16_c.inc"
55C-----------------------------------------------
56C D u m m y A r g u m e n t s
57C-----------------------------------------------
58 INTEGER SIZP0
59 INTEGER IXR(NIXR,*),IPARG(NPARG,*),IGEO(NPROPGI,*),
60 . IPARTR(*),IPART_STATE(*),STAT_INDXR(*)
61 my_real
62 . geo(npropg,*)
63 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
64 double precision WA(*),WAP0(*)
65C-----------------------------------------------
66C L o c a l V a r i a b l e s
67C-----------------------------------------------
68 INTEGER I,J,K,N,II(6),IV,JJ,LEN,IOFF,IE,NG,NEL,NFT,LFT,
69 . LLT,ITY,ID,IPRT0,IPRT,IGTYP,IPROP,NUVAR,J_FIN
70 INTEGER PTWA(STAT_NUMELR),
71 . PTWA_P0(0:MAX(1,STAT_NUMELR_G))
72 CHARACTER*100 DELIMIT
73 TYPE(G_BUFEL_) ,POINTER :: GBUF
74C-----------------------------------------------
75 DATA delimit(1:60)
76 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
77 DATA delimit(61:100)
78 ./'----7----|----8----|----9----|----10---|'/
79C=======================================================================
80C SPRING
81C-----------------------------------------------
82 jj = 0
83C
84 IF (stat_numelr == 0) GOTO 100
85C
86 ie=0
87 DO ng=1,ngroup
88 ity = iparg(5,ng)
89 IF (ity == 6) THEN
90 gbuf => elbuf_tab(ng)%GBUF
91 nel = iparg(2,ng)
92 nft = iparg(3,ng)
93 iprop = ixr(1,nft+1)
94 igtyp = igeo(11,iprop)
95 lft=1
96 llt=nel
97C
98 DO i=lft,llt
99 n = i + nft
100 iprt=ipartr(n)
101 IF (ipart_state(iprt) == 0) cycle
102 wa(jj + 1) = gbuf%OFF(i)
103 wa(jj + 2) = iprt
104 wa(jj + 3) = ixr(nixr,n)
105 wa(jj + 4) = igtyp
106 wa(jj + 5) = 0 ! for NUVAR
107 jj = jj + 5
108C------------
109 IF (igtyp == 4) THEN
110C------------
111 wa(jj + 1) = gbuf%FOR(i)
112 wa(jj + 2) = gbuf%TOTDEPL(i)
113 wa(jj + 3) = gbuf%FOREP(i)
114 wa(jj + 4) = gbuf%DEP_IN_TENS(i)
115 wa(jj + 5) = gbuf%DEP_IN_COMP(i)
116 wa(jj + 6) = gbuf%LENGTH(i)
117 wa(jj + 7) = gbuf%EINT(i)
118cc
119 jj = jj + 7
120C------------
121 ELSEIF (igtyp == 12) THEN
122C------------
123 wa(jj + 1) = gbuf%FOR(i)
124 wa(jj + 2) = gbuf%TOTDEPL(i)
125 wa(jj + 3) = gbuf%FOREP(i)
126 wa(jj + 4) = gbuf%DEP_IN_TENS(i)
127 wa(jj + 5) = gbuf%DEP_IN_COMP(i)
128 wa(jj + 6) = gbuf%LENGTH(i)
129 wa(jj + 7) = gbuf%EINT(i)
130 wa(jj + 8) = gbuf%DFS(i)
131cc
132 jj = jj + 8
133C------------
134 ELSEIF (igtyp == 8 .OR. igtyp == 13 .OR. igtyp == 25
135 . .OR. igtyp == 23 ) THEN
136C------------
137 DO j=1,6
138 ii(j) = (j-1)*nel + 1
139 ENDDO
140 DO j=1,3
141 wa(jj + (j-1)*5 + 1) = gbuf%FOR(ii(j) + i - 1)
142 wa(jj + (j-1)*5 + 2) = gbuf%TOTDEPL(ii(j) + i - 1)
143 wa(jj + (j-1)*5 + 3) = gbuf%FOREP(ii(j) + i - 1)
144 wa(jj + (j-1)*5 + 4) = gbuf%DEP_IN_TENS(ii(j) + i - 1)
145 wa(jj + (j-1)*5 + 5) = gbuf%DEP_IN_COMP(ii(j) + i - 1)
146 wa(jj + (j-1)*5 + 16)= gbuf%MOM(ii(j) + i - 1)
147 wa(jj + (j-1)*5 + 17)= gbuf%TOTROT(ii(j) + i - 1)
148 wa(jj + (j-1)*5 + 18)= gbuf%MOMEP(ii(j) + i - 1)
149 wa(jj + (j-1)*5 + 19)= gbuf%ROT_IN_TENS(ii(j) + i - 1)
150 wa(jj + (j-1)*5 + 20)= gbuf%ROT_IN_COMP(ii(j) + i - 1)
151 wa(jj + j + 30) = gbuf%LENGTH(ii(j) + i - 1)
152 ENDDO
153 wa(jj + 34) = gbuf%EINT(i)
154 DO j=1,6
155 wa(jj + j + 34) = gbuf%E6(ii(j) + i - 1) ! E6(1:6)
156 ENDDO
157 jj = jj + 40
158C------------
159 ELSEIF (igtyp == 26) THEN
160C------------
161 wa(jj + 1) = gbuf%FOR(i)
162 wa(jj + 2) = gbuf%TOTDEPL(i)
163 wa(jj + 3) = gbuf%FOREP(i)
164 wa(jj + 4) = gbuf%LENGTH(i)
165 wa(jj + 5) = gbuf%EINT(i)
166 wa(jj + 6) = gbuf%DV(i)
167 jj = jj + 6
168C------------
169 ELSEIF (igtyp == 29 .OR. igtyp == 30 .OR. igtyp == 31 .OR.
170 . igtyp == 32 .OR. igtyp == 33 .OR. igtyp == 35 .OR.
171 . igtyp == 36 .OR. igtyp == 44 .OR. igtyp == 45 .OR.
172 . igtyp == 46) THEN
173C------------
174 nuvar = nint(geo(25,iprop))
175 wa(jj) = nuvar
176 DO j=1,3
177 ii(j) = (j-1)*nel + 1
178 wa(jj + (j-1)*2 + 1) = gbuf%FOR(ii(j) + i - 1)
179 wa(jj + (j-1)*2 + 2) = gbuf%V_REPCVT(ii(j) + i - 1)
180 wa(jj + (j-1)*2 + 7) = gbuf%MOM(ii(j) + i - 1)
181 wa(jj + (j-1)*2 + 8) = gbuf%VR_REPCVT(ii(j) + i - 1)
182 ENDDO
183 wa(jj + 13) = gbuf%EINT(i)
184 jj = jj + 13
185!! IF (IGTYP /= 32 .AND. IGTYP /= 33 .AND. IGTYP /= 45) THEN
186!! WA(JJ + 1) = GBUF%MOM(II(4) + I - 1) ! MOM1Y
187!! WA(JJ + 2) = GBUF%MOM(II(5) + I - 1) ! MOM1Z
188!! JJ = JJ + 2
189!! ENDIF
190 DO j=1,nuvar
191 iv = nuvar*(i-1) + j
192 wa(jj + j) = gbuf%VAR(iv)
193 ENDDO
194 jj = jj + nuvar
195C------------
196 ENDIF ! IF (IGTYP)
197C
198 ie=ie+1
199C end-of-zone pointer in wa
200 ptwa(ie)=jj
201 ENDDO ! DO I=LFT,LLT
202c------- end loop over spring elements
203 ENDIF ! ITY == 6
204 ENDDO ! NG = 1, NGROUP
205C
206 100 CONTINUE
207c-----------------------------------------------------------------------
208c SPRING - WRITE
209c-----------------------------------------------------------------------
210 IF (nspmd == 1) THEN
211C unnecessary copies for code simplification
212 ptwa_p0(0)=0
213 DO n=1,stat_numelr
214 ptwa_p0(n)=ptwa(n)
215 ENDDO
216 len=jj
217 DO j=1,len
218 wap0(j)=wa(j)
219 ENDDO
220 ELSE
221C builds the pointers in the global wap0 array
222 CALL spmd_stat_pgather(ptwa,stat_numelr,ptwa_p0,stat_numelr_g)
223 len = 0
224 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
225 ENDIF
226c-------------------------------------
227 IF (ispmd == 0 .AND. len > 0) THEN
228 iprt0 = 0
229 DO n=1,stat_numelr_g
230C find the nieme elt in the order of an increasing id
231 k=stat_indxr(n)
232C Find the address in WAP0
233 j=ptwa_p0(k-1)
234C
235 ioff = nint(wap0(j + 1))
236 IF (ioff >= 1) THEN
237 iprt = nint(wap0(j + 2))
238 id = nint(wap0(j + 3))
239 igtyp = nint(wap0(j + 4))
240 nuvar = nint(wap0(j + 5))
241 j = j + 5
242C--------------------------------------
243 IF (igtyp == 4) THEN
244C--------------------------------------
245 IF (iprt /= iprt0) THEN
246 WRITE(iugeo,'(A)') delimit
247 WRITE(iugeo,'(A)')'/INISPRI/FULL'
248 WRITE(iugeo,'(A)')
249 . '#----------------------------------------------------------'
250 WRITE(iugeo,'(A)')'#SPRING_ID PROP_TYPE NUVAR'
251 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(F(I),DL(I),FEP(I),DPL(I),DPL2(I),I=SPRING_ID)'
252 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(XLO(I),EI(I),I=SPRING_ID)'
253 WRITE(iugeo,'(A)')
254 . '#----------------------------------------------------------'
255 iprt0=iprt
256 iprt0=iprt
257 ENDIF ! IF (IPRT /= IPRT0)
258C---
259 WRITE(iugeo,'(3I10)') id,igtyp,nuvar
260!! WRITE(IUGEO,'(1P5E20.13)')(WAP0(J+K),K=1,7)
261 WRITE(iugeo,'(1P5E20.13)')(wap0(j+k),k=1,5)
262 WRITE(iugeo,'(1P2E20.13)')(wap0(j+k),k=6,7)
263C--------------------------------------
264 ELSEIF (igtyp == 12) THEN
265C--------------------------------------
266 IF (iprt /= iprt0) THEN
267 WRITE(iugeo,'(A)') delimit
268 WRITE(iugeo,'(A)')'/INISPRI/FULL'
269 WRITE(iugeo,'(A)')
270 . '#----------------------------------------------------------'
271 WRITE(iugeo,'(A)')
272 . '#SPRING_ID PROP_TYPE NUVAR'
273 WRITE(iugeo,'(A)') '#FORMAT:(1P5E20.13) #(F(I),DL(I),FEP(I),DPL(I),DPL2(I),I=SPRING_ID)'
274 WRITE(iugeo,'(A)') '#FORMAT:(1P3E20.13) #(XL0(I),EI(I),DFS(I),I=SPRING_ID)'
275 WRITE(iugeo,'(A)')
276 . '#----------------------------------------------------------'
277 iprt0=iprt
278 ENDIF ! IF (IPRT /= IPRT0)
279C---
280 WRITE(iugeo,'(3I10)') id,igtyp,nuvar
281!! WRITE(IUGEO,'(1P5E20.13)')(WAP0(J+K),K=1,8)
282 WRITE(iugeo,'(1P5E20.13)')(wap0(j+k),k=1,5)
283 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=6,8)
284C--------------------------------------
285 ELSEIF (igtyp == 8 .OR. igtyp == 13 .OR. igtyp == 25
286 . .OR. igtyp == 23 ) THEN
287C--------------------------------------
288 IF (iprt /= iprt0) THEN
289 WRITE(iugeo,'(A)') delimit
290 WRITE(iugeo,'(A)')'/INISPRI/FULL'
291 WRITE(iugeo,'(A)')
292 . '#----------------------------------------------------------'
293 WRITE(iugeo,'(A)')
294 . '#SPRING_ID PROP_TYPE NUVAR'
295 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(FX(I),DX(I),FXEP(I),DPX(I),DPX2(I),I=SPRING_ID)'
296 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(FY(I),DY(I),FYEP(I),DPX(I),DPX2(I),I=SPRING_ID)'
297 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(FZ(I),DZ(I),FZEP(I),DPX(I),DPX2(I),I=SPRING_ID)'
298 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(XMOM(I),RX(I),XMEP(I),RPX(I),RPX2(I),I=SPRING_ID)'
299 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(YMOM(I),RY(I),YMEP(I),RPY(I),RPY2(I),I=SPRING_ID)'
300 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(ZMOM(I),RZ(I),ZMEP(I),RPZ(I),RPZ2(I),I=SPRING_ID)'
301 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(XLO(I),YL0(I),ZL0(I),EI(I),E1(I),I=SPRING_ID)'
302 WRITE(iugeo,'(2A)')'#FORMAT:(1P5E20.13) #(E2(I),E3(I),E4(I),E5(I),E6(I),I=SPRING_ID)'
303 WRITE(iugeo,'(A)')
304 . '#----------------------------------------------------------'
305 iprt0=iprt
306 ENDIF ! IF (IPRT /= IPRT0)
307C---
308 WRITE(iugeo,'(3I10)') id,igtyp,nuvar
309 WRITE(iugeo,'(1P5E20.13)')(wap0(j+k),k=1,40)
310C--------------------------------------
311 ELSEIF (igtyp == 26) THEN
312C--------------------------------------
313 IF (iprt /= iprt0) THEN
314 WRITE(iugeo,'(A)') delimit
315 WRITE(iugeo,'(A)')'/INISPRI/FULL'
316 WRITE(iugeo,'(A)')
317 . '#----------------------------------------------------------'
318 WRITE(iugeo,'(A)')
319 . '#SPRING_ID PROP_TYPE NUVAR'
320 WRITE(iugeo,'(A)') '#FORMAT:(1P3E20.13) #(F(I),DL(I),FEP(I),I=SPRING_ID)'
321 WRITE(iugeo,'(A)') '#FORMAT:(1P3E20.13) #(XL0(I),EI(I),DV(I),I=SPRING_ID)'
322 WRITE(iugeo,'(A)')
323 . '#----------------------------------------------------------'
324 iprt0=iprt
325 ENDIF ! IF (IPRT /= IPRT0)
326C---
327 WRITE(iugeo,'(3I10)') id,igtyp,nuvar
328 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=1,3)
329 WRITE(iugeo,'(1P3E20.13)')(wap0(j+k),k=4,6)
330C--------------------------------------
331 ELSEIF (igtyp == 29 .OR. igtyp == 30 .OR. igtyp == 31 .OR.
332 . igtyp == 32 .OR. igtyp == 33 .OR. igtyp == 35 .OR.
333 . igtyp == 36 .OR. igtyp == 44 .OR. igtyp == 45 .OR.
334 . igtyp == 46) THEN
335C--------------------------------------
336 IF (iprt /= iprt0) THEN
337 WRITE(iugeo,'(A)') delimit
338 WRITE(iugeo,'(A)')'/INISPRI/FULL'
339 WRITE(iugeo,'(A)')
340 . '#----------------------------------------------------------'
341 WRITE(iugeo,'(A)')
342 . '#SPRING_ID PROP_TYPE NUVAR'
343 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(FX(I),DX(I),I=SPRING_ID)'
344 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(FY(I),DY(I),I=SPRING_ID)'
345 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(FZ(I),DZ(I),I=SPRING_ID)'
346 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(XMOM(I),RX(I),I=SPRING_ID)'
347 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(YMOM(I),RY(I),I=SPRING_ID)'
348 WRITE(iugeo,'(A)')'#FORMAT:(1P2E20.13) #(ZMOM(I),RZ(I),I=SPRING_ID)'
349 WRITE(iugeo,'(A)')'#FORMAT:(1P1E20.13) #(EI(I),I=1,NEL)'
350!! IF (IGTYP /= 32 .AND. IGTYP /= 33 .AND. IGTYP /= 45) THEN
351!! WRITE(IUGEO,'(A)')'#FORMAT:(1P2E20.13)
352!! . #(MOM1Y(I),MOM1Z(I),I=SPRING_ID)'
353!! ENDIF
354 WRITE(iugeo,'(A)')'#FORMAT:(1P5E20.13) #(UVAR(I,J),J=1,NUVAR),I=SPRING_ID)'
355 WRITE(iugeo,'(A)')
356 . '#----------------------------------------------------------'
357 iprt0=iprt
358 ENDIF ! IF (IPRT /= IPRT0)
359C---
360 WRITE(iugeo,'(3I10)') id,igtyp,nuvar
361!! WRITE(IUGEO,'(1P5E20.13)') (WAP0(J+K),K=1,12)
362 WRITE(iugeo,'(1P2E20.13)') (wap0(j+k),k=1,2)
363 WRITE(iugeo,'(1P2E20.13)') (wap0(j+k),k=3,4)
364 WRITE(iugeo,'(1P2E20.13)') (wap0(j+k),k=5,6)
365 WRITE(iugeo,'(1P2E20.13)') (wap0(j+k),k=7,8)
366 WRITE(iugeo,'(1P2E20.13)') (wap0(j+k),k=9,10)
367 WRITE(iugeo,'(1P2E20.13)') (wap0(j+k),k=11,12)
368 WRITE(iugeo,'(1P1E20.13)') wap0(j+13) ! EINT
369 j_fin = j + 13
370C
371!! IF (IGTYP /= 32 .AND. IGTYP /= 33 .AND. IGTYP /= 45) THEN
372!! WRITE(IUGEO,'(1P2E20.13)') (WAP0(J_FIN+K),K=1,2) ! MOM1Y, MOM1Z
373!! J_FIN = J_FIN + 2
374!! ENDIF
375C ( + NUVAR )
376 WRITE(iugeo,'(1P5E20.13)')(wap0(j_fin+k),k=1,nuvar)
377C--------------------------------------
378 ENDIF ! IF (IGTYP)
379C--------------------------------------
380 ENDIF ! IF (IOFF >= 1)
381 ENDDO ! DO N=1,STAT_NUMELR_G
382 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
383C---
384 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
id
initmumps id
Definition multiplerhs_example.m:4
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