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

Go to the source code of this file.

Functions/Subroutines

subroutine stat_c_straf (elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, thke, sizp0)

Function/Subroutine Documentation

◆ stat_c_straf()

subroutine stat_c_straf ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartc,
integer, dimension(*) iparttg,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxc,
integer, dimension(*) stat_indxtg,
thke,
integer sizp0 )

Definition at line 37 of file stat_c_straf.F.

40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE elbufdef_mod
44 USE my_alloc_mod
45 use element_mod , only : nixc,nixtg
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "com01_c.inc"
54#include "com04_c.inc"
55#include "param_c.inc"
56#include "units_c.inc"
57#include "scr14_c.inc"
58#include "scr16_c.inc"
59#include "task_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER SIZP0
64 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
65 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
66 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
67 . STAT_INDXC(*), STAT_INDXTG(*)
68 my_real
69 . thke(*)
70 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
71 double precision WA(*),WAP0(*)
72C-----------------------------------------------
73C L o c a l V a r i a b l e s
74C-----------------------------------------------
75 INTEGER I,J,K,N,II,JJ,LEN, IOFF, NG, NEL, NFT, ITY, LFT, NPT,
76 . LLT, MLW, ISTRAIN,ID, IPRT0, IPRT,NPG,IPG,IE,NPTR,NPTS,G_STRA,
77 . ITHK,KK(8)
78 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
79 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
80 double precision
81 . THK, EM, EB, H1, H2, H3
82 CHARACTER*100 DELIMIT,LINE
83 TYPE(G_BUFEL_) ,POINTER :: GBUF
84
85
86 my_real,
87 . DIMENSION(:),POINTER :: strain
88C-----------------------------------------------
89 DATA delimit(1:60)
90 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
91 DATA delimit(61:100)
92 ./'----7----|----8----|----9----|----10---|'/
93C-----------------------------------------------
94C 4-NODE SHELLS
95C-----------------------------------------------
96 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
97 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
98C-----------------------------------------------
99 jj = 0
100 IF(stat_numelc==0) GOTO 200
101
102 ie=0
103 DO ng=1,ngroup
104 ity =iparg(5,ng)
105 IF (ity == 3) THEN
106 gbuf => elbuf_tab(ng)%GBUF
107 mlw =iparg(1,ng)
108 nel =iparg(2,ng)
109 nft =iparg(3,ng)
110 npt = iparg(6,ng)
111 ithk =iparg(28,ng)
112 nptr = elbuf_tab(ng)%NPTR
113 npts = elbuf_tab(ng)%NPTS
114 npg = nptr*npts
115 lft=1
116 llt=nel
117 g_stra = gbuf%G_STRA
118!
119 DO j=1,8 ! length max of GBUF%G_STRA = 8
120 kk(j) = nel*(j-1)
121 ENDDO
122!
123c--------------------
124 DO i=lft,llt
125 n = i + nft
126
127 iprt=ipartc(n)
128 IF(ipart_state(iprt)==0)cycle
129
130 jj = jj + 1
131 IF (mlw /= 0 .AND. mlw /= 13) THEN
132 wa(jj) = gbuf%OFF(i)
133 ELSE
134 wa(jj) = zero
135 ENDIF
136 jj = jj + 1
137 wa(jj) = iprt
138 jj = jj + 1
139 wa(jj) = ixc(nixc,n)
140 jj = jj + 1
141 wa(jj) = npt
142 jj = jj + 1
143 wa(jj) = npg
144 jj = jj + 1
145 IF (mlw /= 0 .AND. mlw /= 13) THEN
146 IF (ithk >0 ) THEN
147 wa(jj) = gbuf%THK(i)
148 ELSE
149 wa(jj) = thke(n)
150 END IF
151 ELSE
152 wa(jj) = zero
153 ENDIF
154c Strain in Gauss points
155 IF (mlw == 0 .or. mlw == 13) THEN
156 DO ipg=1,npg
157 DO j=1,g_stra
158 jj = jj + 1
159 wa(jj)=zero
160 END DO
161 END DO
162 ELSEIF (g_stra /= 0) THEN
163 IF (npg > 1) THEN
164 strain => gbuf%STRPG
165 ELSE
166 strain => gbuf%STRA
167 ENDIF
168 ii = g_stra*(i-1)
169 DO ipg=1,npg
170 k = (ipg-1)*nel*g_stra
171 DO j=1,g_stra
172 jj = jj + 1
173 wa(jj) = strain(kk(j)+i+k)
174 END DO
175 END DO
176 END IF
177
178 ie=ie+1
179C end-of-zone pointer in wa
180 ptwa(ie)=jj
181c
182 ENDDO ! I=LFT,LLT
183 END IF ! ITY==3
184 ENDDO ! NG=1,NGROUP
185
186 200 CONTINUE
187
188 IF(nspmd == 1)THEN
189 ptwa_p0(0)=0
190 DO n=1,stat_numelc
191 ptwa_p0(n)=ptwa(n)
192 END DO
193 len=jj
194 DO j=1,len
195 wap0(j)=wa(j)
196 END DO
197 ELSE
198C builds the pointers in the global array wap0
199 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
200 len = 0
201 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
202 END IF
203
204 IF(ispmd==0.AND.len>0) THEN
205
206 iprt0=0
207 DO n=1,stat_numelc_g
208
209C find the nieme elt in the order of an increasing id
210 k=stat_indxc(n)
211C Find the address in WAP0
212 j=ptwa_p0(k-1)
213
214 ioff = nint(wap0(j + 1))
215 IF(ioff >= 1)THEN
216 iprt = nint(wap0(j + 2))
217 IF(iprt /= iprt0)THEN
218 IF (izipstrs == 0) THEN
219 WRITE(iugeo,'(A)') delimit
220 WRITE(iugeo,'(A)')'/INISHE/STRA_F'
221 WRITE(iugeo,'(A)')
222 .'#------------------------ REPEAT --------------------------'
223 WRITE(iugeo,'(A)')
224 . '# SHELLID NPT NPG THK'
225 WRITE(iugeo,'(A/A/A)')
226 .'# REPEAT I=1,NPG :',
227 .'# E1, E2, E12, E23, E31,',
228 .'# K1, K2, K12'
229 WRITE(iugeo,'(A)')
230 .'#---------------------- END REPEAT ------------------------'
231 WRITE(iugeo,'(A)') delimit
232 ELSE
233 WRITE(line,'(A)') delimit
234 CALL strs_txt50(line,100)
235 WRITE(line,'(A)')'/INISHE/STRA_F'
236 CALL strs_txt50(line,100)
237 WRITE(line,'(A)')
238 .'#------------------------ REPEAT --------------------------'
239 CALL strs_txt50(line,100)
240 WRITE(line,'(A)')
241 . '# SHELLID NPT NPG THK'
242 CALL strs_txt50(line,100)
243 WRITE(line,'(A)')'# REPEAT I=1,NPG :'
244 CALL strs_txt50(line,100)
245 WRITE(line,'(A)')'# E1, E2, E12, E23, E31,'
246 CALL strs_txt50(line,100)
247 WRITE(line,'(A)')'# K1, K2, K12'
248 CALL strs_txt50(line,100)
249 WRITE(line,'(A)')
250 .'#---------------------- END REPEAT ------------------------'
251 CALL strs_txt50(line,100)
252 WRITE(line,'(A)') delimit
253 CALL strs_txt50(line,100)
254 ENDIF
255 iprt0=iprt
256 END IF
257 id = nint(wap0(j + 3))
258 npt = nint(wap0(j + 4))
259 npg = nint(wap0(j + 5))
260 thk = wap0(j + 6)
261 j = j + 6
262 IF (izipstrs == 0) THEN
263 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
264 ELSE
265 WRITE(line,'(3i10,1pe20.13)')ID,NPT,NPG,THK
266 CALL STRS_TXT50(LINE,100)
267 ENDIF
268
269 DO IPG=1,NPG
270 IF (IZIPSTRS == 0) THEN
271 WRITE(IUGEO,'(1p5e20.13)')(WAP0(J + K),K=1,5)
272 WRITE(IUGEO,'(1p3e20.13)')(WAP0(J + K),K=6,8)
273 ELSE
274 CALL TAB_STRS_TXT50(WAP0(1),5,J,SIZP0,5)
275 CALL TAB_STRS_TXT50(WAP0(6),3,J,SIZP0,3)
276 ENDIF
277 J = J + 8
278 END DO
279 END IF
280 ENDDO
281 ENDIF
282
283C-----------------------------------------------
284C 3-NODE SHELLS
285C-----------------------------------------------
286 JJ = 0
287 IF (STAT_NUMELTG==0) GOTO 300
288 IE=0
289
290 DO NG=1,NGROUP
291 ITY =IPARG(5,NG)
292 IF (ITY == 7) THEN
293 GBUF => ELBUF_TAB(NG)%GBUF
294 G_STRA = GBUF%G_STRA
295 MLW =IPARG(1,NG)
296 NEL =IPARG(2,NG)
297 NFT =IPARG(3,NG)
298 NPT = IPARG(6,NG)
299 ITHK = IPARG(28,NG)
300 NPTR = ELBUF_TAB(NG)%NPTR
301 NPTS = ELBUF_TAB(NG)%NPTS
302 NPG = NPTR*NPTS
303 LFT=1
304 LLT=NEL
305!
306 DO J=1,8 ! length max of GBUF%G_STRA = 8
307 KK(J) = NEL*(J-1)
308 ENDDO
309!
310c--------------------
311 DO I=LFT,LLT
312 N = I + NFT
313
314 IPRT=IPARTTG(N)
315 IF(IPART_STATE(IPRT)==0)CYCLE
316
317
318 JJ = JJ + 1
319.AND. IF (MLW /= 0 MLW /= 13) THEN
320 WA(JJ) = GBUF%OFF(I)
321 ELSE
322 WA(JJ) = ZERO
323 ENDIF
324 JJ = JJ + 1
325 WA(JJ) = IPRT
326 JJ = JJ + 1
327 WA(JJ) = IXTG(NIXTG,N)
328 JJ = JJ + 1
329 WA(JJ) = NPT
330 JJ = JJ + 1
331 WA(JJ) = NPG
332 JJ = JJ + 1
333.AND. IF (MLW /= 0 MLW /= 13) THEN
334 IF (ITHK >0 ) THEN
335 WA(JJ) = GBUF%THK(I)
336 ELSE
337 WA(JJ) = THKE(N+NUMELC)
338 END IF
339 ELSE
340 WA(JJ) = ZERO
341 ENDIF
342
343c Strain in Gauss points
344.or. IF (MLW == 0 MLW == 13) THEN
345 DO IPG=1,NPG
346 DO J=1,G_STRA
347 JJ = JJ + 1
348 WA(JJ) = ZERO
349 END DO
350 END DO
351 ELSEIF (G_STRA > 0) THEN
352 IF (NPG > 1) THEN
353 STRAIN => GBUF%STRPG
354 ELSE
355 STRAIN => GBUF%STRA
356 ENDIF
357 II = G_STRA*(I-1)
358 DO IPG=1,NPG
359 K = (IPG-1)*NEL*G_STRA
360 DO J=1,G_STRA
361 JJ = JJ + 1
362 WA(JJ) = STRAIN(KK(J)+I+K)
363 END DO
364 END DO
365 END IF ! ISTRAIN /=0
366
367 IE=IE+1
368C end-of-zone pointer
369 PTWA(IE)=JJ
370c
371 ENDDO ! I=LFT,LLT
372 END IF ! ITY==3
373 ENDDO ! NG=1,NGROUP
374
375 300 CONTINUE
376
377 IF(NSPMD == 1)THEN
378 LEN=JJ
379 DO J=1,LEN
380 WAP0(J)=WA(J)
381 END DO
382 PTWA_P0(0)=0
383 DO N=1,STAT_NUMELTG
384 PTWA_P0(N)=PTWA(N)
385 END DO
386 ELSE
387C builds the pointers in the global array wap0
388 CALL SPMD_STAT_PGATHER(PTWA,STAT_NUMELTG,PTWA_P0,STAT_NUMELTG_G)
389 LEN = 0
390 CALL SPMD_RGATHER9_DP(WA,JJ,WAP0,SIZP0,LEN)
391 END IF
392
393.AND. IF(ISPMD==0LEN>0) THEN
394
395 IPRT0=0
396 DO N=1,STAT_NUMELTG_G
397
398C find the nieme elt in the order of an increasing id
399 K=STAT_INDXTG(N)
400C Find the address in WAP0
401 J=PTWA_P0(K-1)
402
403 IOFF = NINT(WAP0(J + 1))
404 IF(IOFF >= 1)THEN
405 IPRT = NINT(WAP0(J + 2))
406 IF(IPRT /= IPRT0)THEN
407 IF (IZIPSTRS == 0) THEN
408 WRITE(IUGEO,'(a)') DELIMIT
409 WRITE(IUGEO,'(a)')'/inish3/stra_f'
410 WRITE(IUGEO,'(a)')
411 .'#------------------------ REPEAT --------------------------'
412 WRITE(iugeo,'(A)')
413 . '# SH3NID NPT NPG THK'
414 WRITE(iugeo,'(A/A/A)')
415 .'# REPEAT I=1,NPG :',
416 .'# E1, E2, E12, E23, E31,',
417 .'# K1, K2, K12'
418 WRITE(iugeo,'(A)')
419 .'#---------------------- END REPEAT ------------------------'
420 WRITE(iugeo,'(A)') delimit
421 ELSE
422 WRITE(line,'(A)') delimit
423 CALL strs_txt50(line,100)
424 WRITE(line,'(A)')'/INISH3/STRA_F'
425 CALL strs_txt50(line,100)
426 WRITE(line,'(A)')
427 .'#------------------------ REPEAT --------------------------'
428 CALL strs_txt50(line,100)
429 WRITE(line,'(A)')
430 . '# SH3NID NPT NPG THK'
431 CALL strs_txt50(line,100)
432 WRITE(line,'(A)')'# REPEAT I=1,NPG :'
433 CALL strs_txt50(line,100)
434 WRITE(line,'(A)')'# E1, E2, E12, E23, E31,'
435 CALL strs_txt50(line,100)
436 WRITE(line,'(A)')'# K1, K2, K12'
437 CALL strs_txt50(line,100)
438 WRITE(line,'(A)')
439 .'#---------------------- END REPEAT ------------------------'
440 CALL strs_txt50(line,100)
441 WRITE(line,'(A)') delimit
442 CALL strs_txt50(line,100)
443 END IF
444 iprt0=iprt
445 END IF
446 id = nint(wap0(j + 3))
447 npt = nint(wap0(j + 4))
448 npg = nint(wap0(j + 5))
449 thk = wap0(j + 6)
450 j = j + 6
451 IF (izipstrs == 0) THEN
452 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
453 ELSE
454 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
455 CALL strs_txt50(line,100)
456 ENDIF
457 DO ipg=1,npg
458 IF (izipstrs == 0) THEN
459 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=1,5)
460 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=6,8)
461 ELSE
462 CALL tab_strs_txt50(wap0(1),5,j,sizp0,5)
463 CALL tab_strs_txt50(wap0(6),3,j,sizp0,3)
464 ENDIF
465 j = j + 8
466 END DO
467 END IF
468
469 ENDDO
470 ENDIF
471c-----------
472 DEALLOCATE(ptwa)
473 DEALLOCATE(ptwa_p0)
474c-----------
475 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
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