OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_s_ortho.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_s_ortho ../engine/source/output/sta/stat_s_ortho.F
25!||--- called by ------------------------------------------------------
26!|| genstat ../engine/source/output/sta/genstat.F
27!||--- calls -----------------------------------------------------
28!|| initbuf ../engine/share/resol/initbuf.F
29!|| spmd_rgather9_dp ../engine/source/mpi/interfaces/spmd_outp.F
30!|| spmd_stat_pgather ../engine/source/mpi/output/spmd_stat.F
31!|| srotorth ../engine/source/elements/solid/srotorth.F
32!|| strs_txt50 ../engine/source/output/sta/sta_txt.F
33!|| tab_strs_txt50 ../engine/source/output/sta/sta_txt.F
34!||--- uses -----------------------------------------------------
35!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
36!|| element_mod ../common_source/modules/elements/element_mod.F90
37!|| initbuf_mod ../engine/share/resol/initbuf.F
38!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
39!||====================================================================
40 SUBROUTINE stat_s_ortho(ELBUF_TAB,IPARG ,IPM ,IGEO ,IXS ,
41 2 WA,WAP0 ,IPARTS, IPART_STATE,
42 3 STAT_INDXS ,X,IGLOB ,IPART,IDEL ,SIZP0)
43C-----------------------------------------------
44C M o d u l e s
45C-----------------------------------------------
46 USE initbuf_mod
47 USE elbufdef_mod
48 USE my_alloc_mod
49 use element_mod , only : nixs
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C C o m m o n B l o c k s
56C-----------------------------------------------
57#include "com01_c.inc"
58#include "param_c.inc"
59#include "units_c.inc"
60#include "task_c.inc"
61#include "scr14_c.inc"
62#include "scr16_c.inc"
63#include "vect01_c.inc"
64#include "scr17_c.inc"
65C-----------------------------------------------
66C D u m m y A r g u m e n t s
67C-----------------------------------------------
68 INTEGER SIZP0,IGLOB,IDEL
69 INTEGER IXS(NIXS,*),
70 . iparg(nparg,*),ipm(npropmi,*),igeo(npropgi,*),
71 . iparts(*), ipart_state(*), stat_indxs(*),ipart(lipart1,*)
72 my_real
73 . x(3,*)
74 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
75 double precision WA(*),WAP0(*)
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79 INTEGER I,N,J,K,II(6),JJ,LEN,ISOLNOD, NPTR, NPTS, NPTT,
80 . NG, NEL, MLW,ID, IPRT0, IPRT,IE,
81 . nlay,pid,icsig,ioff
82 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
83 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
84 my_real
85 . gama(6)
86 CHARACTER*100 DELIMIT,LINE
87 DATA DELIMIT(1:60)
88 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
89 DATA delimit(61:100)
90 ./'----7----|----8----|----9----|----10---|'/
91C----
92 TYPE(l_bufel_) ,POINTER :: LBUF
93 TYPE(G_BUFEL_) ,POINTER :: GBUF
94C-----------------------------------------------
95C 8 NODES BRICK
96C======================================================================|
97 CALL my_alloc(ptwa,stat_numels)
98 ALLOCATE(ptwa_p0(0:max(1,stat_numels_g)))
99C-----------------------------------------------
100 jj = 0
101 IF(stat_numels==0) GOTO 200
102
103 ie=0
104 DO ng=1,ngroup
105 ity =iparg(5,ng)
106 isolnod = iparg(28,ng)
107 mlw =iparg(1,ng)
108 nel =iparg(2,ng)
109 nft =iparg(3,ng)
110 iad =iparg(4,ng)
111 icsig =iparg(17,ng)
112 lft=1
113 llt = nel
114c
115 IF (ity == 1) THEN
116 CALL initbuf(iparg ,ng ,
117 2 mlw ,nel ,nft ,iad ,ity ,
118 3 npt ,jale ,ismstr ,jeul ,jtur ,
119 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
120 5 nvaux ,jpor ,jcvt ,jclose ,jplasol ,
121 6 irep ,iint ,igtyp ,israt ,isrot ,
122 7 icsen ,isorth ,isorthg ,ifailure,jsms )
123
124 iprt=iparts(lft+nft)
125 pid = ipart(2,iprt)
126C JHBE = IGEO(10,PID)
127c
128 IF (jhbe==17.AND.iint==2) jhbe = 18
129 IF (jhbe==1.AND.iint==3) jhbe = 5
130 gbuf => elbuf_tab(ng)%GBUF
131 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
132 IF(igtyp == 22) THEN
133 nlay = elbuf_tab(ng)%NLAY
134 ELSE
135 nlay = 1
136 ENDIF
137 nptr = elbuf_tab(ng)%NPTR
138 npts = elbuf_tab(ng)%NPTS
139 nptt = elbuf_tab(ng)%NPTT
140 npt = nptr * npts * nptt * nlay
141!
142 DO j=1,6
143 ii(j) = nel*(j-1)
144 ENDDO
145!
146c
147 DO i=lft,llt
148 n = i + nft
149 iprt=iparts(n)
150 IF(ipart_state(iprt)==0)cycle
151c
152 wa(jj+ 1)= iprt
153 wa(jj+ 2)= ixs(nixs,n)
154 wa(jj+ 3)= isorth
155 wa(jj+ 4)= nlay
156 wa(jj+ 5)= nptr
157 wa(jj+ 6)= npts
158 wa(jj+ 7)= nptt
159 wa(jj+ 8)= isolnod
160 wa(jj+ 9)= jhbe
161 wa(jj+10)= igtyp
162 wa(jj+11)= gbuf%OFF(i)
163 jj = jj + 11
164c
165 DO j=1,nlay
166 lbuf => elbuf_tab(ng)%BUFLY(j)%LBUF(1,1,1)
167 IF (isorth == 1) THEN
168 IF(igtyp == 21 .OR. igtyp == 22) THEN
169 IF (iglob == 1)THEN ! Orthotropic directions in global reference
170 IF (igtyp == 22) THEN
171 gama(1)= lbuf%GAMA(ii(1)+i)
172 gama(2)= lbuf%GAMA(ii(2)+i)
173 ELSEIF (igtyp == 21) THEN
174 gama(1)= gbuf%GAMA(ii(1)+i)
175 gama(2)= gbuf%GAMA(ii(2)+i)
176 ENDIF
177 gama(3)= zero
178 gama(4)= zero
179 gama(5)= zero
180 gama(6)= zero
181 CALL srotorth(x,ixs(1,n),gama,jhbe,igtyp,
182 . icsig) ! Transformation : COS(PHI), SIN(PHI) -> Orthotropic Axes in global reference
183 wa(jj+1)=gama(1)
184 wa(jj+2)=gama(2)
185 wa(jj+3)=gama(3)
186 wa(jj+4)=gama(4)
187 wa(jj+5)=gama(5)
188 wa(jj+6)=gama(6)
189 ELSE
190 IF (igtyp == 22) THEN
191 wa(jj+1)= lbuf%GAMA(ii(1)+i)
192 wa(jj+2)= lbuf%GAMA(ii(2)+i)
193 ELSEIF (igtyp == 21) THEN
194 wa(jj+1)= gbuf%GAMA(ii(1)+i)
195 wa(jj+2)= gbuf%GAMA(ii(2)+i)
196 ENDIF
197 wa(jj+3)= zero
198 wa(jj+4)= zero
199 wa(jj+5)= zero
200 wa(jj+6)= zero
201 ENDIF
202 ELSEIF (jhbe == 1 .OR.
203 . jhbe == 2 .OR. jhbe == 12) THEN
204 wa(jj+1)= gbuf%GAMA(ii(1)+i)
205 wa(jj+2)= gbuf%GAMA(ii(2)+i)
206 wa(jj+3)= gbuf%GAMA(ii(3)+i)
207 wa(jj+4)= gbuf%GAMA(ii(4)+i)
208 wa(jj+5)= gbuf%GAMA(ii(5)+i)
209 wa(jj+6)= gbuf%GAMA(ii(6)+i)
210 ELSE
211 gama(1) = gbuf%GAMA(ii(1)+i)
212 gama(2) = gbuf%GAMA(ii(2)+i)
213 gama(3) = gbuf%GAMA(ii(3)+i)
214 gama(4) = gbuf%GAMA(ii(4)+i)
215 gama(5) = gbuf%GAMA(ii(5)+i)
216 gama(6) = gbuf%GAMA(ii(6)+i)
217 CALL srotorth(x,ixs(1,n),gama,jhbe,igtyp,
218 . icsig)
219 wa(jj+1)=gama(1)
220 wa(jj+2)=gama(2)
221 wa(jj+3)=gama(3)
222 wa(jj+4)=gama(4)
223 wa(jj+5)=gama(5)
224 wa(jj+6)=gama(6)
225 ENDIF
226 ELSE
227 wa(jj+1)= zero
228 wa(jj+2)= zero
229 wa(jj+3)= zero
230 wa(jj+4)= zero
231 wa(jj+5)= zero
232 wa(jj+6)= zero
233 ENDIF
234 jj = jj + 6
235 ENDDO
236 ie=ie+1
237C end-of-zone pointer in wa
238 ptwa(ie)=jj
239 ENDDO
240 ENDIF
241 ENDDO
242 200 CONTINUE
243c-----------------------
244 IF(nspmd == 1)THEN
245C unnecessary copies for code simplification
246 ptwa_p0(0)=0
247 DO n=1,stat_numels
248 ptwa_p0(n)=ptwa(n)
249 END DO
250 len=jj
251 DO j=1,len
252 wap0(j)=wa(j)
253 END DO
254 ELSE
255C builds the pointers in the global wap0 array
256 CALL spmd_stat_pgather(ptwa,stat_numels,ptwa_p0,stat_numels_g)
257 len = 0
258 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
259 END IF
260 IF(ispmd==0.AND.len>0) THEN
261 iprt0=0
262 DO n=1,stat_numels_g
263C find the nieme elt in the order of an increasing id
264 k=stat_indxs(n)
265C Find the address in WAP0
266 j=ptwa_p0(k-1)
267c
268 iprt = nint(wap0(j + 1))
269 id = nint(wap0(j + 2))
270 isorth = nint(wap0(j + 3))
271 nlay = nint(wap0(j + 4))
272 nptr = nint(wap0(j + 5))
273 npts = nint(wap0(j + 6))
274 nptt = nint(wap0(j + 7))
275 isolnod= nint(wap0(j + 8))
276 jhbe = nint(wap0(j + 9))
277 igtyp = nint(wap0(j +10))
278 ioff = nint(wap0(j + 11))
279 IF(idel==0.OR.(idel==1.AND.ioff >=1))THEN
280c
281 IF(iprt /= iprt0 .AND. isorth /= 0)THEN
282 IF (izipstrs == 0) THEN
283 WRITE(iugeo,'(A)') delimit
284 IF(iglob==1.) THEN
285 WRITE(iugeo,'(A)')'/INIBRI/ORTHO_FGLO'
286 ELSE
287 WRITE(iugeo,'(A)')'/INIBRI/ORTHO'
288 ENDIF
289 WRITE(iugeo,'(A)')
290 . '# BRICKID NLAY ISOLNOD IGTYP JJHBE'
291 WRITE(iugeo,'(A)')
292 .'#------------------------ REPEAT --------------------------'
293 IF(iglob==1.OR.(igtyp /= 21 .AND. igtyp /= 22)) THEN
294 WRITE(iugeo,'(A)')
295 . '# X1, Y1, Z1, X2, Y2'
296 WRITE(iugeo,'(A)')
297 . '# Z2'
298 ELSE
299 WRITE(iugeo,'(A)')
300 . '# COS(PHI), SIN(PHI)'
301 ENDIF
302 WRITE(iugeo,'(A)')
303 .'#---------------------- END REPEAT ------------------------'
304 WRITE(iugeo,'(A)') delimit
305 ELSE
306 WRITE(line,'(A)') delimit
307 CALL strs_txt50(line,100)
308 IF(iglob==1.) THEN
309 WRITE(line,'(A)')'/INIBRI/ORTHO_FGLO'
310 ELSE
311 WRITE(line,'(A)')'/INIBRI/ORTHO'
312 ENDIF
313 CALL strs_txt50(line,100)
314 WRITE(line,'(A)')
315 . '#------------------------ REPEAT --------------------------'
316 CALL strs_txt50(line,100)
317 WRITE(line,'(A)')
318 . '# BRICKID NLAY ISOLNOD IGTYP JJHBE'
319 CALL strs_txt50(line,100)
320 IF(igtyp /= 21 .AND. igtyp /= 22) THEN
321 WRITE(line,'(A)')
322 . '# X1, Y1, Z1, X2, Y2'
323 CALL strs_txt50(line,100)
324 WRITE(line,'(A)')
325 . '# Z2'
326 CALL strs_txt50(line,100)
327 ELSE
328 WRITE(line,'(A)')
329 . '# COS(PHI), SIN(PHI)'
330 CALL strs_txt50(line,100)
331 ENDIF
332 WRITE(line,'(A)')
333 . '#------------------------ REPEAT --------------------------'
334 CALL strs_txt50(line,100)
335 WRITE(line,'(A)') delimit
336 CALL strs_txt50(line,100)
337 END IF
338 iprt0=iprt
339 END IF
340 IF(isorth == 1)THEN
341 IF (izipstrs == 0) THEN
342 WRITE(iugeo,'(5I10)') id,nlay,isolnod,igtyp,jhbe
343 ELSE
344 WRITE(line,'(5I10)') id,nlay,isolnod,igtyp,jhbe
345 CALL strs_txt50(line,100)
346 ENDIF
347 j = j + 11
348 IF(iglob==1.OR.(igtyp /= 21 .AND. igtyp /= 22)) THEN
349 jj = j
350 DO i=1,nlay
351 IF (izipstrs == 0) THEN
352 WRITE(iugeo,'(1P5E20.13)')(wap0(jj + k),k=1,5)
353 WRITE(iugeo,'(1PE20.13)')(wap0(jj + k),k=6,6)
354 ELSE
355 CALL tab_strs_txt50(wap0(1),5,jj,sizp0,5)
356 CALL tab_strs_txt50(wap0(6),1,jj,sizp0,1)
357 ENDIF
358 jj = jj + 6
359 ENDDO
360 ELSE
361 jj = j
362 DO i=1,nlay
363 IF (izipstrs == 0) THEN
364 WRITE(iugeo,'(1P2E20.13)')(wap0(jj + k),k=1,2)
365 ELSE
366 CALL tab_strs_txt50(wap0(1),2,jj,sizp0,2)
367 ENDIF
368 jj = jj + 6
369 ENDDO
370
371 ENDIF
372 ENDIF
373 ENDIF !IOFF
374 ENDDO
375 ENDIF
376c-----------
377 DEALLOCATE(ptwa)
378 DEALLOCATE(ptwa_p0)
379c-----------
380 RETURN
381 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
initbuf_mod
Definition initbuf.F:160
initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261
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
srotorth
subroutine srotorth(x, ixs, gama, khbe, ityp, icsig)
Definition srotorth.F:37
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_s_ortho
subroutine stat_s_ortho(elbuf_tab, iparg, ipm, igeo, ixs, wa, wap0, iparts, ipart_state, stat_indxs, x, iglob, ipart, idel, sizp0)
Definition stat_s_ortho.F:43