OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sdlen_sms.F File Reference
#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "scr17_c.inc"
#include "sms_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sdlen_sms (deltax, volg, ixs, x1, x2, x3, x4, x5, x6, x7, x8, y1, y2, y3, y4, y5, y6, y7, y8, z1, z2, z3, z4, z5, z6, z7, z8, iparts, tagprt_sms, tagelem_sms, nel)

Function/Subroutine Documentation

◆ sdlen_sms()

subroutine sdlen_sms ( deltax,
volg,
integer, dimension(nixs,*) ixs,
x1,
x2,
x3,
x4,
x5,
x6,
x7,
x8,
y1,
y2,
y3,
y4,
y5,
y6,
y7,
y8,
z1,
z2,
z3,
z4,
z5,
z6,
z7,
z8,
integer, dimension(*) iparts,
integer, dimension(*) tagprt_sms,
integer, dimension(*) tagelem_sms,
integer, intent(in) nel )

Definition at line 35 of file sdlen_sms.F.

44 use element_mod , only : nixs
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49C-----------------------------------------------
50C G l o b a l P a r a m e t e r s
51C-----------------------------------------------
52#include "mvsiz_p.inc"
53C-----------------------------------------------
54C D u m m y A r g u m e n t s
55C-----------------------------------------------
56 INTEGER, INTENT(IN) :: NEL
57 INTEGER IXS(NIXS,*), IPARTS(*), TAGPRT_SMS(*), TAGELEM_SMS(*)
58C REAL
59 my_real
60 . deltax(*),volg(*),
61 . x1(*), x2(*), x3(*), x4(*), x5(*), x6(*), x7(*), x8(*),
62 . y1(*), y2(*), y3(*), y4(*), y5(*), y6(*), y7(*), y8(*),
63 . z1(*), z2(*), z3(*), z4(*), z5(*), z6(*), z7(*), z8(*)
64C-----------------------------------------------
65C C o m m o n B l o c k s
66C-----------------------------------------------
67#include "scr17_c.inc"
68#include "sms_c.inc"
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER I, J, IT, IPT, IDEGE(MVSIZ), NINDX, NJNDX,
73 . INDEX(MVSIZ), JNDEX(MVSIZ)
74C REAL
75 my_real
76 . aj11, aj12, aj13, aj21,
77 . aj22, aj23, aj31, aj32,
78 . aj33, ai11,
79 . ai21, ai31
80C REAL
81 my_real
82 . x12(mvsiz), x34(mvsiz), x56(mvsiz),
83 . x78(mvsiz), y12(mvsiz), y34(mvsiz), y56(mvsiz), y78(mvsiz),
84 . z12(mvsiz), z34(mvsiz), z56(mvsiz), z78(mvsiz), x14(mvsiz),
85 . x23(mvsiz), x58(mvsiz), x67(mvsiz), y14(mvsiz), y23(mvsiz),
86 . y58(mvsiz), y67(mvsiz), z14(mvsiz), z23(mvsiz), z58(mvsiz),
87 . z67(mvsiz), x15(mvsiz), x26(mvsiz), x37(mvsiz), x48(mvsiz),
88 . y15(mvsiz), y26(mvsiz), y37(mvsiz), y48(mvsiz), z15(mvsiz),
89 . z26(mvsiz), z37(mvsiz), z48(mvsiz), h(8),
90 . xx1,yy1,zz1,xx2,yy2,zz2,xx3,yy3,zz3,smax(mvsiz),vmin,
91 . p1(8), p2(8), p3(8),vlinc(mvsiz,8)
92 my_real
93 . aream(mvsiz), fac, v_g
94C-----------------------------------------------
95C
96 nindx=0
97 njndx=0
98C
99 IF (isms_selec==1) THEN
100C-- Full AMS
101 DO i=1,nel
102 njndx=njndx+1
103 jndex(njndx)=i
104 END DO
105 ELSEIF (isms_selec==2) THEN
106C-- AMS by parts
107 DO i=1,nel
108 IF(tagprt_sms(iparts(i))==0)THEN
109 nindx=nindx+1
110 index(nindx)=i
111 ELSE
112 njndx=njndx+1
113 jndex(njndx)=i
114 END IF
115 END DO
116 ELSEIF (isms_selec==3) THEN
117C-- AMS auto - defined by elements
118 DO i=1,nel
119 IF(tagelem_sms(i)==0)THEN
120 nindx=nindx+1
121 index(nindx)=i
122 ELSE
123 njndx=njndx+1
124 jndex(njndx)=i
125 END IF
126 END DO
127 ELSEIF (isms_selec==4) THEN
128C-- AMS auto + parts
129 DO i=1,nel
130 IF ((tagelem_sms(i)==0).AND.(tagprt_sms(iparts(i))==0)) THEN
131 nindx=nindx+1
132 index(nindx)=i
133 ELSE
134 njndx=njndx+1
135 jndex(njndx)=i
136 END IF
137 END DO
138 ENDIF
139C
140 IF(idts6 > 0)THEN
141 CALL degenes8(
142 1 ixs, idege, nel)
143 ELSE
144 idege(1:nel)=0
145 END IF
146C-----------------------------------------------------------
147C Non AMS elements ~ sdlen.F
148C-----------------------------------------------------------
149 DO j=1,nindx
150 i=index(j)
151C
152 aream(i) =em20
153C
154 CALL idege8(x1(i),x2(i),x3(i),x4(i),y1(i),y2(i),y3(i),y4(i),
155 . z1(i),z2(i),z3(i),z4(i),aream(i),fac,it)
156 CALL idege8(x5(i),x6(i),x7(i),x8(i),y5(i),y6(i),y7(i),y8(i),
157 . z5(i),z6(i),z7(i),z8(i),aream(i),fac,it)
158 CALL idege8(x1(i),x2(i),x6(i),x5(i),y1(i),y2(i),y6(i),y5(i),
159 . z1(i),z2(i),z6(i),z5(i),aream(i),fac,it)
160 CALL idege8(x2(i),x3(i),x7(i),x6(i),y2(i),y3(i),y7(i),y6(i),
161 . z2(i),z3(i),z7(i),z6(i),aream(i),fac,it)
162 CALL idege8(x3(i),x4(i),x8(i),x7(i),y3(i),y4(i),y8(i),y7(i),
163 . z3(i),z4(i),z8(i),z7(i),aream(i),fac,it)
164 CALL idege8(x4(i),x1(i),x5(i),x8(i),y4(i),y1(i),y5(i),y8(i),
165 . z4(i),z1(i),z5(i),z8(i),aream(i),fac,it)
166C----tetra 4 ,pyrami
167 IF(idege(i) > 0)THEN
168C----tetra 4 ,pyrami
169 IF (idege(i) > 2) THEN
170 fac=one_over_9
171 ELSEIF (idege(i) > 1) THEN
172 fac=fourth
173 ELSE
174 fac=one
175 END IF
176C--------suposse here V=0.5*A_max*L for penta =0.333A_max*L for Pyram
177 IF (it ==0 ) aream(i)=fac*aream(i)
178C--------add special treat for tetra4, as V is not right values
179 IF (idege(i) > 3 ) THEN
180 aream(i)=aream(i)*fac
181 CALL deges4v(v_g,
182 . x1(i), x2(i), x3(i), x4(i), x5(i), x6(i), x7(i), x8(i),
183 . y1(i), y2(i), y3(i), y4(i), y5(i), y6(i), y7(i), y8(i),
184 . z1(i), z2(i), z3(i), z4(i), z5(i), z6(i), z7(i), z8(i))
185 ELSE
186 v_g=volg(i)
187 END IF
188 ENDIF
189C------
190 deltax(i)=four*volg(i)/sqrt(aream(i))
191 END DO
192C-----------------------------------------------------------
193C AMS elements ~ sdlen8
194C-----------------------------------------------------------
195 DO j=1,njndx
196 i=jndex(j)
197 IF(idege(i)/=0) THEN
198C------- due to the fact that AREA_Max*L is far from V for Dege---
199 aream(i) =em20
200C----tetra 4 ,pyrami
201 IF (idege(i) > 2) THEN
202 fac=one_over_9
203 ELSEIF (idege(i) > 1) THEN
204 fac=fourth
205 ELSE
206 fac=one
207 END IF
208 it = 0
209 CALL idege8(x1(i),x2(i),x3(i),x4(i),y1(i),y2(i),y3(i),y4(i),
210 . z1(i),z2(i),z3(i),z4(i),aream(i),fac,it)
211 CALL idege8(x5(i),x6(i),x7(i),x8(i),y5(i),y6(i),y7(i),y8(i),
212 . z5(i),z6(i),z7(i),z8(i),aream(i),fac,it)
213 CALL idege8(x1(i),x2(i),x6(i),x5(i),y1(i),y2(i),y6(i),y5(i),
214 . z1(i),z2(i),z6(i),z5(i),aream(i),fac,it)
215 CALL idege8(x2(i),x3(i),x7(i),x6(i),y2(i),y3(i),y7(i),y6(i),
216 . z2(i),z3(i),z7(i),z6(i),aream(i),fac,it)
217 CALL idege8(x3(i),x4(i),x8(i),x7(i),y3(i),y4(i),y8(i),y7(i),
218 . z3(i),z4(i),z8(i),z7(i),aream(i),fac,it)
219 CALL idege8(x4(i),x1(i),x5(i),x8(i),y4(i),y1(i),y5(i),y8(i),
220 . z4(i),z1(i),z5(i),z8(i),aream(i),fac,it)
221C----tetra 4
222 IF (it ==0 ) aream(i)=fac*aream(i)
223 IF (idege(i) > 3 ) THEN
224 aream(i)=aream(i)*fac
225 CALL deges4v(v_g,
226 . x1(i), x2(i), x3(i), x4(i), x5(i), x6(i), x7(i), x8(i),
227 . y1(i), y2(i), y3(i), y4(i), y5(i), y6(i), y7(i), y8(i),
228 . z1(i), z2(i), z3(i), z4(i), z5(i), z6(i), z7(i), z8(i))
229 ELSE
230 v_g=volg(i)
231 END IF
232 deltax(i) = four*v_g/sqrt(aream(i))
233 END IF
234 END DO
235
236 DO i=1,nel
237 x12(i)=x1(i)-x2(i)
238 y12(i)=y1(i)-y2(i)
239 z12(i)=z1(i)-z2(i)
240 x34(i)=x3(i)-x4(i)
241 y34(i)=y3(i)-y4(i)
242 z34(i)=z3(i)-z4(i)
243 x56(i)=x5(i)-x6(i)
244 y56(i)=y5(i)-y6(i)
245 z56(i)=z5(i)-z6(i)
246 x78(i)=x7(i)-x8(i)
247 y78(i)=y7(i)-y8(i)
248 z78(i)=z7(i)-z8(i)
249 x14(i)=x1(i)-x4(i)
250 y14(i)=y1(i)-y4(i)
251 z14(i)=z1(i)-z4(i)
252 x23(i)=x2(i)-x3(i)
253 y23(i)=y2(i)-y3(i)
254 z23(i)=z2(i)-z3(i)
255 x58(i)=x5(i)-x8(i)
256 y58(i)=y5(i)-y8(i)
257 z58(i)=z5(i)-z8(i)
258 x67(i)=x6(i)-x7(i)
259 y67(i)=y6(i)-y7(i)
260 z67(i)=z6(i)-z7(i)
261 x15(i)=x1(i)-x5(i)
262 y15(i)=y1(i)-y5(i)
263 z15(i)=z1(i)-z5(i)
264 x26(i)=x2(i)-x6(i)
265 y26(i)=y2(i)-y6(i)
266 z26(i)=z2(i)-z6(i)
267 x37(i)=x3(i)-x7(i)
268 y37(i)=y3(i)-y7(i)
269 z37(i)=z3(i)-z7(i)
270 x48(i)=x4(i)-x8(i)
271 y48(i)=y4(i)-y8(i)
272 z48(i)=z4(i)-z8(i)
273 ENDDO
274C
275 DO ipt=1,8
276 CALL basisf (h,p1,p2,p3,ipt)
277C
278 DO i=1,nel
279 aj11=p1(1)*x12(i)+p1(3)*x34(i)+p1(5)*x56(i)+p1(7)*x78(i)
280 aj12=p1(1)*y12(i)+p1(3)*y34(i)+p1(5)*y56(i)+p1(7)*y78(i)
281 aj13=p1(1)*z12(i)+p1(3)*z34(i)+p1(5)*z56(i)+p1(7)*z78(i)
282 aj21=p2(1)*x14(i)+p2(2)*x23(i)+p2(5)*x58(i)+p2(6)*x67(i)
283 aj22=p2(1)*y14(i)+p2(2)*y23(i)+p2(5)*y58(i)+p2(6)*y67(i)
284 aj23=p2(1)*z14(i)+p2(2)*z23(i)+p2(5)*z58(i)+p2(6)*z67(i)
285 aj31=p3(1)*x15(i)+p3(2)*x26(i)+p3(3)*x37(i)+p3(4)*x48(i)
286 aj32=p3(1)*y15(i)+p3(2)*y26(i)+p3(3)*y37(i)+p3(4)*y48(i)
287 aj33=p3(1)*z15(i)+p3(2)*z26(i)+p3(3)*z37(i)+p3(4)*z48(i)
288 ai11= aj22*aj33-aj23*aj32
289 ai21=-aj21*aj33+aj23*aj31
290 ai31= aj21*aj32-aj22*aj31
291 vlinc(i,ipt)=aj11*ai11+aj12*ai21+aj13*ai31
292 ENDDO
293 END DO ! IPT=1,8
294C
295 DO i=1,nel
296c mediane * 4
297 xx1 = x1(i) + x2(i) + x3(i) + x4(i)
298 . - x5(i) - x6(i) - x7(i) - x8(i)
299 yy1 = y1(i) + y2(i) + y3(i) + y4(i)
300 . - y5(i) - y6(i) - y7(i) - y8(i)
301 zz1 = z1(i) + z2(i) + z3(i) + z4(i)
302 . - z5(i) - z6(i) - z7(i) - z8(i)
303 xx2 = x1(i) + x2(i) + x5(i) + x6(i)
304 . - x3(i) - x4(i) - x7(i) - x8(i)
305 yy2 = y1(i) + y2(i) + y5(i) + y6(i)
306 . - y3(i) - y4(i) - y7(i) - y8(i)
307 zz2 = z1(i) + z2(i) + z5(i) + z6(i)
308 . - z3(i) - z4(i) - z7(i) - z8(i)
309 xx3 = x1(i) + x4(i) + x5(i) + x8(i)
310 . - x3(i) - x2(i) - x7(i) - x6(i)
311 yy3 = y1(i) + y4(i) + y5(i) + y8(i)
312 . - y3(i) - y2(i) - y7(i) - y6(i)
313 zz3 = z1(i) + z4(i) + z5(i) + z8(i)
314 . - z3(i) - z2(i) - z7(i) - z6(i)
315C surface * 16
316 smax(i) = (yy1 * zz2 - yy2 * zz1)**2
317 . + (zz1 * xx2 - zz2 * xx1)**2
318 . + (xx1 * yy2 - xx2 * yy1)**2
319 smax(i) = max(smax(i),(yy1 * zz3 - yy3 * zz1)**2
320 . + (zz1 * xx3 - zz3 * xx1)**2
321 . + (xx1 * yy3 - xx3 * yy1)**2)
322 smax(i) = max(smax(i),(yy3 * zz2 - yy2 * zz3)**2
323 . + (zz3 * xx2 - zz2 * xx3)**2
324 . + (xx3 * yy2 - xx2 * yy3)**2)
325 ENDDO
326
327C volume / 8
328 IF (idts6>0) THEN
329 DO i=1,nel
330 IF(idege(i)==0)THEN
331 vmin = min(vlinc(i,1),vlinc(i,2),vlinc(i,3),vlinc(i,4),
332 . vlinc(i,5),vlinc(i,6),vlinc(i,7),vlinc(i,8))
333 deltax(i)=hundred28*vmin/sqrt(smax(i))
334 ENDIF
335 ENDDO
336 ELSE
337 DO i=1,nel
338 vmin = min(vlinc(i,1),vlinc(i,2),vlinc(i,3),vlinc(i,4),
339 . vlinc(i,5),vlinc(i,6),vlinc(i,7),vlinc(i,8))
340 deltax(i)=hundred28*vmin/sqrt(smax(i))
341 ENDDO
342 ENDIF
343C-----------
344 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
degenes8
subroutine degenes8(ixs, idege, nel)
Definition degenes8.F:39
deges4v
subroutine deges4v(det, x1, x2, x3, x4, x5, x6, x7, x8, y1, y2, y3, y4, y5, y6, y7, y8, z1, z2, z3, z4, z5, z6, z7, z8)
Definition deges4v.F:37
idege8
subroutine idege8(x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, amax, fac, it)
Definition idege8.F:30
idege
subroutine idege(x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, a, amax, fac, it4, it, indx, n_indx)
Definition idege.F:30
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
basisf
subroutine basisf(h, p1, p2, p3, ipt)
Definition basisf.F:32