OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_shel_spmd.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_spmd ../engine/source/output/sta/stat_shel_spmd.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!|| spmd_iget_partn_sta ../engine/source/mpi/output/spmd_stat.F
30!|| spmd_rgather9_dp ../engine/source/mpi/interfaces/spmd_outp.F
31!||--- uses -----------------------------------------------------
32!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
33!|| message_mod ../engine/share/message_module/message_mod.F
34!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
35!||====================================================================
36 SUBROUTINE stat_shel_spmd(ITAB,ITABG,LENG,IPART,IGEO,
37 . IXC,IXTG,IPARTC,IPARTTG,IPART_STATE,
38 . NODTAG,STAT_INDXC,STAT_INDXTG,LENGC,LENGTG,
39 . IPARG ,ELBUF_TAB,THKE,IDEL)
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE elbufdef_mod
44 USE message_mod
45 USE my_alloc_mod
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 "scr16_c.inc"
57#include "scr17_c.inc"
58#include "spmd_c.inc"
59#include "task_c.inc"
60#include "units_c.inc"
61C-----------------------------------------------
62C D u m m y A r g u m e n t s
63C-----------------------------------------------
64 INTEGER ITAB(*), ITABG(*), LENG, IPART(LIPART1,*),
65 . IGEO(NPROPGI,*), IXC(NIXC,*), IXTG(NIXTG,*),
66 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
67 . nodtag(*), stat_indxc(*), stat_indxtg(*),
68 . lengc, lengtg, iparg(nparg,*),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, IPRT, BUF, IPRT0, K, II
76 INTEGER NG, NEL, NFT, LFT, LLT, ITY, LEN, ITHK, MLW,IOFF
77 INTEGER WORK(70000)
78 INTEGER THK_LEN,THK0_LEN
79 INTEGER,DIMENSION(:),ALLOCATABLE :: IADD
80 INTEGER,DIMENSION(:,:),ALLOCATABLE :: IADG
81 INTEGER,DIMENSION(:),ALLOCATABLE :: NP
82 INTEGER,DIMENSION(:),ALLOCATABLE :: NPGLOB
83 INTEGER,DIMENSION(:,:),ALLOCATABLE :: CLEF
84 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: THK ! Gather Thickness from Shell & Triangle elements
85 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: THK0 ! ISPMD=0 : Shell & Triangle Thicknesses after gather.
86 TYPE(g_bufel_) ,POINTER :: GBUF
87C-----------------------------------------------
88 CALL my_alloc(np,max(7*numelc,6*numeltg))
89 CALL my_alloc(npglob,max(7*lengc,6*lengtg))
90 CALL my_alloc(clef,2,max(numelcg,numeltgg))
91 CALL my_alloc(iadg,nspmd,npart)
92 CALL my_alloc(iadd,npart+1)
93C-----------------------------------------------
94C INITIALIZATION
95C-----------------------------------------------
96 thk_len = max(1,max(numelc,numeltg))
97 ALLOCATE(thk(thk_len))
98 IF (ispmd == 0) THEN
99 thk0_len = max(1,max(numelcg,numeltgg))
100 ELSE
101 thk0_len=1
102 ENDIF
103 ALLOCATE(thk0(thk0_len))
104C-----------------------------------------------
105C 4-NODE SHELLS
106C-----------------------------------------------
107 iadd = 0
108 npglob(1:max(7*lengc,6*lengtg)) = 0
109C
110 jj = 0
111 ii = 0
112 DO ng=1,ngroup
113 ity =iparg(5,ng)
114 IF(ity==3) THEN
115 nel =iparg(2,ng)
116 nft =iparg(3,ng)
117 gbuf => elbuf_tab(ng)%GBUF
118 mlw =iparg(1,ng)
119 ithk =iparg(28,ng)
120 lft=1
121 llt=nel
122 DO i=lft,llt
123 n = i + nft
124
125 iprt=ipartc(n)
126 IF(ipart_state(iprt)==0)cycle
127
128 np(jj+1) = ixc(nixc,n)
129 np(jj+2) = itab(ixc(2,n))
130 np(jj+3) = itab(ixc(3,n))
131 np(jj+4) = itab(ixc(4,n))
132 np(jj+5) = itab(ixc(5,n))
133 np(jj+6) = iprt
134 np(jj+7) = iabs(nint(gbuf%OFF(i)))
135 ii = ii + 1
136 IF (mlw /= 0 .AND. mlw /= 13) THEN
137 IF (ithk >0 ) THEN
138 thk(ii) = gbuf%THK(i)
139 ELSE
140 thk(ii) = thke(n)
141 END IF
142 ELSE
143 thk(ii) = zero
144 ENDIF
145 jj = jj + 7
146
147 stat_numelc =stat_numelc+1
148
149 nodtag(ixc(2,n))=1
150 nodtag(ixc(3,n))=1
151 nodtag(ixc(4,n))=1
152 nodtag(ixc(5,n))=1
153 END DO
154 END IF
155 END DO
156C-----
157 stat_numelc_g=0
158 CALL spmd_iget_partn_sta(7,stat_numelc,stat_numelc_g,lengc,np,
159 . iadg,npglob,stat_indxc)
160 len = 0
161 CALL spmd_rgather9_dp(thk,ii,thk0,thk0_len,len)
162
163C-----
164 IF (ispmd==0) THEN
165 DO n=1,stat_numelc_g
166 stat_indxc(n)=n
167 clef(1,n)=npglob(7*(n-1)+7)
168 clef(2,n)=npglob(7*(n-1)+1)
169 END DO
170 CALL my_orders(0,work,clef,stat_indxc,stat_numelc_g,2)
171
172 iprt0=0
173 DO n=1,stat_numelc_g
174 k=stat_indxc(n)
175 jj=7*(k-1)
176 iprt=npglob(jj+6)
177 ioff=npglob(jj+7)
178 IF(idel==0.OR.(idel==1.AND.ioff >= 1)) THEN
179 IF(iprt /= iprt0)THEN
180 WRITE(iugeo,'(A,I10)')'/SHELL/',ipart(4,iprt)
181 WRITE(iugeo,'(A)')
182 . '# SHELLID NOD1 NOD2 NOD3 NOD4 THK'
183 iprt0=iprt
184 END IF
185 WRITE(iugeo,'(5I10,30X,1PE20.13)')
186 . npglob(jj+1),
187 . npglob(jj+2),npglob(jj+3),npglob(jj+4),npglob(jj+5),thk0(k)
188 ENDIF
189 END DO
190 ENDIF
191C-----------------------------------------------
192C 3-NODE SHELLS
193C-----------------------------------------------
194 iadd = 0
195C
196 jj = 0
197 ii = 0
198 DO ng=1,ngroup
199 ity =iparg(5,ng)
200 IF(ity==7) THEN
201 nel =iparg(2,ng)
202 nft =iparg(3,ng)
203 gbuf => elbuf_tab(ng)%GBUF
204 mlw =iparg(1,ng)
205 ithk =iparg(28,ng)
206 lft=1
207 llt=nel
208C
209 DO i=lft,llt
210 n = i + nft
211
212 iprt=iparttg(n)
213 IF(ipart_state(iprt)==0)cycle
214
215 np(jj+1) = ixtg(nixtg,n)
216 np(jj+2) = itab(ixtg(2,n))
217 np(jj+3) = itab(ixtg(3,n))
218 np(jj+4) = itab(ixtg(4,n))
219 np(jj+5) = iprt
220 np(jj+6) = iabs(nint(gbuf%OFF(i)))
221 ii = ii + 1
222 IF (mlw /= 0 .AND. mlw /= 13) THEN
223 IF (ithk >0 ) THEN
224 thk(ii) = gbuf%THK(i)
225 ELSE
226 thk(ii) = thke(n)
227 END IF
228 ELSE
229 thk(ii) = zero
230 ENDIF
231
232 jj = jj + 6
233
234 stat_numeltg =stat_numeltg+1
235
236 nodtag(ixtg(2,n))=1
237 nodtag(ixtg(3,n))=1
238 nodtag(ixtg(4,n))=1
239 END DO
240 END IF
241 END DO
242C-----
243 stat_numeltg_g=0
244 CALL spmd_iget_partn_sta(6,stat_numeltg,stat_numeltg_g,lengtg,np,
245 . iadg,npglob,stat_indxtg)
246 len = 0
247 CALL spmd_rgather9_dp(thk,ii,thk0,thk0_len,len)
248C-----
249 IF (ispmd==0) THEN
250 DO n=1,stat_numeltg_g
251 stat_indxtg(n)=n
252 clef(1,n)=npglob(6*(n-1)+6)
253 clef(2,n)=npglob(6*(n-1)+1)
254 END DO
255 CALL my_orders(0,work,clef,stat_indxtg,stat_numeltg_g,2)
256
257 iprt0=0
258 DO n=1,stat_numeltg_g
259 k=stat_indxtg(n)
260 jj=6*(k-1)
261 iprt=npglob(jj+5)
262 ioff=npglob(jj+6)
263 IF(idel==0.OR.(idel==1.AND.ioff >= 1)) THEN
264 IF(iprt /= iprt0)THEN
265 WRITE(iugeo,'(A,I10)')'/SH3N/',ipart(4,iprt)
266 WRITE(iugeo,'(A)')
267 . '# SH3NID NOD1 NOD2 NOD3 THK'
268 iprt0=iprt
269 END IF
270 WRITE(iugeo,'(4I10,40X,1PE20.13)')
271 . npglob(jj+1),
272 . npglob(jj+2),npglob(jj+3),npglob(jj+4),thk0(k)
273 ENDIF
274 END DO
275 ENDIF
276
277 DEALLOCATE(thk)
278 DEALLOCATE(thk0)
279 DEALLOCATE(np)
280 DEALLOCATE(npglob)
281 DEALLOCATE(clef)
282 DEALLOCATE(iadg)
283 DEALLOCATE(iadd)
284C-----------------------------------------------
285 RETURN
286 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
message_mod
Definition message_mod.F:1249
spmd_rgather9_dp
subroutine spmd_rgather9_dp(v, len, vp0, lenp0, iad)
Definition spmd_outp.F:1015
spmd_iget_partn_sta
subroutine spmd_iget_partn_sta(size, stat_numel, stat_lenelg, leng, np, iadg, npglob, stat_indx)
Definition spmd_stat.F:129
stat_shel_spmd
subroutine stat_shel_spmd(itab, itabg, leng, ipart, igeo, ixc, ixtg, ipartc, iparttg, ipart_state, nodtag, stat_indxc, stat_indxtg, lengc, lengtg, iparg, elbuf_tab, thke, idel)
Definition stat_shel_spmd.F:40