OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
joint_block_stiffness.F File Reference
#include "implicit_f.inc"
#include "com08_c.inc"
#include "com01_c.inc"
#include "param_c.inc"
#include "scr02_c.inc"
#include "scr17_c.inc"
#include "scr18_c.inc"
#include "cong2_c.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine joint_block_stiffness (itab, ms, in, stifn, stifr, weight, ixr, ipart, x, ipartr, igeo, geo, npby, iparg, elbuf_tab, dmas, diner)

Function/Subroutine Documentation

◆ joint_block_stiffness()

subroutine joint_block_stiffness ( integer, dimension(*) itab,
ms,
in,
stifn,
stifr,
integer, dimension(*) weight,
integer, dimension(nixr,*) ixr,
integer, dimension(lipart1,*) ipart,
x,
integer, dimension(*) ipartr,
integer, dimension(npropgi,*) igeo,
geo,
integer, dimension(nnpby,*) npby,
integer, dimension(nparg,*) iparg,
type(elbuf_struct_), dimension(ngroup), target elbuf_tab,
dmas,
diner )

Definition at line 33 of file joint_block_stiffness.F.

36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE elbufdef_mod
40 use element_mod , only : nixr
41C----6---------------------------------------------------------------7---------8
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44#include "implicit_f.inc"
45C-----------------------------------------------
46C G l o b a l P a r a m e t e r s
47C-----------------------------------------------
48#include "com08_c.inc"
49#include "com01_c.inc"
50#include "param_c.inc"
51#include "scr02_c.inc"
52#include "scr17_c.inc"
53#include "scr18_c.inc"
54#include "cong2_c.inc"
55#include "units_c.inc"
56C-----------------------------------------------------------------
57C D u m m y A r g u m e n t s
58C-----------------------------------------------
59 INTEGER ITAB(*),WEIGHT(*),IXR(NIXR,*),
60 . IPART(LIPART1,*),IPARTR(*),IGEO(NPROPGI,*),NPBY(NNPBY,*),
61 . IPARG(NPARG,*)
62C REAL
63 my_real stifn(*), stifr(*),ms(*) ,in(*),x(3,*),
64 . dmas,diner,geo(npropg,*)
65C
66 TYPE(ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I,J,M1,M2,IG,IGTYP,N1,N2,ITYP,NG,JFT,JLT,NEL,
71 . FLAG,NFT,NUVAR,JNTYP,IRB1,IRB2,FLAG_S,FLAG_PR,NV
72 my_real iner1,iner2,km1,krm1,km2,krm2,xx,kx1,kx2,kr1,dtc,alpha,
73 . xl,kxmax,krmax,kx,kr,scf,get_u_geo,
74 . xx1,xx2,dta,mass1,mass2
75 CHARACTER(LEN=30) :: INFO_MESSAGE
76C
77 TYPE(G_BUFEL_),POINTER :: GBUF
78C-----------------------------------------------
79 EXTERNAL get_u_geo
80C----------------------------------------------------------
81
82 flag_pr = 0
83
84 dtc = dt2
85 dta = dtmin1(11)
86
87 IF (tt==0) THEN
88C----------------------------------------------------------
89 IF (nodadt>0) THEN
90 dtc = max(dtc,dtmin1(11)/dtfac1(11))
91 IF (dtmx>em20) dtc = min(dtc,dtmx)
92 ENDIF
93
94 IF (dtc>90000) THEN
95 IF (dta==0) THEN
96 print *,"ERROR NO TARGET TIME STEP DT=",dtc
97 print *,"STIFFNESS CAN NOT BE COMPUTED"
98 CALL arret(2)
99 ELSE
100 dtc = dta
101 ENDIF
102 ENDIF
103
104 alpha = 4.1
105
106 DO ng=1,ngroup
107 ityp = iparg(5,ng)
108 nel = iparg(2,ng)
109 nft = iparg(3,ng)
110 jft = 1
111 jlt = min(nvsiz,nel)
112 gbuf => elbuf_tab(ng)%GBUF
113 IF (ityp /= 6) GOTO 250
114C--------> Loop over spring elements -------
115 DO i=jft,jlt
116 j = i + nft
117 ig = ipart(2,ipartr(j))
118 igtyp = igeo(11,ig)
119 nuvar = nint(geo(25,ig))
120 nv = nuvar*(i-1) + 1
121 IF (igtyp==45) THEN
122 scf = get_u_geo(11,ig)
123 jntyp = nint(get_u_geo(1,ig))
124 flag = nint(get_u_geo(10,ig))
125 flag_s = 0
126 IF (flag==0) THEN
127C
128 n1 = ixr(2,j)
129 n2 = ixr(3,j)
130C
131 irb1 = nint(gbuf%VAR(nv + 37))
132 IF (irb1 > 0) THEN
133 m1 = npby(1,irb1)
134 ELSE
135 m1 = n1
136 ENDIF
137C
138 irb2 = nint(gbuf%VAR(nv + 38))
139 IF (irb2 > 0) THEN
140 m2 = npby(1,irb2)
141 ELSE
142 m2 = n2
143 ENDIF
144C
145 xl = ((x(1,n1)-x(1,n2))**2)+((x(2,n1)-x(2,n2))**2)
146 . +((x(3,n1)-x(3,n2))**2)
147 xx1 = ((x(1,n1)-x(1,m1))**2)+((x(2,n1)-x(2,m1))**2)
148 . +((x(3,n1)-x(3,m1))**2)
149 xx2 = ((x(1,n2)-x(1,m2))**2)+((x(2,n2)-x(2,m2))**2)
150 . +((x(3,n2)-x(3,m2))**2)
151 xx = max(xx1,xx2)
152C
153C--------> Stiffness calculation node 1 side -------
154 mass1 = ms(m1)
155 iner1 = in(m1)
156 km1 = stifn(m1)
157 krm1 = stifr(m1)
158C
159 kx1 = (2*mass1/(alpha*dtc*dtc)) - km1
160 IF (iner1 > zero) THEN
161 kx2 = 0.8*(iner1/(alpha*dtc*dtc)- krm1)/(max(em20,(xx+xl)))
162 kr = iner1/(alpha*dtc*dtc)- krm1
163 ELSE
164 kx2 = ep30
165 kr = zero
166 ENDIF
167 kxmax = min(kx1,kx2)
168C
169C--------> Stiffness calculation node 2 side -------
170 mass2 = ms(m2)
171 iner2 = in(m2)
172 km2 = stifn(m2)
173 krm2 = stifr(m2)
174C
175 kx1 = (2*mass2/(alpha*dtc*dtc)) - km2
176 IF (iner2 > zero) THEN
177 kx2 = 0.8*(iner2/(alpha*dtc*dtc)- krm2)/(max(em20,(xx+xl)))
178 kr1 = iner2/(alpha*dtc*dtc)- krm2
179 ELSE
180 kx2 = ep30
181 kr1 = zero
182 ENDIF
183C
184 kxmax = min(kx1,kx2,kxmax)
185 kr = min(kr,kr1)
186
187C--------> Final stiffness calculation and assignment-------
188 kx = max(kxmax,2*km1,2*km2)
189 IF ((kx - kxmax)>1e-8) flag_s = 1
190 IF ((iner1 == zero).OR.(iner2 == zero)) THEN
191C-- Rotational stiffness set to zero if kjoint attached to a solid node --
192 kr = zero
193 krmax = kr
194 flag_s = 0
195 ELSE
196 krmax = kr
197 kr = max(kr,2*krm1,2*krm2)
198 ENDIF
199C
200 info_message = ''
201 IF ((kx-kxmax)>1e-8 .OR. (kr-krmax)>1e-8) THEN
202 IF ((irb1 > 0).AND.(irb2 > 0)) THEN
203 info_message = '(FROM RIGID BODIES)'
204 ELSE
205 info_message = '(FROM CONNECTED STRUCTURES)'
206 ENDIF
207 ENDIF
208C
209 IF (flag_s==1) THEN
210 kr = max(kr,1.3*kx*(xx+xl))
211 ENDIF
212C
213 kx = scf*kx
214 kr = scf*kr
215C
216 WRITE(iout,'(I10,I10,8X,1PE11.4,8X,1PE11.4,1X,A)')
217 . ixr(nixr,j),jntyp,kx,kr,info_message
218C
219 gbuf%VAR(nv + 16) = kx
220 gbuf%VAR(nv + 17) = kr
221
222C--------> Spherical Joint-------
223 IF (jntyp==1) THEN
224 gbuf%VAR(nv + 18) = kx
225 gbuf%VAR(nv + 19) = kx
226 gbuf%VAR(nv + 20) = kx
227C--------> Revolutional Joint-------
228 ELSEIF (jntyp==2) THEN
229 gbuf%VAR(nv + 18) = kx
230 gbuf%VAR(nv + 19) = kx
231 gbuf%VAR(nv + 20) = kx
232 gbuf%VAR(nv + 31) = kr
233 gbuf%VAR(nv + 32) = kr
234C--------> Cylindrical Joint-------
235 ELSEIF (jntyp==3) THEN
236 gbuf%VAR(nv + 19) = kx
237 gbuf%VAR(nv + 20) = kx
238 gbuf%VAR(nv + 31) = kr
239 gbuf%VAR(nv + 32) = kr
240C--------> Planar Joint-------
241 ELSEIF (jntyp==4) THEN
242 gbuf%VAR(nv + 18) = kx
243 gbuf%VAR(nv + 31) = kr
244 gbuf%VAR(nv + 32) = kr
245C--------> Universal Joint-------
246 ELSEIF (jntyp==5) THEN
247 gbuf%VAR(nv + 18) = kx
248 gbuf%VAR(nv + 19) = kx
249 gbuf%VAR(nv + 20) = kx
250 gbuf%VAR(nv + 30) = kr
251C--------> Translational Joint-------
252 ELSEIF (jntyp==6) THEN
253 gbuf%VAR(nv + 19) = kx
254 gbuf%VAR(nv + 20) = kx
255 gbuf%VAR(nv + 30) = kr
256 gbuf%VAR(nv + 31) = kr
257 gbuf%VAR(nv + 32) = kr
258C--------> Oldham Joint-------
259 ELSEIF (jntyp==7) THEN
260 gbuf%VAR(nv + 18) = kx
261 gbuf%VAR(nv + 30) = kr
262 gbuf%VAR(nv + 31) = kr
263 gbuf%VAR(nv + 32) = kr
264C--------> Rigid Joint-------
265 ELSEIF (jntyp==8) THEN
266 gbuf%VAR(nv + 18) = kx
267 gbuf%VAR(nv + 19) = kx
268 gbuf%VAR(nv + 20) = kx
269 gbuf%VAR(nv + 30) = kr
270 gbuf%VAR(nv + 31) = kr
271 gbuf%VAR(nv + 32) = kr
272 ENDIF ! IF (JNTYP)
273C
274 ENDIF ! IF (FLAG==0)
275 ENDIF ! IF (IGTYP==45)
276C
277 ENDDO
278250 CONTINUE
279 ENDDO
280
281C----------------------------------------------------------
282
283 ENDIF
284C
285 RETURN
286C
my_real
#define my_real
Definition cppsort.cpp:32
alpha
#define alpha
Definition eval.h:35
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
arret
subroutine arret(nn)
Definition arret.F:86