OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cortdir3.F File Reference
#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine cortdir3 (elbuf_str, dir_a, dir_b, jft, jlt, nlay, irep, rx, ry, rz, sx, sy, sz, e1x, e1y, e1z, e2x, e2y, e2z, nel)

Function/Subroutine Documentation

◆ cortdir3()

subroutine cortdir3 ( type (elbuf_struct_), target elbuf_str,
dir_a,
dir_b,
integer jft,
integer jlt,
integer nlay,
integer irep,
rx,
ry,
rz,
sx,
sy,
sz,
e1x,
e1y,
e1z,
e2x,
e2y,
e2z,
integer nel )

Definition at line 41 of file cortdir3.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE elbufdef_mod
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C G l o b a l P a r a m e t e r s
55C-----------------------------------------------
56C C o m m o n B l o c k s
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER JFT,JLT,NLAY,IREP,NEL,IDRAPE,IT
61C REAL
62 my_real
63 . rx(*),ry(*),rz(*),sx(*),sy(*),sz(*),
64 . dir_a(*),dir_b(*),e1x(*),e1y(*),e1z(*),e2x(*),e2y(*),e2z(*)
65cc . DIR_A(*),DIR_B(*),E1X(*),E1Y(*),E1Z(*),E2X(*),E2Y(*),E2Z(*)
66 TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_STR
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I,J,N,ILAW,NPTT,IAD
71C REAL
72 my_real
73 . v1,v2,v3,vr,vs,aa,bb,suma
74 my_real,
75 . DIMENSION(:) , POINTER :: dir1, dir2
76 TYPE(L_BUFEL_DIR_) ,POINTER :: LBUF_DIR
77C=======================================================================
78 idrape = elbuf_str%IDRAPE
79 IF(idrape == 0) THEN
80 IF (irep == 1) THEN
81 DO n=1,nlay
82 dir1 => elbuf_str%BUFLY(n)%DIRA
83 j = (n-1)*nel*2
84! or J = 2*(N-1)
85 DO i=jft,jlt
86 aa = dir1(i)
87 bb = dir1(i + nel)
88 v1 = aa*rx(i) + bb*sx(i)
89 v2 = aa*ry(i) + bb*sy(i)
90 v3 = aa*rz(i) + bb*sz(i)
91 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
92 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
93 suma=sqrt(vr*vr + vs*vs)
94 dir_a(j+i) = vr/suma
95 dir_a(j+i+nel) = vs/suma
96! or DIR_A(I,J+1) = VR/SUMA
97! DIR_A(I,J+2) = VS/SUMA
98 ENDDO
99 ENDDO
100 ELSEIF (irep == 2) THEN
101 DO n=1,nlay
102 dir1 => elbuf_str%BUFLY(n)%DIRA
103 dir2 => elbuf_str%BUFLY(n)%DIRB
104 j = (n-1)*nel*2
105! or J = 2*(N-1)
106 DO i=jft,jlt
107C--- Axe I
108 aa = dir1(i)
109 bb = dir1(i + nel)
110 v1 = aa*rx(i) + bb*sx(i)
111 v2 = aa*ry(i) + bb*sy(i)
112 v3 = aa*rz(i) + bb*sz(i)
113 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
114 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
115 suma = max( sqrt(vr*vr + vs*vs), em20)
116 dir_a(j+i) = vr/suma
117 dir_a(j+i+nel) = vs/suma
118! or DIR_A(I,J+1) = VR/SUMA
119! DIR_A(I,J+2) = VS/SUMA
120C--- Axe II
121 aa = dir2(i)
122 bb = dir2(i + nel)
123 v1 = aa*rx(i) + bb*sx(i)
124 v2 = aa*ry(i) + bb*sy(i)
125 v3 = aa*rz(i) + bb*sz(i)
126 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
127 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
128 suma = max( sqrt(vr*vr + vs*vs), em20)
129 dir_b(j+i) = vr/suma
130 dir_b(j+i+nel) = vs/suma
131! or DIR_B(I,J+1) = VR/SUMA
132! DIR_B(I,J+2) = VS/SUMA
133 ENDDO
134 ENDDO
135 ELSEIF (irep == 3) THEN
136C mixing law58 with other user laws with IREP = 0 within PID51
137 DO n=1,nlay
138 ilaw = elbuf_str%BUFLY(n)%ILAW
139 IF (ilaw == 58) THEN
140 dir1 => elbuf_str%BUFLY(n)%DIRA
141 dir2 => elbuf_str%BUFLY(n)%DIRB
142 j = (n-1)*nel*2
143! or J = 2*(N-1)
144 DO i=jft,jlt
145C--- Axe I
146 aa = dir1(i)
147 bb = dir1(i + nel)
148 v1 = aa*rx(i) + bb*sx(i)
149 v2 = aa*ry(i) + bb*sy(i)
150 v3 = aa*rz(i) + bb*sz(i)
151 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
152 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
153 suma = max( sqrt(vr*vr + vs*vs), em20)
154 dir_a(j+i) = vr/suma
155 dir_a(j+i+nel) = vs/suma
156! or DIR_A(I,J+1) = VR/SUMA
157! DIR_A(I,J+2) = VS/SUMA
158C--- Axe II
159 aa = dir2(i)
160 bb = dir2(i + nel)
161 v1 = aa*rx(i) + bb*sx(i)
162 v2 = aa*ry(i) + bb*sy(i)
163 v3 = aa*rz(i) + bb*sz(i)
164 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
165 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
166 suma = max( sqrt(vr*vr + vs*vs), em20)
167 dir_b(j+i) = vr/suma
168 dir_b(j+i+nel) = vs/suma
169! or DIR_B(I,J+1) = VR/SUMA
170! DIR_B(I,J+2) = VS/SUMA
171 ENDDO
172 ELSE ! IREP = 0 within PID51
173 dir1 => elbuf_str%BUFLY(n)%DIRA
174! J = 2*(N-1)
175 j = (n-1)*nel*2
176 DO i=jft,jlt
177 dir_a(j+i) = dir1(i)
178 dir_a(j+i+nel) = dir1(i+nel)
179! or DIR_A(I,J+1) = VR/SUMA
180! DIR_A(I,J+2) = VS/SUMA
181 ENDDO
182 ENDIF
183 ENDDO
184 ELSEIF (irep == 4) THEN
185C mixing law58 with other user laws with IREP = 1 within PID51
186 DO n=1,nlay
187 ilaw = elbuf_str%BUFLY(n)%ILAW
188 IF (ilaw == 58) THEN
189 dir1 => elbuf_str%BUFLY(n)%DIRA
190 dir2 => elbuf_str%BUFLY(n)%DIRB
191 j = (n-1)*nel*2
192! or J = 2*(N-1)
193 DO i=jft,jlt
194C--- Axe I
195 aa = dir1(i)
196 bb = dir1(i + nel)
197 v1 = aa*rx(i) + bb*sx(i)
198 v2 = aa*ry(i) + bb*sy(i)
199 v3 = aa*rz(i) + bb*sz(i)
200 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
201 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
202 suma = max( sqrt(vr*vr + vs*vs), em20)
203 dir_a(j+i) = vr/suma
204 dir_a(j+i+nel) = vs/suma
205! or DIR_A(I,J+1) = VR/SUMA
206! DIR_A(I,J+2) = VS/SUMA
207C--- Axe II
208 aa = dir2(i)
209 bb = dir2(i + nel)
210 v1 = aa*rx(i) + bb*sx(i)
211 v2 = aa*ry(i) + bb*sy(i)
212 v3 = aa*rz(i) + bb*sz(i)
213 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
214 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
215 suma = max( sqrt(vr*vr + vs*vs), em20)
216 dir_b(j+i) = vr/suma
217 dir_b(j+i+nel) = vs/suma
218! or dir_b(i,j+1) = vr/suma
219! DIR_B(I,J+2) = VS/SUMA
220 ENDDO
221 ELSE ! IREP = 1 within PID51
222 dir1 => elbuf_str%BUFLY(n)%DIRA
223 j = (n-1)*nel*2
224! or J = 2*(N-1)
225 DO i=jft,jlt
226 aa = dir1(i)
227 bb = dir1(i + nel)
228 v1 = aa*rx(i) + bb*sx(i)
229 v2 = aa*ry(i) + bb*sy(i)
230 v3 = aa*rz(i) + bb*sz(i)
231 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
232 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
233 suma=sqrt(vr*vr + vs*vs)
234 dir_a(j+i) = vr/suma
235 dir_a(j+i+nel) = vs/suma
236! or DIR_A(I,J+1) = VR/SUMA
237! DIR_A(I,J+2) = VS/SUMA
238 ENDDO
239 ENDIF
240 ENDDO
241 ENDIF
242 ELSE ! idrape
243 IF (irep == 1) THEN
244 iad = 0
245 DO n=1,nlay
246 nptt = elbuf_str%BUFLY(n)%NPTT
247 DO it = 1,nptt
248 lbuf_dir => elbuf_str%BUFLY(n)%LBUF_DIR(it)
249 dir1 => lbuf_dir%DIRA
250 j = iad + (it-1)*nel*2
251! or J = 2*(N-1)
252 DO i=jft,jlt
253 aa = dir1(i)
254 bb = dir1(i + nel)
255 v1 = aa*rx(i) + bb*sx(i)
256 v2 = aa*ry(i) + bb*sy(i)
257 v3 = aa*rz(i) + bb*sz(i)
258 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
259 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
260 suma=sqrt(vr*vr + vs*vs)
261 dir_a(j+i) = vr/suma
262 dir_a(j+i+nel) = vs/suma
263! or DIR_A(I,J+1) = VR/SUMA
264! DIR_A(I,J+2) = VS/SUMA
265 ENDDO
266 ENDDO ! NPTT
267 iad = iad + nptt*nel*2
268 ENDDO ! NLAY
269 ELSEIF (irep == 2) THEN
270 iad = 0
271 DO n=1,nlay
272 nptt = elbuf_str%BUFLY(n)%NPTT
273 DO it = 1,nptt
274 lbuf_dir => elbuf_str%BUFLY(n)%LBUF_DIR(it)
275 dir1 => lbuf_dir%DIRA
276 dir2 => lbuf_dir%DIRB
277 j = iad + (it-1)*nel*2
278! or J = 2*(N-1)
279 DO i=jft,jlt
280C--- Axe I
281 aa = dir1(i)
282 bb = dir1(i + nel)
283 v1 = aa*rx(i) + bb*sx(i)
284 v2 = aa*ry(i) + bb*sy(i)
285 v3 = aa*rz(i) + bb*sz(i)
286 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
287 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
288 suma = max( sqrt(vr*vr + vs*vs), em20)
289 dir_a(j+i) = vr/suma
290 dir_a(j+i+nel) = vs/suma
291! or DIR_A(I,J+1) = VR/SUMA
292! DIR_A(I,J+2) = VS/SUMA
293C--- Axe II
294 aa = dir2(i)
295 bb = dir2(i + nel)
296 v1 = aa*rx(i) + bb*sx(i)
297 v2 = aa*ry(i) + bb*sy(i)
298 v3 = aa*rz(i) + bb*sz(i)
299 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
300 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
301 suma = max( sqrt(vr*vr + vs*vs), em20)
302 dir_b(j+i) = vr/suma
303 dir_b(j+i+nel) = vs/suma
304! or DIR_B(I,J+1) = VR/SUMA
305! DIR_B(I,J+2) = VS/SUMA
306 ENDDO
307 ENDDO ! NPTT
308 iad = iad + nptt*nel*2
309 ENDDO ! NLAY
310 ELSEIF (irep == 3) THEN
311C mixing law58 with other user laws with IREP = 0 within PID51
312 iad = 0
313 DO n=1,nlay
314 ilaw = elbuf_str%BUFLY(n)%ILAW
315 IF (ilaw == 58) THEN
316 nptt = elbuf_str%BUFLY(n)%NPTT
317 DO it = 1,nptt
318 lbuf_dir => elbuf_str%BUFLY(n)%LBUF_DIR(it)
319 dir1 => lbuf_dir%DIRA
320 dir2 => lbuf_dir%DIRB
321 j = iad + (it-1)*nel*2
322! or J = 2*(N-1)
323 DO i=jft,jlt
324C--- Axe I
325 aa = dir1(i)
326 bb = dir1(i + nel)
327 v1 = aa*rx(i) + bb*sx(i)
328 v2 = aa*ry(i) + bb*sy(i)
329 v3 = aa*rz(i) + bb*sz(i)
330 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
331 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
332 suma = max( sqrt(vr*vr + vs*vs), em20)
333 dir_a(j+i) = vr/suma
334 dir_a(j+i+nel) = vs/suma
335! or DIR_A(I,J+1) = VR/SUMA
336! DIR_A(I,J+2) = VS/SUMA
337C--- Axe II
338 aa = dir2(i)
339 bb = dir2(i + nel)
340 v1 = aa*rx(i) + bb*sx(i)
341 v2 = aa*ry(i) + bb*sy(i)
342 v3 = aa*rz(i) + bb*sz(i)
343 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
344 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
345 suma = max( sqrt(vr*vr + vs*vs), em20)
346 dir_b(j+i) = vr/suma
347 dir_b(j+i+nel) = vs/suma
348! or DIR_B(I,J+1) = VR/SUMA
349! DIR_B(I,J+2) = VS/SUMA
350 ENDDO
351 ENDDO ! NPTT
352 iad = iad + nptt*2*nel
353 ELSE ! IREP = 0 within PID51
354 nptt = elbuf_str%BUFLY(n)%NPTT
355 DO it = 1,nptt
356 lbuf_dir => elbuf_str%BUFLY(n)%LBUF_DIR(it)
357 dir1 => lbuf_dir%DIRA
358! J = 2*(N-1)
359 j = iad + (it-1)*nel*2
360 DO i=jft,jlt
361 dir_a(j+i) = dir1(i)
362 dir_a(j+i+nel) = dir1(i+nel)
363! or DIR_A(I,J+1) = VR/SUMA
364! DIR_A(I,J+2) = VS/SUMA
365 ENDDO
366 ENDDO ! NPTT
367 iad = iad + 2*nel*nptt
368 ENDIF
369 ENDDO ! NALY
370 ELSEIF (irep == 4) THEN
371C mixing law58 with other user laws with IREP = 1 within PID51
372 iad = 0
373 DO n=1,nlay
374 ilaw = elbuf_str%BUFLY(n)%ILAW
375 IF (ilaw == 58) THEN
376 nptt = elbuf_str%BUFLY(n)%NPTT
377 DO it = 1,nptt
378 lbuf_dir => elbuf_str%BUFLY(n)%LBUF_DIR(it)
379 dir1 => lbuf_dir%DIRA
380 dir2 => lbuf_dir%DIRB
381 j = iad + (it - 1)*nel*2
382! or J = 2*(N-1)
383 DO i=jft,jlt
384C--- Axe I
385 aa = dir1(i)
386 bb = dir1(i + nel)
387 v1 = aa*rx(i) + bb*sx(i)
388 v2 = aa*ry(i) + bb*sy(i)
389 v3 = aa*rz(i) + bb*sz(i)
390 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
391 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
392 suma = max( sqrt(vr*vr + vs*vs), em20)
393 dir_a(j+i) = vr/suma
394 dir_a(j+i+nel) = vs/suma
395! or DIR_A(I,J+1) = VR/SUMA
396! DIR_A(I,J+2) = VS/SUMA
397C--- Axe II
398 aa = dir2(i)
399 bb = dir2(i + nel)
400 v1 = aa*rx(i) + bb*sx(i)
401 v2 = aa*ry(i) + bb*sy(i)
402 v3 = aa*rz(i) + bb*sz(i)
403 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
404 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
405 suma = max( sqrt(vr*vr + vs*vs), em20)
406 dir_b(j+i) = vr/suma
407 dir_b(j+i+nel) = vs/suma
408! or DIR_B(I,J+1) = VR/SUMA
409! DIR_B(I,J+2) = VS/SUMA
410 ENDDO
411 ENDDO ! NPTT
412 iad = iad + nptt*2*nel
413 ELSE ! IREP = 1 within PID51
414 nptt = elbuf_str%BUFLY(n)%NPTT
415 DO it = 1,nptt
416 lbuf_dir => elbuf_str%BUFLY(n)%LBUF_DIR(it)
417 dir1 => lbuf_dir%DIRA
418 j = iad + (it-1)*nel*2
419! or J = 2*(N-1)
420 DO i=jft,jlt
421 aa = dir1(i)
422 bb = dir1(i + nel)
423 v1 = aa*rx(i) + bb*sx(i)
424 v2 = aa*ry(i) + bb*sy(i)
425 v3 = aa*rz(i) + bb*sz(i)
426 vr = v1*e1x(i)+ v2*e1y(i) + v3*e1z(i)
427 vs = v1*e2x(i)+ v2*e2y(i) + v3*e2z(i)
428 suma=sqrt(vr*vr + vs*vs)
429 dir_a(j+i) = vr/suma
430 dir_a(j+i+nel) = vs/suma
431! or DIR_A(I,J+1) = VR/SUMA
432! DIR_A(I,J+2) = VS/SUMA
433 ENDDO
434 ENDDO ! NPTT
435 iad = iad + 2*nptt*nel
436 ENDIF
437 ENDDO ! NLAY
438 ENDIF
439
440
441 ENDIF ! IDRAPE
442C----------------------------
443 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21