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
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C C o m m o n B l o c k s
64C-----------------------------------------------
65#include "param_c.inc"
66#include "units_c.inc"
67#include "scr17_c.inc"
68#include "com04_c.inc"
69#include "random_c.inc"
70#include "tabsiz_c.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER, INTENT(IN) :: ITABM1(NUMNOD),IXR(NIXR,NUMELR),ITAB(NUMNOD),FUNC_ID(NFUNCT),IPM(NPROPMI,NUMMAT)
75 INTEGER, INTENT(INOUT) :: NOM_OPT(LNOPT1,SNOM_OPT1)
76 my_real, INTENT(IN) :: alea(nrand)
77 my_real, INTENT(INOUT) :: x(3,numnod)
78 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
79 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
80C-----------------------------------------------
81C L o c a l V a r i a b l e s
82C-----------------------------------------------
83 INTEGER ,DIMENSION(NRETRACTOR) :: RET_ID
84 INTEGER :: I,J,K,ID, UID, NODE_ID, EL_ID, IERR1
85 INTEGER :: NODE1,NODE2,EL_LOC,BID,ISENS(2),IFUNC(3),IFUNC_LOC(3),TENS_TYP,MID,MTYP
86 my_real :: force,elem_size,dist1,dist2,dist3,pull,yscale1,xscale1,xscale1_unit,yscale1_unit
87 my_real :: yscale2,xscale2,xscale2_unit,yscale2_unit,xx,dxdy,get_u_func,alea_max,tole_2
88 CHARACTER(LEN=NCHARTITLE) :: TITR
89 CHARACTER(LEN=NCHARKEY) :: KEY2
90 CHARACTER :: MESS*40
91 LOGICAL :: IS_AVAILABLE
92 EXTERNAL get_u_func
93C-----------------------------------------------
94C E x t e r n a l F u n c t i o n s
95C-----------------------------------------------
96 INTEGER USR2SYS,NINTRI
97C=======================================================================
98 DATA mess/'RETRACTOR DEFINITION '/
99C-----------------------------------------------
100C S o u r c e L i n e s
101C-----------------------------------------------
102 ierr1 = 0
103C
104 IF(nretractor > 0 ) THEN
105C
106 WRITE(iout,1000)
107C
108 ALLOCATE(retractor(nretractor))
109 DO i=1,nretractor
110 retractor(i)%ID = 0
111 retractor(i)%IDG = 0
112 retractor(i)%UPDATE = 0
113 retractor(i)%ANCHOR_NODE = 0
114 retractor(i)%NODE = 0
115 retractor(i)%NODE_NEXT = 0
116 retractor(i)%STRAND_DIRECTION = 0
117 retractor(i)%IFUNC = 0
118 retractor(i)%ISENS = 0
119 retractor(i)%TENS_TYP = 0
120 retractor(i)%LOCKED = 0
121 retractor(i)%LOCKED_FREEZE = 0
122 retractor(i)%PRETENS_ACTIV = 0
123 retractor(i)%INACTI_NNOD = 0
124 retractor(i)%INACTI_NNOD_MAX = 0
125 retractor(i)%N_REMOTE_PROC=0
126 retractor(i)%VECTOR = zero
127 retractor(i)%ELEMENT_SIZE = zero
128 retractor(i)%FORCE = zero
129 retractor(i)%MATERIAL_FLOW = zero
130 retractor(i)%RESIDUAL_LENGTH = zero
131 retractor(i)%FAC = zero
132 retractor(i)%PULLOUT = zero
133 retractor(i)%UNLOCK_FORCE = zero
134 retractor(i)%LOCK_PULL = zero
135 retractor(i)%LOCK_PULL_SAV = zero
136 retractor(i)%LOCK_OFFSET = zero
137 retractor(i)%LOCK_YIELD_FORCE = zero
138 retractor(i)%RINGSLIP = zero
139 retractor(i)%PRETENS_TIME = zero
140 retractor(i)%PRETENS_PULL = zero
141 retractor(i)%PRETENS_PULLMAX = zero
142 retractor(i)%RET_FORCE = zero
143 ENDDO
144C
145 CALL hm_option_start('/RETRACTOR')
146
147 DO i = 1,nretractor
148 CALL hm_option_read_key(lsubmodel, option_titr = titr, option_id = id, unit_id = uid)
149C
150 nom_opt(1,i)=id
151 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
152C
153 CALL hm_get_intv('EL_ID', el_id, is_available, lsubmodel)
154 CALL hm_get_intv('Node_ID', node_id, is_available, lsubmodel)
155 CALL hm_get_floatv('Elem_size', elem_size, is_available, lsubmodel,unitab)
156C
157 CALL hm_get_intv('Sens_ID1', isens(1), is_available, lsubmodel)
158 CALL hm_get_floatv('Pullout', pull, is_available, lsubmodel,unitab)
159 CALL hm_get_intv('Fct_ID1', ifunc(1), is_available, lsubmodel)
160 CALL hm_get_intv('Fct_ID2', ifunc(2), is_available, lsubmodel)
161 CALL hm_get_floatv('Yscale1',yscale1,is_available,lsubmodel,unitab)
162 CALL hm_get_floatv('Xscale1',xscale1,is_available,lsubmodel,unitab)
163C
164 CALL hm_get_floatv_dim('Yscale1',yscale1_unit,is_available,lsubmodel,unitab)
165 CALL hm_get_floatv_dim('Xscale1',xscale1_unit,is_available,lsubmodel,unitab)
166C
167 CALL hm_get_intv('Sens_ID2', isens(2), is_available, lsubmodel)
168 CALL hm_get_intv('Tens_typ', tens_typ, is_available, lsubmodel)
169 CALL hm_get_floatv('Force', force, is_available, lsubmodel,unitab)
170 CALL hm_get_intv('Fct_ID3', ifunc(3), is_available, lsubmodel)
171 CALL hm_get_floatv('Yscale2',yscale2,is_available,lsubmodel,unitab)
172 CALL hm_get_floatv('Xscale2',xscale2,is_available,lsubmodel,unitab)
173C
174 CALL hm_get_floatv_dim('Yscale2',yscale2_unit,is_available,lsubmodel,unitab)
175 CALL hm_get_floatv_dim('Xscale2',xscale2_unit,is_available,lsubmodel,unitab)
176C
177 ret_id(i) = id
178C
179 IF (ifunc(1) > 0) THEN
180 IF (xscale1== zero) xscale1 = one*xscale1_unit
181 IF (yscale1== zero) yscale1 = one*yscale1_unit
182 ENDIF
183C
184 IF (ifunc(2) == 0) ifunc(2) = ifunc(1)
185C
186 IF (ifunc(3) > 0) THEN
187 IF (xscale2== zero) xscale2 = one*xscale2_unit
188 IF (yscale2== zero) yscale2 = one*yscale2_unit
189 ENDIF
190C
191 WRITE(iout,1100) id,trim(titr),el_id,node_id,elem_size,isens(1),pull,ifunc(1),ifunc(2),
192 . xscale1,yscale1
193C
194 IF (isens(2) > 0) WRITE(iout,1200) isens(2),tens_typ,force,ifunc(3),xscale2,yscale2
195C
196 IF (force == zero) force = ep30
197C
198 node_id = usr2sys(node_id,itabm1,mess,retractor(i)%ID)
199 el_loc=nintri(el_id,ixr,nixr,numelr,nixr)
200C
201 IF(el_loc == 0) THEN
202 CALL ancmsg(msgid=2008,
203 . msgtype=msgerror,
204 . anmode=aninfo_blind_1,
205 . i1=id,i2=el_id)
206 ELSE
207 mtyp = 0
208 mid = ixr(5,el_loc)
209 IF (mid > 0) mtyp = ipm(2,mid)
210 IF (mtyp /= 114) CALL ancmsg(msgid=2033,
211 . msgtype=msgerror,
212 . anmode=aninfo,
213 . i1=id,i2=el_id)
214 ENDIF
215C
216C---------Check of sensors is done in creat_seatblet as sensors are not yet available
217C
218C---------Check of functions
219C
220 ifunc_loc(1:3) = 0
221C
222 DO j=1,3
223 IF (ifunc(j) > 0) THEN
224 DO k=1,nfunct
225 IF (func_id(k) == ifunc(j)) ifunc_loc(j) = k
226 ENDDO
227 IF(ifunc_loc(j) == 0) CALL ancmsg(msgid=2028,
228 . msgtype=msgerror,
229 . anmode=aninfo_blind_1,
230 . c1='FUNCTION',
231 . i1=id,i2=ifunc(j))
232 ENDIF
233 ENDDO
234C
235 IF ((isens(1) > 0).AND.(ifunc(1)==0)) THEN
236C-- function is mandatory for locking if sensor1 is input
237 CALL ancmsg(msgid=2031,
238 . msgtype=msgerror,
239 . anmode=aninfo_blind_1,
240 . i1=id)
241 ENDIF
242C
243 IF ((isens(2) > 0).AND.(ifunc(3)==0)) THEN
244C-- function is mandatory for pretensionin if sensor2 is input
245 CALL ancmsg(msgid=2025,
246 . msgtype=msgerror,
247 . anmode=aninfo_blind_1,i1=id)
248 ENDIF
249C
250 retractor(i)%ID = id
251 retractor(i)%ANCHOR_NODE = node_id
252 retractor(i)%ELEMENT_SIZE = elem_size
253C
254 retractor(i)%ISENS(1) = isens(1)
255 retractor(i)%PULLOUT = pull
256 retractor(i)%IFUNC(1) = ifunc_loc(1)
257 retractor(i)%IFUNC(2) = ifunc_loc(2)
258 retractor(i)%FAC(1) = yscale1
259 retractor(i)%FAC(2) = xscale1
260C
261 retractor(i)%ISENS(2) = isens(2)
262 retractor(i)%TENS_TYP = tens_typ
263 retractor(i)%FORCE = force
264 retractor(i)%IFUNC(3) = ifunc_loc(3)
265 retractor(i)%FAC(3) = yscale2
266 retractor(i)%FAC(4) = xscale2
267C
268 IF (retractor(i)%IFUNC(1)==0) THEN
269 retractor(i)%UNLOCK_FORCE = retractor(i)%FAC(1)
270 ELSE
271C- Force in unlock state is the first point of the curve
272 xx = zero
273 retractor(i)%UNLOCK_FORCE = retractor(i)%FAC(1)*get_u_func(retractor(i)%IFUNC(1),xx,dxdy)
274 ENDIF
275C
276 node1 = ixr(2,el_loc)
277 node2 = ixr(3,el_loc)
278C
279 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
280 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
281C
282C-- default tolerance
283 tole_2 = em10*retractor(i)%ELEMENT_SIZE*retractor(i)%ELEMENT_SIZE
284C-- compatibility with random noise
285 IF (nrand > 0) THEN
286 alea_max = zero
287 DO j=1,nrand
288 alea_max = max(alea_max,alea(j))
289 ENDDO
290 tole_2 = max(tole_2,ten*alea_max*alea_max)
291 ENDIF
292C
293C-- tolerance if node is very close to anchorage node
294 IF ((dist1 < dist2).AND.(dist1 <= tole_2)) THEN
295 x(1,node1) = x(1,node_id)
296 x(2,node1) = x(2,node_id)
297 x(3,node1) = x(3,node_id)
298 dist1 = zero
299 ELSEIF (dist2 <= tole_2) THEN
300 x(1,node2) = x(1,node_id)
301 x(2,node2) = x(2,node_id)
302 x(3,node2) = x(3,node_id)
303 dist2 = zero
304 ENDIF
305C
306 dist3 = (x(1,node2)-x(1,node1))**2+(x(2,node2)-x(2,node1))**2+(x(3,node2)-x(3,node1))**2
307C
308 IF (dist1 < em30) THEN
309 retractor(i)%NODE(1) = node2
310 retractor(i)%NODE(2) = node1
311 IF (retractor(i)%ELEMENT_SIZE == zero) retractor(i)%ELEMENT_SIZE = dist2
312 retractor(i)%VECTOR(1) = (x(1,node2)-x(1,node1))/sqrt(max(em30,dist3))
313 retractor(i)%VECTOR(2) = (x(2,node2)-x(2,node1))/sqrt(max(em30,dist3))
314 retractor(i)%VECTOR(3) = (x(3,node2)-x(3,node1))/sqrt(max(em30,dist3))
315C-- retractor direction 2->1
316 retractor(i)%STRAND_DIRECTION = -1
317 ELSEIF (dist2 < em30) THEN
318 retractor(i)%NODE(1) = node1
319 retractor(i)%NODE(2) = node2
320 IF (retractor(i)%ELEMENT_SIZE == zero) retractor(i)%ELEMENT_SIZE = dist1
321 retractor(i)%VECTOR(1) = (x(1,node1)-x(1,node2))/sqrt(max(em30,dist3))
322 retractor(i)%VECTOR(2) = (x(2,node1)-x(2,node2))/sqrt(max(em30,dist3))
323 retractor(i)%VECTOR(3) = (x(3,node1)-x(3,node2))/sqrt(max(em30,dist3))
324C-- retractor direction 1->2
325 retractor(i)%STRAND_DIRECTION = 1
326 ELSE
327 CALL ancmsg(msgid=2009,
328 . msgtype=msgerror,
329 . anmode=aninfo_blind_1,
330 . i1=id)
331 ENDIF
332C
333 IF (dist3 < em30) THEN
334 CALL ancmsg(msgid=2022,
335 . msgtype=msgerror,
336 . anmode=aninfo_blind_1,
337 . i1=id)
338 ENDIF
339C
340 IF (retractor(i)%NODE(2) == retractor(i)%ANCHOR_NODE) THEN
341 CALL ancmsg(msgid=2030,
342 . msgtype=msgerror,
343 . anmode=aninfo_blind_1,
344 . i1=id,i2=itab(retractor(i)%ANCHOR_NODE))
345 ENDIF
346C
347 ENDDO
348C
349 ENDIF
350C
351 IF (ierr1 /= 0) THEN
352 WRITE(iout,*)' ** ERROR IN MEMORY ALLOCATION'
353 WRITE(istdo,*)' ** ERROR IN MEMORY ALLOCATION'
354 CALL arret(2)
355 ENDIF
356C
357C-------------------------------------
358C Recherche des ID doubles
359C-------------------------------------
360 CALL udouble(ret_id,1,nretractor,mess,0,bid)
361 RETURN
362C
3631000 FORMAT(/
364 . ' RETRACTOR/SPRING DEFINITIONS '/
365 . ' ---------------------- ')
3661100 FORMAT(/5x,'RETRACTOR ID ',i10,1x,a
367 . /5x,'CONNECTED SPRING ELEMENT . . . . . . . . .',i10
368 . /5x,'ANCHORAGE NODE . . . . . . . . . . . . . .',i10
369 . /5x,'ELEMENT SIZE . . . . . . . . . . . . . . .',1pg20.4
370 . /5x,'SENSOR ID1 . . . . . . . . . . . . . . . .',i10
371 . /5x,'PULLOUT BEFORE LOCKING . . . . . . . . . .',1pg20.4
372 . /5x,'FUNC1 - LOADING - FORCE VS PULLOUT . . . .',i10
373 . /5x,'FUNC2 - UNLOADING - FORCE VS PULLOUT . . .',i10
374 . /5x,'FUNC1/2 ABCISSA SCALE FACTOR . . . . . . .',1pg20.4
375 . /5x,'FUNC1/2 ORDINATE SCALE FACTOR. . . . . . .',1pg20.4)
3761200 FORMAT( 5x,'PRETENSION :'
377 . /5x,'SENSOR ID2 . . . . . . . . . . . . . . . .',i10
378 . /5x,'PRETENSION TYPE. . . . . . . . . . . . . .',i10
379 . /5x,'MAXIMUM FORCE. . . . . . . . . . . . . . .',1pg20.4
380 . /5x,'FUNC3. . . . . . . . . . . . . . . . . . .',i10
381 . /5x,'FUNC3 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
382 . /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:415
hm_get_floatv_dim
subroutine hm_get_floatv_dim(name, dim_fac, is_available, lsubmodel, unitab)
Definition hm_get_floatv_dim.F:159
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
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:712
unitab_mod
Definition unitab_mod.F:513
nintri
integer function nintri(iext, antn, m, n, m1)
Definition nintrr.F:46
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:889
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
arret
subroutine arret(nn)
Definition arret.F:87
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589