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