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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_inimap2d (inimap2d, func2d, itabm1, xgrid, igrbric, igrquad, igrsh3n, unitab, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_inimap2d()

subroutine hm_read_inimap2d ( type(inimap2d_struct), dimension(ninimap2d), intent(inout) inimap2d,
type(func2d_struct), dimension(nfunc2d), intent(in) func2d,
integer, dimension(*), intent(in) itabm1,
dimension(3, *), intent(in) xgrid,
type (group_), dimension(ngrbric) igrbric,
type (group_), dimension(ngrquad) igrquad,
type (group_), dimension(ngrsh3n) igrsh3n,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(nsubmod), intent(in) lsubmodel )

Definition at line 45 of file hm_read_inimap2d.F.

47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE inimap2d_mod
51 USE func2d_mod
52 USE message_mod
53 USE groupdef_mod
54 USE unitab_mod
55 USE submodel_mod
56 USE hm_option_read_mod
57 USE names_and_titles_mod , ONLY : nchartitle, ncharline
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C C o m m o n B l o c k s
64C-----------------------------------------------
65#include "units_c.inc"
66!NFUNCT
67#include "com04_c.inc"
68C-----------------------------------------------
69C D u m m y A r g u m e n t s
70C-----------------------------------------------
71 INTEGER, INTENT(IN) :: ITABM1(*)
72 my_real, INTENT(IN) :: xgrid(3, *)
73 TYPE(INIMAP2D_STRUCT), DIMENSION(NINIMAP2D), INTENT(INOUT) :: INIMAP2D
74 TYPE(FUNC2D_STRUCT), DIMENSION(NFUNC2D), INTENT(IN) :: FUNC2D
75C-----------------------------------------------
76 TYPE (GROUP_) , DIMENSION(NGRBRIC) :: IGRBRIC
77 TYPE (GROUP_) , DIMENSION(NGRQUAD) :: IGRQUAD
78 TYPE (GROUP_) , DIMENSION(NGRSH3N) :: IGRSH3N
79 TYPE (UNIT_TYPE_), INTENT(IN) :: UNITAB
80 TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
81C-----------------------------------------------
82C E x t e r n a l F u n c t i o n s
83C-----------------------------------------------
84 INTEGER USR2SYS
85C-----------------------------------------------
86C L o c a l V a r i a b l e s
87C-----------------------------------------------
88 CHARACTER MESS*40
89 CHARACTER(LEN=NCHARLINE) :: KEY2
90 CHARACTER(LEN=NCHARTITLE) :: TITR
91 INTEGER :: II, JJ, LL, IFUNC1, IFUNC2, IFUNC3, LNODID1, LNODID2, LNODID3, KK, ID, UID, J
92 my_real :: norm
93 DATA mess/'INFILE'/
94 INTEGER :: GRBRICID_LOC, GRQUADID_LOC, GRSH3NID_LOC, IAD1, IAD2, SIZE
95 my_real :: x0(3), x1(3), x2(3), vec3(3), fac1, fac2, fac_vel
96 LOGICAL :: FOUND
97 CHARACTER(LEN=NCHARLINE) :: FILENAME
98 CHARACTER MSG_DESCRIPTION*32
99 LOGICAL :: IS_AVAILABLE
100
101 IF (ninimap2d > 0) THEN
102 WRITE(iout, 2000)
103 ENDIF
104
105 is_available = .false.
106
107 CALL hm_option_start('/INIMAP2D')
108
109 DO kk = 1, ninimap2d
110 inimap2d(kk)%CORRECTLY_READ=.true.
111 CALL hm_option_read_key(lsubmodel, option_id = id, unit_id = uid, option_titr = titr,
112 . keyword2 = key2)
113 inimap2d(kk)%TITLE = trim(titr)
114 WRITE(iout, 2001) id
115 WRITE(iout, 2002) trim(titr)
116 inimap2d(kk)%ID = id
117 inimap2d(kk)%FILE = .false.
118
119 IF (key2(1:2) == 'VP') THEN
120 inimap2d(kk)%FORMULATION = 1
121 WRITE(iout, 2010)
122 ELSE IF (key2(1:2) == 'VE') THEN
123 inimap2d(kk)%FORMULATION = 2
124 WRITE(iout, 2020)
125 ELSE IF (key2(1:5) == 'FILE ') THEN
126 inimap2d(kk)%FORMULATION = 1
127 inimap2d(kk)%FILE = .true.
128 WRITE(iout, 2025)
129 ELSE
130C Error message here
131 ENDIF
132 CALL hm_get_intv('node_ID1', inimap2d(kk)%NODEID1, is_available, lsubmodel)
133 CALL hm_get_intv('node_ID2', inimap2d(kk)%NODEID2, is_available, lsubmodel)
134 CALL hm_get_intv('node_ID3', inimap2d(kk)%NODEID3, is_available, lsubmodel)
135
136 inimap2d(kk)%GRBRICID = 0
137 inimap2d(kk)%GRQUADID = 0
138 inimap2d(kk)%GRSH3NID = 0
139
140 CALL hm_get_intv('grbric_ID', inimap2d(kk)%GRBRICID, is_available, lsubmodel)
141 CALL hm_get_intv('grquad_ID', inimap2d(kk)%GRQUADID, is_available, lsubmodel)
142 CALL hm_get_intv('grtria_ID', inimap2d(kk)%GRSH3NID, is_available, lsubmodel)
143
144C ==============
145C Check if found
146C ==============
147 IF (inimap2d(kk)%GRBRICID + inimap2d(kk)%GRQUADID + inimap2d(kk)%GRSH3NID == 0) THEN
148 CALL ancmsg(msgid=1554, msgtype=msgwarning, anmode=aninfo,
149 . c1='IN /INIMAP2D OPTION')
150 ELSE
151 grbricid_loc = -1
152 grquadid_loc = -1
153 grsh3nid_loc = -1
154 IF (inimap2d(kk)%GRBRICID /= 0) THEN
155 DO j = 1,ngrbric
156 IF (inimap2d(kk)%GRBRICID == igrbric(j)%ID) THEN
157 grbricid_loc = j
158 inimap2d(kk)%GRBRICID = j
159 EXIT
160 ENDIF
161 ENDDO
162 IF (grbricid_loc == -1) THEN
163 CALL ancmsg(msgid=1554,
164 . msgtype=msgerror,
165 . anmode=aninfo,
166 . c1='IN /INIMAP2D OPTION',
167 . i1=inimap2d(kk)%GRBRICID)
168 ENDIF
169 ENDIF
170 IF (inimap2d(kk)%GRQUADID /= 0) THEN
171 DO j = 1,ngrquad
172 IF (inimap2d(kk)%GRQUADID == igrquad(j)%ID) THEN
173 grquadid_loc = j
174 inimap2d(kk)%GRQUADID = j
175 EXIT
176 ENDIF
177 ENDDO
178 IF (grquadid_loc == -1) THEN
179 CALL ancmsg(msgid=1554,
180 . msgtype=msgerror,
181 . anmode=aninfo,
182 . c1='IN /INIMAP2D OPTION',
183 . i1=inimap2d(kk)%GRQUADID)
184 ENDIF
185 ENDIF
186 IF (inimap2d(kk)%GRSH3NID /= 0) THEN
187 DO j = 1,ngrsh3n
188 IF (inimap2d(kk)%GRSH3NID == igrsh3n(j)%ID) THEN
189 grsh3nid_loc = j
190 inimap2d(kk)%GRSH3NID = j
191 EXIT
192 ENDIF
193 ENDDO
194 IF (grsh3nid_loc == -1) THEN
195 CALL ancmsg(msgid=1554,
196 . msgtype=msgerror,
197 . anmode=aninfo,
198 . c1='IN /INIMAP2D OPTION',
199 . i1=inimap2d(kk)%GRSH3NID)
200 ENDIF
201 ENDIF
202 ENDIF
203
204C ==============
205C functions
206C ==============
207 IF(.NOT. inimap2d(kk)%FILE)THEN
208 CALL hm_get_intv('FUN_IDV', ifunc3, is_available, lsubmodel)
209 CALL hm_get_floatv('FSCALEV', fac_vel, is_available, lsubmodel, unitab)
210 msg_description = 'CANNOT READ VELOCITY FUNCTION ID'
211 IF (fac_vel == zero) fac_vel = one
212 WRITE(iout, 2040) ifunc3, fac_vel
213 IF (ifunc3 > 0) THEN
214 found = .false.
215 DO jj = 1, nfunc2d
216 IF (ifunc3 == func2d(jj)%ID) THEN
217 inimap2d(kk)%FUNC_VEL = jj
218 found = .true.
219 EXIT
220 ENDIF
221 ENDDO
222 IF (.NOT. found) THEN
223 CALL ancmsg(msgid = 120, msgtype = msgerror, anmode = aninfo,
224 . c1 = 'IN /INIMAP2D OPTION', i1 = ifunc3)
225 ENDIF
226 ELSE
227 inimap2d(kk)%FUNC_VEL = 0
228 ENDIF
229 IF (fac_vel == zero) fac_vel = one
230 inimap2d(kk)%FAC_VEL = fac_vel
231
232 CALL hm_get_intv('Nb_integr', SIZE, is_available, lsubmodel)
233
234 inimap2d(kk)%NBMAT = SIZE
235 ALLOCATE(inimap2d(kk)%FUNC_ALPHA(size), inimap2d(kk)%FUNC_RHO(size),
236 . inimap2d(kk)%FUNC_ENER(size), inimap2d(kk)%FUNC_PRES(size),
237 . inimap2d(kk)%FAC_PRES_ENER(size), inimap2d(kk)%FAC_RHO(size))
238 inimap2d(kk)%FUNC_ALPHA(1:size) = 0
239 DO ll = 1, SIZE
240 CALL hm_get_int_array_index('fct_Idvfi', ifunc1, ll, is_available, lsubmodel)
241 CALL hm_get_int_array_index('fct_IDri', ifunc2, ll, is_available, lsubmodel)
242 CALL hm_get_float_array_index('Fscalerhoi', fac1, ll, is_available, lsubmodel, unitab)
243 CALL hm_get_int_array_index('fct_IDpei', ifunc3, ll, is_available, lsubmodel)
244 CALL hm_get_float_array_index('Fscalepei', fac2, ll, is_available, lsubmodel, unitab)
245
246 IF (ifunc1 > 0) THEN
247 found = .false.
248 DO jj = 1, nfunc2d
249 IF (ifunc1 == func2d(jj)%ID) THEN
250 inimap2d(kk)%FUNC_ALPHA(ll) = jj
251 found = .true.
252 EXIT
253 ENDIF
254 ENDDO
255 IF (.NOT. found) THEN
256 CALL ancmsg(msgid = 1734, msgtype = msgerror, anmode = aninfo,
257 . c1 = 'IN /INIMAP2D OPTION', i1 = ifunc1)
258 ENDIF
259 ELSE
260 inimap2d(kk)%FUNC_ALPHA(ll) = 0
261 ENDIF
262 IF (ifunc2 > 0) THEN
263 found = .false.
264 DO jj = 1, nfunc2d
265 IF (ifunc2 == func2d(jj)%ID) THEN
266 inimap2d(kk)%FUNC_RHO(ll) = jj
267 found = .true.
268 EXIT
269 ENDIF
270 ENDDO
271 IF (.NOT. found) THEN
272 CALL ancmsg(msgid = 1734, msgtype = msgerror, anmode = aninfo,
273 . c1 = 'IN /INIMAP2D OPTION', i1 = ifunc2)
274 ENDIF
275 ELSE
276 inimap2d(kk)%FUNC_RHO(ll) = 0
277 ENDIF
278 IF (ifunc3 > 0) THEN
279 found = .false.
280 DO jj = 1, nfunc2d
281 IF (ifunc3 == func2d(jj)%ID) THEN
282 IF (inimap2d(kk)%FORMULATION == 1) THEN
283 inimap2d(kk)%FUNC_PRES(ll) = jj
284 inimap2d(kk)%FUNC_ENER(ll) = 0
285 ELSE IF (inimap2d(kk)%FORMULATION == 2) THEN
286 inimap2d(kk)%FUNC_PRES(ll) = 0
287 inimap2d(kk)%FUNC_ENER(ll) = jj
288 ENDIF
289 found = .true.
290 EXIT
291 ENDIF
292 ENDDO
293 IF (.NOT. found) THEN
294 CALL ancmsg(msgid = 1734, msgtype = msgerror, anmode = aninfo,
295 . c1 = 'IN /INIMAP2D OPTION', i1 = ifunc3)
296 ENDIF
297 ELSE
298 inimap2d(kk)%FUNC_PRES(ll) = 0
299 inimap2d(kk)%FUNC_ENER(ll) = 0
300 ENDIF
301 IF (fac1 == zero) fac1 = one
302 IF (fac2 == zero) fac2 = one
303 inimap2d(kk)%FAC_RHO(ll) = fac1
304 inimap2d(kk)%FAC_PRES_ENER(ll) = fac2
305 IF (inimap2d(kk)%FORMULATION == 1) THEN
306 WRITE(iout, 2060) ll, ifunc1, ifunc2, fac1, ifunc3, fac2
307 ENDIF
308 IF (inimap2d(kk)%FORMULATION == 2) THEN
309 WRITE(iout, 2050) ll, ifunc1, ifunc2, fac1, ifunc3, fac2
310 ENDIF
311 ENDDO
312
313 ELSEIF(key2(1:5) == 'FILE ')THEN
314 CALL hm_get_string('Filename', filename, ncharline, is_available)
315 msg_description = 'CANNOT READ FILENAME '
316 WRITE(iout, 2026)trim(filename)
317 CALL lec_inimap2d_file(inimap2d(kk), filename, id, titr )
318 ENDIF
319 lnodid1 = 0
320 lnodid2 = 0
321 lnodid3 = 0
322 IF (inimap2d(kk)%NODEID1 > 0) THEN
323 lnodid1 = usr2sys(inimap2d(kk)%NODEID1, itabm1, mess, inimap2d(kk)%NODEID1)
324 inimap2d(kk)%NODEID1 = lnodid1
325 ENDIF
326 IF (inimap2d(kk)%NODEID2 > 0) THEN
327 lnodid2 = usr2sys(inimap2d(kk)%NODEID2, itabm1, mess, inimap2d(kk)%NODEID2)
328 inimap2d(kk)%NODEID2 = lnodid2
329 ENDIF
330 IF (inimap2d(kk)%NODEID3 > 0) THEN
331 lnodid3 = usr2sys(inimap2d(kk)%NODEID3, itabm1, mess, inimap2d(kk)%NODEID3)
332 inimap2d(kk)%NODEID3 = lnodid3
333 ENDIF
334
335 IF (lnodid1==0 .or. lnodid2==0 .or. lnodid3==0) THEN
336C Error here, we need 3 nodes to define a plane
337 ELSE
338 x0(1:3) = xgrid(1:3, lnodid1)
339 x1(1:3) = xgrid(1:3, lnodid2)
340 x2(1:3) = xgrid(1:3, lnodid3)
341 norm = sqrt(dot_product(x1(1:3) - x0(1:3), x1(1:3) - x0(1:3)))
342 inimap2d(kk)%VEC1(1:3) = (x1(1:3) - x0(1:3)) / norm
343 norm = sqrt(dot_product(x2(1:3) - x0(1:3), x2(1:3) - x0(1:3)))
344 inimap2d(kk)%VEC2(1:3) = (x2(1:3) - x0(1:3)) / norm
345 vec3(1) = inimap2d(kk)%VEC1(2) * inimap2d(kk)%VEC2(3) -
346 . inimap2d(kk)%VEC1(3) * inimap2d(kk)%VEC2(2)
347 vec3(2) = -inimap2d(kk)%VEC1(1) * inimap2d(kk)%VEC2(3) +
348 . inimap2d(kk)%VEC1(3) * inimap2d(kk)%VEC2(1)
349 vec3(3) = inimap2d(kk)%VEC1(1) * inimap2d(kk)%VEC2(2) -
350 . inimap2d(kk)%VEC1(2) * inimap2d(kk)%VEC2(1)
351
352 inimap2d(kk)%VEC2(1) = -inimap2d(kk)%VEC1(2) * vec3(3) +
353 . inimap2d(kk)%VEC1(3) * vec3(2)
354 inimap2d(kk)%VEC2(2) = inimap2d(kk)%VEC1(1) * vec3(3) -
355 . inimap2d(kk)%VEC1(3) * vec3(1)
356 inimap2d(kk)%VEC2(3) = -inimap2d(kk)%VEC1(1) * vec3(2) +
357 . inimap2d(kk)%VEC1(2) * vec3(1)
358
359 inimap2d(kk)%VEC3(1) = vec3(1)
360 inimap2d(kk)%VEC3(2) = vec3(2)
361 inimap2d(kk)%VEC3(3) = vec3(3)
362
363
364 ENDIF
365
366 ENDDO ! KK = 1, NINIMAP2D
367 RETURN
368
369
370 2000 FORMAT(//
371 .' 2D INITIAL MAPPING (/INIMAP2D) '/
372 .' ------------------------------ ')
373 2001 FORMAT(' ID : ', 1x, i10)
374 2002 FORMAT(' TITLE : ', a)
375 2010 FORMAT(' FORMULATION : VP (INITIALIZATION FROM DENSITY AND PRESSURE FUNCTIONS)')
376 2020 FORMAT(' FORMULATION : VE (INITIALIZATION FROM DENSITY AND SPECIFIC EINT FUNCTIONS)')
377 2025 FORMAT(' FORMULATION : FILE (INITIALIZATION FROM STATE FILE)')
378 2026 FORMAT(' FILENAME : ', a)
379 2040 FORMAT(' --VELOCITY FUNCT ID, SCALE FACTOR: ', i10, 1pg20.13)
380 2050 FORMAT(' PHASE ', i10,
381 . /, ' VOLUME FRACTION FUNCT ID: ', i10,
382 . /, ' MASS DENSITY FUNCT ID, SCALE FACTOR: ', i10, 1pg20.13,
383 . /, ' SPECIFIC ENERGY FUNCT ID, SCALE FACTOR: ', i10, 1pg20.13)
384 2060 FORMAT(' PHASE ', i10,
385 . /, ' volume fraction funct id: ', I10,
386 . /, ' mass density funct id, scale factor: ', I10, 1PG20.13,
387 . /, ' pressure funct id, scale factor: ', I10, 1PG20.13)
388
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_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_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_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
lec_inimap2d_file
subroutine lec_inimap2d_file(inimap2d, filename, id, title)
Definition lec_inimap2d_file.F:36
id
initmumps id
Definition multiplerhs_example.m:4
func2d_mod
Definition func2d_mod.F:35
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
inimap2d_mod
Definition inimap2d_mod.F:35
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::ncharline
integer, parameter ncharline
Definition names_and_titles_mod.F:1001
submodel_mod
Definition submodel_mod.F:712
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
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160