OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_retractor.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "random_c.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_retractor (lsubmodel, itabm1, ixr, itab, unitab, x, func_id, nom_opt, alea, ipm)

Function/Subroutine Documentation

◆ hm_read_retractor()

subroutine hm_read_retractor ( type(submodel_data), dimension(nsubmod), intent(in) lsubmodel,
integer, dimension(numnod), intent(in) itabm1,
integer, dimension(nixr,numelr), intent(in) ixr,
integer, dimension(numnod), intent(in) itab,
type (unit_type_), intent(in) unitab,
dimension(3,numnod), intent(inout) x,
integer, dimension(nfunct), intent(in) func_id,
integer, dimension(lnopt1,snom_opt1), intent(inout) nom_opt,
dimension(nrand), intent(in) alea,
integer, dimension(npropmi,nummat), intent(in) ipm )

Definition at line 45 of file hm_read_retractor.F.

47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE my_alloc_mod
51 USE message_mod
52 USE unitab_mod
53 USE seatbelt_mod
54 USE groupdef_mod
55 USE submodel_mod
56 USE hm_option_read_mod
57 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
58 use element_mod , only : nixr
59C-----------------------------------------------
60C I m p l i c i t T y p e s
61C-----------------------------------------------
62#include "implicit_f.inc"
63C-----------------------------------------------
64C C o m m o n B l o c k s
65C-----------------------------------------------
66#include "param_c.inc"
67#include "units_c.inc"
68#include "scr17_c.inc"
69#include "com04_c.inc"
70#include "random_c.inc"
71#include "tabsiz_c.inc"
72C-----------------------------------------------
73C D u m m y A r g u m e n t s
74C-----------------------------------------------
75 INTEGER, INTENT(IN) :: ITABM1(NUMNOD),IXR(NIXR,NUMELR),ITAB(NUMNOD),FUNC_ID(NFUNCT),IPM(NPROPMI,NUMMAT)
76 INTEGER, INTENT(INOUT) :: NOM_OPT(LNOPT1,SNOM_OPT1)
77 my_real, INTENT(IN) :: alea(nrand)
78 my_real, INTENT(INOUT) :: x(3,numnod)
79 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
80 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER ,DIMENSION(NRETRACTOR) :: RET_ID
85 INTEGER :: I,J,K,ID, UID, NODE_ID, EL_ID, IERR1
86 INTEGER :: NODE1,NODE2,EL_LOC,BID,ISENS(2),IFUNC(3),IFUNC_LOC(3),TENS_TYP,MID,MTYP
87 my_real :: force,elem_size,dist1,dist2,dist3,pull,yscale1,xscale1,xscale1_unit,yscale1_unit
88 my_real :: yscale2,xscale2,xscale2_unit,yscale2_unit,xx,dxdy,get_u_func,alea_max,tole_2
89 CHARACTER(LEN=NCHARTITLE) :: TITR
90 CHARACTER(LEN=NCHARKEY) :: KEY2
91 CHARACTER :: MESS*40
92 LOGICAL :: IS_AVAILABLE
93 EXTERNAL get_u_func
94C-----------------------------------------------
95C E x t e r n a l F u n c t i o n s
96C-----------------------------------------------
97 INTEGER USR2SYS,NINTRI
98C=======================================================================
99 DATA mess/'RETRACTOR DEFINITION '/
100C-----------------------------------------------
101C S o u r c e L i n e s
102C-----------------------------------------------
103 ierr1 = 0
104C
105 IF(nretractor > 0 ) THEN
106C
107 WRITE(iout,1000)
108C
109 ALLOCATE(retractor(nretractor))
110 DO i=1,nretractor
111 retractor(i)%ID = 0
112 retractor(i)%IDG = 0
113 retractor(i)%UPDATE = 0
114 retractor(i)%ANCHOR_NODE = 0
115 retractor(i)%NODE = 0
116 retractor(i)%NODE_NEXT = 0
117 retractor(i)%STRAND_DIRECTION = 0
118 retractor(i)%IFUNC = 0
119 retractor(i)%ISENS = 0
120 retractor(i)%TENS_TYP = 0
121 retractor(i)%LOCKED = 0
122 retractor(i)%LOCKED_FREEZE = 0
123 retractor(i)%PRETENS_ACTIV = 0
124 retractor(i)%INACTI_NNOD = 0
125 retractor(i)%INACTI_NNOD_MAX = 0
126 retractor(i)%N_REMOTE_PROC=0
127 retractor(i)%VECTOR = zero
128 retractor(i)%ELEMENT_SIZE = zero
129 retractor(i)%FORCE = zero
130 retractor(i)%MATERIAL_FLOW = zero
131 retractor(i)%RESIDUAL_LENGTH = zero
132 retractor(i)%FAC = zero
133 retractor(i)%PULLOUT = zero
134 retractor(i)%UNLOCK_FORCE = zero
135 retractor(i)%LOCK_PULL = zero
136 retractor(i)%LOCK_PULL_SAV = zero
137 retractor(i)%LOCK_OFFSET = zero
138 retractor(i)%LOCK_YIELD_FORCE = zero
139 retractor(i)%RINGSLIP = zero
140 retractor(i)%PRETENS_TIME = zero
141 retractor(i)%PRETENS_PULL = zero
142 retractor(i)%PRETENS_PULLMAX = zero
143 retractor(i)%RET_FORCE = zero
144 ENDDO
145C
146 CALL hm_option_start('/RETRACTOR')
147
148 DO i = 1,nretractor
149 CALL hm_option_read_key(lsubmodel, option_titr = titr, option_id = id, unit_id = uid)
150C
151 nom_opt(1,i)=id
152 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
153C
154 CALL hm_get_intv('EL_ID', el_id, is_available, lsubmodel)
155 CALL hm_get_intv('Node_ID', node_id, is_available, lsubmodel)
156 CALL hm_get_floatv('Elem_size', elem_size, is_available, lsubmodel,unitab)
157C
158 CALL hm_get_intv('Sens_ID1', isens(1), is_available, lsubmodel)
159 CALL hm_get_floatv('Pullout', pull, is_available, lsubmodel,unitab)
160 CALL hm_get_intv('Fct_ID1', ifunc(1), is_available, lsubmodel)
161 CALL hm_get_intv('Fct_ID2', ifunc(2), is_available, lsubmodel)
162 CALL hm_get_floatv('Yscale1',yscale1,is_available,lsubmodel,unitab)
163 CALL hm_get_floatv('Xscale1',xscale1,is_available,lsubmodel,unitab)
164C
165 CALL hm_get_floatv_dim('Yscale1',yscale1_unit,is_available,lsubmodel,unitab)
166 CALL hm_get_floatv_dim('Xscale1',xscale1_unit,is_available,lsubmodel,unitab)
167C
168 CALL hm_get_intv('Sens_ID2', isens(2), is_available, lsubmodel)
169 CALL hm_get_intv('Tens_typ', tens_typ, is_available, lsubmodel)
170 CALL hm_get_floatv('Force', force, is_available, lsubmodel,unitab)
171 CALL hm_get_intv('Fct_ID3', ifunc(3), is_available, lsubmodel)
172 CALL hm_get_floatv('Yscale2',yscale2,is_available,lsubmodel,unitab)
173 CALL hm_get_floatv('Xscale2',xscale2,is_available,lsubmodel,unitab)
174C
175 CALL hm_get_floatv_dim('Yscale2',yscale2_unit,is_available,lsubmodel,unitab)
176 CALL hm_get_floatv_dim('Xscale2',xscale2_unit,is_available,lsubmodel,unitab)
177C
178 ret_id(i) = id
179C
180 IF (ifunc(1) > 0) THEN
181 IF (xscale1== zero) xscale1 = one*xscale1_unit
182 IF (yscale1== zero) yscale1 = one*yscale1_unit
183 ENDIF
184C
185 IF (ifunc(2) == 0) ifunc(2) = ifunc(1)
186C
187 IF (ifunc(3) > 0) THEN
188 IF (xscale2== zero) xscale2 = one*xscale2_unit
189 IF (yscale2== zero) yscale2 = one*yscale2_unit
190 ENDIF
191C
192 WRITE(iout,1100) id,trim(titr),el_id,node_id,elem_size,isens(1),pull,ifunc(1),ifunc(2),
193 . xscale1,yscale1
194C
195 IF (isens(2) > 0) WRITE(iout,1200) isens(2),tens_typ,force,ifunc(3),xscale2,yscale2
196C
197 IF (force == zero) force = ep30
198C
199 node_id = usr2sys(node_id,itabm1,mess,retractor(i)%ID)
200 el_loc=nintri(el_id,ixr,nixr,numelr,nixr)
201C
202 IF(el_loc == 0) THEN
203 CALL ancmsg(msgid=2008,
204 . msgtype=msgerror,
205 . anmode=aninfo_blind_1,
206 . i1=id,i2=el_id)
207 ELSE
208 mtyp = 0
209 mid = ixr(5,el_loc)
210 IF (mid > 0) mtyp = ipm(2,mid)
211 IF (mtyp /= 114) CALL ancmsg(msgid=2033,
212 . msgtype=msgerror,
213 . anmode=aninfo,
214 . i1=id,i2=el_id)
215 ENDIF
216C
217C---------Check of sensors is done in creat_seatblet as sensors are not yet available
218C
219C---------Check of functions
220C
221 ifunc_loc(1:3) = 0
222C
223 DO j=1,3
224 IF (ifunc(j) > 0) THEN
225 DO k=1,nfunct
226 IF (func_id(k) == ifunc(j)) ifunc_loc(j) = k
227 ENDDO
228 IF(ifunc_loc(j) == 0) CALL ancmsg(msgid=2028,
229 . msgtype=msgerror,
230 . anmode=aninfo_blind_1,
231 . c1='FUNCTION',
232 . i1=id,i2=ifunc(j))
233 ENDIF
234 ENDDO
235C
236 IF ((isens(1) > 0).AND.(ifunc(1)==0)) THEN
237C-- function is mandatory for locking if sensor1 is input
238 CALL ancmsg(msgid=2031,
239 . msgtype=msgerror,
240 . anmode=aninfo_blind_1,
241 . i1=id)
242 ENDIF
243C
244 IF ((isens(2) > 0).AND.(ifunc(3)==0)) THEN
245C-- function is mandatory for pretensionin if sensor2 is input
246 CALL ancmsg(msgid=2025,
247 . msgtype=msgerror,
248 . anmode=aninfo_blind_1,i1=id)
249 ENDIF
250C
251 retractor(i)%ID = id
252 retractor(i)%ANCHOR_NODE = node_id
253 retractor(i)%ELEMENT_SIZE = elem_size
254C
255 retractor(i)%ISENS(1) = isens(1)
256 retractor(i)%PULLOUT = pull
257 retractor(i)%IFUNC(1) = ifunc_loc(1)
258 retractor(i)%IFUNC(2) = ifunc_loc(2)
259 retractor(i)%FAC(1) = yscale1
260 retractor(i)%FAC(2) = xscale1
261C
262 retractor(i)%ISENS(2) = isens(2)
263 retractor(i)%TENS_TYP = tens_typ
264 retractor(i)%FORCE = force
265 retractor(i)%IFUNC(3) = ifunc_loc(3)
266 retractor(i)%FAC(3) = yscale2
267 retractor(i)%FAC(4) = xscale2
268C
269 IF (retractor(i)%IFUNC(1)==0) THEN
270 retractor(i)%UNLOCK_FORCE = retractor(i)%FAC(1)
271 ELSE
272C- Force in unlock state is the first point of the curve
273 xx = zero
274 retractor(i)%UNLOCK_FORCE = retractor(i)%FAC(1)*get_u_func(retractor(i)%IFUNC(1),xx,dxdy)
275 ENDIF
276C
277 node1 = ixr(2,el_loc)
278 node2 = ixr(3,el_loc)
279C
280 dist1 = (x(1,node1)-x(1,node_id))**2+(x(2,node1)-x(2,node_id))**2+(x(3,node1)-x(3,node_id))**2
281 dist2 = (x(1,node2)-x(1,node_id))**2+(x(2,node2)-x(2,node_id))**2+(x(3,node2)-x(3,node_id))**2
282C
283C-- default tolerance
284 tole_2 = em10*retractor(i)%ELEMENT_SIZE*retractor(i)%ELEMENT_SIZE
285C-- compatibility with random noise
286 IF (nrand > 0) THEN
287 alea_max = zero
288 DO j=1,nrand
289 alea_max = max(alea_max,alea(j))
290 ENDDO
291 tole_2 = max(tole_2,ten*alea_max*alea_max)
292 ENDIF
293C
294C-- tolerance if node is very close to anchorage node
295 IF ((dist1 < dist2).AND.(dist1 <= tole_2)) THEN
296 x(1,node1) = x(1,node_id)
297 x(2,node1) = x(2,node_id)
298 x(3,node1) = x(3,node_id)
299 dist1 = zero
300 ELSEIF (dist2 <= tole_2) THEN
301 x(1,node2) = x(1,node_id)
302 x(2,node2) = x(2,node_id)
303 x(3,node2) = x(3,node_id)
304 dist2 = zero
305 ENDIF
306C
307 dist3 = (x(1,node2)-x(1,node1))**2+(x(2,node2)-x(2,node1))**2+(x(3,node2)-x(3,node1))**2
308C
309 IF (dist1 < em30) THEN
310 retractor(i)%NODE(1) = node2
311 retractor(i)%NODE(2) = node1
312 IF (retractor(i)%ELEMENT_SIZE == zero) retractor(i)%ELEMENT_SIZE = dist2
313 retractor(i)%VECTOR(1) = (x(1,node2)-x(1,node1))/sqrt(max(em30,dist3))
314 retractor(i)%VECTOR(2) = (x(2,node2)-x(2,node1))/sqrt(max(em30,dist3))
315 retractor(i)%VECTOR(3) = (x(3,node2)-x(3,node1))/sqrt(max(em30,dist3))
316C-- retractor direction 2->1
317 retractor(i)%STRAND_DIRECTION = -1
318 ELSEIF (dist2 < em30) THEN
319 retractor(i)%NODE(1) = node1
320 retractor(i)%NODE(2) = node2
321 IF (retractor(i)%ELEMENT_SIZE == zero) retractor(i)%ELEMENT_SIZE = dist1
322 retractor(i)%VECTOR(1) = (x(1,node1)-x(1,node2))/sqrt(max(em30,dist3))
323 retractor(i)%VECTOR(2) = (x(2,node1)-x(2,node2))/sqrt(max(em30,dist3))
324 retractor(i)%VECTOR(3) = (x(3,node1)-x(3,node2))/sqrt(max(em30,dist3))
325C-- retractor direction 1->2
326 retractor(i)%STRAND_DIRECTION = 1
327 ELSE
328 CALL ancmsg(msgid=2009,
329 . msgtype=msgerror,
330 . anmode=aninfo_blind_1,
331 . i1=id)
332 ENDIF
333C
334 IF (dist3 < em30) THEN
335 CALL ancmsg(msgid=2022,
336 . msgtype=msgerror,
337 . anmode=aninfo_blind_1,
338 . i1=id)
339 ENDIF
340C
341 IF (retractor(i)%NODE(2) == retractor(i)%ANCHOR_NODE) THEN
342 CALL ancmsg(msgid=2030,
343 . msgtype=msgerror,
344 . anmode=aninfo_blind_1,
345 . i1=id,i2=itab(retractor(i)%ANCHOR_NODE))
346 ENDIF
347C
348 ENDDO
349C
350 ENDIF
351C
352 IF (ierr1 /= 0) THEN
353 WRITE(iout,*)' ** ERROR IN MEMORY ALLOCATION'
354 WRITE(istdo,*)' ** error in memory allocation'
355 CALL ARRET(2)
356 ENDIF
357C
358C-------------------------------------
359C search for duplicate ids
360C-------------------------------------
361 CALL UDOUBLE(RET_ID,1,NRETRACTOR,MESS,0,BID)
362 RETURN
363C
3641000 FORMAT(/
365 . ' retractor/spring definitions '/
366 . ' ---------------------- ')
3671100 FORMAT(/5X,'retractor id ',I10,1X,A
368 . /5X,'connected spring element . . . . . . . . .',I10
369 . /5X,'anchorage node . . . . . . . . . . . . . .',I10
370 . /5X,'element SIZE . . . . . . . . . . . . . . .',1PG20.4
371 . /5X,'sensor id1 . . . . . . . . . . . . . . . .',I10
372 . /5X,'pullout before locking . . . . . . . . . .',1PG20.4
373 . /5X,'func1 - loading - force vs pullout . . . .',I10
374 . /5X,'func2 - unloading - force vs pullout . . .',I10
375 . /5X,'func1/2 abcissa scale factor . . . . . . .',1PG20.4
376 . /5X,'func1/2 ordinate scale factor. . . . . . .',1PG20.4)
3771200 FORMAT( 5X,'pretension :'
378 . /5X,'sensor id2 . . . . . . . . . . . . . . . .',I10
379 . /5X,'pretension type. . . . . . . . . . . . . .',I10
380 . /5X,'maximum force. . . . . . . . . . . . . . .',1PG20.4
381 . /5X,'func3. . . . . . . . . . . . . . . . . . .',I10
382 . /5X,'func3 abcissa scale factor . . . . . . . .',1PG20.4
383 . /5X,'func3 ordinate scale factor . . . . . . .',1PG20.4)
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
hm_get_floatv_dim
subroutine hm_get_floatv_dim(name, dim_fac, is_available, lsubmodel, unitab)
Definition hm_get_floatv_dim.F:161
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
seatbelt_mod
Definition seatbelt_mod.F:55
seatbelt_mod::retractor
type(retractor_struct), dimension(:), allocatable retractor
Definition seatbelt_mod.F:155
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
nintri
integer function nintri(iext, antn, m, n, m1)
Definition nintrr.F:45
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:146