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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_subset (subset, ipart, nsubs, npart, lsubmodel)
recursive integer function sublvl (subset, nsubs, isu, np, buftmp)
subroutine ecrsub2 (subset, nsubs, isu, ipart, nivmax)

Function/Subroutine Documentation

◆ ecrsub2()

subroutine ecrsub2 ( type (subset_), dimension(nsubs) subset,
integer nsubs,
integer isu,
integer, dimension(lipart1,*) ipart,
integer nivmax )

Definition at line 396 of file hm_read_subset.F.

397 USE message_mod
398 USE groupdef_mod
399 USE names_and_titles_mod , ONLY : nchartitle
400C-----------------------------------------------
401C I m p l i c i t T y p e s
402C-----------------------------------------------
403#include "implicit_f.inc"
404C-----------------------------------------------
405C D u m m y A r g u m e n t s
406C-----------------------------------------------
407 INTEGER NSUBS,ISU,IPART(LIPART1,*)
408 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
409C-----------------------------------------------
410C C o m m o n B l o c k s
411C-----------------------------------------------
412#include "units_c.inc"
413#include "scr17_c.inc"
414C-----------------------------------------------
415C L o c a l V a r i a b l e s
416C-----------------------------------------------
417 INTEGER I,K,K2,L,LL,NP,IP,ID,NIVEAU,NIVMAX,TITLEN
418 INTEGER CNT(0:33)
419 CHARACTER LIGNE*132,LIGN2*132,BAR(33)*10,BLI*21
420 CHARACTER(LEN=NCHARTITLE)::TITR
421 DATA bar /33*'| '/
422 DATA bli /'|____________________'/
423 DATA cnt /34*0/
424C=======================================================================
425
426 ligne=' '
427 id = subset(isu)%ID
428 niveau = subset(isu)%LEVEL
429 IF (niveau >= 33) GOTO 999
430 cnt(niveau) = cnt(niveau)+1
431 bar(niveau+1)='| '
432 cnt(niveau+1)=0
433
434 l = min(10,max(2,22/(nivmax+1)))
435
436c lignes vides avant subset
437 k = 3
438 DO i=1,niveau
439 ligne(k:k+l) = bar(i)(1:l)
440 k = k+l
441 IF (k > 132) GOTO 999
442 ENDDO
443 k = k-1
444 WRITE(iout,'(A)')ligne(1:k)
445 WRITE(iout,'(A)')ligne(1:k)
446c--------------------------------
447 IF (niveau == 0) THEN
448 ELSEIF (cnt(niveau) == subset(subset(isu)%PARENT)%NCHILD) THEN
449 bar(niveau) = ' '
450 ENDIF
451
452c ligne subset
453 ligne=' '
454 IF (niveau == 0) THEN
455 k = 2
456 ELSE
457 k = 3
458 ENDIF
459
460 DO i=1,niveau-1
461 ligne(k:k+l-1)=bar(i)(1:l)
462 k=k+l
463 IF (k > 132) GOTO 999
464 ENDDO
465 IF (niveau /= 0) THEN
466 ligne(k:k+l-2)=bli(1:l-1)
467 k = k+l-1
468 IF (k > 132-16) GOTO 999
469 ENDIF
470 WRITE(ligne(k:k+17),fmt='(A7,I10,A1)')'SUBSET:',id,','
471 k = k+17
472 i = 0
473 titlen = len(subset(isu)%TITLE)
474 DO WHILE (i < titlen .AND. k < 132)
475 k=k+1
476 i=i+1
477 ligne(k:k) = subset(isu)%TITLE(i:i)
478 ENDDO
479 WRITE(iout,'(A)')ligne(1:k)
480
481c subset souligne + ligne vide apres subset
482 k=3
483 ligne=' '
484 DO i=1,niveau
485 ligne(k:k+l-1)=bar(i)(1:l)
486 k=k+l
487 IF(k > 132)GOTO 999
488 ENDDO
489 k2 = k
490 k = k-1
491 WRITE(ligne(k:k+5),fmt='(A6)')'~~~~~~'
492 WRITE(iout,'(A)')ligne(1:k+5)
493c part
494 np = subset(isu)%NPART
495 IF (np == 0) RETURN
496
497 k = k2
498 ligne(k-1:k)=' |'
499 WRITE(iout,'(A)')ligne(1:k)
500 DO ll=1,np
501 ip = subset(isu)%PART(ll)
502
503 ligne=' '
504 k=3
505 DO i=1,niveau
506 ligne(k:k+l-1)=bar(i)(1:l)
507 k = k+l
508 IF (k > 132-20) GOTO 999
509 ENDDO
510c
511 IF (ll == 1) THEN
512 ligne(k:k+l-2)=bli(1:l-1)
513 WRITE(ligne(k+l-1:k+l+17),fmt='(a8,i10,a1)')
514 . 'part(s):',IPART(4,IP),','
515 ELSEIF (SUBSET(ISU)%NCHILD == 0) THEN
516 WRITE(LIGNE(K+L-1:K+L+17),FMT='(a8,i10,a1)')
517 . ' ',IPART(4,IP),','
518 ELSE
519 LIGNE(K:K)='|'
520 WRITE(LIGNE(K+L-1:K+L+17),FMT='(a8,i10,a1)')
521 . ' ',IPART(4,IP),','
522 ENDIF
523 K = K + L + 17
524 I = 0
525 CALL FRETITL2(TITR,IPART(LIPART1-LTITR+1,IP),LTITR)
526.AND. DO WHILE (I < 40 K < 132)
527 K = K + 1
528 I = I + 1
529 LIGNE(K:K) = TITR(I:I)
530 ENDDO
531 WRITE(IOUT,'(a)')LIGNE(1:K)
532C
533 ENDDO
534c-----------
535 RETURN
536c-----------
537 999 CALL ANCMSG(MSGID=170,
538 . MSGTYPE=MSGERROR,
539 . ANMODE=ANINFO,
540 . C1=LIGNE(1:132))
541c-----------
542 RETURN
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
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

◆ hm_read_subset()

subroutine hm_read_subset ( type (subset_), dimension(nsubs) subset,
integer, dimension(lipart1,*), intent(inout) ipart,
integer, intent(in) nsubs,
integer, intent(in) npart,
type(submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 41 of file hm_read_subset.F.

42C-----------------------------------------------
43C ROUTINE DESCRIPTION :
44C ===================
45C READ /SUBSET USING HM_READER
46C BUILD SUBSET HIERARCHY
47C-----------------------------------------------
48C DUMMY ARGUMENTS DESCRIPTION:
49C ===================
50C
51C NAME DESCRIPTION
52C
53C SUBSET SUBSET STRUCTURE
54C IPART PART ARRAY
55C NSUBS SUBSET NUMBER ( INCLUDING GLOBAL SUBSET )
56C NPART PART NUMBER
57C LSUBMODEL SUBMODEL STRUCTURE
58C-----------------------------------------------
59C M o d u l e s
60C-----------------------------------------------
61 USE my_alloc_mod
62 USE message_mod
63 USE groupdef_mod
64 USE submodel_mod
65 USE hm_option_read_mod
66C-----------------------------------------------
67C I m p l i c i t T y p e s
68C-----------------------------------------------
69#include "implicit_f.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73C INPUT ARGUMENTS
74 INTEGER,INTENT(IN)::NSUBS
75 INTEGER,INTENT(IN)::NPART
76 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
77C OUTPUT ARGUMENTS
78c TYPE (SUBSET_),DIMENSION(NSUBS),INTENT(OUT)::SUBSET
79 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
80C MODIFIED ARGUMENTS
81 INTEGER,INTENT(INOUT)::IPART(LIPART1,*)
82C-----------------------------------------------
83C C o m m o n B l o c k s
84C-----------------------------------------------
85#include "scr17_c.inc"
86#include "units_c.inc"
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90 INTEGER I,J,K,ID,IDV,IAD,IP,IS,ISU,NSU,NL,NC,NP,NTP,NS,
91 . CONT,NIVEAU,NIVMAX,LIST_IGR(NSUBS),UID,SUB_INDEX
92 INTEGER IFIX_TMP,TITLEN,ICHILD
93 INTEGER J10(10)
94 INTEGER, DIMENSION(NPART+NSUBS) :: BUFTMP
95 my_real bid
96 CHARACTER(LEN=NCHARTITLE) :: TITR
97 CHARACTER MESS*40
98 LOGICAL IS_AVAILABLE
99C-----------------------------------------------
100C E x t e r n a l F u n c t i o n s
101C-----------------------------------------------
102 INTEGER LISTCNT,SUBLVL
103c-----------------------------------------------
104 DATA mess/' SUBSET DEFINITION '/
105c-----------------------------------------------
106C SUBSET(ISU)%ID ::SUBSET identifier
107C SUBSET(ISU)%TITLE : SUBSET title
108C SUBSET(ISU)%TH_FLAG : TIME HISTORY flag
109C SUBSET(ISU)%PARENT : SUBSET PARENT
110C SUBSET(ISU)%NCHILD : SUBSETS number of childs
111C SUBSET(ISU)%NPART : SUBSET number of part (within one subset)
112C SUBSET(ISU)%NTPART : Total number of parts (within parent subset)
113C SUBSET(ISU)%THIAD : IAD for global ITHBUF storage variables
114C SUBSET(ISU)%NVARTH : nb of subset TH/ATH variable (10)
115! /iTH , i=A,,B, ... I
116! ( /iTH --> 9 additional time history files + 1 for /TH )
117C=======================================================================
118 is_available = .false.
119 sub_index = 0
120 uid = 0
121 isu = 0
122 buftmp(:) = 0
123C--------------------------------------------------
124C START READING SUBSETS
125C--------------------------------------------------
126 CALL hm_option_start('SUBSET')
127C--------------------------------------------------
128C BROWSING SUBSETS 1->NSUBS-1 ( NSUBS = NUMBER OF /SUBSET + GLOBAL_SUBSET )
129C--------------------------------------------------
130 DO i=1,nsubs-1
131 titr = ''
132C--------------------------------------------------
133C EXTRACT DATAS OF /SUBSET/... LINE
134C--------------------------------------------------
135c CALL HM_OPTION_READ(ID,UID,SUB_INDEX,TITR,LSUBMODEL)
136 CALL hm_option_read_key(lsubmodel,
137 . option_id = id,
138 . unit_id = uid,
139 . submodel_index = sub_index,
140 . option_titr = titr)
141 IF(len(titr)==0 .OR. len(trim(titr))==0 )titr(1:6)='noname'
142C--------------------------------------------------
143C EXTRACT DATAS NUMBER OF CHILDREN(INTEGER VALUE)
144C--------------------------------------------------
145 CALL hm_get_intv('numberofassemblies',nsu,is_available,lsubmodel)
146 isu = isu+1
147 subset(isu)%ID = id
148 subset(isu)%LEVEL = 0
149 subset(isu)%PARENT = 0
150 subset(isu)%NPART = 0
151 subset(isu)%NCHILD = nsu
152 subset(isu)%TH_FLAG = 0
153 CALL my_alloc(subset(isu)%NVARTH,10)
154c /iTH , i=A,,B, ... I
155c ( /iTH --> 9 additional time history files + 1 for /TH )
156 subset(isu)%NVARTH(1:10) = 0
157 subset(isu)%THIAD = 0
158 CALL my_alloc(subset(isu)%CHILD,nsu)
159 DO k=1,nsu
160 subset(isu)%CHILD(k) = 0
161 ENDDO
162 subset(isu)%TITLE = titr
163C--------------------------------------------------
164C EXTRACT CHILDREN(INTEGER VALUES)
165C--------------------------------------------------
166 DO ns=1,nsu
167 CALL hm_get_int_array_index('assemblies',ichild,ns,is_available,lsubmodel)
168 subset(isu)%CHILD(ns) = ichild
169 ENDDO
170 ENDDO
171C-------------------------------------
172c SEARCH FOR DUPLICATED IDs
173C-------------------------------------
174 list_igr(1:nsubs) = 0
175 DO isu=1,nsubs-1
176 list_igr(isu) = subset(isu)%ID
177 ENDDO
178 CALL udouble_igr(list_igr,nsubs,mess,0,bid)
179C-------------------------------------
180C REPLACE USER IDs WITH SYSTEM IDs
181C-------------------------------------
182 DO isu=1,nsubs-1
183 nsu = subset(isu)%NCHILD
184 DO i=1,nsu
185 id = subset(isu)%CHILD(i)
186 subset(isu)%CHILD(i) = 0
187 DO is=1,nsubs
188 idv = subset(is)%ID
189 IF (id == idv) THEN
190 subset(isu)%CHILD(i) = is
191 subset(is)%PARENT = isu
192 ENDIF
193 ENDDO
194 IF (subset(isu)%CHILD(i) == 0) THEN
195 CALL ancmsg(msgid=182,
196 . msgtype=msgwarning,
197 . anmode=aninfo,
198 . i1=subset(isu)%ID,
199 . c1=subset(isu)%TITLE,
200 . i2=id,
201 . i3=id)
202 ENDIF
203 ENDDO
204 ENDDO
205C-------------------------------------
206c COMPACTION (INEXISTING SUBSET <=> MSGID=182)
207C-------------------------------------
208 DO isu=1,nsubs-1
209 ns = subset(isu)%NCHILD
210 nsu = 0
211 DO i=1,ns
212 id = subset(isu)%CHILD(i)
213 IF (id /= 0) THEN
214 nsu = nsu + 1
215 subset(isu)%CHILD(nsu) = id
216 ENDIF
217 ENDDO
218 subset(isu)%NCHILD = nsu
219 ENDDO
220C-------------------------------------
221c CREATE GLOBAL SUBSET
222C-------------------------------------
223 buftmp(:) = 0
224 titr = 'GLOBAL MODEL'
225 subset(nsubs)%TITLE = titr
226c
227 subset(nsubs)%ID = 0
228 subset(nsubs)%LEVEL = 0
229 subset(nsubs)%PARENT = 0
230 subset(nsubs)%NCHILD = 0
231 subset(nsubs)%NPART = 0
232 subset(nsubs)%TH_FLAG = 0
233 CALL my_alloc(subset(nsubs)%NVARTH,10) ! /iTH , i=A,,B, ... I
234! ( /iTH --> 9 additional time history files + 1 for /TH )
235 subset(nsubs)%NVARTH(1:10) = 0
236 subset(nsubs)%THIAD = 0
237!
238 nsu = 0
239 DO isu=1,nsubs-1
240 IF (subset(isu)%PARENT == 0) THEN
241 subset(isu)%PARENT = nsubs
242 nsu = nsu+1
243 buftmp(nsu) = isu
244 ENDIF
245 ENDDO
246!==================================================
247 subset(nsubs)%NCHILD = nsu
248 CALL my_alloc(subset(nsubs)%CHILD,nsu)
249 DO i=1,nsu
250 subset(nsubs)%CHILD(i) = buftmp(i)
251 ENDDO
252!==================================================
253C-------------------------------------
254c SEARCH CHILDREN OF EACH SUBSET
255C-------------------------------------
256 DO isu=1,nsubs
257 id = subset(isu)%ID
258 buftmp(:) = 0
259 np = 0
260 DO k=1,npart
261 IF (id == ipart(7,k)) THEN
262 ipart(3,k) = isu
263 np = np+1
264 buftmp(np) = k
265 ENDIF
266 ENDDO
267 subset(isu)%NPART = np
268 CALL my_alloc(subset(isu)%PART,np)
269 DO k=1,np
270 subset(isu)%PART(k) = buftmp(k)
271 ENDDO
272 ENDDO
273C-------------------------------------
274c CHECK SUBSETs REFERENCED BY PARTs
275C-------------------------------------
276 DO k=1,npart
277 IF (ipart(3,k) == 0) THEN
278 CALL fretitl2(titr,ipart(lipart1-ltitr+1,k),ltitr)
279 CALL ancmsg(msgid=183,
280 . msgtype=msgwarning,
281 . anmode=aninfo,
282 . i1=ipart(4,k),
283 . c1=titr,
284 . i2=ipart(7,k))
285 ENDIF
286 ENDDO
287C-------------------------------------
288c SORTING SUBSET BY LEVEL NSUBS*LOG(NSUBS)
289C-------------------------------------
290 nivmax = 0
291 cont = 1
292 DO WHILE (cont == 1)
293 cont = 0
294 DO isu=1,nsubs
295 id = subset(isu)%PARENT
296 IF (id > 0) THEN
297 niveau = subset(id)%LEVEL + 1
298 IF (subset(isu)%LEVEL /= niveau) THEN
299 subset(isu)%LEVEL = niveau
300 nivmax = max(nivmax,niveau)
301 cont = 1
302 ENDIF
303 ENDIF
304 ENDDO
305 ENDDO
306C-------------------------------------
307c SEARCH PARTS IN DESCENDANCE (recursive)
308C-------------------------------------
309 DO isu = 1,nsubs
310 buftmp(:) = 0
311 ntp = 0
312 nc = subset(isu)%NCHILD
313 IF (nc == 0) nc = subset(isu)%NPART
314 DO WHILE (nc > 0)
315 nc = sublvl(subset,nsubs,isu,ntp,buftmp)
316 ENDDO
317 subset(isu)%NTPART = ntp
318 CALL my_alloc(subset(isu)%TPART,ntp)
319 DO i=1,ntp
320 subset(isu)%TPART(i) = buftmp(i)
321 ENDDO
322 ENDDO
323C-------------------------------------
324c WRITING SUBSETS (TREE WRITING)
325C-------------------------------------
326 WRITE(iout,'(//A)')' HIERARCHICAL SUBSET ORGANIZATION'
327 WRITE(iout,'(A//)')' --------------------------------'
328 iad = 1
329 buftmp(:) = 0
330 DO isu=1,nsubs
331 IF (subset(isu)%LEVEL == 0) THEN
332 buftmp(iad) = isu
333 DO WHILE (iad > 0)
334 i = buftmp(iad)
335 nsu = subset(i)%NCHILD
336 iad = iad - 1
337 CALL ecrsub2(subset,nsubs,i,ipart,nivmax)
338 IF (nsu > 0) THEN
339 DO k = nsu,1,-1
340 iad = iad+1
341 buftmp(iad) = subset(i)%CHILD(k)
342 ENDDO
343 ENDIF
344 ENDDO
345 ENDIF
346 ENDDO
347C=======================================================================
348 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
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_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
sublvl
recursive integer function sublvl(subset, nsubs, isu, np, buftmp)
Definition hm_read_subset.F:353
ecrsub2
subroutine ecrsub2(subset, nsubs, isu, ipart, nivmax)
Definition hm_read_subset.F:397
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
hm_option_read_mod
Definition hm_option_read_mod.F:408
submodel_mod
Definition submodel_mod.F:712
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
udouble_igr
subroutine udouble_igr(list, nlist, mess, ir, rlist)
Definition sysfus.F:1220

◆ sublvl()

recursive integer function sublvl ( type (subset_), dimension(nsubs) subset,
integer nsubs,
integer isu,
integer np,
integer, dimension(*) buftmp )

Definition at line 351 of file hm_read_subset.F.

353C-----------------------------------------------
354 USE groupdef_mod
355C-----------------------------------------------
356C I m p l i c i t T y p e s
357C-----------------------------------------------
358#include "implicit_f.inc"
359C-----------------------------------------------
360C D u m m y A r g u m e n t s
361C-----------------------------------------------
362 INTEGER ISU,NP,NSUBS,BUFTMP(*)
363 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
364C-----------------------------------------------
365C L o c a l V a r i a b l e s
366C-----------------------------------------------
367 INTEGER I,J,K,NC,IS,IP,NK
368c=======================================================================
369 ns = subset(isu)%NCHILD
370 DO j=1,subset(isu)%NPART
371 np = np + 1
372 buftmp(np) = subset(isu)%PART(j)
373 ENDDO
374 IF (ns > 0) THEN
375 nc = 0
376 DO i = 1,ns
377 is = subset(isu)%CHILD(i)
378 nk = sublvl(subset,nsubs,is,np,buftmp)
379 nc = nc + nk
380 ENDDO
381 IF (nc == 0) ns = 0
382 ENDIF
383c-----------
384 RETURN