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