OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_c_straf.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| stat_c_straf ../engine/source/output/sta/stat_c_straf.F
25!||--- called by ------------------------------------------------------
26!|| genstat ../engine/source/output/sta/genstat.F
27!||--- calls -----------------------------------------------------
28!|| spmd_rgather9_dp ../engine/source/mpi/interfaces/spmd_outp.F
29!|| spmd_stat_pgather ../engine/source/mpi/output/spmd_stat.F
30!|| strs_txt50 ../engine/source/output/sta/sta_txt.F
31!|| tab_strs_txt50 ../engine/source/output/sta/sta_txt.F
32!||--- uses -----------------------------------------------------
33!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
34!|| element_mod ../common_source/modules/elements/element_mod.F90
35!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
36!||====================================================================
37 SUBROUTINE stat_c_straf(ELBUF_TAB,IPARG ,IPM ,IGEO ,IXC ,
38 2 IXTG ,WA,WAP0 ,IPARTC, IPARTTG,
39 3 IPART_STATE,STAT_INDXC,STAT_INDXTG,THKE,SIZP0)
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 IF (mlw /= 0 .AND. 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 IF (mlw /= 0 .AND. 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 IF (mlw == 0 .or. 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 IF(ispmd==0.AND.len>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
476 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
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
stat_c_straf
subroutine stat_c_straf(elbuf_tab, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, thke, sizp0)
Definition stat_c_straf.F:40