OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
aniskew.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!|| aniskew ../starter/source/output/anim/aniskew.F
25!||--- called by ------------------------------------------------------
26!|| genani1 ../starter/source/output/anim/genani1.F
27!||--- calls -----------------------------------------------------
28!||--- uses -----------------------------------------------------
29!||====================================================================
30 SUBROUTINE aniskew(ELBUF_TAB,SKEW ,IPARG ,X , IXT,
31 . IXP ,IXR ,GEO ,BUFL)
32C-----------------------------------------------
33C M o d u l e s
34C-----------------------------------------------
35 USE elbufdef_mod
36 use element_mod , only : nixt,nixp,nixr
37C-----------------------------------------------
38C I m p l i c i t T y p e s
39C-----------------------------------------------
40#include "implicit_f.inc"
41C-----------------------------------------------
42C C o m m o n B l o c k s
43C-----------------------------------------------
44#include "com01_c.inc"
45#include "com04_c.inc"
46#include "param_c.inc"
47C-----------------------------------------------
48C D u m m y A r g u m e n t s
49C-----------------------------------------------
50 my_real
51 . x(3,*), skew(lskew,*), geo(npropg,*)
52 INTEGER IXT(NIXT,*),IXP(NIXP,*),IXR(NIXR,*),IPARG(NPARG,*),
53 . bufl
54C
55 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
56C-----------------------------------------------
57C L o c a l V a r i a b l e s
58C-----------------------------------------------
59 INTEGER I,J,ISK(6),JJ,NEL,LFT,LLT,NG,
60 . ity,mlw,nft,n,ii,len,iprop,igtyp,wa(bufl)
61 my_real
62 . ex(9),s3000,x1,y1,z1,x2,y2,z2,s
63C
64 TYPE(g_bufel_) ,POINTER :: GBUF
65C-----------------------------------------------
66 s3000 = three1000
67C-----------------------------------------------
68C SKEW
69C-----------------------------------------------
70 DO i=1,numskw
71 isk(1)=nint(skew(1,i)*s3000)
72 isk(2)=nint(skew(2,i)*s3000)
73 isk(3)=nint(skew(3,i)*s3000)
74 isk(4)=nint(skew(4,i)*s3000)
75 isk(5)=nint(skew(5,i)*s3000)
76 isk(6)=nint(skew(6,i)*s3000)
77 CALL write_s_c(isk,6)
78 ENDDO
79C-----------------------------------------------
80C SKEW ELEMENT 1D
81C-----------------------------------------------
82 DO ng=1,ngroup
83 mlw = iparg(1,ng)
84 nel = iparg(2,ng)
85 ity = iparg(5,ng)
86 nft = iparg(3,ng)
87 lft = 1
88 llt = nel
89C
90 gbuf => elbuf_tab(ng)%GBUF
91C-----------------------------------------------
92C TRUSS
93C-----------------------------------------------
94 IF (ity == 4) THEN
95 DO i=lft,llt
96 n = i + nft
97 x1=x(1,ixt(3,i))-x(1,ixt(2,i))
98 y1=x(2,ixt(3,i))-x(2,ixt(2,i))
99 z1=x(3,ixt(3,i))-x(3,ixt(2,i))
100 s=one/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
101 x1=x1*s
102 y1=y1*s
103 z1=z1*s
104C
105 IF (abs(z1) < half) THEN
106 x2 = -z1*x1
107 y2 = -z1*y1
108 z2 = one -z1*z1
109 ELSE
110 x2 = one -x1*x1
111 y2 = -x1*y1
112 z2 = -x1*z1
113 ENDIF
114 s=s3000/sqrt(x2*x2+y2*y2+z2*z2)
115 isk(1)=nint(x1*s3000)
116 isk(2)=nint(y1*s3000)
117 isk(3)=nint(z1*s3000)
118 isk(4)=nint(x2*s)
119 isk(5)=nint(y2*s)
120 isk(6)=nint(z2*s)
121 CALL write_s_c(isk,6)
122 ENDDO
123C-----------------------------------------------
124C POUTRES
125C-----------------------------------------------
126 ELSEIF (ity == 5) THEN
127 DO i=lft,llt
128 jj = 3*(i-1)
129 n = i + nft
130 x1=x(1,ixp(3,n))-x(1,ixp(2,n))
131 y1=x(2,ixp(3,n))-x(2,ixp(2,n))
132 z1=x(3,ixp(3,n))-x(3,ixp(2,n))
133 s=s3000/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
134 x2 = gbuf%SKEW(jj + 1)
135 y2 = gbuf%SKEW(jj + 2)
136 z2 = gbuf%SKEW(jj + 3)
137cc X2= BUFEL(NB6+3*I-3)
138cc Y2= BUFEL(NB6+3*I-2)
139cc Z2= BUFEL(NB6+3*I-1)
140 isk(1)=nint(x1*s)
141 isk(2)=nint(y1*s)
142 isk(3)=nint(z1*s)
143 isk(4)=nint(x2*s3000)
144 isk(5)=nint(y2*s3000)
145 isk(6)=nint(z2*s3000)
146 CALL write_s_c(isk,6)
147 ENDDO
148C-----------------------------------------------
149C RESSORTS
150C-----------------------------------------------
151 ELSEIF (ity == 6) THEN
152 iprop = ixr(1,nft+1)
153 igtyp = nint(geo(12,iprop))
154C
155 IF (igtyp == 4) THEN
156 DO i=lft,llt
157 n = i + nft
158 x1=x(1,ixr(3,n))-x(1,ixr(2,n))
159 y1=x(2,ixr(3,n))-x(2,ixr(2,n))
160 z1=x(3,ixr(3,n))-x(3,ixr(2,n))
161 s=x1*x1+y1*y1+z1*z1
162 IF (s < em30) THEN
163 x1=one
164 y1=zero
165 z1=zero
166 ELSE
167 s=one/sqrt(s)
168 x1=x1*s
169 y1=y1*s
170 z1=z1*s
171 ENDIF
172 IF (abs(z1) < half) THEN
173 x2 = -z1*x1
174 y2 = -z1*y1
175 z2 = one -z1*z1
176 ELSE
177 x2 = one -x1*x1
178 y2 = -x1*y1
179 z2 = -x1*z1
180 ENDIF
181 s=x2*x2+y2*y2+z2*z2
182 s=s3000/max(em20,sqrt(s))
183 isk(1)=nint(x1*s3000)
184 isk(2)=nint(y1*s3000)
185 isk(3)=nint(z1*s3000)
186 isk(4)=nint(x2*s)
187 isk(5)=nint(y2*s)
188 isk(6)=nint(z2*s)
189 CALL write_s_c(isk,6)
190 ENDDO
191C
192 ELSEIF (igtyp == 12) THEN
193 DO i=lft,llt
194 n = i + nft
195 x1=x(1,ixr(3,n))-x(1,ixr(2,n))
196 y1=x(2,ixr(3,n))-x(2,ixr(2,n))
197 z1=x(3,ixr(3,n))-x(3,ixr(2,n))
198 s=one/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
199 x1=x1*s
200 y1=y1*s
201 z1=z1*s
202 IF (abs(z1) < half) THEN
203 x2 = -z1*x1
204 y2 = -z1*y1
205 z2 = one -z1*z1
206 ELSE
207 x2 = one -x1*x1
208 y2 = -x1*y1
209 z2 = -x1*z1
210 ENDIF
211 s=s3000/max(em20,sqrt(x2*x2+y2*y2+z2*z2))
212 isk(1)=nint(x1*s3000)
213 isk(2)=nint(y1*s3000)
214 isk(3)=nint(z1*s3000)
215 isk(4)=nint(x2*s)
216 isk(5)=nint(y2*s)
217 isk(6)=nint(z2*s)
218 CALL write_s_c(isk,6)
219 x1=x(1,ixr(4,n))-x(1,ixr(3,n))
220 y1=x(2,ixr(4,n))-x(2,ixr(3,n))
221 z1=x(3,ixr(4,n))-x(3,ixr(3,n))
222 s=one/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
223 x1=x1*s
224 y1=y1*s
225 z1=z1*s
226 IF (z1 < half) THEN
227 x2 = -z1*x1
228 y2 = -z1*y1
229 z2 = one -z1*z1
230 ELSE
231 x2 = one -x1*x1
232 y2 = -x1*y1
233 z2 = -x1*z1
234 ENDIF
235 s=s3000/max(em20,sqrt(x2*x2+y2*y2+z2*z2))
236 isk(1)=nint(x1*s3000)
237 isk(2)=nint(y1*s3000)
238 isk(3)=nint(z1*s3000)
239 isk(4)=nint(x2*s)
240 isk(5)=nint(y2*s)
241 isk(6)=nint(z2*s)
242 CALL write_s_c(isk,6)
243 ENDDO
244C
245 ELSEIF (igtyp == 13 .OR. igtyp == 23) THEN
246 DO i=lft,llt
247 jj = 3*(i-1)
248 n = i + nft
249 x1=x(1,ixr(3,n))-x(1,ixr(2,n))
250 y1=x(2,ixr(3,n))-x(2,ixr(2,n))
251 z1=x(3,ixr(3,n))-x(3,ixr(2,n))
252 s=s3000/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
253 x2 = gbuf%SKEW(jj + 1)
254 y2 = gbuf%SKEW(jj + 2)
255 z2 = gbuf%SKEW(jj + 3)
256cc X2= BUFEL(NB14+3*I-3)
257cc Y2= BUFEL(NB14+3*I-2)
258cc Z2= BUFEL(NB14+3*I-1)
259 isk(1)=nint(x1*s)
260 isk(2)=nint(y1*s)
261 isk(3)=nint(z1*s)
262 isk(4)=nint(x2*s3000)
263 isk(5)=nint(y2*s3000)
264 isk(6)=nint(z2*s3000)
265 CALL write_s_c(isk,6)
266 ENDDO
267 ELSEIF (igtyp == 25) THEN
268C
269 DO i=lft,llt
270 jj = 3*(i-1)
271 n = i + nft
272 x1=x(1,ixr(3,n))-x(1,ixr(2,n))
273 y1=x(2,ixr(3,n))-x(2,ixr(2,n))
274 z1=x(3,ixr(3,n))-x(3,ixr(2,n))
275 s=s3000/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
276 x2 = gbuf%SKEW(jj + 1)
277 y2 = gbuf%SKEW(jj + 2)
278 z2 = gbuf%SKEW(jj + 3)
279cc X2= BUFEL(NB14+3*I-3)
280cc Y2= BUFEL(NB14+3*I-2)
281cc Z2= BUFEL(NB14+3*I-1)
282 isk(1)=nint(x1*s)
283 isk(2)=nint(y1*s)
284 isk(3)=nint(z1*s)
285 isk(4)=nint(x2*s3000)
286 isk(5)=nint(y2*s3000)
287 isk(6)=nint(z2*s3000)
288 CALL write_s_c(isk,6)
289 ENDDO
290C
291 ELSEIF (igtyp >= 29 .AND. igtyp <= 32) THEN
292C
293 DO i=lft,llt
294 jj = 3*(i-1)
295 n = i + nft
296 x1=x(1,ixr(3,n))-x(1,ixr(2,n))
297 y1=x(2,ixr(3,n))-x(2,ixr(2,n))
298 z1=x(3,ixr(3,n))-x(3,ixr(2,n))
299 s=s3000/max(em20,sqrt(x1*x1+y1*y1+z1*z1))
300 x2 = gbuf%SKEW(jj + 1)
301 y2 = gbuf%SKEW(jj + 2)
302 z2 = gbuf%SKEW(jj + 3)
303cc X2= BUFEL(NB14+3*I-3)
304cc Y2= BUFEL(NB14+3*I-2)
305cc Z2= BUFEL(NB14+3*I-1)
306 isk(1)=nint(x1*s)
307 isk(2)=nint(y1*s)
308 isk(3)=nint(z1*s)
309 isk(4)=nint(x2*s3000)
310 isk(5)=nint(y2*s3000)
311 isk(6)=nint(z2*s3000)
312 CALL write_s_c(isk,6)
313 ENDDO
314C
315 ELSEIF (igtyp == 33 .OR. igtyp == 45) THEN
316 DO i=lft,llt
317 jj = 22*(i-1)
318 n = i + nft
319 ex(1) = gbuf%VAR(jj + 1) ! UVAR(22,I)= EX(1)
320 ex(2) = gbuf%VAR(jj + 2) ! UVAR(23,I)= EX(2)
321 ex(3) = gbuf%VAR(jj + 3) ! UVAR(24,I)= EX(3)
322 ex(4) = gbuf%VAR(jj + 4) ! UVAR(25,I)= EX(4)
323 ex(5) = gbuf%VAR(jj + 5) ! UVAR(26,I)= EX(5)
324 ex(6) = gbuf%VAR(jj + 6) ! UVAR(27,I)= EX(6)
325cc EX(1) = BUFEL(NB15+22)
326cc EX(2) = BUFEL(NB15+23)
327cc EX(3) = BUFEL(NB15+24)
328cc EX(4) = BUFEL(NB15+25)
329cc EX(5) = BUFEL(NB15+26)
330cc EX(6) = BUFEL(NB15+27)
331 isk(1)=nint(ex(1)*s3000)
332 isk(2)=nint(ex(2)*s3000)
333 isk(3)=nint(ex(3)*s3000)
334 isk(4)=nint(ex(4)*s3000)
335 isk(5)=nint(ex(5)*s3000)
336 isk(6)=nint(ex(6)*s3000)
337 CALL write_s_c(isk,6)
338 ENDDO
339 ENDIF ! IF (IGTYP)
340 ENDIF ! IF (ITY)
341C-----------------------------------------------
342C FIN DE BOUCLE
343C-----------------------------------------------
344 ENDDO ! DO NG=1,NGROUP
345C
346 RETURN
347 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
aniskew
subroutine aniskew(elbuf_tab, skew, iparg, x, ixt, ixp, ixr, geo, bufl)
Definition aniskew.F:32
write_s_c
void write_s_c(int *w, int *len)
Definition write_routines.c:687