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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_inigrav (igrv, ibuf, agrv, itab, itabm1, igrpart, npc, unitab, iskn, itagnd, igrsurf, pld, bufsf, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_inigrav()

subroutine hm_read_inigrav ( integer, dimension(nigrv,*) igrv,
integer, dimension(*) ibuf,
agrv,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
type (group_), dimension(ngrpart) igrpart,
integer, dimension(*) npc,
type (unit_type_), intent(in) unitab,
integer, dimension(liskn,*) iskn,
integer, dimension(*) itagnd,
type (surf_), dimension(nsurf) igrsurf,
pld,
bufsf,
type(submodel_data), dimension(*) lsubmodel )

Definition at line 39 of file hm_read_inigrav.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE unitab_mod
46 USE message_mod
47 USE inigrav
48 USE groupdef_mod
49 USE submodel_mod
50 USE hm_option_read_mod
51 USE names_and_titles_mod , ONLY : nchartitle, ncharfield
52C-----------------------------------------------
53C I m p l i c i t T y p e s
54C-----------------------------------------------
55#include "implicit_f.inc"
56C-----------------------------------------------
57C C o m m o n B l o c k s
58C-----------------------------------------------
59#include "com04_c.inc"
60#include "units_c.inc"
61#include "param_c.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
66 INTEGER IGRV(NIGRV,*), IBUF(*), ITAB(*), ITABM1(*),NPC(*),
67 . ISKN(LISKN,*),ITAGND(*)
68 my_real
69 . agrv(lfacgrv,*)
70 my_real pld(*), bufsf(*)
71 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
72C-----------------------------------------------
73 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
74 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 my_real
79 . ngx,ngy,ngz,dotprod
80 INTEGER UID,
81 . IAD,J,K,ID,IFLAGUNIT,IADPL
82 CHARACTER X*1, Y*1, Z*1, XX*2, YY*2, ZZ*2, MESS*40
83 CHARACTER(LEN=NCHARTITLE)::TITR
84
85 INTEGER :: IGU,ISU,IGRAV, IG, IS, IDIR, PN1, ICURS, IIGRAV,IIG,IIS
86 my_real :: bx_,by_,bz_, grav0,nx,ny,nz,norm,psurf
87 LOGICAL :: lFOUND, lPLANAR_SURF, lUSER_SURF, lOUTP, lGRAV, lUNIQUE, IS_AVAILABLE
88 CHARACTER*2 :: CDIR
89
90 INTEGER :: M,ID_LIST(NINIGRAV)
91C-----------------------------------------------
92 DATA x/'X'/
93 DATA y/'Y'/
94 DATA z/'Z'/
95 DATA xx/'XX'/
96 DATA yy/'YY'/
97 DATA zz/'ZZ'/
98 DATA mess/'INITIAL GRAVITY LOADING DEFINITION '/
99C=======================================================================
100C
101 ! Initialization of variable
102 lplanar_surf = .false.
103 luser_surf = .false.
104 lgrav = .true.
105 loutp = .true.
106 is_available = .false.
107 ngx = zero
108 ngy = zero
109 ngz = zero
110C
111 ! Start reading /INIGRAV card
112 CALL hm_option_start('/INIGRAV')
113C
114 ! Loop over /INIGRAV
115 DO k=1,ninigrav
116C
117 ! Read title, ID and Unit ID
118 titr = ''
119 CALL hm_option_read_key(lsubmodel,
120 . option_id = id,
121 . unit_id = uid,
122 . option_titr = titr)
123C
124 ! Checking unit ID
125 iflagunit = 0
126 DO j=1,unitab%NUNITS
127 IF (unitab%UNIT_ID(j) == uid) THEN
128 iflagunit = 1
129 EXIT
130 ENDIF
131 ENDDO
132C
133 id_list(k)=id
134 lunique = .true.
135 DO m=1,k-1
136 IF(id==id_list(m))THEN
137 lunique=.false.
138 EXIT
139 ENDIF
140 ENDDO
141C
142 IF (uid /= 0 .AND. iflagunit == 0) THEN
143 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
144 . i2=uid,i1=id,
145 . c1='INITIAL GRAVITY LOADING',
146 . c2='INITIAL GRAVITY LOADING',
147 . c3= titr)
148 loutp = .false.
149 ENDIF
150C
151 ! Reading 1st card : ids
152 CALL hm_get_intv('grpart_ID',igu,is_available,lsubmodel)
153 CALL hm_get_intv('surf_ID' ,isu,is_available,lsubmodel)
154 CALL hm_get_intv('grav_ID' ,igrav,is_available,lsubmodel)
155C
156 ! Reading 2nd card : pressure, etc
157 CALL hm_get_floatv('Pref' ,psurf,is_available, lsubmodel, unitab)
158 ! Only if ISU == 0
159 IF (isu == 0) THEN
160 CALL hm_get_floatv('Bx',bx_,is_available, lsubmodel, unitab)
161 CALL hm_get_floatv('By',by_,is_available, lsubmodel, unitab)
162 CALL hm_get_floatv('Bz',bz_,is_available, lsubmodel, unitab)
163 ENDIF
164C
165 ! Checking Gravity ID
166 lfound = .false.
167 iigrav = 0
168 grav0 = zero
169 DO ig=1,ngrav
170 IF (igrav == igrv(5,ig)) THEN
171 lfound = .true.
172 iigrav = ig
173 icurs = igrv(3,ig)
174 IF (icurs > 0) THEN
175 pn1 = npc(icurs)
176 grav0 = agrv(1,ig)*pld(pn1+1)
177 ELSE
178 grav0 = agrv(1,ig)
179 ENDIF
180 idir = mod(igrv(2,ig),10)
181 ngx = zero
182 ngy = zero
183 ngz = zero
184 SELECT CASE (idir)
185 CASE(1)
186 cdir(1:2) =' X'
187 ngx = one
188 CASE(2)
189 cdir(1:2) =' Y'
190 ngy = one
191 CASE(3)
192 cdir(1:2) =' Z'
193 ngz = one
194 END SELECT
195 cdir(1:1)="+"
196 IF (grav0 < zero) THEN
197 cdir(1:1)="-"
198 ngx = -ngx
199 ngy = -ngy
200 ngz = -ngz
201 ENDIF
202 EXIT
203 ENDIF
204 ENDDO
205 ! Wrong gravity ID
206 IF (.NOT.lfound) THEN
207 CALL ancmsg(msgid=73,anmode=aninfo,msgtype=msgerror,
208 . i1=id,
209 . c1=titr,
210 . i2= igrav,
211 . c2='DOES NOT REFER TO A VALID /GRAV ID')
212 loutp = .false.
213 lgrav = .false.
214 ENDIF
215 ! Inigrav ID duplicated
216 IF (.NOT.lunique) THEN
217 CALL ancmsg(msgid=73,anmode=aninfo,msgtype=msgerror,
218 . i1=id,
219 . c1=titr,
220 . i2= id,
221 . c2='IDENTIFIER IS DUPLICATED')
222 ENDIF
223C
224 ! Checking surface ID
225 iis = 0
226 IF (isu > 0) THEN
227 lfound = .false.
228 DO is=1,nsurf
229 IF (isu == igrsurf(is)%ID)THEN
230 SELECT CASE(igrsurf(is)%TYPE)
231 CASE(0)
232 iis = is
233 luser_surf=.true.
234 iadpl = igrsurf(is)%IAD_BUFR
235 lfound = .true.
236 bx_ = zero
237 by_ = zero
238 bz_ = zero
239 nx = zero
240 ny = zero
241 nz = zero
242 nx = zero
243 ny = zero
244 nz = zero
245 EXIT
246 CASE(200)
247 iis = is
248 lplanar_surf=.true.
249 iadpl = igrsurf(is)%IAD_BUFR
250 lfound = .true.
251 bx_ = bufsf(iadpl+1)
252 by_ = bufsf(iadpl+2)
253 bz_ = bufsf(iadpl+3)
254 nx = bufsf(iadpl+4)- bufsf(iadpl+1)
255 ny = bufsf(iadpl+5)- bufsf(iadpl+2)
256 nz = bufsf(iadpl+6)- bufsf(iadpl+3)
257 norm = sqrt(nx*nx+ny*ny+nz*nz)
258 nx = nx / norm
259 ny = ny / norm
260 nz = nz / norm
261 EXIT
262 END SELECT
263 ENDIF
264 ENDDO
265 ! Wrong surface ID
266 IF (.NOT.lfound) THEN
267 CALL ancmsg(msgid=73,anmode=aninfo,msgtype=msgerror,
268 . i1=id,
269 . c1=titr,
270 . i2= isu,
271 . c2='DOES NOT REFER TO A VALID /SURF ID')
272 loutp = .false.
273 ENDIF
274 ELSE
275 nx = ngx
276 ny = ngy
277 nz = ngz
278 ENDIF
279C
280 ! Checking GRPART ID
281 lfound = .false.
282 iig = 0
283 iad = ngrnod+ngrbric+ngrquad+ngrshel+ngrsh3n+ngrtrus+ngrbeam+ngrspri
284 IF (igu > 0) THEN
285 DO ig=1,ngrpart
286 IF (igu == igrpart(ig)%ID) THEN
287 iig = ig
288 lfound = .true.
289 EXIT
290 ENDIF
291 ENDDO
292 ! Wrong GRPART ID
293 IF (.NOT.lfound) THEN
294 CALL ancmsg(msgid=73,anmode=aninfo,msgtype=msgerror,
295 . i1=id,
296 . c1=titr,
297 . i2= igu,
298 . c2='DOES NOT REFER TO A VALID GRPART ')
299 loutp = .false.
300 ENDIF
301 ENDIF
302C
303 ! Checking the normal
304 IF (lplanar_surf .AND. lgrav) THEN
305 dotprod = nx*ngx+ny*ngy+nz*ngz
306 IF(abs(dotprod)<=em20)THEN
307 CALL ancmsg(msgid=73,anmode=aninfo,msgtype=msgerror,
308 . i1=id,
309 . c1=titr,
310 . i2= igrav,
311 . c2='REFER TO A GRAVITY DIRECTION COLINEAR TO THE INPUT SURFACE')
312 loutp = .false.
313 ENDIF
314 ENDIF
315C
316 ! Storing IDs in INIGRV table
317 inigrv(1,k) = iig
318 inigrv(2,k) = iis
319 inigrv(3,k) = iigrav
320 inigrv(4,k) = id
321C
322 ! Storing real data in LINIGRAV table
323 linigrav(01,k) = bx_
324 linigrav(02,k) = by_
325 linigrav(03,k) = bz_
326 linigrav(04,k) = nx
327 linigrav(05,k) = ny
328 linigrav(06,k) = nz
329 linigrav(07,k) = grav0
330 linigrav(08,k) = ngx
331 linigrav(09,k) = ngy
332 linigrav(10,k) = ngz
333 linigrav(11,k) = psurf
334C
335 ! Printout data
336 IF (lplanar_surf) THEN
337 WRITE (iout,2000)
338 WRITE (iout,fmt='(A)') ''
339 WRITE (iout,3000) igu,isu,igrav,bx_,by_,bz_, psurf
340 WRITE (iout,3001) cdir(2:2)
341 WRITE (iout,3002) grav0
342 IF(lplanar_surf) WRITE (iout,3003) nx,ny,nz
343 ELSEIF(luser_surf)THEN
344 WRITE (iout,2001)
345 WRITE (iout,fmt='(A)') ''
346 WRITE (iout,3005) igu,isu,igrav, psurf
347 WRITE (iout,3001) cdir(2:2)
348 WRITE (iout,3002) grav0
349 IF(luser_surf)WRITE (iout,3004)
350 ENDIF
351 ENDDO !next K
352C-----------
353 RETURN
354C-----------
355 2000 FORMAT(//
356 .' INITIAL GRAVITY LOADING '/
357 .' ----------------------- '/
358 .' GRPART_ID SURF_ID GRAV_ID BX BY BZ PSURF ')
359
360 2001 FORMAT(//
361 .' INITIAL GRAVITY LOADING '/
362 .' ----------------------- '/
363 .' GRPART_ID SURF_ID GRAV_ID PSURF ')
364
365 3000 FORMAT(2x,i10,2x,i10,2x,i10,2x,e12.4,2x,e12.4,2x,e12.4,2x,e12.4)
366 3005 FORMAT(2x,i10,2x,i10,2x,i10,3x,e12.4)
367
368 3001 FORMAT(' GRAVITY ORIENTATION : ',1x,a2)
369 3002 FORMAT(' GRAVITY VALUE : ',2x,e12.4)
370 3003 FORMAT(' SURFACE ORIENTATION : ',2x,e12.4,2x,e12.4,2x,e12.4)
371 3004 FORMAT(' USER DEFINED SURFACE')
372C-----------
373 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
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
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
inigrav::inigrv
integer, dimension(:,:), allocatable inigrv
Definition inigrav_mod.F:38
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::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
submodel_mod
Definition submodel_mod.F:717
unitab_mod
Definition unitab_mod.F:517
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:895