OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_slipring.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_slipring (lsubmodel, itabm1, ixr, itab, unitab, x, func_id, nom_opt, alea, igrnod, igrsh4n, ixc, ipm)

Function/Subroutine Documentation

◆ hm_read_slipring()

subroutine hm_read_slipring ( 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,
type (group_), dimension(ngrnod), target igrnod,
type (group_), dimension(ngrshel), target igrsh4n,
integer, dimension(nixc,numelc), intent(in) ixc,
integer, dimension(npropmi,nummat), intent(in) ipm )

Definition at line 45 of file hm_read_slipring.F.

48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE my_alloc_mod
52 USE message_mod
53 USE unitab_mod
54 USE seatbelt_mod
55 USE groupdef_mod
56 USE submodel_mod
57 USE hm_option_read_mod
58 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
59 use element_mod , only : nixc,nixr
60C-----------------------------------------------
61C I m p l i c i t T y p e s
62C-----------------------------------------------
63#include "implicit_f.inc"
64C-----------------------------------------------
65C C o m m o n B l o c k s
66C-----------------------------------------------
67#include "param_c.inc"
68#include "units_c.inc"
69#include "scr17_c.inc"
70#include "com04_c.inc"
71#include "random_c.inc"
72#include "tabsiz_c.inc"
73C-----------------------------------------------
74C D u m m y A r g u m e n t s
75C-----------------------------------------------
76 INTEGER, INTENT(IN) :: ITABM1(NUMNOD),IXR(NIXR,NUMELR),IXC(NIXC,NUMELC),ITAB(NUMNOD),FUNC_ID(NFUNCT),IPM(NPROPMI,NUMMAT)
77 INTEGER, INTENT(INOUT) :: NOM_OPT(LNOPT1,SNOM_OPT1)
78 my_real, INTENT(IN) :: alea(nrand)
79 my_real, INTENT(INOUT) :: x(3,numnod)
80 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
81 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
82 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
83 TYPE (GROUP_) ,TARGET, DIMENSION(NGRSHEL) :: IGRSH4N
84C-----------------------------------------------
85C L o c a l V a r i a b l e s
86C-----------------------------------------------
87 INTEGER ,DIMENSION(NSLIPRING) :: SLIP_ID
88 INTEGER :: I,J,K,L,ID, UID, NODE_ID, EL1, EL2, IERR1, NODE_ID2
89 INTEGER :: NODE1,NODE2,NODE3,NODE4,EL1_LOC,EL2_LOC,BID,ISENS,FLOW_FLAG
90 INTEGER :: IFUNC(4),IFUNC_LOC(4),NFRAM,ISHELL,GR_NOD,GR_SHEL1,GR_SHEL2,GRN_LOC,GRS1_LOC,GRS2_LOC
91 INTEGER :: N_FIRST,N_LAST,NJ,NODE,IPOS,IERROR,NJ_NEXT,MID,MTYP
92 INTEGER , DIMENSION(:), ALLOCATABLE:: TAGNO,ELEM1_NOD,ELEM2_NOD,CORES1,CORES2,IPOS1_NOD,IPOS2_NOD,JPERM
93 INTEGER :: SIZE_COM_NOD,CPT_COM_NOD
94 INTEGER , DIMENSION(:), ALLOCATABLE:: COM_NOD
95 my_real :: distn,dist1,dist2,dist3,a,ed_factor,fricd,xscale1,yscale2,xscale2,frics,xscale3,yscale4,xscale4
96 my_real :: xscale1_unit,xscale2_unit,nn(3),norm,n1(3),n2(3),n3(3),scal,alea_max,tole_2,normj
97 my_real :: dist_min,vect(3),vectj(3)
98 my_real , DIMENSION(:), ALLOCATABLE:: dist
99 CHARACTER(LEN=NCHARTITLE) :: TITR
100 CHARACTER(LEN=NCHARKEY) :: KEY
101 CHARACTER MESS*40
102 INTEGER, DIMENSION(:), POINTER :: INGR2USR
103!
104 LOGICAL :: IS_AVAILABLE
105C-----------------------------------------------
106C E x t e r n a l F u n c t i o n s
107C-----------------------------------------------
108 INTEGER USR2SYS,NINTRI,NGR2USR
109C=======================================================================
110 DATA mess/'SLIPRING DEFINITION '/
111C-----------------------------------------------
112C S o u r c e L i n e s
113C-----------------------------------------------
114 ierr1 = 0
115C
116 IF(nslipring > 0 ) THEN
117 node1 = 0
118C
119 WRITE(iout,1000)
120C
121 ALLOCATE(slipring(nslipring))
122 DO i=1,nslipring
123 slipring(i)%ID = 0
124 slipring(i)%IDG = 0
125 slipring(i)%NFRAM = 0
126 slipring(i)%IFUNC = 0
127 slipring(i)%SENSID = 0
128 slipring(i)%FL_FLAG = 0
129 slipring(i)%RBODY = 0
130 slipring(i)%A = zero
131 slipring(i)%DC = zero
132 slipring(i)%FRIC = zero
133 slipring(i)%FAC_D = zero
134 slipring(i)%FRICS = zero
135 slipring(i)%FAC_S = zero
136 ENDDO
137C
138 CALL hm_option_start('/SLIPRING')
139C
140 DO i = 1,nslipring
141C
142 CALL hm_option_read_key(lsubmodel,option_titr=titr,option_id=id,unit_id=uid,keyword2=key)
143C
144 nom_opt(1,i)=id
145 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
146C
147 CALL hm_get_intv('Sens_ID', isens, is_available, lsubmodel)
148 CALL hm_get_intv('Flow_flag', flow_flag, is_available, lsubmodel)
149 CALL hm_get_floatv('A',a,is_available,lsubmodel,unitab)
150 CALL hm_get_floatv('Ed_factor',ed_factor,is_available,lsubmodel,unitab)
151C
152 CALL hm_get_intv('Fct_ID1', ifunc(1), is_available, lsubmodel)
153 CALL hm_get_intv('Fct_ID2', ifunc(2), is_available, lsubmodel)
154 CALL hm_get_floatv('Fricd',fricd,is_available,lsubmodel,unitab)
155 CALL hm_get_floatv('Xscale1',xscale1,is_available,lsubmodel,unitab)
156 CALL hm_get_floatv('Yscale2',yscale2,is_available,lsubmodel,unitab)
157 CALL hm_get_floatv('Xscale2',xscale2,is_available,lsubmodel,unitab)
158C
159 CALL hm_get_intv('Fct_ID3', ifunc(3), is_available, lsubmodel)
160 CALL hm_get_intv('Fct_ID4', ifunc(4), is_available, lsubmodel)
161 CALL hm_get_floatv('Frics',frics,is_available,lsubmodel,unitab)
162 CALL hm_get_floatv('Xscale3',xscale3,is_available,lsubmodel,unitab)
163 CALL hm_get_floatv('Yscale4',yscale4,is_available,lsubmodel,unitab)
164 CALL hm_get_floatv('Xscale4',xscale4,is_available,lsubmodel,unitab)
165C
166 CALL hm_get_floatv_dim('Xscale1',xscale1_unit,is_available,lsubmodel,unitab)
167 CALL hm_get_floatv_dim('Xscale2',xscale2_unit,is_available,lsubmodel,unitab)
168C
169 slip_id(i) = id
170C
171 IF (ifunc(1) > 0) THEN
172 IF (fricd== zero) fricd = one
173 IF (xscale1== zero) xscale1 = one*xscale1_unit
174 ENDIF
175C
176 IF (ifunc(2) > 0) THEN
177 IF (yscale2== zero) yscale2 = one
178 IF (xscale2== zero) xscale2 = one*xscale2_unit
179 ENDIF
180C
181 IF (ifunc(3) > 0) THEN
182 IF (frics== zero) frics = one
183 IF (xscale3== zero) xscale3 = one*xscale1_unit
184 ENDIF
185C
186 IF (ifunc(4) > 0) THEN
187 IF (yscale4== zero) yscale4 = one
188 IF (xscale4== zero) xscale4 = one*xscale2_unit
189 ENDIF
190C
191C---------Check of sensors is done in creat_seatblet as sensors are not yet available
192C
193C---------Check of functions
194C
195 ifunc_loc(1:4) = 0
196C
197 DO j=1,4
198 IF (ifunc(j) > 0) THEN
199 DO k=1,nfunct
200 IF (func_id(k) == ifunc(j)) ifunc_loc(j) = k
201 ENDDO
202 IF(ifunc_loc(j) == 0) CALL ancmsg(msgid=2002,
203 . msgtype=msgerror,
204 . anmode=aninfo_blind_1,
205 . c1='FUNCTION',
206 . i1=id,i2=ifunc(j))
207 ENDIF
208 ENDDO
209C
210 slipring(i)%ID = id
211 slipring(i)%SENSID = isens
212 slipring(i)%FL_FLAG = flow_flag
213C
214 slipring(i)%IFUNC(1) = ifunc_loc(1)
215 slipring(i)%IFUNC(2) = ifunc_loc(2)
216 slipring(i)%IFUNC(3) = ifunc_loc(3)
217 slipring(i)%IFUNC(4) = ifunc_loc(4)
218C
219 slipring(i)%DC = ed_factor
220 slipring(i)%A = a
221C
222 slipring(i)%FRIC = fricd
223 slipring(i)%FAC_D(1) = xscale1
224 slipring(i)%FAC_D(2) = xscale2
225 slipring(i)%FAC_D(3) = yscale2
226 slipring(i)%FRICS = frics
227 slipring(i)%FAC_S(1) = xscale3
228 slipring(i)%FAC_S(2) = xscale4
229 slipring(i)%FAC_S(3) = yscale4
230C
231 IF (key(1:6)=='SPRING') THEN
232C
233C---------- SLIPRING/SPRING------------------------------------------------------------------
234C
235 CALL hm_get_intv('EL_ID1', el1, is_available, lsubmodel)
236 CALL hm_get_intv('EL_ID2', el2, is_available, lsubmodel)
237 CALL hm_get_intv('Node_ID', node_id, is_available, lsubmodel)
238 CALL hm_get_intv('Node_ID2', node_id2, is_available, lsubmodel)
239C
240 WRITE(iout,1100) id,trim(titr),el1,el2,node_id,node_id2,isens,flow_flag,a,ed_factor,
241 . ifunc(1),ifunc(2),fricd,xscale1,yscale2,xscale2,
242 . ifunc(3),ifunc(4),frics,xscale3,yscale4,xscale4
243C
244C
245 el1_loc=nintri(el1,ixr,nixr,numelr,nixr)
246 el2_loc=nintri(el2,ixr,nixr,numelr,nixr)
247C
248 IF(el1_loc == 0) THEN
249 CALL ancmsg(msgid=2002,
250 . msgtype=msgerror,
251 . anmode=aninfo_blind_1,
252 . c1='SPRING ELEMENT',i1=id,i2=el1)
253 ELSE
254 mtyp = 0
255 mid = ixr(5,el1_loc)
256 IF (mid > 0) mtyp = ipm(2,mid)
257 IF (mtyp /= 114) CALL ancmsg(msgid=2032,
258 . msgtype=msgerror,
259 . anmode=aninfo,
260 . i1=id,i2=el1)
261 ENDIF
262C
263 IF(el2_loc == 0) THEN
264 CALL ancmsg(msgid=2002,
265 . msgtype=msgerror,
266 . anmode=aninfo_blind_1,
267 . c1='SPRING ELEMENT',i1=id,i2=el2)
268 ELSE
269 mtyp = 0
270 mid = ixr(5,el1_loc)
271 IF (mid > 0) mtyp = ipm(2,mid)
272 IF (mtyp /= 114) CALL ancmsg(msgid=2032,
273 . msgtype=msgerror,
274 . anmode=aninfo,
275 . i1=id,i2=el2)
276 ENDIF
277C
278C-------- Initialisation of fram structure
279C
280 nfram = 1
281 slipring(i)%NFRAM = 1
282 ALLOCATE(slipring(i)%FRAM(nfram))
283C
284 DO j=1,nfram
285 slipring(i)%FRAM(j)%UPDATE = 0
286 slipring(i)%FRAM(j)%ANCHOR_NODE = 0
287 slipring(i)%FRAM(j)%ORIENTATION_NODE = 0
288 slipring(i)%FRAM(j)%NODE = 0
289 slipring(i)%FRAM(j)%NODE_NEXT = 0
290 slipring(i)%FRAM(j)%NODE2_PREV = 0
291 slipring(i)%FRAM(j)%N_REMOTE_PROC = 0
292 slipring(i)%FRAM(j)%STRAND_DIRECTION = 1
293 slipring(i)%FRAM(j)%LOCKED = 0
294 slipring(i)%FRAM(j)%VECTOR = zero
295 slipring(i)%FRAM(j)%ORIENTATION_ANGLE = zero
296 slipring(i)%FRAM(j)%MATERIAL_FLOW = zero
297 slipring(i)%FRAM(j)%MATERIAL_FLOW_OLD = zero
298 slipring(i)%FRAM(j)%DFS = zero
299 slipring(i)%FRAM(j)%RESIDUAL_LENGTH = zero
300 slipring(i)%FRAM(j)%CURRENT_LENGTH = zero
301 slipring(i)%FRAM(j)%RINGSLIP = zero
302 slipring(i)%FRAM(j)%BETA = zero
303 slipring(i)%FRAM(j)%GAMMA = zero
304 slipring(i)%FRAM(j)%SLIP_FORCE = zero
305 slipring(i)%FRAM(j)%PREV_REF_LENGTH = zero
306 slipring(i)%FRAM(j)%INTVAR_STR1 = zero
307 slipring(i)%FRAM(j)%INTVAR_STR2 = zero
308 ENDDO
309C
310C---------- Fill of fram structure
311C
312 node_id = usr2sys(node_id,itabm1,mess,slipring(i)%ID)
313 IF (node_id2 > 0) node_id2 = usr2sys(node_id2,itabm1,mess,slipring(i)%ID)
314C
315C---------
316C
317 slipring(i)%FRAM(1)%ANCHOR_NODE = node_id
318 slipring(i)%FRAM(1)%ORIENTATION_NODE = node_id2
319C
320 node1 = ixr(2,el1_loc)
321 node2 = ixr(3,el1_loc)
322 node3 = ixr(2,el2_loc)
323 node4 = ixr(3,el2_loc)
324C
325 IF (node2 == node3) THEN
326 slipring(i)%FRAM(1)%NODE(1) = node1
327 slipring(i)%FRAM(1)%NODE(2) = node2
328 slipring(i)%FRAM(1)%NODE(3) = node4
329 ELSEIF (node1 == node3) THEN
330 slipring(i)%FRAM(1)%NODE(1) = node2
331 slipring(i)%FRAM(1)%NODE(2) = node1
332 slipring(i)%FRAM(1)%NODE(3) = node4
333 ELSEIF (node1 == node4) THEN
334 slipring(i)%FRAM(1)%NODE(1) = node2
335 slipring(i)%FRAM(1)%NODE(2) = node1
336 slipring(i)%FRAM(1)%NODE(3) = node3
337 ELSEIF (node2 == node4) THEN
338 slipring(i)%FRAM(1)%NODE(1) = node1
339 slipring(i)%FRAM(1)%NODE(2) = node2
340 slipring(i)%FRAM(1)%NODE(3) = node3
341 ENDIF
342C
343 IF(slipring(i)%FRAM(1)%NODE(2) == 0) THEN
344 IF ((el1_loc > 0).AND.(el2_loc > 0)) THEN
345 CALL ancmsg(msgid=2003,
346 . msgtype=msgerror,
347 . anmode=aninfo_blind_1,
348 . i1=id,i2=el1,i3=el2)
349 ENDIF
350 ELSEIF (slipring(i)%FRAM(1)%NODE(2) == slipring(i)%FRAM(1)%ANCHOR_NODE) THEN
351 CALL ancmsg(msgid=2029,
352 . msgtype=msgerror,
353 . anmode=aninfo_blind_1,
354 . i1=id,i2=itab(slipring(i)%FRAM(1)%ANCHOR_NODE))
355 ENDIF
356C
357 node1 = slipring(i)%FRAM(1)%NODE(1)
358 node2 = slipring(i)%FRAM(1)%NODE(2)
359 node3 = slipring(i)%FRAM(1)%NODE(3)
360 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
361 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
362 dist3 = (x(1,node3)-x(1,node_id))**2+(x(2,node3)-x(2,node_id))**2+(x(3,node3)-x(3,node_id))**2
363C
364C-- default tolerance
365 tole_2 = em10*(max(dist1,dist3))**2
366C-- compatibility with random noise
367 IF (nrand > 0) THEN
368 alea_max = zero
369 DO j=1,nrand
370 alea_max = max(alea_max,alea(j))
371 ENDDO
372 tole_2 = max(tole_2,ten*alea_max*alea_max)
373 ENDIF
374C
375C-- tolerance if node is very close to anchorage node
376 IF (dist2 <= ten*tole_2) THEN
377 x(1,node2) = x(1,node_id)
378 x(2,node2) = x(2,node_id)
379 x(3,node2) = x(3,node_id)
380 dist2 = zero
381 ENDIF
382C
383 IF ((el1_loc > 0).AND.(el2_loc > 0)) THEN
384 IF(dist2 > em30) CALL ancmsg(msgid=2004,
385 . msgtype=msgerror,
386 . anmode=aninfo_blind_1,
387 . i1=id)
388 ENDIF
389C
390 IF (node_id2 > 0) THEN
391C
392 nn(1) = x(1,node_id2) - x(1,node_id)
393 nn(2) = x(2,node_id2) - x(2,node_id)
394 nn(3) = x(3,node_id2) - x(3,node_id)
395 norm = sqrt(max(em30,nn(1)*nn(1)+nn(2)*nn(2)+nn(3)*nn(3)))
396 nn(1) = nn(1) / norm
397 nn(2) = nn(2) / norm
398 nn(3) = nn(3) / norm
399C
400 IF(norm < em20) CALL ancmsg(msgid=2018,
401 . msgtype=msgerror,
402 . anmode=aninfo_blind_1,
403 . i1=id)
404C
405 n1(1) = x(1,slipring(i)%FRAM(1)%NODE(1)) - x(1,slipring(i)%FRAM(1)%NODE(2))
406 n1(2) = x(2,slipring(i)%FRAM(1)%NODE(1)) - x(2,slipring(i)%FRAM(1)%NODE(2))
407 n1(3) = x(3,slipring(i)%FRAM(1)%NODE(1)) - x(3,slipring(i)%FRAM(1)%NODE(2))
408 norm = sqrt(max(em30,n1(1)*n1(1)+n1(2)*n1(2)+n1(3)*n1(3)))
409 n1(1) = n1(1) / norm
410 n1(2) = n1(2) / norm
411 n1(3) = n1(3) / norm
412C
413 n2(1) = x(1,slipring(i)%FRAM(1)%NODE(3)) - x(1,slipring(i)%FRAM(1)%NODE(2))
414 n2(2) = x(2,slipring(i)%FRAM(1)%NODE(3)) - x(2,slipring(i)%FRAM(1)%NODE(2))
415 n2(3) = x(3,slipring(i)%FRAM(1)%NODE(3)) - x(3,slipring(i)%FRAM(1)%NODE(2))
416 norm = sqrt(max(em30,n2(1)*n2(1)+n2(2)*n2(2)+n2(3)*n2(3)))
417 n2(1) = n2(1) / norm
418 n2(2) = n2(2) / norm
419 n2(3) = n2(3) / norm
420C
421 n3(1) = n1(2)*n2(3)-n1(3)*n2(2)
422 n3(2) = n1(3)*n2(1)-n1(1)*n2(3)
423 n3(3) = n1(1)*n2(2)-n1(2)*n2(1)
424 norm = sqrt(max(em30,n3(1)*n3(1)+n3(2)*n3(2)+n3(3)*n3(3)))
425 n3(1) = n3(1) / norm
426 n3(2) = n3(2) / norm
427 n3(3) = n3(3) / norm
428C
429 scal = abs(n3(1)*nn(1)+n3(2)*nn(2)+n3(3)*nn(3))
430 slipring(i)%FRAM(1)%ORIENTATION_ANGLE = acos(scal)
431C
432 WRITE(iout,1200) slipring(i)%FRAM(1)%ORIENTATION_ANGLE
433C
434 ENDIF
435C
436 ELSEIF (key(1:5)=='SHELL') THEN
437C
438C--------- SLIPRING/SHELL --------------------------------------------------------
439C
440 CALL hm_get_intv('EL_SET1', gr_shel1, is_available, lsubmodel)
441 CALL hm_get_intv('EL_SET2', gr_shel2, is_available, lsubmodel)
442 CALL hm_get_intv('Node_SET',gr_nod, is_available, lsubmodel)
443C
444 WRITE(iout,1300) id,trim(titr),gr_shel1,gr_shel2,gr_nod,isens,flow_flag,a,ed_factor,
445 . ifunc(1),ifunc(2),fricd,xscale1,yscale2,xscale2,
446 . ifunc(3),ifunc(4),frics,xscale3,yscale4,xscale4
447C
448 ingr2usr => igrnod(1:ngrnod)%ID
449 grn_loc=ngr2usr(gr_nod,ingr2usr,ngrnod)
450 nfram = igrnod(grn_loc)%NENTITY
451C
452 ingr2usr => igrsh4n(1:ngrshel)%ID
453 grs1_loc = ngr2usr(gr_shel1,ingr2usr,ngrshel)
454 grs2_loc = ngr2usr(gr_shel2,ingr2usr,ngrshel)
455C
456C-------- Initialisation of fram structure
457C
458 slipring(i)%NFRAM = nfram
459 ALLOCATE(slipring(i)%FRAM(nfram))
460 DO j=1,nfram
461 slipring(i)%FRAM(j)%UPDATE = 0
462 slipring(i)%FRAM(j)%ANCHOR_NODE = 0
463 slipring(i)%FRAM(j)%ORIENTATION_NODE = 0
464 slipring(i)%FRAM(j)%NODE = 0
465 slipring(i)%FRAM(j)%NODE_NEXT = 0
466 slipring(i)%FRAM(j)%NODE2_PREV = 0
467 slipring(i)%FRAM(j)%N_REMOTE_PROC = 0
468 slipring(i)%FRAM(j)%STRAND_DIRECTION = 1
469 slipring(i)%FRAM(j)%LOCKED = 0
470 slipring(i)%FRAM(j)%VECTOR = zero
471 slipring(i)%FRAM(j)%ORIENTATION_ANGLE = zero
472 slipring(i)%FRAM(j)%MATERIAL_FLOW = zero
473 slipring(i)%FRAM(j)%MATERIAL_FLOW_OLD = zero
474 slipring(i)%FRAM(j)%DFS = zero
475 slipring(i)%FRAM(j)%RESIDUAL_LENGTH = zero
476 slipring(i)%FRAM(j)%CURRENT_LENGTH = zero
477 slipring(i)%FRAM(j)%RINGSLIP = zero
478 slipring(i)%FRAM(j)%BETA = zero
479 slipring(i)%FRAM(j)%GAMMA = zero
480 slipring(i)%FRAM(j)%SLIP_FORCE = zero
481 slipring(i)%FRAM(j)%PREV_REF_LENGTH = zero
482 slipring(i)%FRAM(j)%INTVAR_STR1 = zero
483 slipring(i)%FRAM(j)%INTVAR_STR2 = zero
484 ENDDO
485C
486C-------- Check of alignment of anchorage nodes
487 CALL my_alloc(dist,nfram)
488 CALL my_alloc(jperm,nfram)
489 jperm(1:nfram) = 0
490 n_first = igrnod(grn_loc)%ENTITY(1)
491 n_last = igrnod(grn_loc)%ENTITY(igrnod(grn_loc)%NENTITY)
492 dist(1) = zero
493 dist(nfram) = (x(1,n_first)-x(1,n_last))**2+(x(2,n_first)-x(2,n_last))**2+(x(3,n_first)-x(3,n_last))**2
494 norm = sqrt(max(em20,dist(nfram)))
495 vect(1) = (x(1,n_first)-x(1,n_last))/norm
496 vect(2) = (x(2,n_first)-x(2,n_last))/norm
497 vect(3) = (x(3,n_first)-x(3,n_last))/norm
498 DO j=2,nfram-1
499 nj = igrnod(grn_loc)%ENTITY(j)
500 dist(j) = (x(1,n_first)-x(1,nj))**2+(x(2,n_first)-x(2,nj))**2+(x(3,n_first)-x(3,nj))**2
501 normj = sqrt(max(em20,dist(j)))
502 vectj(1) = (x(1,n_first)-x(1,nj))/normj
503 vectj(2) = (x(2,n_first)-x(2,nj))/normj
504 vectj(3) = (x(3,n_first)-x(3,nj))/normj
505 scal = one - abs(vect(1)*vectj(1)+vect(2)*vectj(2)+vect(3)*vectj(3))
506 IF (abs(scal) > em07) THEN
507 CALL ancmsg(msgid=2051,
508 . msgtype=msgerror,
509 . anmode=aninfo_blind_1,
510 . i1=id,i2=itab(nj))
511 ENDIF
512 ENDDO
513
514C-------- Check of distance between anchorage nodes (sorting by distance to first node)
515 CALL myqsort(nfram,dist,jperm,ierror)
516 DO j=1,nfram-1
517 IF (dist(j)==dist(j+1)) THEN
518 nj = igrnod(grn_loc)%ENTITY(jperm(j))
519 nj_next = igrnod(grn_loc)%ENTITY(jperm(j+1))
520 CALL ancmsg(msgid=2052,
521 . msgtype=msgerror,
522 . anmode=aninfo_blind_1,
523 . i1=id,i2=itab(nj),i3=itab(nj_next))
524 ENDIF
525 ENDDO
526 DEALLOCATE(dist,jperm)
527C
528C-------- Identification of node 2 for each frame
529C
530 size_com_nod = 4*(igrsh4n(grs1_loc)%NENTITY
531 . +igrsh4n(grs2_loc)%NENTITY)
532 CALL my_alloc(elem1_nod,nfram)
533 CALL my_alloc(elem2_nod,nfram)
534 CALL my_alloc(ipos1_nod,nfram)
535 CALL my_alloc(ipos2_nod,nfram)
536 CALL my_alloc(cores1,nfram)
537 CALL my_alloc(cores2,nfram)
538 CALL my_alloc(tagno,numnod)
539 CALL my_alloc(com_nod,size_com_nod)
540 cores1(1:nfram) = 0
541 cores1(1:nfram) = 0
542 ipos1_nod(1:nfram) = 0
543 elem1_nod(1:nfram) = 0
544 ipos2_nod(1:nfram) = 0
545 elem2_nod(1:nfram) = 0
546 tagno(1:numnod) = 0
547 com_nod(1:size_com_nod) = 0
548C
549C-- Tag and identification of common nodes between GRS1 and GRS2
550 DO k=1,igrsh4n(grs1_loc)%NENTITY
551 ishell = igrsh4n(grs1_loc)%ENTITY(k)
552 DO l = 1,4
553 node = ixc(1+l,ishell)
554 tagno(node)=1
555 ENDDO
556 ENDDO
557 cpt_com_nod = 0
558 DO k=1,igrsh4n(grs2_loc)%NENTITY
559 ishell = igrsh4n(grs2_loc)%ENTITY(k)
560 DO l = 1,4
561 node = ixc(1+l,ishell)
562 IF (tagno(node)==1) THEN
563 cpt_com_nod = cpt_com_nod+1
564 com_nod(cpt_com_nod) = node
565 ENDIF
566 ENDDO
567 ENDDO
568C
569C---------- Check that all nodes of 2d slipring are on location of common nodes of gr1 and gr2
570C
571 tagno(1:numnod) = 0
572 DO j=1,nfram
573 nj = igrnod(grn_loc)%ENTITY(j)
574C-- Search for closest node on element set 1 for each anchorage node
575 dist_min = ep30
576 DO k=1,igrsh4n(grs1_loc)%NENTITY
577 ishell = igrsh4n(grs1_loc)%ENTITY(k)
578 DO l = 1,4
579 node = ixc(1+l,ishell)
580 distn = (x(1,node)-x(1,nj))**2+(x(2,node)-x(2,nj))**2+(x(3,node)-x(3,nj))**2
581 IF (distn < dist_min) THEN
582 dist_min = distn
583 cores1(j) = node
584 elem1_nod(j) = ishell
585 ipos1_nod(j) = l
586 ENDIF
587 ENDDO
588 mid = ixc(1,ishell)
589 IF (ipm(2,mid)/=119) THEN
590 CALL ancmsg(msgid=2074,
591 . msgtype=msgerror,
592 . anmode=aninfo_blind_1,
593 . i1=ixc(nixc,ishell),
594 . prmod=msg_cumu)
595 ENDIF
596 ENDDO
597 IF (cores1(j) > 0) tagno(cores1(j)) = 1
598C-- Search for closest node on element set 2 for each anchorage node
599 dist_min = ep30
600 DO k=1,igrsh4n(grs2_loc)%NENTITY
601 ishell = igrsh4n(grs2_loc)%ENTITY(k)
602 DO l = 1,4
603 node = ixc(1+l,ishell)
604 distn = (x(1,node)-x(1,nj))**2+(x(2,node)-x(2,nj))**2+(x(3,node)-x(3,nj))**2
605 IF (distn < dist_min) THEN
606 dist_min = distn
607 cores2(j) = node
608 elem2_nod(j) = ishell
609 ipos2_nod(j) = l
610 ENDIF
611 ENDDO
612 mid = ixc(1,ishell)
613 IF (ipm(2,mid)/=119) THEN
614 CALL ancmsg(msgid=2074,
615 . msgtype=msgerror,
616 . anmode=aninfo_blind_1,
617 . i1=ixc(nixc,ishell),
618 . prmod=msg_cumu)
619 ENDIF
620 ENDDO
621 IF (cores2(j) > 0) tagno(cores2(j)) = 1
622C--
623 IF (cores1(j) /= cores2(j)) THEN
624 CALL ancmsg(msgid=2053,
625 . msgtype=msgerror,
626 . anmode=aninfo_blind_1,
627 . i1=id,i2=gr_shel1,i3=gr_shel2,i4=itab(nj))
628 ENDIF
629C
630 ENDDO
631C
632 CALL ancmsg(msgid=2074,
633 . msgtype=msgerror,
634 . anmode=aninfo_blind_1,
635 . i1=id,
636 . prmod=msg_print)
637C
638C---------- Check that all common nodes of gr1 and gr2 are on location of slipring nodes
639C
640 DO j=1,cpt_com_nod
641 IF (tagno(com_nod(j))==0) THEN
642 CALL ancmsg(msgid=3041,
643 . msgtype=msgerror,
644 . anmode=aninfo_blind_1,
645 . i1=itab(com_nod(j)),
646 . prmod=msg_cumu)
647 ENDIF
648 ENDDO
649C
650 CALL ancmsg(msgid=3041,
651 . msgtype=msgerror,
652 . anmode=aninfo_blind_1,
653 . i1=id,
654 . prmod=msg_print)
655C
656C---------- Fill of fram structure
657C
658 DO j=1,nfram
659C
660 node1 = -huge(node1)
661 node2 = -huge(node2)
662 node3 = -huge(node3)
663 node_id = igrnod(grn_loc)%ENTITY(j)
664 slipring(i)%FRAM(j)%ANCHOR_NODE = node_id
665 slipring(i)%FRAM(j)%ORIENTATION_NODE = 0
666C
667 node2 = cores1(j)
668 slipring(i)%FRAM(j)%NODE(2) = node2
669C
670 ishell = elem1_nod(j)
671 ipos = ipos1_nod(j)
672 DO k=1,4
673 IF ((k/=ipos+2).AND.(k/=ipos-2).AND.(tagno(ixc(k+1,ishell)) == 0)) node1 = ixc(k+1,ishell)
674 ENDDO
675 slipring(i)%FRAM(j)%NODE(1) = node1
676C
677 ishell = elem2_nod(j)
678 ipos = ipos2_nod(j)
679 DO k=1,4
680 IF ((k/=ipos+2).AND.(k/=ipos-2).AND.(tagno(ixc(k+1,ishell)) == 0)) node3 = ixc(k+1,ishell)
681 ENDDO
682 slipring(i)%FRAM(j)%NODE(3) = node3
683C
684 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
685 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
686 dist3 = (x(1,node3)-x(1,node_id))**2+(x(2,node3)-x(2,node_id))**2+(x(3,node3)-x(3,node_id))**2
687C
688C-- default tolerance
689 tole_2 = em10*(max(dist1,dist3))**2
690C-- compatibility with random noise
691 IF (nrand > 0) THEN
692 alea_max = zero
693 DO k=1,nrand
694 alea_max = max(alea_max,alea(k))
695 ENDDO
696 tole_2 = max(tole_2,ten*alea_max*alea_max)
697 ENDIF
698C
699C-- tolerance if node is very close to anchorage node
700 IF (dist2 <= ten*tole_2) THEN
701 x(1,node2) = x(1,node_id)
702 x(2,node2) = x(2,node_id)
703 x(3,node2) = x(3,node_id)
704 dist2 = zero
705 ENDIF
706C
707 IF ((dist2 > em30).AND.(cores1(j) == cores2(j))) THEN
708 CALL ancmsg(msgid=2054,
709 . msgtype=msgerror,
710 . anmode=aninfo_blind_1,
711 . i1=id,i2=itab(node_id))
712 ENDIF
713C
714 ENDDO
715C
716 DEALLOCATE(elem1_nod,ipos1_nod,elem2_nod,ipos2_nod,cores1,cores2,
717 . tagno,com_nod)
718C
719 ENDIF
720C
721 ENDDO
722C
723 ENDIF
724C
725 IF (ierr1 /= 0) THEN
726 WRITE(iout,*)' ** ERROR IN MEMORY ALLOCATION'
727 WRITE(istdo,*)' ** ERROR IN MEMORY ALLOCATION'
728 CALL arret(2)
729 ENDIF
730C
731C-------------------------------------
732C search for duplicate ids
733C-------------------------------------
734 CALL udouble(slip_id,1,nslipring,mess,0,bid)
735 RETURN
736C
7371000 FORMAT(/
738 . ' SLIPRING DEFINITIONS '/
739 . ' ---------------------- ')
7401100 FORMAT(/5x,'SLIPRING SPRING ID ',i10,1x,a
741 . /5x,'FIRST SPRING ELEMENT . . . . . . . . . . .',i10
742 . /5x,'SECOND SPRING ELEMENT . . . . . . . . . .',i10
743 . /5x,'ANCHORAGE NODE . . . . . . . . . . . . . .',i10
744 . /5x,'ORIENTATION NODE . . . . . . . . . . . . .',i10
745 . /5x,'SENSOR ID . . . . . . . . . . . . . . . .',i10
746 . /5x,'FLOW FLAG . . . . . . . . . . . . . . . .',i10
747 . /5x,'A. . . . . . . . . . . . . . . . . . . . .',1pg20.4
748 . /5x,'EXPONENTIAL DECAY FACTOR . . . . . . . . .',1pg20.4
749 . /5x,'FUNC1 - DYNAMIC FRIC FUNC VS TIME . . . .',i10
750 . /5x,'FUNC2 - DYNAMIC FRIC FUNC VS NORMAL FORCE ',i10
751 . /5x,'DYNAMIC FRIC COEFFICIENT . . . . . . . . .',1pg20.4
752 . /5x,'FUNC1 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
753 . /5x,'FUNC2 ORDINATE SCALE FACTOR . . . . . . .',1pg20.4
754 . /5x,'FUNC2 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
755 . /5x,'FUNC3 - STATIC FRIC FUNC VS TIME . . . . .',i10
756 . /5x,'FUNC4 - STATIC FRIC FUNC VS NORMAL FORCE .',i10
757 . /5x,'STATIC FRIC COEFFICIENT . . . . . . . . .',1pg20.4
758 . /5x,'FUNC3 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
759 . /5x,'FUNC4 ORDINATE SCALE FACTOR . . . . . . .',1pg20.4
760 . /5x,'FUNC4 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4)
761C
7621200 FORMAT( 5x,'INITIAL ORIENTATION ANGLE (RAD) . . . . .',1pg20.4)
763C
7641300 FORMAT(/5x,'SLIPRING SHELL ID ',i10,1x,a
765 . /5x,'FIRST ELEMENT GROUP . . . . . . . . . . .',i10
766 . /5x,'SECOND ELEMENT GROUP . . . . . . . . . . .',i10
767 . /5x,'ANCHORAGE NODE GROUP . . . . . . . . . . .',i10
768 . /5x,'SENSOR ID . . . . . . . . . . . . . . . .',i10
769 . /5x,'FLOW FLAG . . . . . . . . . . . . . . . .',i10
770 . /5x,'A. . . . . . . . . . . . . . . . . . . . .',1pg20.4
771 . /5x,'EXPONENTIAL DECAY FACTOR . . . . . . . . .',1pg20.4
772 . /5x,'FUNC1 - DYNAMIC FRIC FUNC VS TIME . . . .',i10
773 . /5x,'FUNC2 - DYNAMIC FRIC FUNC VS NORMAL FORCE ',i10
774 . /5x,'DYNAMIC FRIC COEFFICIENT . . . . . . . . .',1pg20.4
775 . /5x,'FUNC1 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
776 . /5x,'FUNC2 ORDINATE SCALE FACTOR . . . . . . .',1pg20.4
777 . /5x,'FUNC2 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
778 . /5x,'FUNC3 - STATIC FRIC FUNC VS TIME . . . . .',i10
779 . /5x,'FUNC4 - STATIC FRIC FUNC VS NORMAL FORCE .',i10
780 . /5x,'STATIC FRIC COEFFICIENT . . . . . . . . .',1pg20.4
781 . /5x,'FUNC3 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4
782 . /5x,'FUNC4 ORDINATE SCALE FACTOR . . . . . . .',1pg20.4
783 . /5x,'FUNC4 ABCISSA SCALE FACTOR . . . . . . . .',1pg20.4)
784
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
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
myqsort
subroutine myqsort(n, a, perm, error)
Definition myqsort.F:51
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::slipring
type(slipring_struct), dimension(:), allocatable slipring
Definition seatbelt_mod.F:110
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:323
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
arret
subroutine arret(nn)
Definition arret.F:86
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:146
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:573