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

Go to the source code of this file.

Functions/Subroutines

subroutine read_impdisp_fgeo (nfgeo, inum, iopt, fbfvel, ibfvel, itab, itabm1, igrnod, nom_opt, x0, ixr, ipart, ipartr, unitab, lsubmodel)

Function/Subroutine Documentation

◆ read_impdisp_fgeo()

subroutine read_impdisp_fgeo ( integer, intent(in) nfgeo,
integer, intent(inout) inum,
integer, intent(inout) iopt,
intent(out) fbfvel,
integer, dimension(nifv,nfxvel), intent(out) ibfvel,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
type (group_), dimension(ngrnod), intent(in) igrnod,
integer, dimension(lnopt1,*), intent(out) nom_opt,
intent(in) x0,
integer, dimension(nixr,*), intent(in) ixr,
integer, dimension(lipart1,*), intent(in) ipart,
integer, dimension(*) ipartr,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 42 of file read_impdisp_fgeo.F.

46C============================================================================
47C M o d u l e s
48C-----------------------------------------------
49 USE message_mod
50 USE groupdef_mod
51 USE submodel_mod
52 USE hm_option_read_mod
53 USE unitab_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 "com04_c.inc"
63#include "scr17_c.inc"
64#include "param_c.inc"
65#include "units_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER ,INTENT(IN ) :: NFGEO
70 INTEGER ,INTENT(INOUT) :: INUM,IOPT
71 INTEGER ,DIMENSION(*) :: ITAB,ITABM1,IPARTR
72 INTEGER ,DIMENSION(LIPART1,*) ,INTENT(IN) :: IPART
73 INTEGER ,DIMENSION(NIXR,*) ,INTENT(IN) :: IXR
74 INTEGER ,DIMENSION(LNOPT1,*) ,INTENT(OUT) :: NOM_OPT
75 INTEGER ,DIMENSION(NIFV,NFXVEL) ,INTENT(OUT) :: IBFVEL
76 my_real ,DIMENSION(LFXVELR,NFXVEL) ,INTENT(OUT) :: fbfvel
77 my_real ,DIMENSION(3,NUMNOD) ,INTENT(IN):: x0
78 TYPE (UNIT_TYPE_) ,INTENT(IN) :: UNITAB
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 I,K,N,N1,N2,NUM0,IFGEO,JPART,NNOD,NOSKEW,NOFRAME,
85 . SENS_ID,PART_ID,OPTID,FUN_ID,IFRA_OUT,ILAGM,
86 . FGEO,IDIS,ICOOR,DISTRIBUTION
87 INTEGER ,DIMENSION(NUMNOD) :: NOD1
88 my_real ,DIMENSION(NUMNOD) :: xf,yf,zf
89 my_real :: tstart,tstop,xscale,fscal_t,fscal_v,dist,xi,yi,zi,xrf,yrf,zrf
90 CHARACTER(LEN=NCHARKEY) :: KEY
91 CHARACTER(LEN=NCHARTITLE) :: TITR,MESS
92 LOGICAL IS_AVAILABLE
93C-----------------------------------------------
94C E x t e r n a l F u n c t i o n s
95C-----------------------------------------------
96 INTEGER USR2SYS
97 EXTERNAL usr2sys
98C-----------------------------------------------
99C D a t a
100C-----------------------------------------------
101 DATA mess/'IMPOSED DISPLACEMENT DEFINITION '/
102C======================================================================|
103 is_available = .false.
104
105 num0 = inum+1
106c--------------------------------------------------
107c READ /IMPVEL/FGEO cards
108c--------------------------------------------------
109c
110 CALL hm_option_start('/IMPDISP/FGEO')
111c
112c--------------------------------------------------
113 DO ifgeo = 1,nfgeo
114c--------------------------------------------------
115 CALL hm_option_read_key(lsubmodel,
116 . option_id = optid,
117 . option_titr = titr,
118 . keyword2 = key)
119c
120 iopt = iopt + 1
121 nom_opt(1,iopt) = optid
122 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,iopt),ltitr)
123c
124c--------------------------------------------------
125 icoor = 0
126 fgeo = 1
127 idis = 0
128 ilagm = 0
129 ifra_out = 0
130 noskew = 0
131 noframe = 0
132c--------------------------------------------------
133c READ STRING VALUES from /IMPDISP
134c--------------------------------------------------
135c CALL HM_GET_INTV ('distribution' ,DISTRIBUTION ,IS_AVAILABLE,LSUBMODEL)
136c
137 CALL hm_get_intv ('curveid' ,fun_id ,is_available,lsubmodel)
138 CALL hm_get_intv ('rad_spring_part',part_id ,is_available,lsubmodel)
139 CALL hm_get_intv ('rad_sensor_id' ,sens_id ,is_available,lsubmodel)
140c
141 CALL hm_get_floatv('xscale' ,xscale ,is_available,lsubmodel,unitab)
142 CALL hm_get_floatv('rad_tstart' ,tstart ,is_available,lsubmodel,unitab)
143 CALL hm_get_floatv('rad_tstop' ,tstop ,is_available,lsubmodel,unitab)
144c
145 CALL hm_get_intv('distribution_table_count' ,nnod ,is_available,lsubmodel)
146 DO i = 1,nnod
147 CALL hm_get_int_array_index('location_unit_node',nod1(i),i,is_available,lsubmodel)
148 CALL hm_get_float_array_index('rad_node_pos_X' ,xf(i) ,i ,is_available,lsubmodel,unitab)
149 CALL hm_get_float_array_index('rad_node_pos_Y' ,yf(i) ,i ,is_available,lsubmodel,unitab)
150 CALL hm_get_float_array_index('rad_node_pos_Z' ,zf(i) ,i ,is_available,lsubmodel,unitab)
151 ENDDO
152c
153c--------------------------------------------------
154c Default scale factors
155c--------------------------------------------------
156 IF (xscale == zero) THEN
157 CALL hm_get_floatv_dim('xscale' ,fscal_t ,is_available,lsubmodel,unitab)
158 xscale = one * fscal_t
159 ENDIF
160 IF (tstop == zero) tstop = infinity
161c
162 WRITE (iout,1000)
163c--------------------------------------------------
164c Treatment of explicitly defined nodes
165c--------------------------------------------------
166 DO i=1,nnod
167c
168 IF (nod1(i) > 0) THEN
169 inum = inum + 1
170 n1 = usr2sys(nod1(i),itabm1,mess,optid)
171 xi = x0(1,n1)
172 yi = x0(2,n1)
173 zi = x0(3,n1)
174 dist = sqrt((xf(i) - xi)**2 + (yf(i) - yi)**2 + (zf(i) - zi)**2)
175c
176 ibfvel(1 ,inum) = n1
177 ibfvel(2 ,inum) = 0
178 ibfvel(3 ,inum) = fun_id
179 ibfvel(4 ,inum) = sens_id
180 ibfvel(5 ,inum) = 0
181 ibfvel(6 ,inum) = 0 ! init dans lecrby (si vitesse de rotation sur main)
182 ibfvel(7 ,inum) = idis
183 ibfvel(8 ,inum) = ilagm
184 ibfvel(9 ,inum) = noframe
185 ibfvel(10,inum) = icoor
186 ibfvel(11,inum) = 0
187 ibfvel(12,inum) = iopt
188 ibfvel(13,inum) = fgeo
189 ibfvel(14,inum) = 0
190 ibfvel(15,inum) = 0
191c
192 fbfvel(1,inum) = dist
193 fbfvel(2,inum) = tstart
194 fbfvel(3,inum) = tstop
195 fbfvel(4,inum) = zero
196 fbfvel(5,inum) = xscale
197 fbfvel(6,inum) = zero
198 IF (dist > zero) THEN
199 fbfvel(7,inum) = (xf(i) - xi) / dist
200 fbfvel(8,inum) = (yf(i) - yi) / dist
201 fbfvel(9,inum) = (zf(i) - zi) / dist
202 ELSE
203 fbfvel(7,inum) = zero
204 fbfvel(8,inum) = zero
205 fbfvel(9,inum) = zero
206 END IF
207c
208 WRITE (iout,2000) itab(n1),fun_id,sens_id,
209 . dist,one/xscale,tstart,tstop,xf(i),yf(i),zf(i)
210 END IF
211 END DO
212c--------------------------------------------------
213c Treatment of nodes defined by spring part
214c--------------------------------------------------
215 IF (part_id > 0) THEN
216 jpart = 0
217 DO n=1,npart
218 IF (ipart(4,n) == part_id) jpart = n
219 ENDDO
220c
221 DO n=1,numelr
222 IF (ipartr(n) == jpart) THEN
223 inum = inum + 1
224 n1 = ixr(2,n)
225 n2 = ixr(3,n)
226 xi = x0(1,n1)
227 yi = x0(2,n1)
228 zi = x0(3,n1)
229 xrf = x0(1,n2)
230 yrf = x0(2,n2)
231 zrf = x0(3,n2)
232 dist= sqrt((xrf-xi)**2 + (yrf-yi)**2 + (zrf-zi)**2)
233c
234 ibfvel(1 ,inum) = n1
235 ibfvel(2 ,inum) = 0
236 ibfvel(3 ,inum) = fun_id
237 ibfvel(4 ,inum) = sens_id
238 ibfvel(5 ,inum) = 0
239 ibfvel(6 ,inum) = 0
240 ibfvel(7 ,inum) = idis
241 ibfvel(8 ,inum) = ilagm
242 ibfvel(9 ,inum) = noframe
243 ibfvel(10,inum) = icoor
244 ibfvel(11,inum) = 0
245 ibfvel(12,inum) = iopt
246 ibfvel(13,inum) = fgeo
247 ibfvel(14,inum) = 0
248 ibfvel(15,inum) = 0
249 ibfvel(16,inum) = 0
250c
251 fbfvel(1,inum) = dist
252 fbfvel(2,inum) = tstart
253 fbfvel(3,inum) = tstop
254 fbfvel(4,inum) = zero
255 fbfvel(5,inum) = xscale
256 fbfvel(6,inum) = zero
257 IF (dist > zero) THEN
258 fbfvel(7,inum) = (xrf - xi) / dist
259 fbfvel(8,inum) = (yrf - yi) / dist
260 fbfvel(9,inum) = (zrf - zi) / dist
261 ELSE
262 fbfvel(7,inum) = zero
263 fbfvel(8,inum) = zero
264 fbfvel(9,inum) = zero
265 END IF
266c
267 WRITE (iout,2000) itab(n1),fun_id,sens_id,
268 . dist,one/xscale,tstart,tstop,xrf,yrf,zrf
269 END IF
270 END DO
271 END IF ! PART_ID > 0
272c----------------------------------------------------------------------
273c /IMPDISP/FGEO CALCULE LE NOMBRE D'OCCURENCES D'ONE NOEUD DE DESTINATION
274c--------------------------------------------------
275 DO n = 1,inum
276 IF (ibfvel(13,n) /= 2) cycle
277 n2 = ibfvel(14,n)
278 k = 1
279 DO i = 1,inum
280 IF (i == n) cycle
281 IF (ibfvel(13,i) /= 2) cycle
282 IF (ibfvel(14,i) == n2) k = k + 1
283 END DO
284 ibfvel(16,n) = k
285 END DO
286c-----------
287 END DO ! IFGEO = 1,NFGEO
288c--------------------------------------------------
289 1000 FORMAT(//
290 .' IMPOSED DISPLACEMENTS PRESCRIBED FINAL GEOMETRY '/
291 .' ------------------------------------------------ '/
292 .' NODE LOAD_CURVE SENSOR FSCALE ',
293 .' ASCALE START_TIME STOP_TIME',
294 .' X Y Z' )
295 2000 FORMAT(3(1x,i10),3(1x,1pg20.13),4(1x,g20.13))
296c--------------------------------------------------
297 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
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_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
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
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
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160