OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_lecgrn.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_lecgrn (itab, itabm1, igrnod, isubmod, x, geo, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ipart, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartg, ipartsp, kxsp, flag, maxnnod, skew, iskn, unitab, ibox, ixs10, ixs20, ixs16, rtrans, lsubmodel, ixx, kxx, ipartx, iadboxmax, igrslin, subset, igrbric, igrquad, igrsh4n, igrsh3n, igrtruss, igrbeam, igrspring, igrsurf, nsets)

Function/Subroutine Documentation

◆ hm_lecgrn()

subroutine hm_lecgrn ( integer, dimension(*) itab,
integer, dimension(*) itabm1,
type (group_), dimension(ngrnod), target igrnod,
integer, dimension(*) isubmod,
x,
geo,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) iparts,
integer, dimension(*) ipartq,
integer, dimension(*) ipartc,
integer, dimension(*) ipartt,
integer, dimension(*) ipartp,
integer, dimension(*) ipartr,
integer, dimension(*) ipartg,
integer, dimension(*) ipartsp,
integer, dimension(nisp,*) kxsp,
integer flag,
integer maxnnod,
skew,
integer, dimension(liskn,*) iskn,
type (unit_type_), intent(in) unitab,
type (box_), dimension(nbbox) ibox,
integer, dimension(6,*) ixs10,
integer, dimension(12,*) ixs20,
integer, dimension(8,*) ixs16,
rtrans,
type(submodel_data), dimension(*) lsubmodel,
integer, dimension(*) ixx,
integer, dimension(*) kxx,
integer, dimension(*) ipartx,
integer iadboxmax,
type (surf_), dimension(nslin), target igrslin,
type (subset_), dimension(nsubs) subset,
type (group_), dimension(ngrbric), target igrbric,
type (group_), dimension(ngrquad), target igrquad,
type (group_), dimension(ngrshel), target igrsh4n,
type (group_), dimension(ngrsh3n), target igrsh3n,
type (group_), dimension(ngrtrus), target igrtruss,
type (group_), dimension(ngrbeam), target igrbeam,
type (group_), dimension(ngrspri), target igrspring,
type (surf_), dimension(nsurf), target igrsurf,
integer nsets )

Definition at line 53 of file hm_lecgrn.F.

66C !!! WARNING due to issues on ibm plateform keep IBUFTMP at the last position
67C-----------------------------------------------
68C M o d u l e s
69C-----------------------------------------------
70 USE my_alloc_mod
71 USE unitab_mod
72 USE submodel_mod
73 USE message_mod
74 USE groupdef_mod
75 USE optiondef_mod
76 USE hm_option_read_mod
77 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
78 use element_mod , only : nixs, nixq, nixc, nixt, nixp, nixr, nixtg
79C-----------------------------------------------
80C I m p l i c i t T y p e s
81C-----------------------------------------------
82#include "implicit_f.inc"
83C-----------------------------------------------
84C C o m m o n B l o c k s
85C-----------------------------------------------
86#include "scr17_c.inc"
87#include "com04_c.inc"
88#include "param_c.inc"
89#include "sphcom.inc"
90C-----------------------------------------------
91C D u m m y A r g u m e n t s
92C-----------------------------------------------
93 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
94 INTEGER ITABM1(*),
95 . IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),
96 . IXP(NIXP,*),IXR(NIXR,*),IXTG(NIXTG,*),IPARTS(*),
97 . IPARTQ(*),IPARTC(*),IPARTT(*),IPARTP(*),IPARTR(*),
98 . IPARTG(*),IPART(LIPART1,*),ITAB(*),
99 . IXS10(6,*) ,IXS20(12,*) ,IXS16(8,*),
100 . KXSP(NISP,*),IPARTSP(*),ISUBMOD(*),ISKN(LISKN,*),
101 . IXX(*),KXX(*),IPARTX(*),IADBOXMAX,NSETS
102 INTEGER FLAG,MAXNNOD
103 my_real
104 . x(3,*),geo(npropg,*),skew(lskew,*),rtrans(*)
105 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
106C-----------------------------------------------
107 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
108 TYPE (GROUP_) , TARGET, DIMENSION(NGRNOD) :: IGRNOD
109 TYPE (GROUP_) , TARGET, DIMENSION(NGRQUAD) :: IGRQUAD
110 TYPE (GROUP_) , TARGET, DIMENSION(NGRBRIC) :: IGRBRIC
111 TYPE (GROUP_) , TARGET, DIMENSION(NGRSHEL) :: IGRSH4N
112 TYPE (GROUP_) , TARGET, DIMENSION(NGRSH3N) :: IGRSH3N
113 TYPE (GROUP_) , TARGET, DIMENSION(NGRTRUS) :: IGRTRUSS
114 TYPE (GROUP_) , TARGET, DIMENSION(NGRBEAM) :: IGRBEAM
115 TYPE (GROUP_) , TARGET, DIMENSION(NGRSPRI) :: IGRSPRING
116 TYPE (SURF_) , TARGET, DIMENSION(NSURF) :: IGRSURF
117 TYPE (SURF_) , TARGET, DIMENSION(NSLIN) :: IGRSLIN
118 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
119C-----------------------------------------------
120C L o c a l V a r i a b l e s
121C-----------------------------------------------
122 INTEGER J10(10),ID_SUB
123 INTEGER, DIMENSION(:), ALLOCATABLE :: BUFTMP ! NUMNOD*2+NPART
124 INTEGER I,J,K,II,KK,N1,N2,ISU,ID,JREC,NNOD,NL,NTRI,IGS,IGRS,
125 . OK,IT0,IT1,IT2,IT3,IT4,IT5,IT6,
126 . FLAG_FMT,FLAG_FMT_TMP,IFIX_TMP,STAT,IT7,UID,IFLAGUNIT,
127 . IT8,SUB_ID,IADBOX,NN,LIST_IGR(NGRNOD),IDMIN,IDMAX,OFFSET,
128 . IT9,IDB,NENTITY,NLINES,JJ
129
130 my_real
131 . xmin,xmax,ymin,ymax,zmin,zmax,bid,fac_l
132 INTEGER, DIMENSION(:),ALLOCATABLE :: BUFTMP2
133 CHARACTER(LEN=NCHARTITLE) :: TITR, TITR1
134 CHARACTER(LEN=NCHARKEY) :: KEY,KEY2
135 CHARACTER MESS*40
136 INTEGER, DIMENSION(:),ALLOCATABLE :: BUFBOX
137 LOGICAL IS_AVAILABLE
138C-----------------------------------------------
139C E x t e r n a l F u n c t i o n s
140C-----------------------------------------------
141 INTEGER USR2SYS,ULIST2S,LISTCNT
142C 1234567890123456789012345678901234567890
143 DATA mess/'NODE GROUP DEFINITION '/
144C-----------------------------------------------
145C IGRNOD(IGS)%ID : GROUP identifier
146C IGRNOD(IGS)%TITLE : GROUP title
147C IGRNOD(IGS)%NENTITY : Entities (nodes) number of the GROUP
148C IGRNOD(IGS)%GRTYPE : TYPE ( 0-NODES, 1-BRIC, 2-QUAD, 3-SHELL_4N,
149! 4-truss, 5-beam, 6-springs,7-shell_3n )
150!! GRTYPE --- > OBSOLETE
151C IGRNOD(IGS)%SORTED : FLAG for sorted/unsorted nodes
152! = 0 -> sorted
153! = 1 -> unsorted
154C IGRNOD(IGS)%GRPGRP : TYPE of nodal GROUP
155! = 1 FOR /GRNOD/NOD
156! = 2 FOR /GRNOD/GNROD
157! = 0 ALL THE REST
158C IGRNOD(IGS)%LEVEL : Hierarchy level
159! (FLAG 'SUBLEVEL DONE' FOR GROUPS OF GROUPS)
160! = 0 ---> not yet initialized
161! = 1 ---> done
162! - R2R -
163! ! R2R_ALL <--- IGROUP2(8,I) = IGROUP2(2,I) -- before splitting
164! ! R2R_SHARE <--- IGROUP2(9,I) (shared on boundary subdomain)
165C IGRNOD(IGS)%R2R_ALL ! Multidomaines -> number of node(elems, parts) before split
166C IGRNOD(IGS)%R2R_SHARE ! shared on boundary subdomain
167C-----------------------------------------------
168 ALLOCATE(buftmp(2*numnod + npart))
169 is_available = .false.
170 it0=0
171 it1=0
172 it2=0
173 it3=0
174 it4=0
175 it5=0
176 it6=0
177 it7=0
178 it8=0
179 it9=0
180C=======================================================================
181C Start reading groups of nodes (type NODE) + init IGRN(1,IGS)
182C=======================================================================
183 igs=0
184 titr1='NODE GROUP'
185C
186 CALL hm_option_start('/GRNOD')
187C
188 ! Loop over all GRNOD
189 DO i=1,ngrnod
190C
191 ! Read keys and uid
192 CALL hm_option_read_key(lsubmodel,
193 . option_id = id,
194 . option_titr = titr ,
195 . unit_id = uid,
196 . keyword2 = key ,
197 . keyword3 = key2)
198C
199 ! Increasing the counter
200 igs=igs+1
201C
202 ! Initialization of data structure
203 IF (flag == 0) THEN
204 igrnod(igs)%ID = 0
205 igrnod(igs)%NENTITY = 0
206 igrnod(igs)%GRTYPE = 0
207 igrnod(igs)%SORTED = 0
208 igrnod(igs)%GRPGRP = 0
209 igrnod(igs)%LEVEL = 0
210 igrnod(igs)%R2R_ALL = 0
211 igrnod(igs)%R2R_SHARE = 0
212 ENDIF
213 nn = 0
214 nnod = 0
215 igrnod(igs)%ID=id
216 igrnod(igs)%GRTYPE=0
217 igrnod(igs)%SORTED=0
218 igrnod(igs)%LEVEL=1
219 igrnod(igs)%TITLE = titr
220C
221 ! Filling data structure following type of GRNOD
222 !-----------------------------------------------------------------
223 ! GRNOD from GRNODNS
224 IF(key(1:7) == 'GRNODNS')THEN
225C tag of groups of groups
226 igrnod(igs)%NENTITY=-1
227c non sorted nodes
228 igrnod(igs)%SORTED=1
229 igrnod(igs)%GRPGRP=2 !!! /GROUP/GROUP
230 igrnod(igs)%LEVEL=0
231 !-----------------------------------------------------------------
232 ! GRNOD from GRNOD
233 ELSEIF(key(1:5) == 'GRNOD')THEN
234 igrnod(igs)%NENTITY=-1
235 igrnod(igs)%GRPGRP=2
236 igrnod(igs)%LEVEL=0
237 it0=it0+1
238 !-----------------------------------------------------------------
239 ! GRNOD from NODENS
240 ELSEIF(key(1:6) == 'NODENS') THEN
241 it1=it1+1
242 IF (flag == 0) THEN
243 CALL hm_get_intv('idsmax' ,nentity,is_available,lsubmodel)
244 DO kk = 1,nentity
245 CALL hm_get_int_array_index ('ids',jj ,kk,is_available,lsubmodel)
246 IF (jj /= 0) THEN
247 nnod = nnod + 1
248 ENDIF
249 ENDDO
250 igrnod(igs)%NENTITY=nnod
251! may be allocated already (prelecgrns.F) if NUMELX > 0
252 IF (.NOT. ALLOCATED(igrnod(igs)%ENTITY))
253 . CALL my_alloc(igrnod(igs)%ENTITY,nnod)
254 igrnod(igs)%GRPGRP=1
255 maxnnod = max(nnod,maxnnod)
256 ELSE
257 igrnod(igs)%SORTED=1
258 CALL hm_get_intv('idsmax' ,nentity,is_available,lsubmodel)
259 DO kk = 1,nentity
260 CALL hm_get_int_array_index ('ids',jj ,kk,is_available,lsubmodel)
261 IF (jj /= 0) THEN
262 nn = nn+1
263 igrnod(igs)%ENTITY(nn) = usr2sys(jj,itabm1,mess,id)
264 ENDIF
265 ENDDO
266 ENDIF
267 !-----------------------------------------------------------------
268 ! GRNOD from NODE
269 ELSEIF(key(1:4) == 'NODE' .OR. key(1:5) == 'CNODE') THEN
270C group of nodes
271 it1=it1+1
272 IF (flag == 0) THEN
273 CALL hm_get_intv('idsmax' ,nentity,is_available,lsubmodel)
274 IF(is_available)nnod = nnod + nentity
275 igrnod(igs)%NENTITY=nnod
276! may be allocated already (prelecgrns.F) if NUMELX > 0
277 IF( .NOT. ALLOCATED(igrnod(igs)%ENTITY))
278 . CALL my_alloc(igrnod(igs)%ENTITY,nnod)
279 igrnod(igs)%GRPGRP=1
280 maxnnod = max(nnod,maxnnod)
281 ELSE
282c sorted nodes
283 CALL hm_get_intv('idsmax' ,nentity,is_available,lsubmodel)
284 DO kk = 1,nentity
285 CALL hm_get_int_array_index ('ids',jj ,kk,is_available,lsubmodel)
286 IF (jj /= 0) THEN
287 nn = nn+1
288 igrnod(igs)%ENTITY(nn) = jj
289 ENDIF
290 ENDDO
291 ENDIF
292 !-----------------------------------------------------------------
293 ! GRNOD from PART, SUBSET, MAT and PROP
294 ELSEIF(key(1:4) == 'PART'.OR.key(1:6) == 'SUBSET'.OR.
295 . key(1:3) == 'MAT' .OR.key(1:4) == 'PROP') THEN
296 it2=it2+1
297 IF (flag == 0) igrnod(igs)%NENTITY=0
298 igrnod(igs)%GRPGRP=0
299 !-----------------------------------------------------------------
300 ! GRNOD from /BOX/RECTA, /BOX/CYLIN, /BOX/SPHERE, GENE, BOXA
301 ELSEIF((key(1:3) == 'BOX' .AND. nbbox == 0 .AND.
302 . (key2(1:5) /= 'RECTA'.AND.
303 . key2(1:5) /= 'CYLIN'.AND.key2(1:5) /= 'SPHER')).OR.
304 . key(1:4) == 'GENE'.OR.key(1:4) == 'BOXA')THEN
305 it3=it3+1
306 IF (flag == 0) igrnod(igs)%NENTITY=0
307 igrnod(igs)%GRPGRP=0
308 !-----------------------------------------------------------------
309 ! grnod from gr, surf, line
310 ELSEIF(key(1:2) == 'GR'.OR.key(1:4) == 'SURF'.OR.key(1:4) == 'LINE')THEN
311 it4=it4+1
312 IF (flag == 0) igrnod(igs)%NENTITY=0
313 igrnod(igs)%GRPGRP=0
314 !-----------------------------------------------------------------
315 ! GRNOD from SUBMODEL
316 ELSEIF(key(1:6) == 'SUBMOD')THEN
317 it5=it5+1
318 IF (flag == 0) igrnod(igs)%NENTITY=0
319 igrnod(igs)%GRPGRP=0
320 !-----------------------------------------------------------------
321 ! GRNOD from /BOX
322 ELSEIF(key(1:3) == 'BOX'.AND.(key2(1:5) == 'RECTA'.OR.
323 . key2(1:5) == 'CYLIN'.OR.key2(1:5) == 'SPHER'))THEN
324C old /grnod/box (not /BOX/BOX)
325C group of nodes in a box (classical box, parallelepiped,
326C cylindrical, spherical)
327 it7=it7+1
328 IF (flag == 0) igrnod(igs)%NENTITY=0
329 igrnod(igs)%GRPGRP=0
330 !-----------------------------------------------------------------
331 ! GRNOD from BOX
332 ELSEIF(key(1:3) == 'BOX' .AND. nbbox > 0)THEN
333C multi box (box de box)
334 it8=it8+1
335 !-----------------------------------------------------------------
336 ! GRNOD from GEN_INCR
337 ELSEIF(key(1:8) == 'GEN_INCR')THEN
338 it9=it9+1
339 IF (flag == 0) igrnod(igs)%NENTITY=0
340 igrnod(igs)%GRPGRP=0
341 ENDIF
342C---
343 ENDDO
344C-------------------------------------
345C Looking for double IDs
346C-------------------------------------
347 IF (flag == 0) THEN
348 DO igs = 1,ngrnod
349 list_igr(igs) = igrnod(igs)%ID
350 ENDDO
351 CALL udouble_igr(list_igr,ngrnod,mess,0,bid)
352 ENDIF
353C=======================================================================
354C Replacement of user node n0 by system n0 (NODE type)
355C=======================================================================
356 IF (it1 /= 0 .AND. flag == 1)THEN
357!
358 ALLOCATE(buftmp2(maxnnod*2),stat=stat)
359 IF (stat /= 0) THEN
360 CALL ancmsg(msgid=727,
361 . msgtype=msgerror,
362 . anmode=anstop,
363 . c1='BUFTMP2')
364 ENDIF
365!
366 DO i=1,ngrnod
367 IF (igrnod(i)%GRPGRP == 1) THEN
368 id=igrnod(i)%ID
369 nnod=igrnod(i)%NENTITY
370 ntri=igrnod(i)%SORTED
371 IF (nnod > 0 .AND. ntri == 0)THEN
372 IF(nnod == 1) THEN
373C no sorting necessary and dichotomy
374 nn = igrnod(i)%ENTITY(nnod)
375 igrnod(i)%ENTITY(nnod)=usr2sys(nn,itabm1,mess,id)
376 igrnod(i)%NENTITY=1
377C ELSEIF(NNOD < 10 or 100 ...)
378C algo with simplified sort and dichotomy, nnod limit to be defined
379 ELSE
380C Algo optimized for non -negligeable size group in front of n nod
381 buftmp2(1:2*nnod) = 0
382 nnod=ulist2s(igrnod(i)%ENTITY,nnod,itabm1,mess,buftmp2,id)
383 igrnod(i)%NENTITY=nnod
384 END IF
385 ENDIF
386 ENDIF
387 ENDDO
388 DEALLOCATE (buftmp2)
389 ENDIF ! IF (IT1 /= 0 .AND. FLAG == 1)THEN
390C=======================================================================
391C BOX, GENERATION
392C=======================================================================
393 igs=0
394 IF (it3 /= 0) THEN
395 CALL hm_option_start('/GRNOD')
396 DO i=1,ngrnod
397C
398 CALL hm_option_read_key(lsubmodel,
399 . option_id = id,
400 . option_titr = titr ,
401 . unit_id = uid,
402 . keyword2 = key ,
403 . keyword3 = key2)
404C
405 nnod = 0
406 nn = 0
407 igs = igs+1
408C-------------------------
409C BOX (old)
410C-------------------------
411 IF((key(1:3) == 'BOX'.AND.(key2(1:5) /= 'RECTA'.AND.
412 . key2(1:5) /= 'CYLIN'.AND.key2(1:5) /= 'SPHER').AND.
413 . nbbox == 0) .OR. (key(1:4) == 'BOXA'))THEN
414 ! No longer supported, ERROR MESSAGE
415C-------------------------
416C GENERATION
417C-------------------------
418 ELSEIF (key(1:4) == 'GENE') THEN
419 buftmp = 0
420C
421 CALL hm_get_intv('grnodGenArrCnt' ,nentity,is_available,lsubmodel)
422 DO kk = 1,nentity
423 CALL hm_get_int_array_index('Ifirst',n1 ,kk ,is_available,lsubmodel)
424 CALL hm_get_int_array_index('Ilast' ,n2 ,kk ,is_available,lsubmodel)
425 IF (n2 >= n1) THEN
426 DO k=1,numnod
427 IF (itab(k) >= n1 .AND. itab(k) <= n2) buftmp(k)=1
428 ENDDO
429 ENDIF
430 ENDDO
431C---
432 nnod=0
433 IF (flag == 0) THEN
434 DO j=1,numnod
435 IF (buftmp(j) == 1) nnod = nnod+1
436 ENDDO
437 igrnod(igs)%NENTITY=nnod
438 CALL my_alloc(igrnod(igs)%ENTITY,nnod)
439 igrnod(igs)%ENTITY=0
440 ELSE
441 DO j=1,numnod
442 IF (buftmp(j) == 1)THEN
443 nn = nn + 1
444 igrnod(igs)%ENTITY(nn)=j
445 ENDIF
446 ENDDO
447 ENDIF
448C---
449 ENDIF
450 ENDDO
451 ENDIF
452C-------------------------
453C BOX (parallelepiped (oriented), cylindrical, spherical) - old one (10SA1)
454C-------------------------
455 igs=0
456 IF(it7 /= 0)THEN
457 ! Error message, obsolete
458 ENDIF
459C-------------------------
460C NEW BOX OPTION (MULTI BOX COMBINATION)
461C-------------------------
462 igs=0
463 IF(it8 /= 0)THEN
464C
465 IF (flag == 0) THEN
466 ALLOCATE(bufbox(1))
467 bufbox = 0
468 ELSEIF (flag == 1) THEN
469 ALLOCATE(bufbox(iadboxmax))
470 bufbox(1:iadboxmax) = 0
471 ENDIF
472C
473 CALL hm_option_start('/GRNOD')
474 DO i = 1,ngrnod
475c
476 CALL hm_option_read_key(lsubmodel,
477 . option_id = id,
478 . option_titr = titr ,
479 . unit_id = uid,
480 . keyword2 = key ,
481 . keyword3 = key2)
482c
483 nn = 0
484 nnod = 0
485 igs = igs+1
486c
487 IF (key(1:3) == 'BOX' .AND. nbbox > 0) THEN
488 iadbox = 1
489 iflagunit = 0
490 DO j=1,unitab%NUNITS
491 IF (unitab%UNIT_ID(j) == uid) THEN
492 fac_l = unitab%FAC_L(j)
493 iflagunit = 1
494 EXIT
495 ENDIF
496 ENDDO
497 IF (uid/=0.AND.iflagunit==0) THEN
498 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
499 . i2=uid,i1=id,c1='NODE GROUP',
500 . c2='NODE GROUP',
501 . c3=titr)
502 ENDIF
503C---
504 CALL hm_get_int_array_index('ids' ,idb ,1,is_available,lsubmodel)
505 CALL hm_bigbox(x ,flag,nnod ,
506 . skew,igs ,iskn ,itabm1,ibox ,
507 . id ,bufbox,iadbox,titr,key,nn,
508 . iadboxmax,igrnod,idb)
509C---
510 iadboxmax = max(iadbox,iadboxmax)
511 IF (flag == 0) THEN
512 igrnod(igs)%NENTITY=nnod
513 CALL my_alloc(igrnod(igs)%ENTITY,nnod)
514 igrnod(igs)%ENTITY = 0
515 ELSEIF (flag == 1) THEN
516 igrnod(igs)%NENTITY=nnod
517 ENDIF ! IF (FLAG == 0)
518 ENDIF
519 ENDDO
520C---
521 IF(ALLOCATED(bufbox))DEALLOCATE(bufbox)
522 ENDIF ! IF(IT8 /= 0)
523C=======================================================================
524C groups of subsets, share, mat, prop
525C=======================================================================
526 igs=0
527 IF (it2 /= 0)THEN
528 CALL hm_option_start('/GRNOD')
529 DO i = 1,ngrnod
530 CALL hm_option_read_key(lsubmodel,
531 . option_id = id,
532 . option_titr = titr ,
533 . unit_id = uid ,
534 . keyword2 = key ,
535 . keyword3 = key2)
536C
537 igs=igs+1
538 nn = 0
539 IF (key(1:4) == 'PART'.OR.key(1:6) == 'SUBSET'.OR.key(1:3) == 'MAT' .OR.key(1:4) == 'PROP') THEN
540C tag the PARTs
541 buftmp = 0
542 CALL hm_tagpart(buftmp ,ipart ,key ,igrnod(igs)%ID,titr ,titr1 ,flag ,subset, lsubmodel)
543C-------------------------
544C tag the nodes
545 CALL tagnods(ixs,ixs10,ixs20,ixs16,iparts,buftmp,igrnod(igs)%ID,titr)
546 CALL tagnod(ixq,nixq,2,5,numelq,ipartq,buftmp,npart)
547 CALL tagnod(ixc,nixc,2,5,numelc,ipartc,buftmp,npart)
548 CALL tagnod(ixtg,nixtg,2,4,numeltg,ipartg,buftmp,npart)
549 CALL tagnod(ixt,nixt,2,3,numelt,ipartt,buftmp,npart)
550 CALL tagnod(ixp,nixp,2,3,numelp,ipartp,buftmp,npart)
551 CALL tagnodr(ixr,geo,numelr,ipartr,buftmp,npart)
552 CALL tagnod(kxsp,nisp,3,3,numsph,ipartsp,buftmp,npart)
553 CALL tagnodx(ixx,kxx,numelx,ipartx,buftmp,npart)
554C---
555 nnod=0
556 IF (flag == 0) THEN
557 DO j=1,numnod
558 IF (buftmp(j+npart) /= 0) nnod=nnod+1
559 ENDDO
560 igrnod(igs)%NENTITY=nnod
561 CALL my_alloc(igrnod(igs)%ENTITY,nnod)
562 igrnod(igs)%ENTITY=0
563 ELSE
564 DO j=1,numnod
565 IF (buftmp(j+npart) /= 0)THEN
566 nn = nn + 1
567 igrnod(igs)%ENTITY(nn) = j
568 ENDIF
569 ENDDO
570 ENDIF
571C---
572 ENDIF
573 ENDDO
574 ENDIF
575C=======================================================================
576C groups of SUBMODELS
577C=======================================================================
578 igs=0
579 IF (it5 > 0)THEN
580 CALL hm_option_start('/GRNOD')
581 DO i = 1,ngrnod
582 CALL hm_option_read_key(lsubmodel,
583 . option_id = id,
584 . option_titr = titr ,
585 . unit_id = uid ,
586 . keyword2 = key ,
587 . keyword3 = key2)
588c
589 nnod = 0
590 igs = igs+1
591 nn = 0
592 IF(key(1:6) == 'SUBMOD')THEN
593 CALL hm_submodgrn(itab ,itabm1 ,isubmod ,id ,
594 . nnod ,mess ,flag ,titr ,
595 . titr1 ,lsubmodel ,igrnod(igs),nn )
596 IF (flag == 0) THEN
597 igrnod(igs)%NENTITY=nnod
598 CALL my_alloc(igrnod(igs)%ENTITY,nnod)
599 igrnod(igs)%ENTITY = 0
600 ENDIF
601 ENDIF
602 ENDDO
603 ENDIF
604C=======================================================================
605C groups of groups of elements + surfaces
606C=======================================================================
607 igs=0
608 IF (it4 /= 0)THEN
609 CALL hm_option_start('/GRNOD')
610 DO i=1,ngrnod
611 CALL hm_option_read_key(lsubmodel,
612 . option_id = id,
613 . option_titr = titr ,
614 . unit_id = uid ,
615 . keyword2 = key ,
616 . keyword3 = key2)
617c
618 igs=igs+1
619 nn = 0
620C---
621 IF(key(1:5) == 'GRNOD')THEN
622 cycle
623 ELSEIF(key(1:2) == 'GR' .OR. key(1:4) == 'SURF' .OR. key(1:4) == 'LINE')THEN
624 buftmp = 0
625 id = igrnod(igs)%ID
626 IF(key(1:6) == 'GRBRIC')THEN
627 CALL hm_elngrs(ixs,ixs10,ixs20,ixs16,ngrbric,key(1:6),
628 . id ,igrbric,buftmp,titr,
629 . flag,lsubmodel)
630 ELSEIF(key(1:6) == 'GRQUAD')THEN
631 CALL hm_elngr(ixq,nixq,2,5,ngrquad,key(1:6),
632 . id,igrquad,buftmp,titr,
633 . flag,lsubmodel)
634 ELSEIF(key(1:6) == 'GRSHEL')THEN
635 CALL hm_elngr(ixc,nixc,2,5,ngrshel,key(1:6),
636 . id,igrsh4n,buftmp,titr,
637 . flag,lsubmodel)
638 ELSEIF(key(1:6) == 'GRTRUS')THEN
639 CALL hm_elngr(ixt,nixt,2,3,ngrtrus,key(1:6),
640 . id,igrtruss,buftmp,titr,
641 . flag,lsubmodel)
642 ELSEIF(key(1:6) == 'GRBEAM')THEN
643 CALL hm_elngr(ixp,nixp,2,3,ngrbeam,key(1:6),
644 . id,igrbeam,buftmp,titr,
645 . flag,lsubmodel)
646 ELSEIF(key(1:6) == 'GRSPRI')THEN
647 CALL hm_elngrr(ixr,geo,ngrspri,id,
648 . igrspring,buftmp,titr,
649 . flag,lsubmodel)
650 ELSEIF(key(1:6) == 'GRSH3N' .OR. key(1:6) == 'GRTRIA')THEN
651 CALL hm_elngr(ixtg,nixtg,2,4,ngrsh3n,key(1:6),
652 . id,igrsh3n,buftmp,titr,
653 . flag,lsubmodel)
654 ELSEIF(key(1:4) == 'SURF')THEN
655 CALL hm_surfnod(id,igrsurf,buftmp,titr,nsets,lsubmodel)
656 ELSEIF(key(1:4) == 'LINE')THEN
657 CALL hm_linengr(id,igrslin,buftmp,titr,nsets,lsubmodel)
658 ENDIF
659C---
660 nnod=0
661 IF (flag == 0) THEN
662 DO j=1,numnod
663 IF (buftmp(j) /= 0) nnod=nnod+1
664 ENDDO
665 igrnod(igs)%NENTITY=nnod
666 CALL my_alloc(igrnod(igs)%ENTITY,nnod)
667 igrnod(igs)%ENTITY = 0
668 ELSE
669 DO j=1,numnod
670 IF (buftmp(j) /= 0)THEN
671 nn = nn + 1
672 igrnod(igs)%ENTITY(nn)=j
673 ENDIF
674 ENDDO
675 ENDIF
676C---
677 ENDIF
678 ENDDO
679 ENDIF
680C=======================================================================
681C BOX, GENERATION
682C=======================================================================
683 igs=0
684 IF(it9 /= 0)THEN
685 CALL hm_option_start('/GRNOD')
686 DO i=1,ngrnod
687 CALL hm_option_read_key(lsubmodel,
688 . option_id = id,
689 . option_titr = titr ,
690 . unit_id = uid ,
691 . keyword2 = key ,
692 . keyword3 = key2 )
693c
694 nnod=0
695 nn = 0
696 igs=igs+1
697C-------------------------
698C GENERATION MIN MAX OFFSET
699C-------------------------
700 IF (key(1:8) == 'GEN_INCR') THEN
701 buftmp = 0
702 CALL hm_get_intv ('grnodGenArrCnt' ,nlines,is_available,lsubmodel)
703 DO kk=1,nlines
704 CALL hm_get_int_array_index('Ifirst',idmin ,kk,is_available,lsubmodel)
705 CALL hm_get_int_array_index('Ilast' ,idmax ,kk,is_available,lsubmodel)
706 CALL hm_get_int_array_index('Iincr' ,offset ,kk,is_available,lsubmodel)
707 DO j=idmin, idmax , offset
708 IF (j > 0) THEN
709 DO k=1,numnod
710 id = itab(k)
711 IF(id<idmin .OR. id>idmax) cycle
712 IF(mod(id-idmin,offset)==0) buftmp(k) = 1
713 ENDDO
714 ENDIF
715 ENDDO
716 ENDDO
717C---
718 nnod=0
719 IF (flag == 0) THEN
720 DO j=1,numnod
721 IF (buftmp(j) == 1) nnod=nnod+1
722 ENDDO
723 igrnod(igs)%NENTITY=nnod
724 CALL my_alloc(igrnod(igs)%ENTITY,nnod)
725 igrnod(igs)%ENTITY=0
726 ELSE
727 DO j=1,numnod
728 IF (buftmp(j) == 1)THEN
729 nn = nn + 1
730 igrnod(igs)%ENTITY(nn)=j
731 ENDIF
732 ENDDO
733 ENDIF
734C---
735 ENDIF
736 ENDDO
737 ENDIF
738C-----
739 DEALLOCATE(buftmp)
740 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
hm_bigbox
subroutine hm_bigbox(x, flag, nnod, skew, igs, iskn, itabm1, ibox, id, ibufbox, iadb, titr, key, nn, iboxmax, igrnod, idb)
Definition hm_bigbox.F:38
hm_elngr
subroutine hm_elngr(ix, nix, nix1, nix2, ngrele, elchar, id, igrelem, tagbuf, titr, flag, lsubmodel)
Definition hm_elngr.F:39
hm_elngrs
subroutine hm_elngrs(ixs, ixs10, ixs20, ixs16, ngrele, elchar, id, igrelem, tagbuf, titr, flag, lsubmodel)
Definition hm_elngr.F:116
hm_elngrr
subroutine hm_elngrr(ixr, geo, ngrele, id, igrelem, tagbuf, titr, flag, lsubmodel)
Definition hm_elngrr.F:39
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_linengr
subroutine hm_linengr(id, igrslin, tagbuf, titr, nsets, lsubmodel)
Definition hm_linengr.F:37
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_submodgrn
subroutine hm_submodgrn(itab, itabm1, isubmod, sid, nnod, mess, flag, titr, titr1, lsubmodel, igrnod, nn)
Definition hm_submodgr.F:39
hm_surfnod
subroutine hm_surfnod(id, igrsurf, tagbuf, titr, nsets, lsubmodel)
Definition hm_surfnod.F:37
hm_tagpart
subroutine hm_tagpart(bufftmp, ipart, key, id, titr, titr1, flag, subset, lsubmodel)
Definition hm_tagpart.F:40
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:274
max
#define max(a, b)
Definition macros.h:21
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
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
optiondef_mod
Definition optiondef_mod.F:90
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
ulist2s
integer function ulist2s(list, nlist, itabm1, mess, index, id)
Definition sysfus.F:449
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:146
udouble_igr
subroutine udouble_igr(list, nlist, mess, ir, rlist)
Definition sysfus.F:1204
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29
tagnods
subroutine tagnods(ixs, ixs10, ixs20, ixs16, iparts, tagbuf, idgrn, titr)
Definition tagnod.F:68
tagnodr
subroutine tagnodr(ixr, geo, numelr, ipartr, tagbuf, npart)
Definition tagnodr.F:30
tagnodx
subroutine tagnodx(ixx, kxx, numelx, ipartx, tagbuf, npart)
Definition tagnodx.F:29