OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
read_impdisp.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_impdisp (ndisp, inum, iopt, fbfvel, ibfvel, itab, itabm1, ikine, igrnod, nom_opt, iskn, unitab, lsubmodel)

Function/Subroutine Documentation

◆ read_impdisp()

subroutine read_impdisp ( integer, intent(in) ndisp,
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,
type (group_), dimension(ngrnod), intent(in) igrnod,
integer, dimension(lnopt1,*), intent(out) nom_opt,
integer, dimension(liskn,*), intent(in) iskn,
type (unit_type_), intent(in) unitab,
type (submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 43 of file read_impdisp.F.

47C============================================================================
48C M o d u l e s
49C-----------------------------------------------
50 USE my_alloc_mod
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, ncharkey, ncharfield
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) :: NDISP
73 INTEGER ,INTENT(INOUT) :: INUM,IOPT
74 INTEGER ,DIMENSION(*) :: ITAB,ITABM1,IKINE
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,IDISP,NN,IDIS,INOD,NODID,NOSKEW,NOFRAME,LEN,
86 . IUNIT,FLAGUNIT,SENS_ID,OPTID,UID,SKEW_ID,FCT_ID,GRN_ID,IGS,
87 . IFGEO,ICOOR,ILAGM,SUBID,NOSUB,SYS_TYPE,FRAME_ID,J,JJ,NN_FM(3)
88 INTEGER ,DIMENSION(:),ALLOCATABLE :: NODENUM
89 INTEGER ,DIMENSION(:),ALLOCATABLE :: IKINE1
90 my_real :: yscale,tstart,tstop,xscale,fscal_t,fscal_l
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
100 EXTERNAL nodgrnr5
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 DISPLACEMENT DEFINITION '/
111C======================================================================|
112 CALL my_alloc(ikine1,3*numnod)
113 CALL my_alloc(nodenum,nfxvel)
114c
115 is_available = .false.
116c
117 ikine1(:)= 0
118 nn_fm(1:3)= 0
119c--------------------------------------------------
120c READ /IMPDISP cards
121c--------------------------------------------------
122c
123 CALL hm_option_start('/IMPDISP')
124c
125 WRITE (iout,1000)
126c
127c--------------------------------------------------
128 DO idisp = 1,ndisp
129c--------------------------------------------------
130 CALL hm_option_read_key(lsubmodel,
131 . option_id = optid,
132 . unit_id = uid,
133 . submodel_id = subid,
134 . submodel_index = nosub,
135 . option_titr = titr,
136 . keyword2 = key)
137c--------------------------------------------------
138 IF (key(1:4) == 'FGEO') cycle
139c
140 iopt = iopt + 1
141 nom_opt(1,iopt) = optid
142 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,iopt),ltitr)
143c
144 icoor = 0 ! ICOOR = 1 => axial coordinates
145 ifgeo = 0
146 ilagm = 0
147 idis = 2
148 len = 1
149 noframe = 0
150 sys_type = 1 ! skew = 1 ,frame =2
151 noskew = 0
152c--------------------------------------------------
153c READ STRING VALUES from /IMPDISP
154c--------------------------------------------------
155 CALL hm_get_intv('rad_system_input_type' ,sys_type ,is_available,lsubmodel)
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 ('inputsystem' ,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_id ,is_available,lsubmodel)
161 CALL hm_get_intv ('rad_icoor' ,icoor ,is_available,lsubmodel)
162 CALL hm_get_intv ('skew_ID' ,skew_id ,is_available,lsubmodel)
163 CALL hm_get_intv ('frame_ID' ,frame_id ,is_available,lsubmodel)
164 IF (sys_type /= 2) CALL hm_get_intv('inputsystem',skew_id ,is_available,lsubmodel)
165c
166 CALL hm_get_floatv('xscale' ,xscale ,is_available,lsubmodel,unitab)
167 CALL hm_get_floatv('magnitude' ,yscale ,is_available,lsubmodel,unitab)
168 CALL hm_get_floatv('rad_tstart' ,tstart ,is_available,lsubmodel,unitab)
169 CALL hm_get_floatv('rad_tstop' ,tstop ,is_available,lsubmodel,unitab)
170c
171 IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) len = 2
172c--------------------------------------------------
173c CHECK IF Unit_ID exists
174c--------------------------------------------------
175 flagunit = 0
176 DO iunit=1,unitab%NUNITS
177 IF (unitab%UNIT_ID(iunit) == uid) THEN
178 flagunit = 1
179 EXIT
180 ENDIF
181 ENDDO
182 IF (uid > 0 .and. flagunit == 0) THEN
183 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
184 . i1= optid,
185 . i2= uid,
186 . c1='IMPDISP',
187 . c2='IMPDISP',
188 . c3= titr)
189 ENDIF
190c--------------------------------------------------
191c Check skew IDs
192c--------------------------------------------------
193 IF ((skew_id == 0).AND.(subid /= 0)) THEN
194 skew_id = lsubmodel(nosub)%SKEW
195 ENDIF
196!
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 DISPLACEMENT',
209 . c2='IMPOSED DISPLACEMENT',
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 DISPLACEMENT',
227 . c2='IMPOSED DISPLACEMENT',
228 . c3= titr)
229 ENDIF
230c----
231c--------------------------------------------------
232c Default scale factors
233c--------------------------------------------------
234 CALL hm_get_floatv_dim('xscale' ,fscal_t ,is_available,lsubmodel,unitab)
235 CALL hm_get_floatv_dim('magnitude',fscal_l ,is_available,lsubmodel,unitab)
236c
237 IF (xscale == zero) xscale = one * fscal_t
238 xscale = one / xscale
239 IF (yscale == zero) yscale = one * fscal_l
240c IF (LEN == 2) THEN ! FSCALE = rad - to be checked in cfg file !
241c YSCALE = YSCALE / FSCAL_L
242c ENDIF
243 IF (tstop == zero) tstop = infinity
244c--------------------------------------------------
245c Read NODE numbers from the group
246c
247 nn = nodgrnr5(grn_id,igs,nodenum,igrnod,itabm1,mess)
248c--------------------------------------------------
249 DO i=1,nn
250 inum = inum + 1
251 ibfvel(1, inum) = nodenum(i)
252 ibfvel(2 ,inum) = 0
253 ibfvel(3 ,inum) = fct_id
254 ibfvel(4 ,inum) = sens_id
255 ibfvel(5 ,inum) = 0
256 ibfvel(6 ,inum) = 0 ! init dans lecrby (si vitesse de rotation sur main)
257 ibfvel(7 ,inum) = idis
258 ibfvel(8 ,inum) = ilagm
259 ibfvel(9 ,inum) = noframe
260 ibfvel(10,inum) = icoor
261 ibfvel(11,inum) = 0
262 ibfvel(12,inum) = iopt
263 ibfvel(13,inum) = ifgeo
264 ibfvel(14,inum) = 0
265c
266 fbfvel(1,inum) = yscale
267 fbfvel(2,inum) = tstart
268 fbfvel(3,inum) = tstop
269 fbfvel(4,inum) = zero
270 fbfvel(5,inum) = xscale
271 fbfvel(6,inum) = zero
272c
273 inod = iabs(nodenum(i))
274 nodid = itab(inod)
275c
276c---------------
277c TAG NODES WITH KINEMATIC CONDITIONS
278c---------------
279 IF (noframe > 0) THEN
280 IF(xyz(1:2) == xx)THEN
281 ibfvel(2,inum) = 4
282 CALL kinset(16,nodid,ikine(inod),4,noframe,ikine1(inod))
283 ELSEIF(xyz(1:2) == yy)THEN
284 ibfvel(2,inum) = 5
285 CALL kinset(16,nodid,ikine(inod),5,noframe,ikine1(inod))
286 ELSEIF(xyz(1:2) == zz)THEN
287 ibfvel(2,inum) = 6
288 CALL kinset(16,nodid,ikine(inod),6,noframe,ikine1(inod))
289 ELSEIF (xyz(1:1) == x)THEN
290 ibfvel(2,inum) = 1
291 CALL kinset(16,nodid,ikine(inod),1,noframe,ikine1(inod))
292 ELSEIF(xyz(1:1) == y)THEN
293 ibfvel(2,inum) = 2
294 CALL kinset(16,nodid,ikine(inod),2,noframe,ikine1(inod))
295 ELSEIF(xyz(1:1) == z)THEN
296 ibfvel(2,inum) = 3
297 CALL kinset(16,nodid,ikine(inod),3,noframe,ikine1(inod))
298 ELSE
299 CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
300 . i1=optid,
301 . c1=titr,
302 . c2=xyz)
303 ENDIF
304!
305 WRITE (iout, 3000) nodid,noskew,frame_id,xyz(1:len),fct_id,sens_id,
306 . yscale,one/xscale,tstart,tstop,icoor
307c---------------
308c check for N1,N2,N3 of frame not the imposed node
309c---------------
310 IF (inod==nn_fm(1) .OR. inod==nn_fm(2) .OR. inod==nn_fm(3)) THEN
311 CALL ancmsg(msgid=3091, msgtype=msgerror, anmode=aninfo,
312 . i1=optid,
313 . c1=titr,
314 . i2=nodid,
315 . i3=frame_id)
316 END IF
317 ELSE ! SKEW
318 IF(xyz(1:2) == xx)THEN
319 ibfvel(2,inum) = 4 + noskew*10
320 CALL kinset(16,nodid,ikine(inod),4,noskew,ikine1(inod))
321 ELSEIF(xyz(1:2) == yy)THEN
322 ibfvel(2,inum) = 5 + noskew*10
323 CALL kinset(16,nodid,ikine(inod),5,noskew,ikine1(inod))
324 ELSEIF(xyz(1:2) == zz)THEN
325 ibfvel(2,inum) = 6 + noskew*10
326 CALL kinset(16,nodid,ikine(inod),6,noskew,ikine1(inod))
327 ELSEIF (xyz(1:1) == x)THEN
328 ibfvel(2,inum)=1 + noskew*10
329 CALL kinset(16,nodid,ikine(inod),1,noskew,ikine1(inod))
330 ELSEIF(xyz(1:1) == y)THEN
331 ibfvel(2,inum) = 2 + noskew*10
332 CALL kinset(16,nodid,ikine(inod),2,noskew,ikine1(inod))
333 ELSEIF(xyz(1:1) == z)THEN
334 ibfvel(2,inum) = 3 + noskew*10
335 CALL kinset(16,nodid,ikine(inod),3,noskew,ikine1(inod))
336 ELSE
337 CALL ancmsg(msgid=164, msgtype=msgerror, anmode=aninfo,
338 . i1=optid,
339 . c1=titr,
340 . c2=xyz)
341 ENDIF
342!----------------
343 WRITE (iout,2000) nodid,iskn(4,noskew),0,xyz(1:len),fct_id,sens_id,
344 . yscale,one/xscale,tstart,tstop
345 ENDIF
346c-----------------------------------------------------------
347c
348 ENDDO ! NN
349c
350 ENDDO ! DO I=1,NFDISP
351c
352 DEALLOCATE(ikine1)
353 DEALLOCATE(nodenum)
354c
355c--------------------------------------------------
356 1000 FORMAT(//
357 .' IMPOSED DISPLACEMENTS '/
358 .' ------------------- '/
359 .' NODE SKEW FRAME DIRECTION LOAD_CURVE',
360 .' SENSOR FSCALE ASCALE',
361 .' START_TIME STOP_TIME')
362 2000 FORMAT(3x,i10,3x,i10,3x,i10,9x,a2,3x,i10,3x,i10,
363 . 2x,1pg20.13,2x,1pg20.13,2x,g20.13,2x,g20.13)
364 3000 FORMAT(3x,i10,3x,i10,3x,i10,9x,a2,3x,i10,3x,i10,
365 . 2x,1pg20.13,2x,1pg20.13,2x,g20.13,2x,g20.13,16x,i10)
366c--------------------------------------------------
367 RETURN
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