OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
read_impvel.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "sphcom.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine read_impvel (nfvel, inum, iopt, fbfvel, ibfvel, itab, itabm1, ikine, ikine1lag, nom_opt, igrnod, iskn, unitab, lsubmodel)

Function/Subroutine Documentation

◆ read_impvel()

subroutine read_impvel ( integer, intent(in) nfvel,
integer, intent(inout) inum,
integer, intent(inout) iopt,
intent(out) fbfvel,
integer, dimension(nifv,nfxvel), intent(out) ibfvel,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
integer, dimension(*) ikine,
integer, dimension(*) ikine1lag,
integer, dimension(lnopt1,*), intent(out) nom_opt,
type (group_), dimension(ngrnod), intent(in) igrnod,
integer, dimension(liskn,*), intent(in) iskn,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 44 of file read_impvel.F.

48C============================================================================
49C M o d u l e s
50C-----------------------------------------------
51 USE message_mod
52 USE groupdef_mod
53 USE submodel_mod
54 USE hm_option_read_mod
55 USE unitab_mod
56 USE names_and_titles_mod , ONLY : nchartitle, ncharfield, ncharkey
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "com04_c.inc"
65#include "scr17_c.inc"
66#include "param_c.inc"
67#include "sphcom.inc"
68#include "units_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER ,INTENT(IN) :: NFVEL
73 INTEGER ,INTENT(INOUT) :: INUM,IOPT
74 INTEGER ,DIMENSION(*) :: ITAB,ITABM1,IKINE,IKINE1LAG
75 INTEGER ,DIMENSION(LISKN,*) ,INTENT(IN) :: ISKN
76 INTEGER ,DIMENSION(LNOPT1,*) ,INTENT(OUT) :: NOM_OPT
77 INTEGER ,DIMENSION(NIFV,NFXVEL) ,INTENT(OUT) :: IBFVEL
78 my_real ,DIMENSION(LFXVELR,NFXVEL) ,INTENT(OUT) :: fbfvel
79 TYPE (UNIT_TYPE_) ,INTENT(IN) :: UNITAB
80 TYPE (GROUP_) ,DIMENSION(NGRNOD) ,INTENT(IN) :: IGRNOD
81 TYPE(SUBMODEL_DATA),DIMENSION(*) ,INTENT(IN) :: LSUBMODEL
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER I,J,JJ,NN,IVEL,IDIS,INOD,NODID,NOD,NOSKEW,NOFRAME,SENS_ID,
86 . OPTID,SYS_TYPE,UID,FCT_ID,SKEW_ID,FRAME_ID,GRN,IGS,LEN,
87 . ILAGM,FGEO,ICOOR,IUNIT,FLAGUNIT,SUBID,NOSUB,NN_FM(3)
88 INTEGER ,DIMENSION(NFXVEL) :: NODENUM
89 INTEGER ,DIMENSION(3*NUMNOD) :: IKINE1
90 my_real :: yscale,tstart,tstop,xscale,fscal_t,fscal_v
91 CHARACTER(LEN=2) :: X,Y,Z,XX,YY,ZZ
92 CHARACTER(LEN=NCHARFIELD) :: XYZ
93 CHARACTER(LEN=NCHARKEY) :: KEY
94 CHARACTER(LEN=NCHARTITLE) :: TITR,MESS
95 LOGICAL IS_AVAILABLE
96C-----------------------------------------------
97C E x t e r n a l F u n c t i o n s
98C-----------------------------------------------
99 INTEGER NODGRNR5,USR2SYS
100 EXTERNAL nodgrnr5,usr2sys
101C-----------------------------------------------
102C D a t a
103C-----------------------------------------------
104 DATA x /'X'/
105 DATA y /'Y'/
106 DATA z /'Z'/
107 DATA xx /'XX'/
108 DATA yy /'YY'/
109 DATA zz /'ZZ'/
110 DATA mess/'IMPOSED VELOCITY DEFINITION '/
111C======================================================================|
112 is_available = .false.
113c
114 ikine1(:) = 0
115 nn_fm(1:3)=0
116c--------------------------------------------------
117c START browsing /IMPVEL options
118c--------------------------------------------------
119c
120 CALL hm_option_start('/IMPVEL')
121c
122 WRITE (iout,1000)
123c
124c--------------------------------------------------
125 DO ivel = 1,nfvel
126c--------------------------------------------------
127 CALL hm_option_read_key(lsubmodel,
128 . option_id = optid,
129 . unit_id = uid,
130 . submodel_id = subid,
131 . submodel_index = nosub,
132 . option_titr = titr,
133 . keyword2 = key)
134c--------------------------------------------------
135 IF (key(1:4) == 'FGEO') cycle
136 IF (key(1:6) == 'LAGMUL') cycle
137c
138 iopt = iopt + 1
139 nom_opt(1,iopt) = optid
140 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,iopt),ltitr)
141c
142 frame_id = 0
143 sys_type = 1 ! skew = 1 ,frame =2
144 icoor = 0 ! ICOOR = 1 => axial coordinates
145 fgeo = 0
146 ilagm = 0
147 idis = 1
148 len = 1
149 tstart = zero
150 tstop = infinity
151c--------------------------------------------------
152c READ STRING VALUES from /IMPVEL
153c--------------------------------------------------
154 CALL hm_get_intv('rad_system_input_type' ,sys_type ,is_available,lsubmodel)
155c
156 CALL hm_get_intv ('curveid' ,fct_id ,is_available,lsubmodel)
157 CALL hm_get_string('rad_dir' ,xyz ,ncharfield,is_available)
158 CALL hm_get_intv ('skew_ID' ,skew_id ,is_available,lsubmodel)
159 CALL hm_get_intv ('rad_sensor_id' ,sens_id ,is_available,lsubmodel)
160 CALL hm_get_intv ('entityid' ,grn ,is_available,lsubmodel)
161 CALL hm_get_intv ('frame_ID' ,frame_id ,is_available,lsubmodel)
162 CALL hm_get_intv ('rad_icoor' ,icoor ,is_available,lsubmodel)
163c
164 CALL hm_get_floatv('xscale' ,xscale ,is_available,lsubmodel,unitab)
165 CALL hm_get_floatv('magnitude' ,yscale ,is_available,lsubmodel,unitab)
166 CALL hm_get_floatv('rad_tstart' ,tstart ,is_available,lsubmodel,unitab)
167 CALL hm_get_floatv('rad_tstop' ,tstop ,is_available,lsubmodel,unitab)
168c
169c--------------------------------------------------
170c CHECK IF Unit_ID exists
171c--------------------------------------------------
172 flagunit = 0
173 DO iunit=1,unitab%NUNITS
174 IF (unitab%UNIT_ID(iunit) == uid) THEN
175 flagunit = 1
176 EXIT
177 ENDIF
178 ENDDO
179 IF (uid > 0 .and. flagunit == 0) THEN
180 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
181 . i1= optid,
182 . i2= uid,
183 . c1='IMPDISP',
184 . c2='IMPDISP',
185 . c3= titr)
186 ENDIF
187c--------------------------------------------------
188c Check skew and frame IDs
189c--------------------------------------------------
190 noskew = 0
191 noframe = 0
192c----
193 IF ((skew_id == 0).AND.(frame_id == 0).AND.(subid /= 0)) THEN
194 skew_id = lsubmodel(nosub)%SKEW
195 ENDIF
196c----
197 IF ((sys_type == 0).OR.(sys_type == 1)) THEN
198 DO j=0,numskw+min(1,nspcond)*numsph+nsubmod
199 IF (skew_id == iskn(4,j+1)) THEN
200 noskew = j+1
201 EXIT
202 ENDIF
203 ENDDO
204 IF (skew_id > 0 .and. noskew == 0)
205 . CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
206 . i1= optid,
207 . i2= skew_id,
208 . c1='IMPOSED VELOCITY',
209 . c2='IMPOSED VELOCITY',
210 . c3= titr)
211c----
212 ELSEIF (sys_type == 2) THEN
213 jj = (numskw+1) + min(1,nspcond)*numsph+1 + nsubmod
214 DO j=1,numfram
215 jj = jj+1
216 IF (frame_id == iskn(4,jj)) THEN
217 noframe = j+1
218 nn_fm(1:3) = iskn(1:3,jj)
219 EXIT
220 ENDIF
221 ENDDO
222 IF (frame_id > 0 .and. noframe == 0)
223 . CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
224 . i1= optid,
225 . i2= frame_id,
226 . c1='IMPOSED VELOCITY',
227 . c2='IMPOSED VELOCITY',
228 . c3= titr)
229 ENDIF
230c
231c----
232 IF (noskew > 0 .AND. noframe > 0) THEN
233 CALL ancmsg(msgid=491,anmode=aninfo_blind_1,
234 . msgtype=msgerror,
235 . i1= optid,
236 . i2= noskew,
237 . i3= noframe,
238 . c1= titr)
239 ENDIF
240c--------------------------------------------------
241c Default scale factors
242c--------------------------------------------------
243 CALL hm_get_floatv_dim('xscale' ,fscal_t ,is_available,lsubmodel,unitab)
244 CALL hm_get_floatv_dim('magnitude',fscal_v ,is_available,lsubmodel,unitab)
245c
246 IF (xscale == zero) xscale = one * fscal_t
247 xscale = one / xscale
248 IF (yscale == zero) yscale = one * fscal_v
249 IF (tstop == zero) tstop = infinity
250c
251 IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
252 len = 2
253c YSCALE = YSCALE / (FSCAL_V * FSCAL_T)
254 ENDIF
255c--------------------------------------------------
256c Read NODE numbers from the group
257c
258 nn = nodgrnr5(grn,igs,nodenum,igrnod,itabm1,mess)
259c
260c--------------------------------------------------
261 DO j=1,nn
262 inum = inum + 1
263 ibfvel(1, inum) = nodenum(j)
264 ibfvel(2 ,inum) = 0
265 ibfvel(3 ,inum) = fct_id
266 ibfvel(4 ,inum) = sens_id
267 ibfvel(5 ,inum) = 0
268 ibfvel(6 ,inum) = 0 ! init dans lecrby (si vitesse de rotation sur main)
269 ibfvel(7 ,inum) = idis
270 ibfvel(8 ,inum) = ilagm
271 ibfvel(9 ,inum) = noframe
272 ibfvel(10,inum) = icoor
273 ibfvel(11,inum) = 0
274 ibfvel(12,inum) = iopt
275 ibfvel(13,inum) = fgeo
276 ibfvel(14,inum) = 0
277c
278 fbfvel(1,inum) = yscale
279 fbfvel(2,inum) = tstart
280 fbfvel(3,inum) = tstop
281 fbfvel(4,inum) = zero
282 fbfvel(5,inum) = xscale
283 fbfvel(6,inum) = zero
284c
285 inod = iabs(nodenum(j))
286 nodid = itab(inod)
287c
288c ! SET DIRECTIONS AND TAG NODES WITH KINEMATIC CONDITIONS
289c
290 IF (noframe > 0) THEN
291 IF(xyz(1:2) == xx)THEN
292 ibfvel(2,inum) = 4
293 CALL kinset(16,nodid,ikine(inod),4,noframe,ikine1(inod))
294 ELSEIF(xyz(1:2) == yy)THEN
295 ibfvel(2,inum) = 5
296 CALL kinset(16,nodid,ikine(inod),5,noframe,ikine1(inod))
297 ELSEIF(xyz(1:2) == zz)THEN
298 ibfvel(2,inum) = 6
299 CALL kinset(16,nodid,ikine(inod),6,noframe,ikine1(inod))
300 ELSEIF (xyz(1:1) == x)THEN
301 ibfvel(2,inum) = 1
302 CALL kinset(16,nodid,ikine(inod),1,noframe,ikine1(inod))
303 ELSEIF(xyz(1:1) == y)THEN
304 ibfvel(2,inum) = 2
305 CALL kinset(16,nodid,ikine(inod),2,noframe,ikine1(inod))
306 ELSEIF(xyz(1:1) == z)THEN
307 ibfvel(2,inum) = 3
308 CALL kinset(16,nodid,ikine(inod),3,noframe,ikine1(inod))
309 ELSE
310 CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
311 . i1=optid,
312 . c1=titr,
313 . c2=xyz)
314 ENDIF
315c
316 WRITE (iout, 3000) nodid,noskew,frame_id,xyz(1:len),fct_id,sens_id,
317 . yscale,one/xscale,tstart,tstop,icoor
318c
319c---------------
320c check for N1,N2,N3 of frame not the imposed node
321c---------------
322 IF (inod==nn_fm(1) .OR. inod==nn_fm(2) .OR. inod==nn_fm(3)) THEN
323 CALL ancmsg(msgid=3091, msgtype=msgerror, anmode=aninfo,
324 . i1=optid,
325 . c1=titr,
326 . i2=nodid,
327 . i3=frame_id)
328 END IF
329c
330 ELSE ! SKEW
331 IF(xyz(1:2) == xx)THEN
332 ibfvel(2,inum) = 4 + noskew*10
333 CALL kinset(16,nodid,ikine(inod),4,noskew,ikine1(inod))
334 ELSEIF(xyz(1:2) == yy)THEN
335 ibfvel(2,inum) = 5 + noskew*10
336 CALL kinset(16,nodid,ikine(inod),5,noskew,ikine1(inod))
337 ELSEIF(xyz(1:2) == zz)THEN
338 ibfvel(2,inum) = 6 + noskew*10
339 CALL kinset(16,nodid,ikine(inod),6,noskew,ikine1(inod))
340 ELSEIF (xyz(1:1) == x)THEN
341 ibfvel(2,inum)=1 + noskew*10
342 CALL kinset(16,nodid,ikine(inod),1,noskew,ikine1(inod))
343 ELSEIF(xyz(1:1) == y)THEN
344 ibfvel(2,inum) = 2 + noskew*10
345 CALL kinset(16,nodid,ikine(inod),2,noskew,ikine1(inod))
346 ELSEIF(xyz(1:1) == z)THEN
347 ibfvel(2,inum) = 3 + noskew*10
348 CALL kinset(16,nodid,ikine(inod),3,noskew,ikine1(inod))
349 ELSE
350 CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
351 . i1=optid,
352 . c1=titr,
353 . c2=xyz)
354 ENDIF
355c
356 WRITE (iout,4000) nodid,iskn(4,noskew),0,xyz(1:len),fct_id,sens_id,
357 . yscale,one/xscale,tstart,tstop,icoor
358c
359 ENDIF
360c-----------------------------------------------------------
361c
362 ENDDO ! NN
363c
364 ENDDO ! DO I=1,NFVEL
365c
366c-----------
367 RETURN
368c--------------------------------------------------
369 1000 FORMAT(//
370 .' IMPOSED VELOCITIES '/
371 .' ------------------- '/
372 .' NODE SKEW FRAME DIRECTION LOAD_CURVE',
373 .' SENSOR FSCALE ASCALE',
374 .' START_TIME STOP_TIME',
375 .' COORDINATE SYSTEM')
376c--------------------------------------------------
377 2000 FORMAT(//
378 .' IMPOSED VELOCITIES BY LAGRANGE MULTIPLIERS '/
379 .' ------------------------------------------ '/
380 .' NODE SKEW FRAME DIRECTION LOAD_CURVE',
381 .' SENSOR FSCALE ASCALE',
382 .' START_TIME STOP_TIME',
383 .' COORDINATE SYSTEM')
384 3000 FORMAT(3x,i10,3x,i10,3x,i10,9x,a2,3x,i10,3x,i10,
385 . 2x,1pg20.13,2x,1pg20.13,2x,g20.13,2x,g20.13,16x,i10)
386 4000 FORMAT(3x,i10,3x,i10,3x,i10,9x,a2,3x,i10,3x,i10,
387 . 2x,1pg20.13,2x,1pg20.13,2x,g20.13,2x,g20.13,16x,i10)
388c--------------------------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_get_floatv_dim
subroutine hm_get_floatv_dim(name, dim_fac, is_available, lsubmodel, unitab)
Definition hm_get_floatv_dim.F:159
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_get_string
subroutine hm_get_string(name, sval, size, is_available)
Definition hm_get_string.F:76
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
min
#define min(a, b)
Definition macros.h:20
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
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
unitab_mod
Definition unitab_mod.F:513
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
nodgrnr5
integer function nodgrnr5(igu, igs, ibuf, igrnod, itabm1, mess)
Definition freform.F:303
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160