OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
corth3.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| corth3 ../starter/source/elements/shell/coque/corth3.F
25!||--- called by ------------------------------------------------------
26!|| c3epsini ../starter/source/elements/sh3n/coque3n/c3epsini.F
27!|| c3init3 ../starter/source/elements/sh3n/coque3n/c3init3.F
28!|| cbainit3 ../starter/source/elements/shell/coqueba/cbainit3.F
29!|| cdkepsini ../starter/source/elements/sh3n/coquedk/cdkepsini.F
30!|| cdkinit3 ../starter/source/elements/sh3n/coquedk/cdkinit3.F
31!|| cepsini ../starter/source/elements/shell/coque/cepsini.F
32!|| cinit3 ../starter/source/elements/shell/coque/cinit3.F
33!|| cnepsini ../starter/source/elements/shell/coqueba/cnepsini.F
34!||--- uses -----------------------------------------------------
35!||====================================================================
36 SUBROUTINE corth3(ELBUF_STR,DIR_A ,DIR_B ,JFT ,JLT ,
37 . NLAY ,IREP ,NEL ,
38 . X1 ,X2 ,X3 ,X4 ,Y1 ,Y2 ,
39 . Y3 ,Y4 ,Z1 ,Z2 ,Z3 ,Z4 ,
40 . E1X, E2X, E3X, E1Y, E2Y, E3Y ,E1Z, E2Z, E3Z ,
41 . IDRAPE, IGTYP )
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
460 END
corth3
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)
Definition corth3.F:42
max
#define max(a, b)
Definition macros.h:21