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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_inimap1d (inimap1d, npc, itabm1, x, igrbric, igrquad, igrsh3n, multi_fvm, unitab, lsubmodel)

Function/Subroutine Documentation

◆ hm_read_inimap1d()

subroutine hm_read_inimap1d ( type(inimap1d_struct), dimension(ninimap1d), intent(inout) inimap1d,
integer, dimension(*), intent(in) npc,
integer, dimension(*), intent(in) itabm1,
dimension(3, *), intent(in) x,
type (group_), dimension(ngrbric) igrbric,
type (group_), dimension(ngrquad) igrquad,
type (group_), dimension(ngrsh3n) igrsh3n,
type(multi_fvm_struct), intent(in) multi_fvm,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(nsubmod), intent(in) lsubmodel )

Definition at line 44 of file hm_read_inimap1d.F.

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