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