69#include "implicit_f.inc"
74 INTEGER,
INTENT(IN)::NSUBS
75 INTEGER,
INTENT(IN)::NPART
79 TYPE (SUBSET_) ,
DIMENSION(NSUBS) :: SUBSET
81 INTEGER,
INTENT(INOUT)::IPART(LIPART1,*)
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 ,TITLEN,ICHILD
94 INTEGER,
DIMENSION(NPART+NSUBS) :: BUFTMP
96 CHARACTER(LEN=NCHARTITLE) :: TITR
102 INTEGER LISTCNT,SUBLVL
104 DATA mess/
' SUBSET DEFINITION '/
118 is_available = .false.
139 . submodel_index = sub_index,
140 . option_titr = titr)
141 IF(len(titr)==0 .OR. len(trim(titr))==0 )titr(1:6)=
'noname'
145 CALL hm_get_intv('numberofassemblies
',NSU,IS_AVAILABLE,LSUBMODEL)
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)
156 SUBSET(ISU)%NVARTH(1:10) = 0
157 SUBSET(ISU)%THIAD = 0
158 CALL MY_ALLOC(SUBSET(ISU)%CHILD,NSU)
160 SUBSET(ISU)%CHILD(K) = 0
162 SUBSET(ISU)%TITLE = TITR
167 CALL HM_GET_INT_ARRAY_INDEX('assemblies
',ICHILD,NS,IS_AVAILABLE,LSUBMODEL)
168 SUBSET(ISU)%CHILD(NS) = ICHILD
174 LIST_IGR(1:NSUBS) = 0
176 LIST_IGR(ISU) = SUBSET(ISU)%ID
178 CALL UDOUBLE_IGR(LIST_IGR,NSUBS,MESS,0,BID)
183 NSU = SUBSET(ISU)%NCHILD
185 ID = SUBSET(ISU)%CHILD(I)
186 SUBSET(ISU)%CHILD(I) = 0
190 SUBSET(ISU)%CHILD(I) = IS
191 SUBSET(IS)%PARENT = ISU
194 IF (SUBSET(ISU)%CHILD(I) == 0) THEN
195 CALL ANCMSG(MSGID=182,
196 . MSGTYPE=MSGWARNING,
199 . C1=SUBSET(ISU)%TITLE,
209 NS = SUBSET(ISU)%NCHILD
212 ID = SUBSET(ISU)%CHILD(I)
215 SUBSET(ISU)%CHILD(NSU) = ID
218 SUBSET(ISU)%NCHILD = NSU
224 TITR = 'global model
'
225 SUBSET(NSUBS)%TITLE = TITR
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
240 IF (SUBSET(ISU)%PARENT == 0) THEN
241 SUBSET(ISU)%PARENT = NSUBS
246!==================================================
247 SUBSET(NSUBS)%NCHILD = NSU
248 CALL MY_ALLOC(SUBSET(NSUBS)%CHILD,NSU)
250 SUBSET(NSUBS)%CHILD(I) = BUFTMP(I)
252!==================================================
261 IF (ID == IPART(7,K)) THEN
267 SUBSET(ISU)%NPART = NP
268 CALL MY_ALLOC(SUBSET(ISU)%PART,NP)
270 SUBSET(ISU)%PART(K) = BUFTMP(K)
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,
295 ID = SUBSET(ISU)%PARENT
297 NIVEAU = SUBSET(ID)%LEVEL + 1
298 IF (SUBSET(ISU)%LEVEL /= NIVEAU) THEN
299 SUBSET(ISU)%LEVEL = NIVEAU
300 NIVMAX = MAX(NIVMAX,NIVEAU)
312 NC = SUBSET(ISU)%NCHILD
313 IF (NC == 0) NC = SUBSET(ISU)%NPART
315 NC = SUBLVL(SUBSET,NSUBS,ISU,NTP,BUFTMP)
317 SUBSET(ISU)%NTPART = NTP
318 CALL MY_ALLOC(SUBSET(ISU)%TPART,NTP)
320 SUBSET(ISU)%TPART(I) = BUFTMP(I)
326 WRITE(IOUT,'(//a)
')' hierarchical subset organization
'
327 WRITE(IOUT,'(a//)
')' --------------------------------
'
331 IF (SUBSET(ISU)%LEVEL == 0) THEN
335 NSU = SUBSET(I)%NCHILD
337 CALL ECRSUB2(SUBSET,NSUBS,I,IPART,NIVMAX)
341 BUFTMP(IAD) = SUBSET(I)%CHILD(K)
396 SUBROUTINE ECRSUB2(SUBSET,NSUBS,ISU,IPART,NIVMAX)
399 USE NAMES_AND_TITLES_MOD , ONLY : NCHARTITLE
403#include "implicit_f.inc"
407 INTEGER NSUBS,ISU,IPART(LIPART1,*)
408 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
412#include "units_c.inc"
413#include "scr17_c.inc"
417 INTEGER I,K,K2,L,LL,NP,IP,ID,NIVEAU,NIVMAX,TITLEN
419 CHARACTER LIGNE*132,LIGN2*132,BAR(33)*10,BLI*21
420 CHARACTER(LEN=NCHARTITLE)::TITR
422 DATA BLI /'|____________________
'/
428 NIVEAU = SUBSET(ISU)%LEVEL
429 IF (NIVEAU >= 33) GOTO 999
430 CNT(NIVEAU) = CNT(NIVEAU)+1
434 L = MIN(10,MAX(2,22/(NIVMAX+1)))
439 LIGNE(K:K+L) = BAR(I)(1:L)
441 IF (K > 132) GOTO 999
444 WRITE(IOUT,'(a)
')LIGNE(1:K)
445 WRITE(IOUT,'(a)
')LIGNE(1:K)
447 IF (NIVEAU == 0) THEN
448 ELSEIF (CNT(NIVEAU) == SUBSET(SUBSET(ISU)%PARENT)%NCHILD) THEN
454 IF (NIVEAU == 0) THEN
461 LIGNE(K:K+L-1)=BAR(I)(1:L)
463 IF (K > 132) GOTO 999
465 IF (NIVEAU /= 0) THEN
466 LIGNE(K:K+L-2)=BLI(1:L-1)
468 IF (K > 132-16) GOTO 999
470 WRITE(LIGNE(K:K+17),FMT='(a7,i10,a1)
')'subset:
',ID,',
'
473 TITLEN = LEN(SUBSET(ISU)%TITLE)
474.AND.
DO WHILE (I < TITLEN K < 132)
477 LIGNE(K:K) = SUBSET(ISU)%TITLE(I:I)
479 WRITE(IOUT,'(a)
')LIGNE(1:K)
485 LIGNE(K:K+L-1)=BAR(I)(1:L)
491 WRITE(LIGNE(K:K+5),FMT='(a6)
')'~~~~~~
'
492 WRITE(IOUT,'(a)
')LIGNE(1:K+5)
494 NP = SUBSET(ISU)%NPART
499 WRITE(IOUT,'(a)
')LIGNE(1:K)
501 IP = SUBSET(ISU)%PART(LL)
506 LIGNE(K:K+L-1)=BAR(I)(1:L)
508 IF (K > 132-20) GOTO 999
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),
','
521 .
' ',ipart(4,ip),
','
525 CALL fretitl2(titr,ipart(lipart1-ltitr+1,ip),ltitr)
526 DO WHILE (i < 40 .AND.
529 ligne(k:k) = titr(i:i)
531 WRITE(iout,
'(A)')ligne(1:k)
537 999
CALL ancmsg(msgid=170,
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)