OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_admas.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| hm_read_admas ../starter/source/tools/admas/hm_read_admas.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| hm_get_float_array_index ../starter/source/devtools/hm_reader/hm_get_float_array_index.F
30!|| hm_get_floatv ../starter/source/devtools/hm_reader/hm_get_floatv.F
31!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
32!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
33!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
34!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
35!|| surfmas ../starter/source/tools/admas/surfmas.F
36!|| usr2sys ../starter/source/system/sysfus.F
37!||--- uses -----------------------------------------------------
38!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
39!|| message_mod ../starter/share/message_module/message_mod.F
40!|| r2r_mod ../starter/share/modules1/r2r_mod.F
41!|| submodel_mod ../starter/share/modules1/submodel_mod.F
42!||====================================================================
43 SUBROUTINE hm_read_admas(
44 . MS ,ITABM1 ,IGRNOD ,UNITAB ,IGRSURF,
45 . IPART ,IPMAS ,TOTADDMAS,FLAG ,IGRPART,
46 . X ,LSUBMODEL)
47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE my_alloc_mod
51 USE unitab_mod
52 USE r2r_mod
53 USE message_mod
54 USE groupdef_mod
56 USE submodel_mod
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 "com01_c.inc"
66#include "com04_c.inc"
67#include "scr17_c.inc"
68#include "r2r_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER ,INTENT(IN) :: ITABM1(*),IPART(LIPART1,*),FLAG
73 my_real ,INTENT(IN) :: X(3,*)
74 my_real ,INTENT(INOUT) :: MS(*),TOTADDMAS
75 TYPE(submodel_data),DIMENSION(*) ,INTENT(IN) :: LSUBMODEL
76 TYPE (UNIT_TYPE_),INTENT(IN) :: UNITAB
77C-----------------------------------------------
78 TYPE (GROUP_) , DIMENSION(NGRNOD) ,INTENT(IN) :: IGRNOD
79 TYPE (GROUP_) , DIMENSION(NGRPART) ,INTENT(IN) :: IGRPART
80 TYPE (SURF_) , DIMENSION(NSURF) ,INTENT(IN) :: IGRSURF
81 TYPE (ADMAS_) , DIMENSION(NODMAS) ,INTENT(INOUT):: IPMAS
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER I,J,K,ITYPE,ID,UID,IGR,IGRS,NOSYS,ISU,NNOD,
86 . ISS,NN,IBUFN(4),CAPT,ITY,IPA,IP,IGRPA,IDP,
87 . NEL,IFLAG,JCURR,FIRST,CPT_LAST,IMS,ENTITYMAX
88 my_real
89 . amas,coeff_r2r
90 LOGICAL LOOP_2
91!
92 CHARACTER(nchartitle) :: TITR,MESS
93 LOGICAL :: IS_AVAILABLE
94!
95 INTEGER, ALLOCATABLE, DIMENSION(:) :: ENTITY_MULTI,IFLAG_MULTI
96 my_real, ALLOCATABLE, DIMENSION(:) :: amas_multi
97C-----------------------------------------------
98C E x t e r n a l F u n c t i o n s
99C-----------------------------------------------
100 INTEGER USR2SYS
101 DATA MESS/'ADDED MASS DEFINITION '/
102C=======================================================================
103! IPMAS(IGM)%ID : ADMAS IDENTIFIER
104! IPMAS(IGM)%NPART : NUMBER of parts to get ADMAS
105! IPMAS(IGM)%TYPE : ! ADMAS type
106! = 0 ! Mass is added to each node of node group
107! = 1 ! Mass/N is added to each node of node group.
108! N being the total number of nodes in the node group
109! = 2 ! Mass/Area - additional surface mass applied on the shell area
110! = 3 ! Additional mass distributed on the part-group
111! = 4 ! Final mass distributed on the part-group
112! = 5 ! Mass is added to each single node
113! = 6 ! Additional mass distributed on each single part
114! = 7 ! Final mass distributed on each single part
115! IPMAS(IGM)%TITLE : ADMAS title
116! IPMAS(IGM)%WEIGHT_FLAG : Flag to switch between area weighted distribution and volume
117! weighted distribution of the added mass to parts)
118! = 0 ! Volume weighted distribution (shell and solid parts) (default)
119! = 1 ! Area weighted distribution (shell parts only)
120! IPMAS(IGM)%PARTID : PART_ID to get ADMAS
121! IPMAS(IGM)%PART(J)%RPMAS : ADMAS added to PARTS (or NODES)
122C=======================================================================
123!
124 is_available = .false.
125!
126C--------------------------------------------------
127C START BROWSING MODEL /ADMAS
128C--------------------------------------------------
129 CALL hm_option_start('/ADMAS')
130C--------------------------------------------------
131C BROWSING MODEL ADMAS 1-> NODMAS
132C--------------------------------------------------
133 imasadd = 0
134c for optimisation 1 (last group is memorised)
135 jcurr = 1
136!
137 DO i=1,nodmas
138 titr = ''
139 ims = 0
140C--------------------------------------------------
141C EXTRACT DATAS OF /ADMAS/... LINE
142C--------------------------------------------------
143 CALL hm_option_read_key(lsubmodel,
144 . option_id = id,
145 . unit_id = uid,
146 . option_titr = titr)
147!
148 CALL hm_get_intv('type' ,itype ,is_available,lsubmodel)
149
150!---
151 ipmas(i)%TITLE = titr
152 ipmas(i)%ID = id
153 ipmas(i)%TYPE = itype
154!------
155 IF (itype == 0 .or. itype == 1) THEN
156!------
157!---
158! added mass to nodes of grnod
159!---
160 IF (flag == 0) THEN
161 CALL hm_get_floatv('masses' ,amas ,is_available ,lsubmodel ,unitab)
162 CALL hm_get_intv('grnd_ID' ,igr ,is_available ,lsubmodel)
163!
164 IF(amas < zero)THEN
165 CALL ancmsg(msgid=476,
166 . msgtype=msgwarning,
167 . anmode=aninfo_blind_1,
168 . i1=id,
169 . c1=titr)
170 ENDIF
171!! AMAS = AMAS * FAC_M
172 IF(igr == 0)THEN
173 CALL ancmsg(msgid=668,
174 . msgtype=msgerror,
175 . anmode=aninfo,
176 . c1='/ADMAS',
177 . c2='/ADMAS',
178 . c3=titr,
179 . i1=id)
180 ENDIF
181!
182 igrs=0
183
184c original
185c DO J=1,NGRNOD
186c IF(IGR == IGROU(1,J))THEN
187c IGRS=J
188c GOTO 100
189c ENDIF
190c ENDDO
191c end original
192ccccccccccccccccccccccccc
193c OPTIMISATION1
194ccccccccccccccccccccccccc
195c optimisation to avoid quadratic loop
196c if group is found, next search start from this group
197c optimal in case of sorted list of GRNOD in ADMAS file
198c in case on non sorted file, a dichotomic search is more appropriate
199
200 cpt_last = ngrnod
201 loop_2 = .false.
202110 CONTINUE
203 DO j=jcurr,cpt_last
204 IF (igr == igrnod(j)%ID) THEN
205 igrs = j
206 jcurr = j
207c group found
208 GOTO 100
209 ENDIF
210 IF (j == ngrnod) THEN
211 IF(loop_2)THEN
212c second passage IGRS has not been found we output in error
213 GOTO 100
214 ELSE
215c first passage in loop, we will start a 2nd passage from 1 to jcurr
216 loop_2 = .true.
217 ENDIF
218 cpt_last = jcurr
219 jcurr = 1
220c begin again loop 1
221 GOTO 110
222 ENDIF
223 ENDDO ! DO J=JCURR,CPT_LAST
224ccccccccccccccccccccccccc
225c end OPTIMISATION1
226ccccccccccccccccccccccccc
227100 CONTINUE
228C---
229 IF (itype == 1) THEN
230 coeff_r2r = 1
231 nnod = igrnod(igrs)%NENTITY
232C-----------Multidomaines : on corrige la masse totale avec le nouveau nb de noeuds--------------
233 IF (nsubdom > 0) THEN
234 IF (ipid==0) nnod = nnod-igrnod(igrs)%R2R_SHARE
235 coeff_r2r=(1.00*nnod)/(1.00*max(1,igrnod(igrs)%R2R_ALL))
236 ENDIF
237 amas = coeff_r2r*amas/max(1,nnod)
238 ENDIF ! ! IF (ITYPE == 1)
239C
240 IF (igrs /= 0) THEN
241 DO j=1,igrnod(igrs)%NENTITY
242 nosys=igrnod(igrs)%ENTITY(j)
243C-----------Multidomaines : les noeuds communs ne sont traites que sur 1 domaine--------------
244 IF ((nsubdom > 0).AND.(ipid == 0)) THEN
245 IF (tagno(npart+nosys) > 1) GOTO 150
246 ENDIF
247 ms(nosys) = ms(nosys) + amas
248 totaddmas = totaddmas + amas
249 150 CONTINUE
250 ENDDO
251 nnod = igrnod(igrs)%NENTITY
252 ELSE
253 CALL ancmsg(msgid=53,
254 . msgtype=msgerror,
255 . anmode=aninfo,
256 . c1='IN /ADMAS OPTION',
257 . i1=igr)
258 ENDIF ! IF (IGRS /= 0)
259 ENDIF ! IF (FLAG == 0)
260!------
261 ELSEIF (itype == 2) THEN
262!------
263!---
264! added mass per unit area for surfaces
265!---
266 IF (flag == 0) THEN
267 isu = 0
268 CALL hm_get_floatv('masses' ,amas ,is_available ,lsubmodel ,unitab)
269 CALL hm_get_intv('surf_ID' ,isu ,is_available ,lsubmodel)
270!
271 IF (amas < zero) THEN
272 CALL ancmsg(msgid=875,
273 . msgtype=msgwarning,
274 . anmode=aninfo_blind_1,
275 . i1=id,
276 . c1=titr,
277 . r1=amas)
278 ENDIF
279!! AMAS = AMAS * FAC_M
280 IF (isu == 0) THEN
281 CALL ancmsg(msgid=872,
282 . msgtype=msgerror,
283 . anmode=aninfo,
284 . i1=id,
285 . c1=titr)
286 ENDIF
287 iss=0
288 nn =0
289 DO j=1,nsurf
290 IF (isu == igrsurf(j)%ID) THEN
291 iss=j
292 nn = igrsurf(iss)%NSEG
293 EXIT
294 ENDIF
295 ENDDO
296C-----------Multidomaines -> on decompte les seg communs, on ne les compte qu'une foi---
297 IF (nsubdom > 0) THEN
298 IF (iddom > 0) nn = nn-isurf_r2r(1,iss)
299 ENDIF
300C-----------
301 IF (iss /= 0) THEN
302 DO j=1,nn
303 IF (iddom > 0) THEN
304C-----------Multidomaines -> on elimine les seg communs, on ne les traite qu'une foi---
305 capt=0
306 DO k=1,4
307 capt=capt+tagno(npart+igrsurf(iss)%NODES(j,k))
308 ENDDO
309 IF (capt == 8) GOTO 160
310 ENDIF
311C
312 ity=igrsurf(iss)%ELTYP(j)
313C
314 ibufn(1)=igrsurf(iss)%NODES(j,1)
315 ibufn(2)=igrsurf(iss)%NODES(j,2)
316 ibufn(3)=igrsurf(iss)%NODES(j,3)
317 IF (igrsurf(iss)%NODES(j,3) ==
318 . igrsurf(iss)%NODES(j,4)) ity = 7
319 IF (ity == 7) THEN
320C true triangles (not segments built from 3 nodes) or degenerated
321 ibufn(4)=0
322 ELSE
323 ibufn(4)=igrsurf(iss)%NODES(j,4)
324 ENDIF
325C
326 CALL surfmas(ms,ibufn,ity,amas,x,igrsurf(iss)%ID,totaddmas,id,titr)
327C
328 160 CONTINUE
329 ENDDO ! DO j=1,nn
330 ELSE
331 CALL ancmsg(msgid=873,
332 . msgtype=msgerror,
333 . anmode=aninfo,
334 . i1=id,
335 . c1=titr,
336 . i2=isu)
337 ENDIF ! IF(ISS /= 0)
338 ENDIF ! IF (FLAG == 0)
339!------
340 ELSEIF (itype == 3 .or. itype == 4) THEN
341!------
342! added mass to a group of parts
343!---
344 CALL hm_get_floatv('masses' ,amas ,is_available ,lsubmodel ,unitab)
345 CALL hm_get_intv('grpart_ID' ,igrpa ,is_available ,lsubmodel)
346 CALL hm_get_intv('iflags' ,iflag ,is_available ,lsubmodel)
347!
348 IF (amas < zero .and. flag == 0) THEN
349 CALL ancmsg(msgid=875,
350 . msgtype=msgwarning,
351 . anmode=aninfo_blind_1,
352 . i1=id,
353 . c1=titr,
354 . r1=amas)
355 ENDIF
356!! AMAS = AMAS * FAC_M
357 IF (igrpa == 0 .and. flag == 0) THEN
358 CALL ancmsg(msgid=878,
359 . msgtype=msgerror,
360 . anmode=aninfo,
361 . i1=id,
362 . c1=titr)
363 ENDIF
364 IF (iflag /= 0 .and. iflag /= 1) iflag = 0
365 ipmas(i)%WEIGHT_FLAG = iflag
366 igrs = 0
367C
368 DO j=1,ngrpart
369 IF (igrpa == igrpart(j)%ID) THEN
370 igrs=j
371 EXIT
372 ENDIF
373 ENDDO
374C---
375 IF (flag == 0) THEN
376 IF (igrs /= 0) THEN
377 nel = igrpart(igrs)%NENTITY
378 ipmas(i)%NPART = nel
379! allocate only one time because of "IDDLEVEL"
380 if (.not.allocated(ipmas(i)%PART)) ALLOCATE(ipmas(i)%PART(nel))
381 if (.not.allocated(ipmas(i)%PARTID))ALLOCATE(ipmas(i)%PARTID(nel))
382 ELSE
383 CALL ancmsg(msgid=879,
384 . msgtype=msgerror,
385 . anmode=aninfo,
386 . i1=id,
387 . c1=titr,
388 . i2=igrpa)
389 ENDIF ! IF (IGRS /= 0)
390 ELSEIF(flag == 1)THEN
391 IF (igrs /= 0) THEN
392 imasadd = imasadd + 1
393C
394 nel = igrpart(igrs)%NENTITY
395C-----------Multidomaines : on ne peut pas splitter la masse dans ce cas--------------
396 IF ((nsubdom > 0) .AND.(nel /= igrpart(igrs)%R2R_ALL).AND.(nel > 0)) THEN
397 CALL ancmsg(msgid=893,
398 . msgtype=msgerror,
399 . anmode=aninfo,
400 . i1=id)
401 ENDIF
402 DO j=1,nel
403 idp=igrpart(igrs)%ENTITY(j)
404 ipmas(i)%PARTID(j) = idp
405 ipmas(i)%PART(j)%RPMAS = amas
406 ENDDO
407 ENDIF ! IF (IGRS /= 0)
408 ENDIF ! IF (FLAG == 0)
409!------
410 ELSEIF (itype == 5) THEN
411!------
412! added mass to nodes
413!---
414 IF (flag == 0) THEN
415 CALL hm_get_intv('entityidsmax' ,entitymax ,is_available ,lsubmodel)
416!
417 ALLOCATE(amas_multi(entitymax))
418 amas_multi(1:entitymax) = zero
419 ALLOCATE(entity_multi(entitymax))
420 entity_multi(1:entitymax) = 0
421 DO j=1,entitymax
422 CALL hm_get_float_array_index('masses' ,amas_multi(j) ,j ,is_available, lsubmodel, unitab)
423 CALL hm_get_int_array_index('node_ID' ,entity_multi(j) ,j ,is_available, lsubmodel)
424!
425 IF (amas_multi(j) < zero) THEN
426 CALL ancmsg(msgid=875,
427 . msgtype=msgwarning,
428 . anmode=aninfo_blind_1,
429 . i1=id,
430 . c1=titr,
431 . r1=amas_multi(j))
432 ENDIF
433!! AMAS = AMAS * FAC_M
434 IF (entity_multi(j) <= 0)THEN
435 CALL ancmsg(msgid=871,
436 . msgtype=msgerror,
437 . anmode=aninfo,
438 . i1=id,
439 . c1=titr,
440 . i2=entity_multi(j))
441 ENDIF
442 nosys = usr2sys(entity_multi(j),itabm1,mess,id)
443C-----------Multidomaines : les noeuds communs ne sont traits que sur 1 domaine--------------
444 IF ((nsubdom > 0) .AND. (ipid == 0)) THEN
445 IF (tagno(npart+nosys) > 1) GOTO 170
446 ENDIF
447 ms(nosys) = ms(nosys) + amas_multi(j)
448 totaddmas = totaddmas + amas_multi(j)
449 170 CONTINUE
450 ENDDO ! DO J=1,ENTITYMAX
451 IF (ALLOCATED(amas_multi)) DEALLOCATE(amas_multi)
452 IF (ALLOCATED(entity_multi)) DEALLOCATE(entity_multi)
453 ENDIF ! IF (FLAG == 0)
454!------
455 ELSEIF (itype == 6 .or. itype == 7) THEN
456!------
457! added mass by part
458!---
459 CALL hm_get_intv('entityidsmax' ,entitymax ,is_available ,lsubmodel)
460!
461 ALLOCATE(amas_multi(entitymax))
462 amas_multi(1:entitymax) = zero
463 ALLOCATE(entity_multi(entitymax))
464 entity_multi(1:entitymax) = 0
465 ALLOCATE(iflag_multi(entitymax))
466 iflag_multi(1:entitymax) = 0
467!
468 IF (flag == 0) THEN
469 ipmas(i)%NPART = entitymax
470! allocate only one time because of "IDDLEVEL"
471 if (.not.allocated(ipmas(i)%PART)) ALLOCATE(ipmas(i)%PART(entitymax))
472 if (.not.allocated(ipmas(i)%PARTID))ALLOCATE(ipmas(i)%PARTID(entitymax))
473 ENDIF ! IF (FLAG == 0)
474!
475 ipa = 0
476 DO j=1,entitymax
477 CALL hm_get_float_array_index('masses' ,amas_multi(j) ,j ,is_available, lsubmodel, unitab)
478 CALL hm_get_int_array_index('part_ID' ,entity_multi(j) ,j ,is_available, lsubmodel)
479 CALL hm_get_int_array_index('iflags' ,iflag_multi(j) ,j ,is_available, lsubmodel)
480!
481 IF (amas_multi(j) < zero .and. flag == 0) THEN
482 CALL ancmsg(msgid=875,
483 . msgtype=msgwarning,
484 . anmode=aninfo_blind_1,
485 . i1=id,
486 . c1=titr,
487 . r1=amas_multi(j))
488 ENDIF
489!! AMAS = AMAS * FAC_M
490 IF (entity_multi(j) == 0 .and. flag == 0) THEN
491 CALL ancmsg(msgid=874,
492 . msgtype=msgerror,
493 . anmode=aninfo,
494 . i1=id,
495 . c1=titr)
496 ENDIF
497 IF (iflag_multi(j) /= 0 .and. iflag_multi(j) /= 1) iflag_multi(j) = 0
498 ipmas(i)%WEIGHT_FLAG = iflag_multi(j)
499!
500 ip = 0
501 IF (flag == 1) THEN
502 DO k=1,npart
503 IF (entity_multi(j) == ipart(4,k)) THEN
504 ip = k
505 EXIT
506 ENDIF
507 ENDDO
508!
509C-----------Multidomaines : on ignore les parts qui ne sont pas propres au domaine--------------
510 IF (nsubdom > 0) THEN
511 IF (tag_part(ip) == 0) THEN
512 ipmas(i)%NPART = ipmas(i)%NPART -1
513 GOTO 180
514 ENDIF
515 ENDIF
516
517 IF (ip > 0) THEN
518 imasadd = imasadd + 1
519 ims = ims + 1
520 ipmas(i)%PARTID(ims) = ip
521 ipmas(i)%PART(ims)%RPMAS = amas_multi(j)
522 ELSE
523 CALL ancmsg(msgid=876,
524 . msgtype=msgerror,
525 . anmode=aninfo,
526 . i1=id,
527 . c1=titr,
528 . i2=entity_multi(j))
529 ENDIF
530180 CONTINUE
531 ENDIF ! IF (FLAG == 1)
532
533 ENDDO ! DO J=1,ENTITYMAX
534 IF (ALLOCATED(amas_multi)) DEALLOCATE(amas_multi)
535 IF (ALLOCATED(entity_multi)) DEALLOCATE(entity_multi)
536 IF (ALLOCATED(iflag_multi)) DEALLOCATE(iflag_multi)
537!------
538 ENDIF ! IF (ITYPE == 0 .or. ITYPE == 1)
539!------
540 ENDDO ! DO I=1,NODMAS
541C---
542 RETURN
543 END
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
subroutine hm_option_start(entity_type)
subroutine hm_read_admas(ms, itabm1, igrnod, unitab, igrsurf, ipart, ipmas, totaddmas, flag, igrpart, x, lsubmodel)
#define max(a, b)
Definition macros.h:21
integer, dimension(:), allocatable tagno
Definition r2r_mod.F:132
integer, dimension(:), allocatable tag_part
Definition r2r_mod.F:134
integer, dimension(:,:), allocatable isurf_r2r
Definition r2r_mod.F:143
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
subroutine surfmas(ms, ibufn, ity, amasu, x, id, addmas, admid, titr)
Definition surfmas.F:33