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