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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_impacc (fac, ibfv, nfxvel0, itab, itabm1, ikine, igrnod, iskn, unitab, lsubmodel, num, nimpacc)

Function/Subroutine Documentation

◆ hm_read_impacc()

subroutine hm_read_impacc ( intent(inout) fac,
integer, dimension(nifv,nfxvel0) ibfv,
integer, intent(in) nfxvel0,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
integer, dimension(*) ikine,
type (group_), dimension(ngrnod), intent(in) igrnod,
integer, dimension(liskn,*) iskn,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(*), intent(in) lsubmodel,
integer, intent(inout) num,
integer, intent(inout) nimpacc )

Definition at line 44 of file hm_read_impacc.F.

48C============================================================================
49C M o d u l e s
50C-----------------------------------------------
51 USE unitab_mod
52 USE message_mod
53 USE groupdef_mod
54 USE submodel_mod
55 USE hm_option_read_mod
56 USE names_and_titles_mod , ONLY : nchartitle, 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 "param_c.inc"
66#include "sphcom.inc"
67#include "units_c.inc"
68C-----------------------------------------------
69C D u m m y A r g u m e n t s
70C-----------------------------------------------
71 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
72 INTEGER ,INTENT(INOUT) :: NIMPACC,NUM
73 INTEGER ,INTENT(IN) :: NFXVEL0
74 INTEGER ,DIMENSION(NIFV,NFXVEL0) :: IBFV
75 INTEGER ,DIMENSION(LISKN,*) :: ISKN
76 INTEGER ,DIMENSION(*) :: ITAB,ITABM1,IKINE
77 my_real,DIMENSION(LFXVELR,*) ,INTENT(INOUT) :: fac
78
79 TYPE (GROUP_) ,DIMENSION(NGRNOD) ,INTENT(IN) :: IGRNOD
80 TYPE(SUBMODEL_DATA),DIMENSION(*) ,INTENT(IN) :: LSUBMODEL
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER J,ID,UID,IACC,FCT_ID,INP_ID,SENS_ID,GRN,NACC,
85 . NOSKEW,NOFRAME,NUM0,NN,I_VDA,INOD,NODID,IGS,
86 . L_XYZ,SUBID,NOSUB,NODENUM(NFXVEL0)
87 INTEGER ,DIMENSION(3*NUMNOD) :: IKINE1
88 LOGICAL IS_AVAILABLE
89 CHARACTER(LEN=NCHARFIELD) :: XYZ
90 CHARACTER(LEN=NCHARTITLE) :: TITR,MESS
91 INTEGER ,DIMENSION(:),ALLOCATABLE :: IACCIDS
92 CHARACTER(LEN=2) :: X,Y,Z,XX,YY,ZZ
93 my_real :: fac1,fac2,fac3,facx,fscal_t,fscal_a,bid
94C-----------------------------------------------
95C D a t a
96C-----------------------------------------------
97 DATA x /'X'/
98 DATA y /'Y'/
99 DATA z /'Z'/
100 DATA xx /'XX'/
101 DATA yy /'YY'/
102 DATA zz /'ZZ'/
103 DATA mess/'IMPOSED ACCELERATION DEFINITION '/
104C-----------------------------------------------
105C E x t e r n a l F u n c t i o n s
106C-----------------------------------------------
107 INTEGER NODGRNR5
108 EXTERNAL nodgrnr5
109C======================================================================|
110!---
111 WRITE (iout,1000)
112!---
113!---
114 i_vda = num ! (VDA ---> velocities + desplacements + accelerations)
115!---
116 ikine1(1:3*numnod) = 0
117 nodenum(1:nfxvel0) = 0
118 bid = zero
119 nacc = 0
120c--------------------------------------------------
121c COUNT /IMPACC Options
122c--------------------------------------------------
123 CALL hm_option_count('/IMPACC',nimpacc)
124!
125 ALLOCATE(iaccids(nimpacc))
126 iaccids(1:nimpacc) = 0
127!
128 is_available = .false.
129C--------------------------------------------------
130C START BROWSING MODEL /IMPACC
131C--------------------------------------------------
132 CALL hm_option_start('/IMPACC')
133C--------------------------------------------------
134C BROWSING MODEL IMPACC 1-> NIMPACC
135C--------------------------------------------------
136 DO iacc=1,nimpacc
137 titr = ''
138C--------------------------------------------------
139C EXTRACT DATAS OF /IMPACC/... LINE
140C--------------------------------------------------
141 CALL hm_option_read_key(lsubmodel,
142 . option_id = id,
143 . unit_id = uid,
144 . submodel_id = subid,
145 . submodel_index = nosub,
146 . option_titr = titr)
147!
148 iaccids(iacc) = id
149!
150C--------------------------------------------------
151C EXTRACT DATA (STRING VALUES)
152C--------------------------------------------------
153 CALL hm_get_intv('curveid' ,fct_id ,is_available,lsubmodel)
154 CALL hm_get_string('rad_dir' ,xyz ,ncharfield,is_available)
155 CALL hm_get_intv('inputsystem' ,inp_id ,is_available,lsubmodel)
156 CALL hm_get_intv('rad_sensor_id' ,sens_id ,is_available,lsubmodel)
157 CALL hm_get_intv('entityid' ,grn ,is_available,lsubmodel)
158!
159 CALL hm_get_floatv('xscale' ,facx,is_available,lsubmodel,unitab)
160 CALL hm_get_floatv('magnitude' ,fac1,is_available,lsubmodel,unitab)
161 CALL hm_get_floatv('rad_tstart' ,fac2,is_available,lsubmodel,unitab)
162 CALL hm_get_floatv('rad_tstop' ,fac3,is_available,lsubmodel,unitab)
163c--------------------------------------------------
164c Check skew and frame IDs
165c--------------------------------------------------
166 IF ((inp_id == 0).AND.(subid /= 0)) THEN
167 inp_id = lsubmodel(nosub)%SKEW
168 ENDIF
169c----
170 noskew = 0
171 noframe = 0
172c----
173 DO j=0,numskw+min(1,nspcond)*numsph+nsubmod
174 IF (inp_id == iskn(4,j+1)) THEN
175 noskew = j+1
176 EXIT
177 ENDIF
178 ENDDO
179 IF (inp_id > 0 .and. noskew == 0)
180 . CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
181 . i1= id,
182 . i2= noskew,
183 . c1='IMPOSED ACCELERATION',
184 . c2='IMPOSED ACCELERATION',
185 . c3= titr)
186c----
187c--------------------------------------------------
188c Default scale factors
189c--------------------------------------------------
190 CALL hm_get_floatv_dim('xscale' ,fscal_t ,is_available,lsubmodel,unitab)
191 CALL hm_get_floatv_dim('magnitude',fscal_a ,is_available,lsubmodel,unitab)
192 IF (facx == zero) facx = one * fscal_t
193 facx = one / facx
194 IF (fac1 == zero) fac1 = one * fscal_a
195 IF (fac3 == zero) fac3 = ep20
196c--------------------------------------------------
197 IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
198 fac1 = fac1 / (fscal_a * fscal_t * fscal_t)
199 ENDIF
200!---
201 num0 = num
202 nn = nodgrnr5(grn,igs,nodenum,igrnod,itabm1,mess)
203 num = num + nn
204 nacc = nacc + nn
205!
206 DO j=1,nn
207 i_vda = i_vda + 1
208 ibfv(1,i_vda) = nodenum(j)
209 ibfv(2,i_vda) = 0
210 ibfv(3,i_vda) = fct_id
211 ibfv(4,i_vda) = sens_id
212 ibfv(5,i_vda) = 0
213 ibfv(6,i_vda) = 0 ! init dans lecrby (si vitesse de rotation sur main)
214 ibfv(7,i_vda) = 0
215 ibfv(8,i_vda) = 0
216 ibfv(9,i_vda) = noframe
217 ibfv(10,i_vda) = 0
218 ibfv(11,i_vda) = 0
219 ibfv(12,i_vda) = iacc
220 ibfv(13,i_vda) = 0
221 ibfv(14,i_vda) = 0
222!
223 fac(1,i_vda)= fac1
224 fac(2,i_vda)= fac2
225 fac(3,i_vda)= fac3
226 fac(4,i_vda)= zero
227 fac(5,i_vda)= facx
228 fac(6,i_vda)= zero
229!
230 inod = iabs(nodenum(j))
231 nodid = itab(inod)
232!---
233! PRINT OUT
234!---
235 l_xyz = 0
236 IF (xyz(1:2) == xx .OR. xyz(1:2) == yy .OR. xyz(1:2) == zz) THEN
237 l_xyz = 2
238 ELSEIF (xyz(1:1) == x .OR. xyz(1:1) == y .OR. xyz(1:1) == z) THEN
239 l_xyz = 1
240 ENDIF
241!
242 WRITE (iout,'(3X,I10,3X,I10,3X,I10,9X,A2,3X,I10,3X,I10,2X,
243 . 1PG20.13,2X,1PG20.13,2X,G20.13,2X,G20.13,16X,I10)')
244 . nodid,iskn(4,noskew),0,xyz(1:l_xyz),ibfv(3,i_vda),sens_id,
245 . fac(1,i_vda),one/facx,fac(2,i_vda),fac(3,i_vda),ibfv(10,i_vda)
246!
247 IF (xyz(1:2) == xx) THEN
248 ibfv(2,i_vda) = 4 + noskew*10
249 CALL kinset(16,nodid,ikine(inod),4,noskew,ikine1(inod))
250 ELSEIF (xyz(1:2) == yy) THEN
251 ibfv(2,i_vda) = 5 + noskew*10
252 CALL kinset(16,nodid,ikine(inod),5,noskew,ikine1(inod))
253 ELSEIF (xyz(1:2) == 'ZZ') THEN
254 ibfv(2,i_vda) = 6 + noskew*10
255 CALL kinset(16,nodid,ikine(inod),6,noskew,ikine1(inod))
256 ELSEIF (xyz(1:1) == x) THEN
257 ibfv(2,i_vda)= 1 + noskew*10
258 CALL kinset(16,nodid,ikine(inod),1,noskew,ikine1(inod))
259 ELSEIF (xyz(1:1) == y) THEN
260 ibfv(2,i_vda) = 2 + noskew*10
261 CALL kinset(16,nodid,ikine(inod),2,noskew,ikine1(inod))
262 ELSEIF (xyz(1:1) == 'Z') THEN
263 ibfv(2,i_vda) = 3 + noskew*10
264 CALL kinset(16,nodid,ikine(inod),3,noskew,ikine1(inod))
265 ELSE
266 CALL ancmsg(msgid=164,
267 . msgtype=msgerror,
268 . anmode=aninfo,i1=id,
269 . c1=titr,
270 . c2=xyz)
271 ENDIF ! IF (XYZ(1:1) == X)
272 ENDDO ! DO J=1,NN
273!---------------------------
274 ENDDO ! DO IACC=1,NIMPACC
275c-----------
276c TEST DOUBLE IDs
277c-----------
278!
279 CALL udouble(iaccids,1,nimpacc,mess,0,bid)
280c
281 nimpacc = nacc
282!
283C-----
284 DEALLOCATE(iaccids)
285C-----
286 1000 FORMAT(//
287 .' IMPOSED ACCELERATIONS '/
288 .' --------------------- '/
289 .' NODE SKEW FRAME DIRECTION LOAD_CURVE',
290 .' SENSOR FSCALE ASCALE',
291 .' START_TIME STOP_TIME')
292C-----
293 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_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
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
id
initmumps id
Definition multiplerhs_example.m:4
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::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
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589