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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_lines (itab, itabm1, isubmod, igrslin, igrsurf, x, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ipart, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, iparttg, nsegs, flag, skew, iskn, unitab, ibox, rtrans, lsubmodel, ipartx, kxx, ixx, iadboxmax, subset, igrtruss, igrbeam, igrspring, nsets, map_tables)

Function/Subroutine Documentation

◆ hm_read_lines()

subroutine hm_read_lines ( integer, dimension(*) itab,
integer, dimension(*) itabm1,
integer, dimension(*) isubmod,
type (surf_), dimension(nslin+nsets) igrslin,
type (surf_), dimension(nsurf+nsets) igrsurf,
x,
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(*) iparttg,
integer nsegs,
integer flag,
skew,
integer, dimension(liskn,*) iskn,
type (unit_type_), intent(in) unitab,
type (box_), dimension(nbbox) ibox,
rtrans,
type(submodel_data), dimension(nsubmod) lsubmodel,
integer, dimension(*) ipartx,
integer, dimension(nixx,*) kxx,
integer, dimension(*) ixx,
integer iadboxmax,
type (subset_), dimension(nsubs) subset,
type (group_), dimension(ngrtrus) igrtruss,
type (group_), dimension(ngrbeam) igrbeam,
type (group_), dimension(ngrspri) igrspring,
integer nsets,
type(mapping_struct_), intent(in) map_tables )

Definition at line 53 of file hm_read_lines.F.

63C-----------------------------------------------
64C M o d u l e s
65C-----------------------------------------------
66 USE my_alloc_mod
67 USE unitab_mod
68 USE submodel_mod , ONLY : nsubmod, submodel_data
69 USE message_mod
70 USE groupdef_mod
71 USE optiondef_mod
72 USE surf_mod
73 USE hm_option_read_mod
74 USE mapping_option_mod
75 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
76 USE reader_old_mod , ONLY : line, kline
77 use element_mod , only : nixs, nixq, nixc, nixt, nixp, nixr, nixtg
78C-----------------------------------------------
79C I m p l i c i t T y p e s
80C-----------------------------------------------
81#include "implicit_f.inc"
82C-----------------------------------------------
83C C o m m o n B l o c k s
84C-----------------------------------------------
85#include "scr17_c.inc"
86#include "scr23_c.inc"
87#include "com04_c.inc"
88#include "param_c.inc"
89C-----------------------------------------------
90C D u m m y A r g u m e n t s
91C-----------------------------------------------
92 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
93 INTEGER ITABM1(*),
94 . IXS(NIXS,*),IXQ(NIXQ,*),IXC(NIXC,*),IXT(NIXT,*),
95 . IXP(NIXP,*),IXR(NIXR,*),IXTG(NIXTG,*),IPARTS(*),
96 . IPARTQ(*),IPARTC(*),IPARTT(*),IPARTP(*),IPARTR(*),
97 . IPARTTG(*),IPART(LIPART1,*),
98 . ITAB(*),ISUBMOD(*),FLAG,NSEGS,ISKN(LISKN,*),
99 . IPARTX(*),KXX(NIXX,*),
100 . IXX(*),IADBOXMAX,NSETS
101 my_real
102 . x(3,*),skew(lskew,*),rtrans(*)
103 TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
104 TYPE(MAPPING_STRUCT_), INTENT(IN) :: MAP_TABLES
105C-----------------------------------------------
106 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
107 TYPE (GROUP_) , DIMENSION(NGRTRUS) :: IGRTRUSS
108 TYPE (GROUP_) , DIMENSION(NGRBEAM) :: IGRBEAM
109 TYPE (GROUP_) , DIMENSION(NGRSPRI) :: IGRSPRING
110 TYPE (SURF_) , DIMENSION(NSURF+NSETS) :: IGRSURF
111 TYPE (SURF_) , DIMENSION(NSLIN+NSETS) :: IGRSLIN
112 TYPE (BOX_) , DIMENSION(NBBOX) :: IBOX
113C-----------------------------------------------
114C L o c a l V a r i a b l e s
115C-----------------------------------------------
116 INTEGER I,II,K,L,J,JC,JJ,KK,ISU,ID,NSEG,NSEG0,NSEGV,N1,N2,NUMEL,
117 . OK,IGS,IGRS,JREC,IAD0,NE,ITYP,
118 . IT0,IT1,IT2,IT3,IT4,IT5,IT6,IT7,SBUFBOX,UID,IFLAGUNIT,
119 . ISK,BOXTYPE,J2(2),IT8,SUB_ID,IBUFSIZ,NINDX,STAT,
120 . INTMAX,IADBOX,LIST_LINE(NSLIN),ISEG,IBID,NSEG_TOT,NN,LINE_NSEG0,SUB_INDEX
121 my_real
122 . xmin,xmax,ymin,ymax,zmin,zmax,bid,fac_l,
123 . diam,xp1,yp1,zp1,xp2,yp2,zp2
124 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1,STRING
125 CHARACTER(LEN=NCHARKEY) :: KEY,KEY2
126 CHARACTER MESS*40
127 INTEGER, DIMENSION(:),ALLOCATABLE :: BUFBOX, BUFTMP, INDX,TAGT ,TAGP
128 LOGICAL :: FLAG_GRBRIC
129 INTEGER :: MODE, NENTITY
130 TYPE(PART_TYPE), DIMENSION(:), ALLOCATABLE :: SURF_ELM
131 LOGICAL IS_AVAILABLE, IS_ENCRYPTED, lERROR
132C-----------------------------------------------
133C D e s c r i p t i o n
134C-----------------------------------------------
135! *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
136! FLAG_GRBRIC : flag to initialize the INDX_SOL(10) arrays
137! and optimize an old and expensive treatment in SSURFTAG
138! NOT USED IN THIS ROUTINE !!!!!!!!!!!!
139! MODE : integer
140! switch to initialize solid/shell/shell3n or truss/beam/spring
141! SURF_ELM : PART_TYPE structure
142! %Nxxx : number of element per part
143! %xxx_PART : ID of the element
144! *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
145C-----------------------------------------------
146! IGRSLIN(IGS)%ID :: LINE identifier
147! IGRSLIN(IGS)%TITLE :: LINE title
148! IGRSLIN(IGS)%NSEG :: Number of lines
149! IGRSLIN(IGS)%LEVEL :: FLAG "SUBLEVEL DONE" FOR LINES OF LINES
150! = 0 ! initialized line
151! = 1 ! uninitialized line
152! IGRSLIN(IGS)%ELEM(J) :: element attached to the line segment
153! IGRSLIN(IGS)%NODES(J,2) :: 2 nodes of the line segment
154! IGRSLIN(IGS)%PROC(J) :: field to store the processor ID (/LINE only)
155!
156! 1. Set processor only when no element is set in lines
157! 2. Split lines accordingly
158!
159C-----------------------------------------------
160C E x t e r n a l F u n c t i o n s
161C-----------------------------------------------
162 INTEGER USR2SYS
163C 1234567890123456789012345678901234567890
164 DATA mess/'LINE DEFINITION '/
165 DATA intmax /2147483647/
166C-----------------------------------------------
167C S o u r c e L i n e s
168C-----------------------------------------------
169 it0=0
170 it1=0
171 it2=0
172 it3=0
173 it4=0
174 it5=0
175 it6=0
176 it7=0
177 it8=0
178 ok =0
179 flag_grbric = .false.
180 ibufsiz=6*nsegs
181 ALLOCATE(buftmp(ibufsiz),indx(ibufsiz),stat=stat)
182 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,msgtype=msgerror,c1='BUFTMP')
183 nindx=0
184 buftmp(1:ibufsiz)=0 ! init to 0 only one time
185C-----------------------------------------------
186 CALL hm_option_start('/LINE')
187 titr1='LINE'
188 DO igs=1,nslin
189 lerror=.false.
190 CALL hm_option_read_key(lsubmodel,
191 . option_id = id,
192 . option_titr = titr ,
193 . unit_id = uid,
194 . keyword2 = key ,
195 . keyword3 = key2)
196 iseg = 0
197 IF (flag == 0) THEN
198 igrslin(igs)%ID = 0
199 igrslin(igs)%NSEG = 0
200 igrslin(igs)%TYPE = 0
201 igrslin(igs)%LEVEL = 0
202 igrslin(igs)%NSEG_R2R_ALL = 0
203 igrslin(igs)%NSEG_R2R_SHARE = 0
204 ENDIF
205 igrslin(igs)%ID = id
206 igrslin(igs)%LEVEL = 1
207 igrslin(igs)%TITLE = titr
208 IF(key(1:4) == 'LINE') THEN !tag des lines of lines
209 igrslin(igs)%NSEG = -1
210 igrslin(igs)%LEVEL = 0
211 it0=it0+1
212 ELSEIF(key(1:3) == 'SEG') THEN
213 it1=it1+1
214 IF (flag == 0) THEN
215 CALL hm_get_intv('segmax',nseg,is_available,lsubmodel)
216 igrslin(igs)%NSEG = nseg
217 CALL my_alloc(igrslin(igs)%NODES,nseg,2)
218 igrslin(igs)%NODES(1:nseg,1:2) = 0
219 CALL my_alloc(igrslin(igs)%ELTYP,nseg)
220 igrslin(igs)%ELTYP(1:nseg) = 0
221 CALL my_alloc(igrslin(igs)%ELEM,nseg)
222 igrslin(igs)%ELEM(1:nseg) = 0
223 CALL my_alloc(igrslin(igs)%PROC,nseg)
224 igrslin(igs)%PROC(1:nseg) = 0
225 ENDIF
226 IF(flag == 1) THEN
227 CALL hm_get_intv ('segmax' ,nentity,is_available,lsubmodel)
228 DO kk=1,nentity
229 CALL hm_get_int_array_index ('N1' ,n1 ,kk,is_available,lsubmodel)
230 CALL hm_get_int_array_index ('N2' ,n2 ,kk,is_available,lsubmodel)
231 igrslin(igs)%NODES(kk,1) = usr2sys(n1,itabm1,mess,id)
232 igrslin(igs)%NODES(kk,2) = usr2sys(n2,itabm1,mess,id)
233 igrslin(igs)%ELTYP(kk) = 0
234 igrslin(igs)%ELEM(kk) = 0
235 ENDDO
236 ENDIF
237 ELSEIF(key(1:4) == 'PART'.OR.key(1:6) == 'SUBSET'.OR. key(1:3) == 'MAT' .OR.key(1:4) == 'PROP') THEN
238C line of SUBSET PART MAT OR PROP
239 it2=it2+1
240 IF (flag == 0) igrslin(igs)%NSEG = 0
241 ELSEIF(key(1:3) == 'BOX'.AND.nbbox == 0 .AND.(key2(1:5) /= 'RECTA'.AND.key2(1:5) /= 'CYLIN'.AND.key2(1:5) /= 'SPHER'))THEN
242C line in a box (old)
243 lerror=.true.
244 ELSEIF(key(1:2) == 'GR'.OR.key(1:4) == 'WIRE') THEN
245C line of ele 2N in an element group
246 it4=it4+1
247 IF (flag == 0) igrslin(igs)%NSEG = 0
248 ELSEIF(key(1:4) == 'SURF'.OR.key(1:4) == 'EDGE') THEN
249C line of ele 2N in a surface or its edge
250 it5=it5+1
251 IF (flag == 0) igrslin(igs)%NSEG = 0
252 ELSEIF(key(1:6) == 'SUBMOD') THEN
253C line of submodel
254 it6=it6+1
255 IF (flag == 0) igrslin(igs)%NSEG = 0
256 ELSEIF(key(1:3) == 'BOX'.AND.(key2(1:5) == 'RECTA'.OR. key2(1:5) == 'CYLIN'.OR.key2(1:5) == 'SPHER'))THEN
257 !old /grnod/box (not /BOX/BOX)
258 !line in a box (classical box, parallelepiped (oriented),
259 ! cylindrical, spherical)
260 lerror=.true.
261 ELSEIF(key(1:3) == 'BOX' .AND. nbbox > 0)THEN
262 !multi box (box de box)
263 it8=it8+1
264 ELSE
265 lerror=.true.
266 ENDIF
267
268 IF(lerror)THEN
269 !INVALID KEYWORD
270 string=' '
271 string = "/LINE/"//key(1:len_trim(key)-1)
272 IF(len_trim(key2)>1)string = string//key2(1:len_trim(key2)-1)
273 CALL ancmsg(msgid=688,anmode=aninfo,msgtype=msgerror,i1=id, c1=titr, c2=string)
274 ENDIF
275
276 ENDDO
277
278C-------------------------------------
279C Search for double IDs
280C-------------------------------------
281 IF (flag == 0) THEN
282 DO igs=1,nslin
283 list_line(igs) = igrslin(igs)%ID
284 ENDDO
285 CALL udouble_igr(list_line,nslin,mess,0,bid)
286 ENDIF
287C=======================================================================
288C BOX (old)
289C=======================================================================
290 IF(it3 /= 0) THEN
291 !NO LONGER SUPPORTED
292 ENDIF
293C=======================================================================
294C BOX (parallelepiped, cylindrical, spherical) - old one (10SA1)
295C=======================================================================
296 IF(it7 /= 0) THEN
297 !NO LONGER SUPPORTED
298 ENDIF
299C-------------------------
300C NEW BOX OPTION (MULTI BOX COMBINATION)
301C-------------------------
302 IF (it8 /= 0) THEN
303 ALLOCATE(tagt(numelt),stat=stat)
304 ALLOCATE(tagp(numelp),stat=stat)
305 tagt(1:numelt) = 0
306 tagp(1:numelp) = 0
307 IF (flag == 0) THEN
308 ALLOCATE(bufbox(1))
309 bufbox = 0
310 ELSEIF (flag == 1) THEN
311 ALLOCATE(bufbox(iadboxmax))
312 bufbox(1:iadboxmax) = 0
313 ENDIF
314 sbufbox = int(intmax)
315 CALL hm_option_start('/LINE')
316 titr1='LINE'
317 DO igs=1,nslin
318 CALL hm_option_read_key(lsubmodel,
319 . option_id = id,
320 . option_titr = titr ,
321 . unit_id = uid,
322 . keyword2 = key ,
323 . keyword3 = key2)
324 nn = 0
325 nseg=0
326 kline=line
327 IF(key(1:3) == 'BOX'.AND. nbbox > 0)THEN
328 nseg=0
329 iadbox = 1
330 iflagunit = 0
331 DO j=1,unitab%NUNITS
332 IF (unitab%UNIT_ID(j) == uid) THEN
333 fac_l = unitab%FAC_L(j)
334 iflagunit = 1
335 EXIT
336 ENDIF
337 ENDDO
338 IF (uid/=0.AND.iflagunit==0) THEN
339 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,i2=uid,i1=id,c1='LINE',c2='LINE',c3=titr)
340 ENDIF
341
342 IF (flag == 1) THEN ! NSEG counted at FLAG = 0
343 nseg0 = igrslin(igs)%NSEG
344 CALL my_alloc(igrslin(igs)%NODES,nseg0,2)
345 igrslin(igs)%NODES(1:nseg0,1:2) = 0
346 CALL my_alloc(igrslin(igs)%ELTYP,nseg0)
347 igrslin(igs)%ELTYP(1:nseg0) = 0
348 CALL my_alloc(igrslin(igs)%ELEM,nseg0)
349 igrslin(igs)%ELEM(1:nseg0) = 0
350 CALL my_alloc(igrslin(igs)%PROC,nseg0)
351 igrslin(igs)%PROC(1:nseg0) = 0
352 ENDIF
353
354 IF(numelt > 0)
355 . CALL hm_bigsbox(numelt ,ixt ,nixt ,2 ,3 ,4 ,
356 . x ,nseg ,flag ,skew ,
357 . iskn ,0 ,itabm1 ,ibox ,
358 . id ,bufbox ,igrslin(igs),iadbox, key ,
359 . sbufbox,titr ,mess ,tagt,
360 . nn ,lsubmodel)
361 iadboxmax = max(iadbox,iadboxmax)
362 IF (iadbox>sbufbox .OR. iadbox<0)
363 . CALL ancmsg(msgid=1007,msgtype=msgerror,anmode=anstop)
364 IF(numelp > 0)
365 . CALL hm_bigsbox(numelp ,ixp ,nixp ,2 ,3 ,5 ,
366 . x ,nseg ,flag ,skew,
367 . iskn ,0 ,itabm1 ,ibox ,
368 . id ,bufbox ,igrslin(igs),iadbox, key ,
369 . sbufbox,titr ,mess ,tagp ,
370 . nn ,lsubmodel)
371 IF (iadbox>sbufbox .OR. iadbox<0)
372 . CALL ancmsg(msgid=1007,msgtype=msgerror,anmode=anstop)
373 iadboxmax = max(iadbox,iadboxmax)
374 IF (flag == 0) THEN
375 igrslin(igs)%NSEG = nseg
376 ELSEIF (flag == 1) THEN
377 igrslin(igs)%NSEG = nseg
378 ENDIF
379 ENDIF
380 ENDDO
381 DEALLOCATE(tagt,tagp)
382 IF(ALLOCATED(bufbox))DEALLOCATE(bufbox)
383 ENDIF ! IF(IT8 /= 0)
384C---
385C=======================================================================
386C line of subsets, share, mat, prop
387C=======================================================================
388 IF(it2/=0.OR.it6/=0) THEN
389 ALLOCATE( surf_elm(npart) )
390 mode = 2
391 CALL init_surf_elm(ibid ,ibid ,ibid ,ibid ,ibid ,
392 1 numelt ,numelp ,numelr ,npart ,ibid ,
393 2 ibid ,ibid ,ipartt ,ipartp ,ipartr ,
394 3 surf_elm,mode )
395 ENDIF
396
397 IF(it2 /= 0) THEN
398 CALL hm_option_start('/LINE')
399 titr1='LINE'
400 DO igs=1,nslin
401 CALL hm_option_read_key(lsubmodel,
402 . option_id = id,
403 . option_titr = titr ,
404 . unit_id = uid,
405 . keyword2 = key ,
406 . keyword3 = key2)
407 nseg=0
408 kline=line
409 IF (key(1:4) == 'PART'.OR.key(1:6) == 'SUBSET'.OR. key(1:3) == 'MAT' .OR.key(1:4) == 'PROP') THEN
410 IF (flag == 1) THEN ! NSEG counted at FLAG = 0
411 nseg0 = igrslin(igs)%NSEG
412 CALL my_alloc(igrslin(igs)%NODES,nseg0,2)
413 igrslin(igs)%NODES(1:nseg0,1:2) = 0
414 CALL my_alloc(igrslin(igs)%ELTYP,nseg0)
415 igrslin(igs)%ELTYP(1:nseg0) = 0
416 CALL my_alloc(igrslin(igs)%ELEM,nseg0)
417 igrslin(igs)%ELEM(1:nseg0) = 0
418 CALL my_alloc(igrslin(igs)%PROC,nseg0)
419 igrslin(igs)%PROC(1:nseg0) = 0
420 ENDIF
421 CALL hm_tagpart2(buftmp,ipart ,key ,
422 . igrslin(igs)%ID,titr,titr1,indx,nindx ,
423 . flag,subset,lsubmodel,map_tables%IPARTM)
424 CALL surftag(numelt,ixt,nixt,2,3,4,ipartt,
425 . buftmp,igrslin(igs),nseg,flag,nindx,
426 . indx,surf_elm)
427 CALL surftag(numelp,ixp,nixp,2,3,5,ipartp,
428 . buftmp,igrslin(igs),nseg,flag,nindx,
429 . indx,surf_elm)
430 IF (key(1:3) /= 'MAT')
431 . CALL surftag(numelr,ixr,nixr,2,3,6,ipartr,
432 . buftmp,igrslin(igs),nseg,flag,nindx,
433 . indx,surf_elm)
434 IF (key(1:4) == 'PART')
435 . CALL surftagx(numelx,ixx,kxx,nixx,8,ipartx,
436 . buftmp,igrslin(igs),nseg,flag)
437 IF (flag == 0) igrslin(igs)%NSEG = nseg
438 ENDIF
439 ! reset BUFTMP to 0 (only where it was set to 1/-1)
440 DO ii=1,nindx
441 buftmp(indx(ii))=0
442 END DO
443 nindx=0
444 ENDDO
445 ENDIF
446
447C=======================================================================
448C line of SUBMODELS
449C=======================================================================
450 igs=0
451 IF (it6 > 0)THEN
452 CALL hm_option_start('/LINE')
453 titr1='LINE'
454 DO igs=1,nslin
455 CALL hm_option_read_key(lsubmodel,
456 . option_id = id,
457 . option_titr = titr ,
458 . unit_id = uid,
459 . keyword2 = key ,
460 . keyword3 = key2)
461 nseg=0
462 IF (key(1:6)=='SUBMOD') THEN
463 IF (flag == 1) THEN ! NSEG counted at FLAG = 0
464 nseg0 = igrslin(igs)%NSEG
465 CALL my_alloc(igrslin(igs)%NODES,nseg0,2)
466 igrslin(igs)%NODES(1:nseg0,1:2) = 0
467 CALL my_alloc(igrslin(igs)%ELTYP,nseg0)
468 igrslin(igs)%ELTYP(1:nseg0) = 0
469 CALL my_alloc(igrslin(igs)%ELEM,nseg0)
470 igrslin(igs)%ELEM(1:nseg0) = 0
471 CALL my_alloc(igrslin(igs)%PROC,nseg0)
472 igrslin(igs)%PROC(1:nseg0) = 0
473 ENDIF
474!
475 CALL hm_submodpart(isubmod,buftmp,ipart,id ,flag ,
476 . mess ,titr ,titr1,indx,nindx,
477 . lsubmodel)
478 CALL surftag(numelt,ixt,nixt,2,3,4,ipartt,
479 . buftmp,igrslin(igs),nseg,flag,nindx,
480 . indx,surf_elm)
481 CALL surftag(numelp,ixp,nixp,2,3,5,ipartp,
482 . buftmp,igrslin(igs),nseg,flag,nindx,
483 . indx,surf_elm)
484 CALL surftag(numelr,ixr,nixr,2,3,6,ipartr,
485 . buftmp,igrslin(igs),nseg,flag,nindx,
486 . indx,surf_elm)
487 IF (flag == 0) igrslin(igs)%NSEG = nseg
488 ENDIF
489C reset BUFTMP to 0 (only where it was set to 1/-1)
490 DO ii=1,nindx
491 buftmp(indx(ii))=0
492 END DO
493 nindx=0
494 ENDDO
495 ENDIF
496C=======================================================================
497C edge line of surface
498C=======================================================================
499 IF (it5 /= 0) THEN
500 CALL hm_option_start('/LINE')
501 titr1='LINE'
502 DO igs=1,nslin
503 CALL hm_option_read_key(lsubmodel,
504 . option_id = id,
505 . option_titr = titr ,
506 . unit_id = uid,
507 . keyword2 = key ,
508 . keyword3 = key2)
509 IF (key(1:4) == 'SURF' .OR. key(1:4) == 'EDGE') THEN
510 iad0 =1
511 nseg =0
512 nseg0=0
513 CALL hm_get_intv ('idsmax' ,nentity,is_available,lsubmodel)
514 DO kk=1,nentity
515 CALL hm_get_int_array_index ('ids' ,jj ,kk,is_available,lsubmodel)
516 IF (jj /= 0) THEN
517 igrs=0
518 DO k=1,nsurf
519 IF (jj == igrsurf(k)%ID) THEN
520 igrs=k
521 EXIT
522 ENDIF
523 ENDDO
524 IF (igrs /= 0) THEN
525 nseg0=nseg0+igrsurf(igrs)%NSEG
526 DO k=0,igrsurf(igrs)%NSEG-1
527 buftmp(iad0+6*k) = igrsurf(igrs)%NODES(k+1,1)
528 buftmp(iad0+6*k+1) = igrsurf(igrs)%NODES(k+1,2)
529 buftmp(iad0+6*k+2) = igrsurf(igrs)%NODES(k+1,3)
530 buftmp(iad0+6*k+3) = igrsurf(igrs)%NODES(k+1,4)
531 buftmp(iad0+6*k+4) = igrsurf(igrs)%ELTYP(k+1)
532 buftmp(iad0+6*k+5) = igrsurf(igrs)%ELEM(k+1)
533 DO jj=1,6
534 nindx=nindx+1
535 indx(nindx)=iad0+6*k+jj-1
536 ENDDO
537 ENDDO
538 iad0=iad0+6*igrsurf(igrs)%NSEG
539 ENDIF
540 ENDIF
541 ENDDO
542 IF (flag == 1) THEN ! NSEG counted at FLAG = 0
543 CALL my_alloc(igrslin(igs)%NODES, igrslin(igs)%NSEG,2)
544 igrslin(igs)%NODES(1:igrslin(igs)%NSEG,1:2) = 0
545 CALL my_alloc(igrslin(igs)%ELTYP,igrslin(igs)%NSEG)
546 igrslin(igs)%ELTYP(1:igrslin(igs)%NSEG) = 0
547 CALL my_alloc(igrslin(igs)%ELEM,igrslin(igs)%NSEG)
548 igrslin(igs)%ELEM(1:igrslin(igs)%NSEG) = 0
549 CALL my_alloc(igrslin(igs)%PROC,igrslin(igs)%NSEG)
550 igrslin(igs)%PROC(1:igrslin(igs)%NSEG) = 0
551 ENDIF
552 IF (nseg0 > 0) THEN
553 line_nseg0 = 1
554 IF (flag == 1) line_nseg0 = igrslin(igs)%NSEG
555 CALL linedge(nseg0 ,nseg ,buftmp,igrslin(igs)%NODES ,key,
556 . flag ,igrslin(igs)%ELTYP,igrslin(igs)%ELEM,
557 . line_nseg0)
558 ENDIF
559 IF (flag == 0) igrslin(igs)%NSEG = nseg
560 ENDIF
561 !reset BUFTMP to 0 (only where it was set to 1/-1)
562 DO ii=1,nindx
563 buftmp(indx(ii))=0
564 END DO
565 nindx=0
566 ENDDO
567 ENDIF
568C=======================================================================
569C LINE FORMED OF TRUSS BEAM SPRING GROUP
570C=======================================================================
571 IF (it4 /= 0) THEN
572 CALL hm_option_start('/LINE')
573 titr1='LINE'
574 DO igs=1,nslin
575 CALL hm_option_read_key(lsubmodel,
576 . option_id = id,
577 . option_titr = titr ,
578 . unit_id = uid,
579 . keyword2 = key ,
580 . keyword3 = key2)
581 nseg=0
582 nseg_tot=0
583 IF (key(1:2) == 'GR'.OR.key(1:4) == 'WIRE') THEN
584 IF (flag == 1) THEN ! NSEG counted at FLAG = 0
585 nseg0 = igrslin(igs)%NSEG
586 CALL my_alloc(igrslin(igs)%NODES,nseg0,2)
587 igrslin(igs)%NODES(1:nseg0,1:2) = 0
588 CALL my_alloc(igrslin(igs)%ELTYP,igrslin(igs)%NSEG)
589 igrslin(igs)%ELTYP(1:igrslin(igs)%NSEG) = 0
590 CALL my_alloc(igrslin(igs)%ELEM,igrslin(igs)%NSEG)
591 igrslin(igs)%ELEM(1:igrslin(igs)%NSEG) = 0
592 CALL my_alloc(igrslin(igs)%PROC,nseg0)
593 igrslin(igs)%PROC(1:nseg0) = 0
594 ENDIF
595 IF(key(1:6) == 'GRSPRI') THEN
596 numel=numelr
597 CALL hm_surfgr2(ngrspri,key(1:6),numel,igrslin(igs)%ID,
598 . igrspring,buftmp,titr,titr1,
599 . indx,nindx,flag,ibid,ibid,
600 . ibid,ibid,flag_grbric,lsubmodel)
601 CALL surftage(numelr,ixr,nixr,2,3,6,
602 . buftmp,igrslin(igs),nseg,flag,
603 . indx,nindx,nseg_tot)
604 ELSEIF(key(1:6) == 'GRTRUS') THEN
605 numel=numelt
606 CALL hm_surfgr2(ngrtrus,key(1:6),numel,igrslin(igs)%ID,
607 . igrtruss,buftmp,titr,titr1,
608 . indx,nindx,flag,ibid,ibid,
609 . ibid,ibid,flag_grbric,lsubmodel)
610 CALL surftage(numelt,ixt,nixt,2,3,4,
611 . buftmp,igrslin(igs),nseg,flag,
612 . indx,nindx,nseg_tot)
613 ELSEIF(key(1:6) == 'GRBEAM') THEN
614 numel=numelp
615 CALL hm_surfgr2(ngrbeam,key(1:6),numel,igrslin(igs)%ID,
616 . igrbeam,buftmp,titr,titr1,
617 . indx,nindx,flag,ibid,ibid,
618 . ibid,ibid,flag_grbric,lsubmodel)
619 CALL surftage(numelp,ixp,nixp,2,3,5,
620 . buftmp,igrslin(igs),nseg,flag,
621 . indx,nindx,nseg_tot)
622 ENDIF
623 IF (flag == 0) igrslin(igs)%NSEG = nseg
624 ENDIF
625 ! reset BUFTMP to 0 (only where it was set to 1/-1)
626 DO ii=1,nindx
627 buftmp(indx(ii))=0
628 END DO
629 nindx=0
630C-----------
631 ENDDO
632 ENDIF
633C=======================================================================
634 DEALLOCATE(buftmp,indx)
635 IF(it2/=0.OR.it6/=0) THEN
636! deallocation of SURT_ELM structure
637 mode = 2
638 CALL deallocate_surf_elm(npart,surf_elm,mode)
639 DEALLOCATE( surf_elm )
640 ENDIF
641 RETURN
642 900 CONTINUE
643c Il n y a pas de label 900 ...
644 CALL ancmsg(msgid=189,msgtype=msgerror,anmode=aninfo,i1=igrslin(igs)%ID)
645 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
hm_bigsbox
subroutine hm_bigsbox(numel, ix, nix, nix1, nix2, ieltyp, x, nseg, flag, skew, iskn, isurf0, itabm1, ibox, id, ibufbox, isurflin, iadb, key, sbufbox, titr, mess, tagshellbox, nn, lsubmodel)
Definition hm_bigsbox.F:44
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_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_submodpart
subroutine hm_submodpart(isubmod, tagbuf, ipart, id, flag, mess, titr, titr1, indx, nindx, lsubmodel)
Definition hm_submodpart.F:41
hm_surfgr2
subroutine hm_surfgr2(ngrele, elchar, numel, id, igrelem, tagbuf, titr, titr1, indx, nindx, flag, nindx_sol, nindx_sol10, indx_sol, indx_sol10, flag_grbric, lsubmodel)
Definition hm_surfgr2.F:40
hm_tagpart2
subroutine hm_tagpart2(bufftmp, ipart, key, id, titr, titr1, indx, nindx, flag, subset, lsubmodel, map)
Definition hm_tagpart2.F:43
init_surf_elm
subroutine init_surf_elm(numels, numels8, numels10, numelc, numeltg, numelt, numelp, numelr, npart, iparts, ipartc, iparttg, ipartt, ipartp, ipartr, surf_elm, mode)
Definition init_surf_elm.F:35
deallocate_surf_elm
subroutine deallocate_surf_elm(npart, surf_elm, mode)
Definition init_surf_elm.F:200
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
linedge
subroutine linedge(nseg0, nseg, buftmp, slin_nodes, key, flag, slin_eltyp, slin_elem, line_nseg0)
Definition linedge.F:32
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
mapping_option_mod
Definition dichotomy_mod.F:36
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
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
surf_mod
Definition surf_mod.F:37
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
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
submodel_mod::submodel_data
Definition submodel_mod.F:728
surftag
subroutine surftag(numel, ix, nix, nix1, nix2, ieltyp, iparte, tagbuf, isu, nseg, flag, nindx, indx, surf_elm)
Definition surftag.F:34
surftagx
subroutine surftagx(numel, ixx, kxx, nixx, ieltyp, iparte, tagbuf, igrslin, nseg, flag)
Definition surftag.F:209
surftage
subroutine surftage(numel, ix, nix, nix1, nix2, ieltyp, tagbuf, isu, nseg, flag, indx, nindx, nseg_tot)
Definition surftage.F:33