OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_shel_mp.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_shel_mp ../engine/source/output/sta/stat_shel_mp.F
25!||--- called by ------------------------------------------------------
26!|| genstat ../engine/source/output/sta/genstat.F
27!||--- calls -----------------------------------------------------
28!|| my_orders ../common_source/tools/sort/my_orders.c
29!||--- uses -----------------------------------------------------
30!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
31!|| element_mod ../common_source/modules/elements/element_mod.F90
32!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
33!||====================================================================
34 SUBROUTINE stat_shel_mp(ITAB,ITABG,LENG,IPART,IGEO,
35 . IXC,IXTG,IPARTC,IPARTTG,IPART_STATE,
36 . NODTAG,STAT_INDXC,STAT_INDXTG,SH4TREE,SH3TREE,
37 . IPARG ,SH4TRIM ,SH3TRIM ,ELBUF_TAB,THKE ,
38 . IDEL)
39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE elbufdef_mod
43 USE my_alloc_mod
44 use element_mod , only : nixc,nixtg
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C C o m m o n B l o c k s
51C-----------------------------------------------
52#include "com01_c.inc"
53#include "com04_c.inc"
54#include "param_c.inc"
55#include "remesh_c.inc"
56#include "scr16_c.inc"
57#include "scr17_c.inc"
58#include "units_c.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER ITAB(*), ITABG(*), LENG, IPART(LIPART1,*),
63 . IGEO(NPROPGI,*), IXC(NIXC,*), IXTG(NIXTG,*),
64 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
65 . NODTAG(*), STAT_INDXC(*), STAT_INDXTG(*),
66 . sh4tree(ksh4tree,*), sh3tree(ksh3tree,*),
67 . iparg(nparg,*), sh4trim(*), sh3trim(*),
68 . idel
69 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
70 my_real
71 . THKE(*)
72C-----------------------------------------------
73C L o c a l V a r i a b l e s
74C-----------------------------------------------
75 INTEGER I, N, JJ, IPRT0, IPRT, K, II
76 INTEGER NG, NEL, NFT, LFT, LLT, ITY, MLW, ITHK,IOFF
77 INTEGER WORK(70000)
78 INTEGER, DIMENSION(:),ALLOCATABLE :: NP
79 INTEGER, DIMENSION(:,:),ALLOCATABLE :: CLEF
80 double precision,DIMENSION(:),ALLOCATABLE :: THK
81 TYPE(g_bufel_) ,POINTER :: GBUF
82C-----------------------------------------------
83 CALL my_alloc(thk,max(numelc,numeltg))
84 CALL my_alloc(clef,2,max(numelc,numeltg))
85 CALL my_alloc(np,8*max(numelc,numeltg))
86C-----------------------------------------------
87C 4-NODE SHELLS
88C-----------------------------------------------
89 jj = 0
90 ii = 0
91 IF(numelc/=0)THEN
92
93 DO ng=1,ngroup
94 ity =iparg(5,ng)
95 IF(ity==3) THEN
96 nel =iparg(2,ng)
97 nft =iparg(3,ng)
98 gbuf => elbuf_tab(ng)%GBUF
99 mlw =iparg(1,ng)
100 ithk =iparg(28,ng)
101 lft=1
102 llt=nel
103 DO i=lft,llt
104 n = i + nft
105
106 iprt=ipartc(n)
107 IF(ipart_state(iprt)==0)cycle
108
109 np(jj+1) = ixc(nixc,n)
110 np(jj+2) = itab(ixc(2,n))
111 np(jj+3) = itab(ixc(3,n))
112 np(jj+4) = itab(ixc(4,n))
113 np(jj+5) = itab(ixc(5,n))
114 np(jj+6) = iprt
115 np(jj+7) = iabs(nint(gbuf%OFF(i)))
116 ii = ii + 1
117 IF (mlw /= 0 .AND. mlw /= 13) THEN
118 IF (ithk >0 ) THEN
119 thk(ii) = gbuf%THK(i)
120 ELSE
121 thk(ii) = thke(n)
122 END IF
123 ELSE
124 thk(ii) = zero
125 ENDIF
126 jj = jj + 7
127
128 stat_numelc =stat_numelc+1
129 clef(1,stat_numelc)=iprt
130 clef(2,stat_numelc)=ixc(nixc,n)
131
132 nodtag(ixc(2,n))=1
133 nodtag(ixc(3,n))=1
134 nodtag(ixc(4,n))=1
135 nodtag(ixc(5,n))=1
136
137 END DO
138 END IF
139 END DO
140 END IF
141C----
142 DO n=1,stat_numelc
143 stat_indxc(n)=n
144 END DO
145 CALL my_orders(0,work,clef,stat_indxc,stat_numelc,2)
146C----
147 iprt0=0
148 DO n=1,stat_numelc
149 k=stat_indxc(n)
150 jj=7*(k-1)
151 iprt=np(jj+6)
152 ioff=np(jj+7)
153 IF(idel==0.OR.(idel==1.AND.ioff >= 1)) THEN
154 IF(iprt /= iprt0)THEN
155 WRITE(iugeo,'(A,I10)')'/SHELL/',ipart(4,iprt)
156 WRITE(iugeo,'(A)')
157 . '# SHELLID NOD1 NOD2 NOD3 NOD4 THK'
158 iprt0=iprt
159 END IF
160 WRITE(iugeo,'(5I10,30X,1PE20.13)')
161 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),np(jj+5),thk(k)
162 ENDIF
163 END DO
164C----
165C Specific adaptive meshing :
166 IF(nadmesh /=0)THEN
167 jj = 0
168 IF(numelc/=0)THEN
169 DO ng=1,ngroup
170 ity =iparg(5,ng)
171 IF(ity==3) THEN
172 nel =iparg(2,ng)
173 nft =iparg(3,ng)
174 lft=1
175 llt=nel
176 DO i=lft,llt
177 n = i + nft
178
179 iprt=ipartc(n)
180 IF(ipart_state(iprt)==0)cycle
181
182 np(jj+1) = ixc(nixc,n)
183 IF(sh4tree(2,n) /= 0)THEN
184 np(jj+2) = ixc(nixc,sh4tree(2,n) )
185 np(jj+3) = ixc(nixc,sh4tree(2,n)+1)
186 np(jj+4) = ixc(nixc,sh4tree(2,n)+2)
187 np(jj+5) = ixc(nixc,sh4tree(2,n)+3)
188 ELSE
189 np(jj+2) =0
190 np(jj+3) =0
191 np(jj+4) =0
192 np(jj+5) =0
193 END IF
194 np(jj+6) = sh4tree(3,n)
195 np(jj+7) = iprt
196 IF(lsh4trim /= 0)THEN
197 IF(sh4trim(n)==-1)THEN
198 np(jj+8) = -1
199 ELSE
200 np(jj+8) = 0
201 END IF
202 ELSE
203 np(jj+8) = 0
204 END IF
205 jj = jj + 8
206 END DO
207 END IF
208 END DO
209 END IF
210
211 iprt0=0
212 DO n=1,stat_numelc
213 k=stat_indxc(n)
214 jj=8*(k-1)
215 iprt=np(jj+7)
216 IF(iprt /= iprt0)THEN
217 WRITE(iugeo,'(A)')'/ADMESH/STATE/SHELL'
218 WRITE(iugeo,'(2A)')
219 . '# SHELLID ID1 ID2 ID3 ID4 LEVEL',
220 . ' IMAPPING'
221 iprt0=iprt
222 END IF
223 WRITE(iugeo,'(7I10)')
224 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),np(jj+5),np(jj+6),np(jj+8)
225 END DO
226
227 END IF
228C-----------------------------------------------
229C 3-NODE SHELLS
230C-----------------------------------------------
231 jj = 0
232 ii = 0
233 IF(numeltg/=0)THEN
234 DO ng=1,ngroup
235 ity =iparg(5,ng)
236 IF(ity==7) THEN
237 nel =iparg(2,ng)
238 nft =iparg(3,ng)
239 gbuf => elbuf_tab(ng)%GBUF
240 mlw =iparg(1,ng)
241 ithk =iparg(28,ng)
242 lft=1
243 llt=nel
244C
245 DO i=lft,llt
246 n = i + nft
247
248 iprt=iparttg(n)
249 IF(ipart_state(iprt)==0)cycle
250
251 np(jj+1) = ixtg(nixtg,n)
252 np(jj+2) = itab(ixtg(2,n))
253 np(jj+3) = itab(ixtg(3,n))
254 np(jj+4) = itab(ixtg(4,n))
255 np(jj+5) = iprt
256 np(jj+6) = iabs(nint(gbuf%OFF(i)))
257 ii = ii + 1
258 IF (mlw /= 0 .AND. mlw /= 13) THEN
259 IF (ithk >0 ) THEN
260 thk(ii) = gbuf%THK(i)
261 ELSE
262 thk(ii) = thke(n)
263 END IF
264 ELSE
265 thk(ii) = zero
266 ENDIF
267 jj = jj + 6
268
269 stat_numeltg =stat_numeltg+1
270 clef(1,stat_numeltg)=iprt
271 clef(2,stat_numeltg)=ixtg(nixtg,n)
272
273 nodtag(ixtg(2,n))=1
274 nodtag(ixtg(3,n))=1
275 nodtag(ixtg(4,n))=1
276
277 END DO
278 END IF
279 END DO
280 END IF
281
282C-----
283 DO n=1,stat_numeltg
284 stat_indxtg(n)=n
285 END DO
286 CALL my_orders(0,work,clef,stat_indxtg,stat_numeltg,2)
287C-----
288 iprt0=0
289 DO n=1,stat_numeltg
290 k=stat_indxtg(n)
291 jj=6*(k-1)
292 iprt=np(jj+5)
293 ioff=np(jj+6)
294 IF(idel==0.OR.(idel==1.AND.ioff >= 1)) THEN
295 IF(iprt /= iprt0)THEN
296 WRITE(iugeo,'(A,I10)')'/SH3N/',ipart(4,iprt)
297 WRITE(iugeo,'(A)')
298 . '# SH3NID NOD1 NOD2 NOD3 THK'
299 iprt0=iprt
300 END IF
301 WRITE(iugeo,'(4I10,40X,1PE20.13)')
302 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),thk(k)
303 ENDIF
304 END DO
305C-----
306C Specific adaptive meshing :
307 IF(nadmesh /=0)THEN
308 jj = 0
309 IF(numeltg/=0)THEN
310
311 DO ng=1,ngroup
312 ity =iparg(5,ng)
313 IF(ity==7) THEN
314 nel =iparg(2,ng)
315 nft =iparg(3,ng)
316 lft=1
317 llt=nel
318C
319 DO i=lft,llt
320 n = i + nft
321
322 iprt=iparttg(n)
323 IF(ipart_state(iprt)==0)cycle
324
325 np(jj+1) = ixtg(nixtg,n)
326 IF(sh3tree(2,n) /= 0)THEN
327 np(jj+2) = ixtg(nixtg,sh3tree(2,n) )
328 np(jj+3) = ixtg(nixtg,sh3tree(2,n)+1)
329 np(jj+4) = ixtg(nixtg,sh3tree(2,n)+2)
330 np(jj+5) = ixtg(nixtg,sh3tree(2,n)+3)
331 ELSE
332 np(jj+2) =0
333 np(jj+3) =0
334 np(jj+4) =0
335 np(jj+5) =0
336 END IF
337 np(jj+6) = sh3tree(3,n)
338 np(jj+7) = iprt
339 IF(lsh3trim /= 0)THEN
340 IF(sh3trim(n)==-1)THEN
341 np(jj+8) = -1
342 ELSE
343 np(jj+8) = 0
344 END IF
345 ELSE
346 np(jj+8) = 0
347 END IF
348 jj = jj + 8
349 END DO
350 END IF
351 END DO
352 END IF
353
354 iprt0=0
355 DO n=1,stat_numeltg
356 k=stat_indxtg(n)
357 jj=8*(k-1)
358 iprt=np(jj+7)
359 IF(iprt /= iprt0)THEN
360 WRITE(iugeo,'(A)')'/ADMESH/STATE/SH3N'
361 WRITE(iugeo,'(2A)')
362 . '# SH3NID ID1 ID2 ID3 ID4 LEVEL',
363 . ' IMAPPING'
364 iprt0=iprt
365 END IF
366 WRITE(iugeo,'(7I10)')
367 . np(jj+1),np(jj+2),np(jj+3),np(jj+4),np(jj+5),np(jj+6),np(jj+8)
368 END DO
369
370 END IF
371C-----------------------------------------------
372 DEALLOCATE(thk)
373 DEALLOCATE(clef)
374 DEALLOCATE(np)
375 RETURN
376 END
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
stat_shel_mp
subroutine stat_shel_mp(itab, itabg, leng, ipart, igeo, ixc, ixtg, ipartc, iparttg, ipart_state, nodtag, stat_indxc, stat_indxtg, sh4tree, sh3tree, iparg, sh4trim, sh3trim, elbuf_tab, thke, idel)
Definition stat_shel_mp.F:39