OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_slipring.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| hm_read_slipring ../starter/source/tools/seatbelts/hm_read_slipring.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.f
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| arret ../starter/source/system/arret.F
30!|| fretitl ../starter/source/starter/freform.F
31!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
32!|| hm_get_floatv_dim ../starter/source/devtools/hm_reader/hm_get_floatv_dim.F
33!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
34!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
35!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
36!|| ngr2usr ../starter/source/system/nintrr.F
37!|| nintri ../starter/source/system/nintrr.F
38!|| udouble ../starter/source/system/sysfus.F
39!|| usr2sys ../starter/source/system/sysfus.f
40!||--- uses -----------------------------------------------------
41!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
42!|| message_mod ../starter/share/message_module/message_mod.F
43!|| submodel_mod ../starter/share/modules1/submodel_mod.f
44!||====================================================================
45 SUBROUTINE hm_read_slipring(LSUBMODEL,ITABM1,IXR,ITAB,UNITAB,
46 . X,FUNC_ID,NOM_OPT,ALEA,IGRNOD,
47 . IGRSH4N,IXC,IPM)
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.AND. IF ((EL1_LOC > 0)(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.AND. IF ((EL1_LOC > 0)(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.AND..AND. IF ((K/=IPOS+2)(K/=IPOS-2)(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.AND..AND. IF ((K/=IPOS+2)(K/=IPOS-2)(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.AND. IF ((DIST2 > EM30)(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
784 END SUBROUTINE HM_READ_SLIPRING
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_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_read_slipring
subroutine hm_read_slipring(lsubmodel, itabm1, ixr, itab, unitab, x, func_id, nom_opt, alea, igrnod, igrsh4n, ixc, ipm)
Definition hm_read_slipring.F:48
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
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
second
real function second()
SECOND Using ETIME
Definition second_EXT_ETIME.f:35
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
lectur
subroutine lectur(multi_fvm, lsubmodel, is_dyna, detonators, ebcs_tab, seatbelt_converted_elements, nb_seatbelt_shells, nb_dyna_include, user_windows, output, mat_elem, names_and_titles, defaults, glob_therm, pblast, sensor_user_struct)
Definition lectur.F:533
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
starter
program starter
Definition starter.F:39
static
subroutine static(v, vr, a, ar, ms, in, igrnod, weight_md, wfext)
Definition static.F:33
submodel_mod::submodel_data
Definition submodel_mod.F:723