OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ruser33.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!|| ruser33 ../engine/source/elements/joint/ruser33.F
25!||--- called by ------------------------------------------------------
26!|| rgjoint ../engine/source/elements/joint/rgjoint.F
27!||--- calls -----------------------------------------------------
28!|| def_fdof ../engine/source/elements/joint/ruser33.F
29!|| get_u_func ../engine/source/user_interface/ufunc.F
30!|| get_u_mid ../engine/source/user_interface/upidmid.F
31!|| get_u_mnu ../engine/source/user_interface/upidmid.F
32!|| get_u_pid ../engine/source/user_interface/upidmid.F
33!|| get_u_pnu ../engine/source/user_interface/upidmid.F
34!|| sens_block ../engine/source/elements/joint/ruser33.F
35!|| stdpl ../engine/source/elements/joint/ruser33.F
36!|| xddl33 ../engine/source/elements/joint/ruser33.F
37!|| xddl33i ../engine/source/elements/joint/ruser33.F
38!||====================================================================
39 SUBROUTINE ruser33(NEL ,IOUT ,IPROP ,NUVAR ,UVAR ,
40 . FX ,FY ,FZ ,XMOM ,YMOM ,
41 . ZMOM ,XKM ,XKR ,XCM ,XCR ,
42 . XL ,MASS ,INER ,OFF ,EINT ,
43 . ROT1 ,ROT2 ,DX ,DY ,DZ ,
44 . RX ,RY ,RZ ,IGTYP ,ISENS ,
45 . X0_ERR)
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"
54#include "com08_c.inc"
55#include "scr05_c.inc"
56C----------------------------------------------------------
57C D u m m y A r g u m e n t s a n d F u n c t i o n
58C----------------------------------------------------------
59 INTEGER NEL,IOUT,IPROP,NUVAR,IGTYP,ISENS
60 my_real DT,
61 . UVAR(NUVAR,*), FX(*), FY(*), FZ(*), EINT(*),
62 . XMOM(*), YMOM(*), ZMOM(*), XKM(*), XKR(*),
63 . XCM(*) ,XCR(*), MASS(*) ,INER(*),
64 . OFF(*), ROT1(3,MVSIZ), ROT2(3,MVSIZ),
65 . dx(*), dy(*), dz(*), rx(*), ry(*), rz(*), x0_err(3,*)
66 DOUBLE PRECISION XL(MVSIZ,3)
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I, K, JTYP, ISK1, ISK2,
71 . IFUN_XX,IFUN_YY,IFUN_ZZ,IFUN_RX,IFUN_RY,IFUN_RZ,
72 . ifun_cxx,ifun_cyy,ifun_czz,ifun_crx,ifun_cry,ifun_crz,
73 . ifun_fmx,ifun_fmy,ifun_fmz,ifun_fmrx,ifun_fmry,ifun_fmrz,
74 . kfunc,kmat,kprop,get_u_pnu,get_u_pid,get_u_mid,get_u_mnu,
75 . fdof(6),icombt,icombr
76 my_real
77 . lx2,ly2,lz2,cxx,cyy,czz,crx,cry,crz,
78 . cr1,cr2,cr3,cr4,cr5,cr6,cx, ms,in,fac_ctx,fac_crx,
79 . my1(mvsiz),my2(mvsiz),mz1(mvsiz),mz2(mvsiz),mx1(mvsiz),
80 . mx2(mvsiz),fold(mvsiz,6),dxold(mvsiz,6),l2(mvsiz),
81 . knx(mvsiz),kny(mvsiz),knz(mvsiz),
82 . krx(mvsiz),kry(mvsiz),krz(mvsiz),
83 . vx(mvsiz),vy(mvsiz),vz(mvsiz),
84 . vx2(mvsiz),vy2(mvsiz),vz2(mvsiz),
85 . th1(mvsiz),th2(mvsiz),th3(mvsiz),
86 . vrx(mvsiz),vry(mvsiz),vrz(mvsiz),
87 . get_u_mat, get_u_geo, get_u_func,
88 . sma(6),smi(6),knn(mvsiz),krr(mvsiz),cr,
89 . dxs(mvsiz),dys(mvsiz),dzs(mvsiz),drxs(mvsiz),
90 . drys(mvsiz),drzs(mvsiz),kf(6),dxsk(6),fm(6),
91 . fcomb(6),deq(mvsiz),req(mvsiz),xcent(6),smeqt,smeqr,
92 . fac_loc_l,fac_loc_t,fac_x,fac_r
93 DOUBLE PRECISION X0DP(3)
94C-----------------------------------------------
95 EXTERNAL GET_U_MAT,GET_U_GEO, GET_U_FUNC,
96 . GET_U_PNU,GET_U_PID,GET_U_MID,GET_U_MNU
97C-----------------------------------------------
98 PARAMETER (KFUNC=29)
99 parameter(kmat=31)
100 parameter(kprop=33)
101C=======================================================================
102 dt = dt1
103 IF (dt==zero) dt = ep30
104 jtyp = nint(get_u_geo(1,iprop))
105C
106 cr = get_u_geo(12,iprop)
107 cr1 = get_u_geo(15,iprop)
108 cr2 = get_u_geo(16,iprop)
109 cr3 = get_u_geo(17,iprop)
110 cr4 = get_u_geo(18,iprop)
111 cr5 = get_u_geo(19,iprop)
112 cr6 = get_u_geo(20,iprop)
113 cxx = get_u_geo(21,iprop)
114 cyy = get_u_geo(22,iprop)
115 czz = get_u_geo(23,iprop)
116 crx = get_u_geo(24,iprop)
117 cry = get_u_geo(25,iprop)
118 crz = get_u_geo(26,iprop)
119 fac_loc_l = get_u_geo(27,iprop)
120 fac_loc_t = get_u_geo(28,iprop)
121C
122 fac_x = one / fac_loc_l
123 fac_r = one
124 fac_ctx = fac_loc_t / fac_loc_l
125 fac_crx = fac_loc_t
126C
127 IF (igtyp==45) THEN
128 ifun_fmx = get_u_pnu(13,iprop,kfunc)
129 ifun_fmy = get_u_pnu(14,iprop,kfunc)
130 ifun_fmz = get_u_pnu(15,iprop,kfunc)
131 ifun_fmrx = get_u_pnu(16,iprop,kfunc)
132 ifun_fmry = get_u_pnu(17,iprop,kfunc)
133 ifun_fmrz = get_u_pnu(18,iprop,kfunc)
134 CALL def_fdof(jtyp,fdof)
135 k = 28
136C
137 xcent(1:6) = zero
138 DO i=1,6
139 kf(i) = get_u_geo(40+i,iprop)
140 fm(i) = get_u_geo(46+i,iprop)
141 smi(i) = get_u_geo(k+1,iprop)
142 sma(i) = get_u_geo(k+2,iprop)
143 fcomb(i) = get_u_geo(54+i,iprop)
144 xcent(i) = half*(sma(i)+smi(i))
145 k = k+2
146 END DO
147C
148 icombt = nint(fcomb(1)+fcomb(2)+fcomb(3))
149 icombr = nint(fcomb(4)+fcomb(5)+fcomb(6))
150 ELSE
151C-- old kjoint type33 -> combined stopping displ/angles not allowed
152 icombt = 0
153 icombr = 0
154 ENDIF
155C
156 ifun_xx = get_u_pnu(1,iprop,kfunc)
157 ifun_yy = get_u_pnu(2,iprop,kfunc)
158 ifun_zz = get_u_pnu(3,iprop,kfunc)
159 ifun_rx = get_u_pnu(4,iprop,kfunc)
160 ifun_ry = get_u_pnu(5,iprop,kfunc)
161 ifun_rz = get_u_pnu(6,iprop,kfunc)
162C
163 ifun_cxx = get_u_pnu(7,iprop,kfunc)
164 ifun_cyy = get_u_pnu(8,iprop,kfunc)
165 ifun_czz = get_u_pnu(9,iprop,kfunc)
166 ifun_crx = get_u_pnu(10,iprop,kfunc)
167 ifun_cry = get_u_pnu(11,iprop,kfunc)
168 ifun_crz = get_u_pnu(12,iprop,kfunc)
169C
170 DO i=1,nel
171 knx(i) = uvar(19,i)
172 kny(i) = uvar(20,i)
173 knz(i) = uvar(21,i)
174 krx(i) = uvar(31,i)
175 kry(i) = uvar(32,i)
176 krz(i) = uvar(33,i)
177 knn(i) = uvar(17,i)
178 krr(i) = uvar(18,i)
179 IF ((igtyp==45).AND.(isens==1)) THEN
180 DO k=1,6
181 dxsk(k) = uvar(4+k-1,i)
182 IF (abs(sma(k))>em20) dxsk(k) = min(dxsk(k),sma(k))
183 IF (abs(smi(k))>em20) dxsk(k) = max(dxsk(k),smi(k))
184 END DO
185 dxs(i) = dxsk(1)
186 dys(i) = dxsk(2)
187 dzs(i) = dxsk(3)
188 drxs(i) = dxsk(4)
189 drys(i) = dxsk(5)
190 drzs(i) = dxsk(6)
191 ENDIF
192 dxold(i,1) = dx(i)
193 dxold(i,2) = dy(i)
194 dxold(i,3) = dz(i)
195 dxold(i,4) = rx(i)
196 dxold(i,5) = ry(i)
197 dxold(i,6) = rz(i)
198 fold(i,1) = fx(i)
199 fold(i,2) = fy(i)
200 fold(i,3) = fz(i)
201 fold(i,4) = xmom(i)
202 fold(i,5) = ymom(i)
203 fold(i,6) = zmom(i)
204 IF (iresp == 1) THEN
205C- simple precision - extended sple precsion only for translational dof
206 IF (tt == zero) THEN
207 uvar(1,i)=xl(i,1)
208 uvar(2,i)=xl(i,2)
209 uvar(3,i)=xl(i,3)
210 x0_err(1,i)= xl(i,1)-uvar(1,i)
211 x0_err(2,i)= xl(i,2)-uvar(2,i)
212 x0_err(3,i)= xl(i,3)-uvar(3,i)
213 ENDIF
214 x0dp(1) = uvar(1,i)
215 x0dp(2) = uvar(2,i)
216 x0dp(3) = uvar(3,i)
217 x0dp(1) = x0dp(1) + x0_err(1,i)
218 x0dp(2) = x0dp(2) + x0_err(2,i)
219 x0dp(3) = x0dp(3) + x0_err(3,i)
220 ELSE
221C-- double precision
222 x0dp(1) = uvar(1,i)
223 x0dp(2) = uvar(2,i)
224 x0dp(3) = uvar(3,i)
225 ENDIF
226C
227 dx(i) = xl(i,1)-x0dp(1)
228 dy(i) = xl(i,2)-x0dp(2)
229 dz(i) = xl(i,3)-x0dp(3)
230 IF (icombt > 1) THEN
231 deq(i) = sqrt(fcomb(1)*(dx(i)-xcent(1))*(dx(i)-xcent(1))
232 . +fcomb(2)*(dy(i)-xcent(2))*(dy(i)-xcent(2))
233 . +fcomb(3)*(dz(i)-xcent(3))*(dz(i)-xcent(3)))
234 ELSE
235 deq(i) = zero
236 ENDIF
237C
238 rx(i) = rot2(1,i)-rot1(1,i)
239 ry(i) = rot2(2,i)-rot1(2,i)
240 rz(i) = rot2(3,i)-rot1(3,i)
241 IF (icombr > 1) THEN
242 req(i) = sqrt(fcomb(4)*(rx(i)-xcent(4))*(rx(i)-xcent(4))
243 . +fcomb(5)*(ry(i)-xcent(5))*(ry(i)-xcent(5))
244 . +fcomb(6)*(rz(i)-xcent(6))*(rz(i)-xcent(6)))
245 ELSE
246 req(i) = zero
247 ENDIF
248C
249 vx(i) = (dx(i) - dxold(i,1)) / dt
250 vy(i) = (dy(i) - dxold(i,2)) / dt
251 vz(i) = (dz(i) - dxold(i,3)) / dt
252 vrx(i) = (rx(i) - dxold(i,4)) / dt
253 vry(i) = (ry(i) - dxold(i,5)) / dt
254 vrz(i) = (rz(i) - dxold(i,6)) / dt
255 xkm(i) = zero
256 xkr(i) = zero
257 xcm(i) = zero
258 xcr(i) = zero
259 ENDDO
260C-------- ELASTIC
261 CALL xddl33(nel, dx, fx, knx, ifun_xx, xkm,fac_x)
262 CALL xddl33(nel, dy, fy, kny, ifun_yy, xkm,fac_x)
263 CALL xddl33(nel, dz, fz, knz, ifun_zz, xkm,fac_x)
264 CALL xddl33(nel, rx, xmom, krx, ifun_rx, xkr,fac_r)
265 CALL xddl33(nel, ry, ymom, kry, ifun_ry, xkr,fac_r)
266 CALL xddl33(nel, rz, zmom, krz, ifun_rz, xkr,fac_r)
267
268C-------- STOP DISPLACEMENT / ANGLE + FRICTION
269 IF (igtyp==45) THEN
270 CALL stdpl(nel,dx,vx,fx,knx,knn,kf(1),cr,cr1,smi(1),sma(1),
271 . xkm,fm(1),uvar(10,1),ifun_fmx,icombt,deq,fcomb(1),xcent(1),fac_x)
272 CALL stdpl(nel,dy,vy,fy,kny,knn,kf(2),cr,cr2,smi(2),sma(2),
273 . xkm,fm(2),uvar(11,1),ifun_fmy,icombt,deq,fcomb(2),xcent(2),fac_x)
274 CALL stdpl(nel,dz,vz,fz,knz,knn,kf(3),cr,cr3,smi(3),sma(3),
275 . xkm,fm(3),uvar(12,1),ifun_fmz,icombt,deq,fcomb(3),xcent(3),fac_x)
276
277 CALL stdpl(nel,rx,vrx,xmom,krx,krr,kf(4),cr,cr4,smi(4),sma(4),
278 . xkr,fm(4),uvar(13,1),ifun_fmrx,icombr,req,fcomb(4),xcent(4),fac_r)
279 CALL stdpl(nel,ry,vry,ymom,kry,krr,kf(5),cr,cr5,smi(5),sma(5),
280 . xkr,fm(5),uvar(14,1),ifun_fmry,icombr,req,fcomb(5),xcent(5),fac_r)
281 CALL stdpl(nel,rz,vrz,zmom,krz,krr,kf(6),cr,cr6,smi(6),sma(6),
282 . xkr,fm(6),uvar(15,1),ifun_fmrz,icombr,req,fcomb(6),xcent(6),fac_r)
283 ENDIF
284C-------- JOINT BLOCKED BY SENSOR ACTIVATION
285 IF ((igtyp==45).AND.(isens==1)) THEN
286 CALL sens_block(nel,dx,fx,knx,knn,cr,cr1,dxs,fdof(1),xkm)
287 CALL sens_block(nel,dy,fy,kny,knn,cr,cr2,dys,fdof(2),xkm)
288 CALL sens_block(nel,dz,fz,knz,knn,cr,cr3,dzs,fdof(3),xkm)
289 CALL sens_block(nel,rx,xmom,krx,krr,cr,cr4,drxs,fdof(4),xkr)
290 CALL sens_block(nel,ry,ymom,kry,krr,cr,cr5,drys,fdof(5),xkr)
291 CALL sens_block(nel,rz,zmom,krz,krr,cr,cr6,drzs,fdof(6),xkr)
292 ENDIF
293C-------- CRITICAL DAMPING
294 DO i=1,nel
295 ms = zero
296 in = zero
297 IF((uvar(34,i)+uvar(35,i))/=zero)
298 . ms = (uvar(34,i)*uvar(35,i))/(uvar(34,i)+uvar(35,i))
299 IF((uvar(36,i)+uvar(37,i))/=zero)
300 . in = (uvar(36,i)*uvar(37,i))/(uvar(36,i)+uvar(37,i))
301 cx = max(cr1,cr2,cr3,cr4,cr5,cr6)
302 xcm(i) = cx*sqrt(xkm(i)*ms)
303 xcr(i) = cx*sqrt(xkr(i)*in)
304C
305 fx(i)= fx(i) + cr1*sqrt(knx(i)*ms)*vx(i)
306 fy(i)= fy(i) + cr2*sqrt(kny(i)*ms)*vy(i)
307 fz(i)= fz(i) + cr3*sqrt(knz(i)*ms)*vz(i)
308 xmom(i)= xmom(i) + cr4*sqrt(krx(i)*in)*vrx(i)
309 ymom(i)= ymom(i) + cr5*sqrt(kry(i)*in)*vry(i)
310 zmom(i)= zmom(i) + cr6*sqrt(krz(i)*in)*vrz(i)
311 ENDDO
312C-------- USER DAMPING
313 CALL xddl33i(nel, vx, fx, cxx, ifun_cxx, xcm, fac_ctx)
314 CALL xddl33i(nel, vy, fy, cyy, ifun_cyy, xcm, fac_ctx)
315 CALL xddl33i(nel, vz, fz, czz, ifun_czz, xcm, fac_ctx)
316 CALL xddl33i(nel, vrx, xmom, crx, ifun_crx, xcr, fac_crx)
317 CALL xddl33i(nel, vry, ymom, cry, ifun_cry, xcr, fac_crx)
318 CALL xddl33i(nel, vrz, zmom, crz, ifun_crz, xcr, fac_crx)
319C
320C---- Internal Energy
321 DO i=1,nel
322 eint(i) = eint(i) + half*(
323 . (dx(i)-dxold(i,1)) * (fx(i)+fold(i,1))
324 . + (dy(i)-dxold(i,2)) * (fy(i)+fold(i,2))
325 . + (dz(i)-dxold(i,3)) * (fz(i)+fold(i,3))
326 . + (rx(i)-dxold(i,4)) * (xmom(i)+fold(i,4))
327 . + (ry(i)-dxold(i,5)) * (ymom(i)+fold(i,5))
328 . + (rz(i)-dxold(i,6)) * (zmom(i)+fold(i,6)))
329 mass(i) = zero
330 iner(i) = zero
331 ENDDO
332C-------------------------------
333 RETURN
334 END
335!||====================================================================
336!|| xddl33 ../engine/source/elements/joint/ruser33.F
337!||--- called by ------------------------------------------------------
338!|| ruser33 ../engine/source/elements/joint/ruser33.F
339!||--- calls -----------------------------------------------------
340!|| get_u_func ../engine/source/user_interface/ufunc.F
341!||====================================================================
342 SUBROUTINE xddl33(NEL, DX, FX, KX, IFUN, KMX, FAC_X)
343C-------------------------------------------------------------------------
344C I m p l i c i t T y p e s
345C-----------------------------------------------
346#include "implicit_f.inc"
347C-----------------------------------------------
348C G l o b a l P a r a m e t e r s
349C-----------------------------------------------
350C----------------------------------------------------------
351C D u m m y A r g u m e n t s a n d F u n c t i o n
352C----------------------------------------------------------
353 INTEGER I,NEL,IFUN
354 my_real DERI, KX(*), DX(*), FX(*), KMX(*),
355 . GET_U_FUNC,FAC_X
356 EXTERNAL GET_U_FUNC
357C----------------------------------------------------------
358 my_real FX0
359C-------------------------------------------------------------------------
360 DO i=1,nel
361 IF(ifun==0) THEN
362 fx(i) = kx(i)*dx(i)
363 kmx(i)= max(kmx(i),kx(i))
364 ELSE
365 fx0= kx(i)*get_u_func(ifun,zero,deri)
366 fx(i) = kx(i)*get_u_func(ifun,dx(i)*fac_x,deri)
367 kmx(i) = max(kmx(i),(kx(i)*fac_x)*deri,(fx(i)-fx0)/max(em15,dx(i)))
368C---- KX is no longer a scale factor on force but the effective stiffness
369 kx(i) = (kx(i)*fac_x)*deri
370 ENDIF
371 ENDDO
372C-------------------------------
373 RETURN
374 END
375!||====================================================================
376!|| xddl33i ../engine/source/elements/joint/ruser33.F
377!||--- called by ------------------------------------------------------
378!|| ruser33 ../engine/source/elements/joint/ruser33.F
379!||--- calls -----------------------------------------------------
380!|| get_u_func ../engine/source/user_interface/ufunc.F
381!||====================================================================
382 SUBROUTINE xddl33i(NEL, DX, FX, KX, IFUN, KMX, FAC_X)
383C-------------------------------------------------------------------------
384C I m p l i c i t T y p e s
385C-----------------------------------------------
386#include "implicit_f.inc"
387C-----------------------------------------------
388C G l o b a l P a r a m e t e r s
389C-----------------------------------------------
390C----------------------------------------------------------
391C D u m m y A r g u m e n t s a n d F u n c t i o n
392C----------------------------------------------------------
393 INTEGER I,NEL,IFUN
394 my_real DERI, FAC_X, KX, DX(*), FX(*), KMX(*),
395 . GET_U_FUNC
396 EXTERNAL GET_U_FUNC
397C-------------------------------------------------------------------------
398 IF (KX/=zero) THEN
399 DO i=1,nel
400 IF(ifun==0) THEN
401 fx(i) = fx(i) + kx*dx(i)
402 kmx(i)= max(kmx(i),kx)
403 ELSE
404 fx(i) = fx(i) + kx*get_u_func(ifun,dx(i)*fac_x,deri)
405 kmx(i) = max(kmx(i),(kx*fac_x)*deri)
406 ENDIF
407 ENDDO
408 ENDIF
409C-------------------------------
410 RETURN
411 END
412!||====================================================================
413!|| stdpl ../engine/source/elements/joint/ruser33.F
414!||--- called by ------------------------------------------------------
415!|| ruser33 ../engine/source/elements/joint/ruser33.F
416!||--- calls -----------------------------------------------------
417!|| get_u_func ../engine/source/user_interface/ufunc.F
418!||====================================================================
419 SUBROUTINE stdpl(NEL,DX,VX,FX,KX,KNN,KF,CR,CRX,DXMI,DXMA,KMX,
420 . FM,FRP,IFUN,ICOMB,DEQ,FCOMB,XCENT,FAC_X)
421C-------------------------------------------------------------------------
422C I m p l i c i t T y p e s
423C-----------------------------------------------
424#include "implicit_f.inc"
425C-----------------------------------------------
426C G l o b a l P a r a m e t e r s
427C-----------------------------------------------
428#include "com08_c.inc"
429C----------------------------------------------------------
430C D u m m y A r g u m e n t s a n d F u n c t i o n
431C----------------------------------------------------------
432 INTEGER I,NEL,IFUN,FLAG_FRIC,ICOMB
433 my_real DERI, KX(*), DX(*), VX(*), FX(*), KMX(*),CRX,
434 . CR,DXMI,DXMA,DELTAX,KNN(*),KF,KLOC,FM,FR,BETA,
435 . DFR,FT,FRP(*),GET_U_FUNC,KTAN,FFM,KTMAX,DEQ(*),FCOMB,RADIUS,XCENT,FAC_X
436 EXTERNAL GET_U_FUNC
437C-------------------------------------------------------------------------
438C
439 IF ((kf>em20).AND.((fm>em20).OR.(ifun>0))) THEN
440C------Friction-----------------------------------------------------------
441 DO i=1,nel
442 dfr = kf*vx(i)*dt12
443 fr = frp(i) + dfr
444 ft = max(fr*fr,em30)
445 deltax = zero
446C
447 IF (ifun>0) THEN
448 ffm = fm*get_u_func(ifun,dx(i)*fac_x,deri)
449 ktmax = max(kf,abs((fm*fac_x)*deri))
450 ELSE
451 ffm = fm
452 ktmax = kf
453 ENDIF
454C
455 beta = min(one,sqrt((ffm**2)/ft))
456C
457 IF (icomb <= 1) THEN
458C- stopping displacement/ angle
459 IF ((dx(i)>0).AND.(dxma>0)) deltax = max(zero,dx(i)-dxma)
460 IF ((dx(i)<0).AND.(dxmi<0)) deltax = min(zero,dx(i)-dxmi)
461 IF (abs(deltax)>em20) beta = one
462 ELSE
463C- combined stopping displacement/ angle
464 radius = half*(dxma-dxmi)
465 IF ((deq(i)>0).AND.(radius>0)) deltax = max(zero,deq(i)-radius)
466 fr = frp(i)
467 IF (abs(deltax)>em20) THEN
468 dfr = dfr*fcomb*abs(dx(i)-xcent)/deq(i)
469 beta = one
470 fr = frp(i) + dfr
471 ENDIF
472 ENDIF
473C
474 fr = fr * beta
475 ktan = abs((fr-frp(i))/(max(em15,vx(i)*dt12)))
476 ktan = min(ktan,ktmax)
477 frp(i) = fr
478C
479 fx(i) = fx(i) + fr
480 kx(i) = kx(i) + ktan
481 kloc = kx(i) + max(ktan,kf)
482 crx = cr
483 kmx(i)= max(kmx(i),kloc)
484 ENDDO
485
486 ELSEIF (((abs(dxmi)+dxma)>0).AND.(icomb <= 1)) THEN
487C------Stopping Angles / displacements only--------------------------------
488 DO i=1,nel
489 deltax = zero
490 kloc = knn(i)
491 IF (kf>em20) kloc = kf
492 IF ((dx(i)>0).AND.(dxma>0)) deltax = max(zero,dx(i)-dxma)
493 IF ((dx(i)<0).AND.(dxmi<0)) deltax = min(zero,dx(i)-dxmi)
494 IF (abs(deltax)>em20) THEN
495 fx(i) = fx(i) + kloc*deltax
496 kx(i) = kx(i) + kloc
497 crx = cr
498 kmx(i)= max(kmx(i),kx(i))
499 ELSEIF (abs((dx(i)-dxma)/dxma)<0.001) THEN
500 kx(i) = kx(i) + kloc
501 crx = cr
502 kmx(i)= max(kmx(i),kx(i))
503 ENDIF
504 ENDDO
505C
506 ELSEIF (((abs(dxmi)+dxma)>0).AND.(icomb > 1)) THEN
507C------Combined stopping Angles / displacements only--------------------------------
508 DO i=1,nel
509 deltax = zero
510 kloc = knn(i)
511 radius = half*(dxma-dxmi)
512 IF (kf>em20) kloc = kf
513 IF ((deq(i)>0).AND.(radius>0)) deltax = max(zero,deq(i)-radius)
514 IF (abs(deltax)>em20) THEN
515 fx(i) = fx(i) + kloc*deltax*(fcomb*(dx(i)-xcent)/deq(i))
516 kx(i) = kx(i) + kloc
517 crx = cr
518 kmx(i)= max(kmx(i),kx(i))
519 ELSEIF (abs((deq(i)-radius)/radius)<0.001) THEN
520 kx(i) = kx(i) + kloc
521 crx = cr
522 kmx(i)= max(kmx(i),kx(i))
523 ENDIF
524 ENDDO
525C
526 ENDIF
527C
528
529C-------------------------------
530 RETURN
531 END
532!||====================================================================
533!|| sens_block ../engine/source/elements/joint/ruser33.F
534!||--- called by ------------------------------------------------------
535!|| ruser33 ../engine/source/elements/joint/ruser33.F
536!||====================================================================
537 SUBROUTINE sens_block(NEL,DX,FX,KX,KNN,CR,CRX,DXS,FLAG,KMX)
538C-------------------------------------------------------------------------
539C I m p l i c i t T y p e s
540C-----------------------------------------------
541#include "implicit_f.inc"
542C-----------------------------------------------
543C G l o b a l P a r a m e t e r s
544C-----------------------------------------------
545C----------------------------------------------------------
546C D u m m y A r g u m e n t s a n d F u n c t i o n
547C----------------------------------------------------------
548 INTEGER I,NEL,FLAG
549 my_real DERI, KX(*), DX(*), FX(*), KMX(*),
550 . CRX,CR,DELTAX,KNN(*),DXS(*)
551C-------------------------------------------------------------------------
552 IF (FLAG==0) goto 350
553C
554 DO i=1,nel
555 deltax = dx(i)-dxs(i)
556 fx(i) = fx(i) + knn(i)*deltax
557 kx(i) = kx(i) + knn(i)
558 crx = cr
559 kmx(i)= max(kmx(i),kx(i))
560 ENDDO
561C
562350 CONTINUE
563C-------------------------------
564 RETURN
565 END
566!||====================================================================
567!|| def_fdof ../engine/source/elements/joint/ruser33.F
568!||--- called by ------------------------------------------------------
569!|| ruser33 ../engine/source/elements/joint/ruser33.F
570!||====================================================================
571 SUBROUTINE def_fdof(JTYP,FDOF)
572C-------------------------------------------------------------------------
573C I m p l i c i t T y p e s
574C-----------------------------------------------
575#include "implicit_f.inc"
576C-----------------------------------------------
577C G l o b a l P a r a m e t e r s
578C-----------------------------------------------
579C----------------------------------------------------------
580C D u m m y A r g u m e n t s a n d F u n c t i o n
581C----------------------------------------------------------
582 INTEGER JTYP,FDOF(6)
583C-------------------------------------------------------------------------
584
585 FDOF = 0
586
587 if (jtyp==1) THEN
588 fdof(4) = 1
589 fdof(5) = 1
590 fdof(6) = 1
591 ELSEIF (jtyp==2) THEN
592 fdof(4) = 1
593 ELSEIF (jtyp==3) THEN
594 fdof(1) = 1
595 fdof(4) = 1
596 ELSEIF (jtyp==4) THEN
597 fdof(2) = 1
598 fdof(3) = 1
599 fdof(4) = 1
600 ELSEIF (jtyp==6) THEN
601 fdof(1) = 1
602 ELSEIF (jtyp==7) THEN
603 fdof(2) = 1
604 fdof(3) = 1
605 ELSEIF (jtyp==9) THEN
606 fdof(1) = 1
607 fdof(2) = 1
608 fdof(3) = 1
609 fdof(4) = 1
610 fdof(5) = 1
611 fdof(6) = 1
612 ENDIF
613
614C-------------------------------
615 RETURN
616 END
if
if(complex_arithmetic) id
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
ruser33
subroutine ruser33(nel, iout, iprop, nuvar, uvar, fx, fy, fz, xmom, ymom, zmom, xkm, xkr, xcm, xcr, xl, mass, iner, off, eint, rot1, rot2, dx, dy, dz, rx, ry, rz, igtyp, isens, x0_err)
Definition ruser33.F:46
xddl33i
subroutine xddl33i(nel, dx, fx, kx, ifun, kmx, fac_x)
Definition ruser33.F:383
xddl33
subroutine xddl33(nel, dx, fx, kx, ifun, kmx, fac_x)
Definition ruser33.F:343
sens_block
subroutine sens_block(nel, dx, fx, kx, knn, cr, crx, dxs, flag, kmx)
Definition ruser33.F:538
stdpl
subroutine stdpl(nel, dx, vx, fx, kx, knn, kf, cr, crx, dxmi, dxma, kmx, fm, frp, ifun, icomb, deq, fcomb, xcent, fac_x)
Definition ruser33.F:421
def_fdof
subroutine def_fdof(jtyp, fdof)
Definition ruser33.F:572
get_u_pid
integer function get_u_pid(ip)
Definition uaccess.F:626
get_u_pnu
integer function get_u_pnu(ivar, ip, k)
Definition uaccess.F:482
get_u_mid
integer function get_u_mid(im)
Definition uaccess.F:668
get_u_mnu
integer function get_u_mnu(ivar, im, k)
Definition uaccess.F:565