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

Go to the source code of this file.

Functions/Subroutines

subroutine corth3 (elbuf_str, dir_a, dir_b, jft, jlt, nlay, irep, nel, x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, e1x, e2x, e3x, e1y, e2y, e3y, e1z, e2z, e3z, idrape, igtyp)

Function/Subroutine Documentation

◆ corth3()

subroutine corth3 ( type (elbuf_struct_), target elbuf_str,
dir_a,
dir_b,
integer jft,
integer jlt,
integer nlay,
integer irep,
integer nel,
intent(in) x1,
intent(in) x2,
intent(in) x3,
intent(in) x4,
intent(in) y1,
intent(in) y2,
intent(in) y3,
intent(in) y4,
intent(in) z1,
intent(in) z2,
intent(in) z3,
intent(in) z4,
intent(in) e1x,
intent(in) e2x,
intent(in) e3x,
intent(in) e1y,
intent(in) e2y,
intent(in) e3y,
intent(in) e1z,
intent(in) e2z,
intent(in) e3z,
integer idrape,
integer igtyp )

Definition at line 36 of file corth3.F.

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