OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_gjoint.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "r2r_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_gjoint (gjbufi, gjbufr, itab, itabm, x, mass, iner, lag_ncf, lag_nkf, lag_nhf, ikine, unitab, ikine1lag, nom_opt, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_gjoint()

subroutine hm_read_gjoint ( integer, dimension(lkjni,*) gjbufi,
gjbufr,
integer, dimension(*) itab,
integer, dimension(*) itabm,
x,
mass,
iner,
integer lag_ncf,
integer lag_nkf,
integer lag_nhf,
integer, dimension(*) ikine,
type (unit_type_), intent(in) unitab,
integer, dimension(*) ikine1lag,
integer, dimension(lnopt1,*) nom_opt,
type(submodel_data), dimension(*) lsubmodel )

Definition at line 42 of file hm_read_gjoint.F.

46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE unitab_mod
50 USE r2r_mod
51 USE message_mod
52 USE submodel_mod
53 USE hm_option_read_mod
54 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "scr17_c.inc"
63#include "param_c.inc"
64#include "units_c.inc"
65#include "r2r_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
70 INTEGER LAG_NCF ,LAG_NKF, LAG_NHF,
71 . GJBUFI(LKJNI,*), ITAB(*), ITABM(*), IKINE(*),
72 . IKINE1LAG(*)
73 my_real
74 . gjbufr(lkjnr,*), x(3,*), mass(*), iner(*)
75 INTEGER NOM_OPT(LNOPT1,*)
76 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
77C-----------------------------------------------
78C L o c a l V a r i a b l e s
79C-----------------------------------------------
80 INTEGER I,J,JJ,KK,ID,UID,JTYP,N1,N2,N3,N0,NG,SUB_ID
81 my_real r1(3),r2(3),r3(3),
82 . alpha,ms0,ms1,ms2,ms3,in0,in1,in2,in3,l1,l2,l3
83 CHARACTER(LEN=NCHARTITLE) :: TITR
84 CHARACTER(LEN=NCHARKEY) :: KEY
85 CHARACTER MESS*40
86 DATA mess/'GEAR JOINTS DEFINITION '/
87 LOGICAL :: IS_AVAILABLE
88C-----------------------------------------------
89C E x t e r n a l F u n c t i o n s
90C-----------------------------------------------
91 INTEGER USR2SYS
92C-----------------------------------------------
93C GJBUFI(1,I) = ID
94C GJBUFI(2,I) = TYPE
95C GJBUFI(3,I) = N0
96C GJBUFI(4,I) = N1
97C GJBUFI(5,I) = N2
98C GJBUFI(6,I) = N3
99C-----------------------------------------------
100C GJBUFR( 1,I) = ALPHA
101C GJBUFR(2 -10,I) = Local Skew
102C GJBUFR(11-13,I) = N1 Axis
103C GJBUFR(14-16,I) = N2 Axis
104C GJBUFR(17-19,I) = N3 Axis
105C======================================================================|
106C
107 is_available = .false.
108C
109 WRITE(iout,1000)
110 ng = 0
111C
112 CALL hm_option_start('/GJOINT')
113C
114 DO i=1,ngjoint
115 ng=ng+1
116C----------Multidomaines --> on ignore les gjoint non tages--------
117 IF(nsubdom>0)THEN
118 IF(tagjoin(ng)==0)CALL hm_sz_r2r(tagjoin,ng,lsubmodel)
119 END IF
120C-----------------------------------------------------------------
121 CALL hm_option_read_key(lsubmodel,
122 . option_id = id,
123 . unit_id = uid,
124 . submodel_id = sub_id,
125 . option_titr = titr,
126 . keyword2 = key)
127C
128 nom_opt(1,i)=id
129 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
130C
131C--------------------------------------------------
132C EXTRACT DATAS (INTEGER VALUES)
133C--------------------------------------------------
134 CALL hm_get_intv('node_ID0',n0,is_available,lsubmodel)
135 CALL hm_get_intv('node_ID1',n1,is_available,lsubmodel)
136 CALL hm_get_intv('node_ID2',n2,is_available,lsubmodel)
137 CALL hm_get_intv('node_ID3',n3,is_available,lsubmodel)
138C--------------------------------------------------
139C EXTRACT DATAS (REAL VALUES)
140C--------------------------------------------------
141 CALL hm_get_floatv('FscaleV',alpha,is_available,lsubmodel,unitab)
142 CALL hm_get_floatv('Mass',ms0,is_available,lsubmodel,unitab)
143 CALL hm_get_floatv('Inertia',in0,is_available,lsubmodel,unitab)
144C
145 CALL hm_get_floatv('Mass1',ms1,is_available,lsubmodel,unitab)
146 CALL hm_get_floatv('Inertia1',in1,is_available,lsubmodel,unitab)
147 CALL hm_get_floatv('r1x',r1(1),is_available,lsubmodel,unitab)
148 CALL hm_get_floatv('r1y',r1(2),is_available,lsubmodel,unitab)
149 CALL hm_get_floatv('r1z',r1(3),is_available,lsubmodel,unitab)
150C
151 CALL hm_get_floatv('Mass2',ms2,is_available,lsubmodel,unitab)
152 CALL hm_get_floatv('Inertia2',in2,is_available,lsubmodel,unitab)
153 CALL hm_get_floatv('r2x',r2(1),is_available,lsubmodel,unitab)
154 CALL hm_get_floatv('r2y',r2(2),is_available,lsubmodel,unitab)
155 CALL hm_get_floatv('r2z',r2(3),is_available,lsubmodel,unitab)
156C
157 IF(key(1:4)=='DIFF') THEN
158 CALL hm_get_floatv('Mass3',ms3,is_available,lsubmodel,unitab)
159 CALL hm_get_floatv('Inertia3',in3,is_available,lsubmodel,unitab)
160 CALL hm_get_floatv('r3x',r3(1),is_available,lsubmodel,unitab)
161 CALL hm_get_floatv('r3y',r3(2),is_available,lsubmodel,unitab)
162 CALL hm_get_floatv('r3z',r3(3),is_available,lsubmodel,unitab)
163 ENDIF
164C------
165 n0 = usr2sys(n0,itabm,mess,id)
166 n1 = usr2sys(n1,itabm,mess,id)
167 n2 = usr2sys(n2,itabm,mess,id)
168 mass(n0) = mass(n0) + ms0
169 mass(n1) = mass(n1) + ms1
170 mass(n2) = mass(n2) + ms2
171 iner(n0) = iner(n0) + in0
172 iner(n1) = iner(n1) + in1
173 iner(n2) = iner(n2) + in2
174 IF (alpha==0) alpha = 1.0
175 IF(r1(1)==zero.AND.r1(2)==zero.AND.r1(3)==zero) r1(1)=1.
176 IF(r2(1)==zero.AND.r2(2)==zero.AND.r2(3)==zero) r2(1)=1.
177 CALL kinset(512,itab(n0),ikine(n0),7,0,ikine1lag(n0))
178 CALL kinset(512,itab(n1),ikine(n1),7,0,ikine1lag(n1))
179 CALL kinset(512,itab(n2),ikine(n2),7,0,ikine1lag(n2))
180C---
181 IF(key(1:4)=='GEAR') THEN
182 jtyp = 1
183 n3 = 0
184 r3(1) = one
185 r3(2) = zero
186 r3(3) = zero
187 ELSEIF(key(1:4)=='DIFF') THEN
188 jtyp = 2
189 n3 = usr2sys(n3,itabm,mess,id)
190 CALL kinset(512,itab(n3),ikine(n3),7,0,ikine1lag(n3))
191 IF(r3(1)==zero.AND.r3(2)==zero.AND.r3(3)==zero) r3(1)=1.
192 mass(n3) = mass(n3) + ms3
193 iner(n3) = iner(n3) + in3
194 ELSEIF(key(1:4)=='RACK') THEN
195 jtyp = 3
196 n3 = 0
197 r3(1) = one
198 r3(2) = zero
199 r3(3) = zero
200
201 ELSE
202c unknown type
203 ENDIF
204C------
205 l1 = one/sqrt(r1(1)*r1(1)+r1(2)*r1(2)+r1(3)*r1(3))
206 l2 = one/sqrt(r2(1)*r2(1)+r2(2)*r2(2)+r2(3)*r2(3))
207 l3 = one/sqrt(r3(1)*r3(1)+r3(2)*r3(2)+r3(3)*r3(3))
208
209 DO j = 1,3
210 r1(j) = r1(j)*l1
211 r2(j) = r2(j)*l2
212 r3(j) = r3(j)*l3
213 ENDDO
214 gjbufi(1,i) = id
215 gjbufi(2,i) = jtyp
216 gjbufi(3,i) = n0
217 gjbufi(4,i) = n1
218 gjbufi(5,i) = n2
219 gjbufi(6,i) = n3
220C
221 gjbufr( 1,i) = one/alpha
222 gjbufr( 2,i) = one
223 gjbufr( 3,i) = zero
224 gjbufr( 4,i) = zero
225 gjbufr( 5,i) = zero
226 gjbufr( 6,i) = one
227 gjbufr( 7,i) = zero
228 gjbufr( 8,i) = zero
229 gjbufr( 9,i) = zero
230 gjbufr(10,i) = one
231 gjbufr(11,i) = r1(1)
232 gjbufr(12,i) = r1(2)
233 gjbufr(13,i) = r1(3)
234 gjbufr(14,i) = r2(1)
235 gjbufr(15,i) = r2(2)
236 gjbufr(16,i) = r2(3)
237 gjbufr(17,i) = r3(1)
238 gjbufr(18,i) = r3(2)
239 gjbufr(19,i) = r3(3)
240C
241C---
242 IF (jtyp==1) THEN
243 lag_nhf = lag_nhf + 55
244 lag_ncf = lag_ncf + 11
245 lag_nkf = lag_nkf + 60
246 WRITE(iout,1101)id,jtyp,itab(n1),itab(n2),itab(n0),
247 . alpha,ms1,ms2,ms0,in1,in2,in0,
248 . r1(1),r1(2),r1(3),r2(1),r2(2),r2(3)
249 ELSEIF (jtyp==2) THEN
250 lag_nhf = lag_nhf + 78
251 lag_ncf = lag_ncf + 13
252 lag_nkf = lag_nkf + 108
253 WRITE(iout,1102)id,jtyp,itab(n1),itab(n2),itab(n3),itab(n0),
254 . alpha,ms1,ms2,ms3,ms0,in1,in2,in3,in0,
255 . r1(1),r1(2),r1(3),r2(1),r2(2),r2(3),r3(1),r3(2),r3(3)
256 ELSEIF (jtyp==3) THEN
257 lag_nhf = lag_nhf + 36
258 lag_ncf = lag_ncf + 9
259 lag_nkf = lag_nkf + 48
260 WRITE(iout,1101)id,jtyp,itab(n1),itab(n2),itab(n0),
261 . alpha,ms1,ms2,ms0,in1,in2,in0,
262 . r1(1),r1(2),r1(3),r2(1),r2(2),r2(3)
263 ENDIF
264C---
265 ENDDO
266C---
267 RETURN
268 1000 FORMAT(//
269 .' COMPLEX JOINTS (GEAR TYPE) '/
270 . ' --------------------------- ')
271 1101 FORMAT( 5x,' JOINT ID . . . . . . . . . . . .',i10
272 . /10x,'JOINT TYPE . . . . . . . . . . .',i10
273 . /10x,'N1 . . . . . . . . . . . . . . .',i10
274 . /10x,'N2 . . . . . . . . . . . . . . .',i10
275 . /10x,'MAIN NODE. . . . . . . . . . .',i10
276 . /10x,'ALPHA. . . . . . . . . . . . . .',1pg20.13
277 . /10x,'ADDED N1 MASS. . . . . . . . .',1pg20.13
278 . /10x,'ADDED N2 MASS. . . . . . . . .',1pg20.13
279 . /10x,'ADDED MAIN MASS . . . . . . .',1pg20.13
280 . /10x,'ADDED N1 INERTIA . . . . . . . .',1pg20.13
281 . /10x,'ADDED N2 INERTIA . . . . . . . .',1pg20.13
282 . /10x,'ADDED MAIN INERTIA . . . . . .',1pg20.13
283 . /10x,'VECTOR T1: '
284 . /10x,' ',1pg20.13,1pg20.13,1pg20.13
285 . /10x,'VECTOR T2: '
286 . /10x,' ',1pg20.13,1pg20.13,1pg20.13/)
287 1102 FORMAT( 5x,' JOINT ID . . . . . . . . . . . .',i10
288 . /10x,'JOINT TYPE . . . . . . . . . . .',i10
289 . /10x,'N1 . . . . . . . . . . . . . . .',i10
290 . /10x,'N2 . . . . . . . . . . . . . . .',i10
291 . /10x,'N3 . . . . . . . . . . . . . . .',i10
292 . /10x,'MAIN NODE. . . . . . . . . . .',i10
293 . /10x,'ALPHA. . . . . . . . . . . . . .',1pg20.13
294 . /10x,'ADDED N1 MASS. . . . . . . . .',1pg20.13
295 . /10x,'ADDED N2 MASS. . . . . . . . .',1pg20.13
296 . /10x,'ADDED N3 MASS. . . . . . . . .',1pg20.13
297 . /10x,'ADDED MAIN MASS . . . . . . .',1pg20.13
298 . /10x,'ADDED N1 INERTIA . . . . . . . .',1pg20.13
299 . /10x,'ADDED N2 INERTIA . . . . . . . .',1pg20.13
300 . /10x,'ADDED N3 INERTIA . . . . . . . .',1pg20.13
301 . /10x,'ADDED MAIN INERTIA . . . . . .',1pg20.13
302 . /10x,'VECTOR T1: '
303 . /10x,' ',1pg20.13,g20.13,g20.13
304 . /10x,'VECTOR T2: '
305 . /10x,' ',1pg20.13,g20.13,g20.13
306 . /10x,'VECTOR T3: '
307 . /10x,' ',1pg20.13,g20.13,g20.13/)
308C---
309 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
alpha
#define alpha
Definition eval.h:35
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
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
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
id
initmumps id
Definition multiplerhs_example.m:4
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
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tagjoin
integer, dimension(:), allocatable tagjoin
Definition r2r_mod.F:138
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:300
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160