OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
aniskew.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine aniskew (elbuf_tab, skew, iparg, x, ixt, ixp, ixr, geo, dd_iad, bufl)

Function/Subroutine Documentation

◆ aniskew()

subroutine aniskew ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
skew,
integer, dimension(nparg,*) iparg,
x,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
geo,
integer, dimension(nspmd+1,*) dd_iad,
integer bufl )

Definition at line 33 of file aniskew.F.

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