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 34 of file aniskew.F.

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