OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_merge.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_merge ../starter/source/constraints/general/merge/hm_read_merge.f
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl ../starter/source/starter/freform.F
30!|| fretitl2 ../starter/source/starter/freform.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!|| nodgrnr5 ../starter/source/starter/freform.F
36!|| rbleveldown ../starter/source/constraints/general/merge/hm_read_merge.F
37!|| rbtag1down ../starter/source/constraints/general/merge/hm_read_merge.F
38!|| rbtag2down ../starter/source/constraints/general/merge/hm_read_merge.F
39!|| trirbmerge ../starter/source/constraints/general/merge/hm_read_merge.F
40!|| usr2sys ../starter/source/system/sysfus.F
41!||--- uses -----------------------------------------------------
42!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.f
43!|| message_mod ../starter/share/message_module/message_mod.F
44!|| rbmerge_mod ../starter/source/constraints/general/merge/rbmerge_type.F90
45!|| submodel_mod ../starter/share/modules1/submodel_mod.F
46!||====================================================================
47 SUBROUTINE hm_read_merge(
48 . MGRBY,SMGRBY,NPBY,LPBY,SLRBODY,
49 . RBY ,NOM_OPT ,PTR_NOPT_RBMERGE,IGRNOD,
50 . ITAB,ITABM1,IBGR,IGRV, LSUBMODEL)
51C-----------------------------------------------
52C M o d u l e s
53C-----------------------------------------------
54 USE my_alloc_mod
55 USE message_mod
56 USE rbmerge_mod , ONLY : rbmerge_
57 USE groupdef_mod , ONLY : group_
58 USE submodel_mod , ONLY : nsubmod, submodel_data
59 USE hm_option_read_mod
60 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
61C-----------------------------------------------
62C I m p l i c i t T y p e s
63C-----------------------------------------------
64#include "implicit_f.inc"
65C-----------------------------------------------
66C C o m m o n B l o c k s
67C-----------------------------------------------
68#include "scr17_c.inc"
69#include "com04_c.inc"
70#include "units_c.inc"
71#include "param_c.inc"
72C-----------------------------------------------
73C D u m m y A r g u m e n t s
74C-----------------------------------------------
75 INTEGER MGRBY(NMGRBY,*),NPBY(NNPBY,*),LPBY(*),SLRBODY,SMGRBY,ITABM1(*),ITAB(*)
76 my_real RBY(NRBY,*)
77 INTEGER NOM_OPT(LNOPT1,*),PTR_NOPT_RBMERGE
78 INTEGER IGRV(NIGRV,*),IBGR(*)
79 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(NSUBMOD)
80C-----------------------------------------------
81 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER I,J,K,L,ID,IRBM,IRBS,NBMERGE,IGS,
86 . N,NOPT,UID, II, NOBJ
87 INTEGER IMAIN,ISECONDARY,FLAGG_OPT, FLAG_BOUCLE, FLAG_ERROR,
88 . flag_doublon, flag_doublemain, m_type, s_type, id_opt,
89 . idnode, nn, prt_opt, idboucle, level
90 INTEGER, DIMENSION(:) , ALLOCATABLE :: INDEX
91 INTEGER, DIMENSION(:,:) , ALLOCATABLE :: INUM
92 INTEGER, DIMENSION(:) , ALLOCATABLE :: NB_MAIN
93 INTEGER, DIMENSION(:) , ALLOCATABLE :: NSECONDARY
94 INTEGER, DIMENSION(:) , ALLOCATABLE :: TAG1
95 INTEGER, DIMENSION(:) , ALLOCATABLE :: TAG2
96 INTEGER, DIMENSION(:) , ALLOCATABLE :: TABBOUCLE
97 INTEGER, DIMENSION(:,:) , ALLOCATABLE :: TABRB
98
99 CHARACTER MYSTRING*100,MYLOOP*200
100 CHARACTER MESS*40,MESS2*40
101 CHARACTER(LEN=nchartitle) :: TITR
102 CHARACTER(LEN=ncharkey) :: KEY2
103 TYPE(rbmerge_), DIMENSION(:), ALLOCATABLE :: RBMERGE
104 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG, WORK
105 INTEGER IWORK(70000)
106 LOGICAL IS_AVAILABLE
107C-----------------------------------------------
108C E x t e r n a l F u n c t i o n s
109C-----------------------------------------------
110 INTEGER USR2SYS,NODGRNR5
111C-----------------------------------------------
112 DATA MESS/'RIGID BODY MERGE DEFINITION '/
113C-----------------------------------------------
114 ALLOCATE(itag(numnod),work(numnod))
115 CALL my_alloc(tabrb,nrbykin,2)
116 CALL my_alloc(nb_main,nrbykin)
117 CALL my_alloc(nsecondary,nrbykin)
118 CALL my_alloc(tag1,nrbykin)
119 CALL my_alloc(tag2,nrbykin)
120 CALL my_alloc(tabboucle,nrbykin+1)
121 j = 0
122 n = 0
123 nopt = 0
124 nobj = 0
125C--------------------------------------------------
126C START BROWSING MODEL RBODY
127C--------------------------------------------------
128 is_available = .false.
129 CALL hm_option_start('/MERGE/RBODY')
130C--------------------------------------------------
131 DO i=1,nrbmerge
132C--------------------------------------------------
133C EXTRACT DATAS OF /RBODY/... LINE
134C--------------------------------------------------
135 CALL hm_option_read_key(lsubmodel, option_id = id, unit_id = uid, option_titr = titr, keyword2 = key2)
136C--------------------------------------------------
137C WRITE TITLE IN OUT FILE
138C--------------------------------------------------
139 nopt=nopt+1
140 nom_opt(1,ptr_nopt_rbmerge+nopt)=id
141 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,ptr_nopt_rbmerge+nopt),ltitr)
142C--------------------------------------------------
143C EXTRACT DATAS (INTEGER VALUES)
144C--------------------------------------------------
145 CALL hm_get_intv('NB_SUBOBJVE',nobj,is_available,lsubmodel)
146C
147 DO j=1,nobj
148 n = n + 1
149 CALL hm_get_int_array_index('Main_ID',imain,j,is_available,lsubmodel)
150 CALL hm_get_int_array_index('M_type',m_type,j,is_available,lsubmodel)
151 CALL hm_get_int_array_index('Secon_ID',isecondary,j,is_available,lsubmodel)
152 CALL hm_get_int_array_index('S_type',s_type,j,is_available,lsubmodel)
153 CALL hm_get_int_array_index('Iflag',flagg_opt,j,is_available,lsubmodel)
154 IF (imain /= 0) THEN
155 IF(m_type == 0) m_type=1
156 IF(s_type == 0) s_type=1
157 IF(flagg_opt == 0) flagg_opt=2
158 mgrby(1,n)=imain
159 mgrby(2,n)=m_type
160 mgrby(3,n)=isecondary
161 mgrby(4,n)=s_type
162 mgrby(5,n)=flagg_opt
163 mgrby(6,n)=id!NOPT
164 mgrby(7,n)=nopt
165 ENDIF ! IMAIN /= 0
166 ENDDO
167
168 ENDDO
169C
170 ALLOCATE (rbmerge(nrbykin))
171 DO i=1,nrbykin
172 ALLOCATE (rbmerge(i)%IDSECONDARY(nrbykin))
173 rbmerge(i)%NBSECONDARY=0
174 ALLOCATE (rbmerge(i)%NODE(nxtra_node))
175 ALLOCATE (rbmerge(i)%FLAG_NODE(nxtra_node))
176 rbmerge(i)%NNODE=0
177 rbmerge(i)%LEVEL=0
178 rbmerge(i)%FLAG_MAIN = 0
179 ENDDO
180
181c
182 nbmerge = 0
183 tabrb(:,:)=0
184 tag1(:)=0
185 tag2(:)=0
186 flag_error = 0
187 nb_main(:)=0
188 itag(1:numnod) = 0
189 flag_doublon=0
190c
191 WRITE(iout,1000)
192 prt_opt=0
193c
194 DO i=1,smgrby ! 1ERE PASSE POUR LES MERGE RBODY/RBODY
195 imain = mgrby(1,i)
196 m_type = mgrby(2,i)
197 isecondary = mgrby(3,i)
198 s_type = mgrby(4,i)
199 flagg_opt = mgrby(5,i)
200 id_opt = mgrby(6,i)
201 IF(s_type == 1) THEN ! SECONDARY IS A RBODY
202c
203 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,ptr_nopt_rbmerge+mgrby(7,i)),ltitr)
204c
205 IF(prt_opt /= mgrby(6,i)) THEN
206 WRITE(iout,1100) mgrby(6,i),trim(titr)
207 prt_opt = mgrby(6,i)
208 ENDIF
209C------------------------------------
210c TESTS D'EXISTENCE SUR LES MAIN ET SECONDARYS
211C------------------------------------
212 irbm=0
213 DO k=1,nrbykin
214 IF (imain == npby(6,k)) THEN
215 irbm=k
216 EXIT
217 ENDIF
218 ENDDO
219 IF (irbm == 0)THEN ! l'ID du rbody n'existe pas
220 CALL ancmsg(msgid=1636,
221 . msgtype=msgerror,
222 . anmode=aninfo,
223 . i1=id_opt,
224 . c1=titr,
225 . i2=imain)
226 ENDIF
227
228 irbs=0
229 DO k=1,nrbykin
230 IF (isecondary == npby(6,k)) THEN
231 irbs=k
232 EXIT
233 ENDIF
234 ENDDO
235 IF (irbs == 0)THEN ! l'ID du rbody n'existe pas
236 CALL ancmsg(msgid=1636,
237 . msgtype=msgerror,
238 . anmode=aninfo,
239 . i1=id_opt,
240 . c1=titr,
241 . i2=isecondary)
242 ENDIF
243C------------------------------------
244c TRI DES RELATIONS LUES
245C------------------------------------
246 IF((irbm /= 0).AND.(irbs /= 0)) THEN
247
248 WRITE(iout,1200) imain, isecondary, flagg_opt
249 mess2 ='SECONDARY RIGID BODY '
250
251 flag_doublon=0
252 flag_doublemain = 0
253 IF(nb_main(irbs) >= 1) THEN
254 DO l=1,nbmerge
255 IF(tabrb(l,2) == irbs) THEN
256 IF(tabrb(l,1) /= irbm) THEN ! le SECONDARY est deja SECONDARY d'un autre
257 CALL ancmsg(msgid=1028,
258 . msgtype=msgerror,
259 . anmode=aninfo_blind_1,
260 . i1=id_opt,
261 . c1=titr,
262 . i2=isecondary)
263 flag_doublemain = 1
264 flag_error = 1
265 ELSE ! la relation de merge est en double
266 CALL ancmsg(msgid=1027,
267 . msgtype=msgwarning,
268 . anmode=aninfo_blind_1,
269 . i1=id_opt,
270 . c1=titr,
271 . i2=imain,
272 . c2=mess2,
273 . i3=isecondary,
274 . i4=flagg_opt)
275 flag_doublon = 1
276 ENDIF
277 ENDIF
278 ENDDO
279 ENDIF
280 IF((flag_doublon + flag_doublemain) == 0) THEN
281 nbmerge = nbmerge + 1
282 nb_main(irbs) = nb_main(irbs) + 1
283 nsecondary(irbm) = nsecondary(irbm) + 1
284 tabrb(nbmerge,1) = irbm ! MAIN
285 tabrb(nbmerge,2) = irbs ! SECONDARY
286c
287 rbmerge(irbs)%ID = isecondary
288 rbmerge(irbs)%IMAIN = irbm
289 rbmerge(irbs)%FLAG_MAIN = flagg_opt
290c
291 rbmerge(irbm)%ID = imain
292 rbmerge(irbm)%NBSECONDARY = rbmerge(irbm)%NBSECONDARY+1
293 rbmerge(irbm)%IDSECONDARY(rbmerge(irbm)%NBSECONDARY) = irbs
294 ELSEIF(flag_doublon == 1) THEN ! Le flag est celui qu'on lit en dernier
295 rbmerge(irbs)%FLAG_MAIN = flagg_opt
296 ENDIF
297 ENDIF ! IRBM /= 0 IRBS /= 0
298 ENDIF ! S_TYPE == 1
299 ENDDO
300C
301 DO i=1,smgrby ! 2ERE PASSE POUR LES MERGE RBODY/NODE & SET OF NODES
302 imain = mgrby(1,i)
303 m_type = mgrby(2,i)
304 isecondary = mgrby(3,i)
305 s_type = mgrby(4,i)
306 flagg_opt = mgrby(5,i)
307 id_opt = mgrby(6,i)
308 IF((s_type == 2).OR.(s_type == 3)) THEN
309c
310 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,ptr_nopt_rbmerge+mgrby(7,i)),ltitr)
311c
312 IF(prt_opt /= mgrby(6,i)) THEN
313 WRITE(iout,1100) mgrby(6,i),trim(titr)
314 prt_opt = mgrby(6,i)
315 ENDIF
316C------------------------------------
317c TESTS D'EXISTENCE SUR LES MAIN ET SECONDARYS
318C------------------------------------
319 irbm=0
320 DO k=1,nrbykin
321 IF (imain == npby(6,k)) THEN
322 irbm=k
323 EXIT
324 ENDIF
325 ENDDO
326 IF (irbm == 0)THEN ! l'ID du rbody n'existe pas
327 CALL ancmsg(msgid=1636,
328 . msgtype=msgerror,
329 . anmode=aninfo,
330 . i1=id_opt,
331 . c1=titr,
332 . i2=imain)
333 ENDIF
334
335 idnode=0
336 nn=0
337 IF(s_type == 2) THEN ! SECONDARY IS A NODE
338 idnode = usr2sys(mgrby(3,i),itabm1,mess,id)
339 ELSEIF(s_type == 3) THEN ! SECONDARY IS A GRNOD
340 nn = nodgrnr5(mgrby(3,i),igs,work,igrnod,itabm1,mess)
341 ENDIF
342
343
344 IF((irbm /= 0).AND.(idnode /= 0)) THEN ! SECONDARY IS A NODE
345
346 WRITE(iout,1300) imain, isecondary, flagg_opt
347 mess2 ='SECONDARY NODE '
348
349 IF(itag(idnode) == 0) THEN
350 itag(idnode) = irbm
351 ELSEIF(itag(idnode) == irbm) THEN
352 flag_doublon = 1
353 CALL ancmsg(msgid=1027,
354 . msgtype=msgwarning,
355 . anmode=aninfo_blind_1,
356 . i1=id_opt,
357 . c1=titr,
358 . i2=imain,
359 . c2=mess2,
360 . i3=isecondary,
361 . i4=flagg_opt)
362 ENDIF
363
364 IF(flag_doublon == 0) THEN
365 rbmerge(irbm)%ID = imain
366 rbmerge(irbm)%NNODE = rbmerge(irbm)%NNODE+1
367 rbmerge(irbm)%NODE(rbmerge(irbm)%NNODE) = idnode
368 rbmerge(irbm)%FLAG_NODE(rbmerge(irbm)%NNODE) = flagg_opt
369 ELSE ! Le flag est celui qu'on lit en dernier
370 DO ii=1,rbmerge(irbm)%NNODE
371 IF(rbmerge(irbm)%NODE(ii) == idnode) THEN
372 rbmerge(irbm)%FLAG_NODE(ii) = flagg_opt
373 ENDIF
374 ENDDO
375 ENDIF
376 ENDIF
377
378 IF((irbm /= 0).AND.(nn /= 0)) THEN ! SECONDARY IS A SET OF NODE
379
380 WRITE(iout,1400) imain, isecondary, flagg_opt
381 WRITE(iout,1410) (itab(work(j)),j=1,nn)
382 mess2 ='SECONDARY NODE '
383
384 rbmerge(irbm)%ID = imain
385 DO j=1,nn
386 flag_doublon = 0
387 flag_doublemain = 0
388 IF(itag(work(j)) == 0) THEN
389 itag(work(j)) = irbm
390 ELSEIF(itag(work(j)) == irbm) THEN
391 flag_doublon = 1
392 CALL ancmsg(msgid=1027,
393 . msgtype=msgwarning,
394 . anmode=aninfo_blind_1,
395 . i1=id_opt,
396 . c1=titr,
397 . i2=imain,
398 . c2=mess2,
399 . i3=itab(work(j)),
400 . i4=flagg_opt)
401 ENDIF
402
403 IF(flag_doublon == 0) THEN
404 rbmerge(irbm)%ID = imain
405 rbmerge(irbm)%NNODE = rbmerge(irbm)%NNODE+1
406 rbmerge(irbm)%NODE(rbmerge(irbm)%NNODE) = work(j)
407 rbmerge(irbm)%FLAG_NODE(rbmerge(irbm)%NNODE) = flagg_opt
408 ELSE ! Le flag est celui qu'on lit en dernier
409 DO ii=1,rbmerge(irbm)%NNODE
410 IF(rbmerge(irbm)%NODE(ii) == work(j)) THEN
411 rbmerge(irbm)%FLAG_NODE(ii) = flagg_opt
412 ENDIF
413 ENDDO
414 ENDIF
415 ENDDO
416
417 ENDIF
418 ENDIF ! S_TYPE = 2 OR 3
419C-----
420 ENDDO
421C------------------------------------
422C TRI DES XTRA_NODES PAR FLAGS CROISSANTS
423C------------------------------------
424 DO i=1,nrbykin
425 IF(rbmerge(i)%NNODE > 0) THEN
426 ALLOCATE(index(2*rbmerge(i)%NNODE))
427 index(1:2*rbmerge(i)%NNODE) = 0
428 ALLOCATE(inum(rbmerge(i)%NNODE,2))
429 DO j=1,rbmerge(i)%NNODE
430 index(j) = j
431 inum(j,1) = rbmerge(i)%FLAG_NODE(j)
432 inum(j,2) = rbmerge(i)%NODE(j)
433 ENDDO
434 CALL my_orders(0,iwork,rbmerge(i)%FLAG_NODE,index,rbmerge(i)%NNODE,1)
435 DO j=1,rbmerge(i)%NNODE
436 rbmerge(i)%FLAG_NODE(j) = inum(index(j),1)
437 rbmerge(i)%NODE(j) = inum(index(j),2)
438 ENDDO
439 DEALLOCATE(index)
440 DEALLOCATE(inum)
441 ENDIF
442 ENDDO
443C------------------------------------
444C TOUTES LES RELATIONS ONT ETE TRIEES (RBODY, NODE, GRNOD)
445C------------------------------------
446 WRITE(iout,2000)
447C------------------------------------
448C TAG ET RECHERCHE DES LOOPS
449C------------------------------------
450 DO i=1,nrbykin
451 IF(nb_main(i) == 0) THEN
452 CALL rbtag1down(tabrb,i,tag1,nbmerge)
453 ENDIF
454 ENDDO
455C
456 DO i=1,nrbykin
457 IF((tag1(i) == 0).AND.(tag2(i) == 0).AND.(rbmerge(i)%NBSECONDARY>0)) THEN
458 flag_boucle = 0
459 idboucle = 0
460 tabboucle(:) = 0
461 CALL rbtag2down(i,tag2,rbmerge,flag_boucle,tabboucle,idboucle)
462 IF (flag_boucle == 1) THEN
463 WRITE(myloop,*) tabboucle(1)
464 myloop = adjustl(myloop)
465 DO j=2,nrbykin+1
466 IF(tabboucle(j) == 0) EXIT
467 WRITE(mystring,*) tabboucle(j)
468 mystring = adjustl(mystring)
469 myloop = myloop(1:len(trim(myloop))) //' -> '// mystring
470 ENDDO
471 CALL ancmsg(msgid=1029,
472 . msgtype=msgerror,
473 . anmode=aninfo_blind_1,
474 . c1=myloop,
475 . prmod=msg_cumu)
476 flag_error = 1
477 ENDIF
478 ENDIF
479 ENDDO
480 IF(flag_error == 1) THEN
481 CALL ancmsg(msgid=1029,
482 . msgtype=msgerror,
483 . anmode=aninfo_blind_1,
484 . prmod=msg_print)
485 ENDIF
486C------------------------------------
487C SI PAS DE LOOP, CONSTRUCTION DES HIERARCHIES
488C------------------------------------
489 IF(flag_error == 0) THEN
490 DO i=1,nrbykin ! RB level calculation
491 IF(nb_main(i) == 0) THEN
492 level = 0
493 CALL rbleveldown(npby,rbmerge,i,level)
494 ENDIF
495 ENDDO
496C------------------------------------
497C ORDONNANCEMENT DES NPBY, LPBY ET RBY, OUTPUTS DES HIERARCHIES
498C------------------------------------
499 CALL trirbmerge(rbmerge,npby ,lpby ,slrbody,
500 . rby ,nom_opt, itab,ibgr,igrv)
501 ENDIF
502c
503 DEALLOCATE(rbmerge,work,itag)
504 DEALLOCATE(tabrb)
505 DEALLOCATE(nb_main)
506 DEALLOCATE(nsecondary)
507 DEALLOCATE(tag1)
508 DEALLOCATE(tag2)
509 DEALLOCATE(tabboucle)
510cC-----------
511 RETURN
512C
5131000 FORMAT(/
514 . ' RIGID BODY MERGE DEFINITIONS '/
515 . ' ---------------------- '/)
5161100 FORMAT( /5x,'RIGID BODY MERGE ID ',i10,1x,a)
5171200 FORMAT(/10x,'MAIN RIGID BODY ID ',i10
518 . /10x,'SECONDARY RIGID BODY ID ',i10
519 . /10x,'IFLAG ',i10)
5201300 FORMAT(/10x,'MAIN RIGID BODY ID ',i10
521 . /10x,'SECONDARY NODE ID ',i10
522 . /10x,'IFLAG ',i10)
5231400 FORMAT(/10x,'MAIN RIGID BODY ID ',i10
524 . /10x,'SECONDARY SET OF NODE ID ',i10
525 . /10x,'IFLAG ',i10
526 . /10x,'SET OF NODES ')
5271410 FORMAT( 10x,10i10)
5282000 FORMAT(/
529 . ' RIGID BODY MERGE CONSTRUCTION '/
530 . ' ---------------------- '/)
531C
532 END SUBROUTINE hm_read_merge
533C
534C-----------------------------------------------
535!||====================================================================
536!|| rbtag1down ../starter/source/constraints/general/merge/hm_read_merge.F
537!||--- called by ------------------------------------------------------
538!|| hm_read_merge ../starter/source/constraints/general/merge/hm_read_merge.F
539!||--- calls -----------------------------------------------------
540!||====================================================================
541 RECURSIVE SUBROUTINE rbtag1down(TABRB,IDRB,TAG1,NBMERGE)
542C-----------------------------------------------
543C I m p l i c i t T y p e s
544C-----------------------------------------------
545#include "implicit_f.inc"
546C-----------------------------------------------
547C C o m m o n B l o c k s
548C-----------------------------------------------
549#include "com04_c.inc"
550C-----------------------------------------------
551C D u m m y A r g u m e n t s
552C-----------------------------------------------
553 INTEGER idrb,nbmerge, tag1(nrbykin),tabrb(NRBYKIN,2)
554C-----------------------------------------------
555C L o c a l V a r i a b l e s
556C-----------------------------------------------
557 INTEGER i, idrbs
558C-----------------------------------------------
559 tag1(idrb) = 1
560c
561 DO i=1,nbmerge
562 IF(tabrb(i,1) == idrb) THEN
563 idrbs = tabrb(i,2)
564 CALL rbtag1down(tabrb,idrbs,tag1,nbmerge)
565 ENDIF
566 ENDDO
567C
568 RETURN
569 END
570C
571C-----------------------------------------------
572!||====================================================================
573!|| rbtag2down ../starter/source/constraints/general/merge/hm_read_merge.F
574!||--- called by ------------------------------------------------------
575!|| hm_read_merge ../starter/source/constraints/general/merge/hm_read_merge.F
576!||--- calls -----------------------------------------------------
577!||--- uses -----------------------------------------------------
578!|| rbmerge_mod ../starter/source/constraints/general/merge/rbmerge_type.F90
579!||====================================================================
580 RECURSIVE SUBROUTINE rbtag2down(IDRB,TAG2,RBMERGE,
581 . FLAG_BOUCLE,TABBOUCLE,IDBOUCLE)
582C-----------------------------------------------
583C M o d u l e s
584C-----------------------------------------------
585 USE rbmerge_mod
586C-----------------------------------------------
587C I m p l i c i t T y p e s
588C-----------------------------------------------
589#include "implicit_f.inc"
590C-----------------------------------------------
591C C o m m o n B l o c k s
592C-----------------------------------------------
593#include "com04_c.inc"
594C-----------------------------------------------
595C D u m m y A r g u m e n t s
596C-----------------------------------------------
597 INTEGER idrb,nbmerge, tag2(nrbykin),flag_boucle
598 INTEGER tabboucle(NRBYKIN+1), idboucle
599 TYPE (rbmerge_) , DIMENSION(NRBYKIN) :: RBMERGE
600C-----------------------------------------------
601C L o c a l V a r i a b l e s
602C-----------------------------------------------
603 INTEGER i, idrbs
604C-----------------------------------------------
605 tag2(idrb) = 1
606c
607 DO i=1,rbmerge(idrb)%NBSECONDARY
608 IF(tag2(rbmerge(idrb)%IDSECONDARY(i)) == 0) THEN
609 idrbs = rbmerge(idrb)%IDSECONDARY(i)
610 CALL rbtag2down(idrbs,tag2,rbmerge,flag_boucle,
611 . tabboucle,idboucle)
612 ELSE ! on a trouve la boucle
613 flag_boucle = 1
614 idrbs = rbmerge(idrb)%IDSECONDARY(i)
615 idboucle = idboucle+1
616 tabboucle(idboucle)=rbmerge(idrbs)%ID
617 EXIT
618 ENDIF
619 ENDDO
620
621 IF(flag_boucle == 1) THEN
622 idboucle = idboucle+1
623 tabboucle(idboucle)=rbmerge(idrb)%ID
624 ELSE
625 tag2(idrb) = 0
626 ENDIF
627C
628 RETURN
629 END
630C
631C-----------------------------------------------
632!||====================================================================
633!|| rbleveldown ../starter/source/constraints/general/merge/hm_read_merge.F
634!||--- called by ------------------------------------------------------
635!|| hm_read_merge ../starter/source/constraints/general/merge/hm_read_merge.F
636!||--- calls -----------------------------------------------------
637!||--- uses -----------------------------------------------------
638!|| rbmerge_mod ../starter/source/constraints/general/merge/rbmerge_type.F90
639!||====================================================================
640 RECURSIVE SUBROUTINE rbleveldown(NPBY,RBMERGE,IDRB,LEVEL)
641C-----------------------------------------------
642C M o d u l e s
643C-----------------------------------------------
644 USE rbmerge_mod
645C-----------------------------------------------
646C I m p l i c i t T y p e s
647C-----------------------------------------------
648#include "implicit_f.inc"
649C-----------------------------------------------
650C C o m m o n B l o c k s
651C-----------------------------------------------
652#include "com04_c.inc"
653#include "param_c.inc"
654C-----------------------------------------------
655C D u m m y A r g u m e n t s
656C-----------------------------------------------
657 INTEGER npby(nnpby,*),idrb, level
658 TYPE (rbmerge_), DIMENSION(NRBYKIN) :: rbmerge
659C-----------------------------------------------
660C L o c a l V a r i a b l e s
661C-----------------------------------------------
662 INTEGER isecondary, nbsecondary
663C-----------------------------------------------
664! RBMERGE(IRBM)%ID :: Rigid body identifier
665! RBMERGE(IRBM)%NBSECONDARY :: Number of SECONDARY rigid body
666! RBMERGE(IRBM)%IMAIN :: 0 if this rigid body doesn't have a MAIN
667! X : The Rigid body's MAIN
668! RBMERGE(IRBM)%LEVEL :: Rigid body level
669! RBMERGE(IRBM)%FLAG_MAIN :: Flag relating the rigid option merge to the MAIN
670! RBMERGE(IRBM)%IDSECONDARY(J) :: SECONDARY rigid bodys attached to the MAIN
671C-----------------------------------------------
672 nbsecondary = rbmerge(idrb)%NBSECONDARY
673 isecondary = 0
674 npby(12,idrb) = level
675 level = level - 1
676 npby(13,idrb) = rbmerge(idrb)%FLAG_MAIN
677c
678 DO WHILE (isecondary < nbsecondary)
679 isecondary = isecondary + 1
680 rbmerge(rbmerge(idrb)%IDSECONDARY(isecondary))%LEVEL=rbmerge(idrb)%LEVEL-1
681 CALL rbleveldown(npby,rbmerge,rbmerge(idrb)%IDSECONDARY(isecondary),level)
682 ENDDO
683C
684 level = level + 1
685
686 RETURN
687 END
688C
689!||====================================================================
690!|| trirbmerge ../starter/source/constraints/general/merge/hm_read_merge.F
691!||--- called by ------------------------------------------------------
692!|| hm_read_merge ../starter/source/constraints/general/merge/hm_read_merge.F
693!||--- calls -----------------------------------------------------
694!|| ancmsg ../starter/source/output/message/message.F
695!|| rb_explore ../starter/source/constraints/general/merge/hm_read_merge.F
696!|| spmdset ../starter/source/constraints/general/rbody/spmdset.F
697!||--- uses -----------------------------------------------------
698!|| message_mod ../starter/share/message_module/message_mod.F
699!|| rbmerge_mod ../starter/source/constraints/general/merge/rbmerge_type.F90
700!||====================================================================
701 SUBROUTINE trirbmerge(RBMERGE,NPBY ,LPBY ,SLRBODY,
702 . RBY ,NOM_OPT,ITAB ,IBGR ,IGRV )
703C-----------------------------------------------
704C M o d u l e s
705C-----------------------------------------------
706 USE my_alloc_mod
707 USE message_mod
708 USE rbmerge_mod
709 USE names_and_titles_mod , ONLY : nchartitle
710C-----------------------------------------------
711C I m p l i c i t T y p e s
712C-----------------------------------------------
713#include "implicit_f.inc"
714C-----------------------------------------------
715C C o m m o n B l o c k s
716C-----------------------------------------------
717#include "scr17_c.inc"
718#include "com04_c.inc"
719#include "units_c.inc"
720#include "param_c.inc"
721C-----------------------------------------------
722C D u m m y A r g u m e n t s
723C-----------------------------------------------
724 INTEGER NPBY(NNPBY,*),LPBY(*),SLRBODY,ITAB(*)
725 TYPE (RBMERGE_) , DIMENSION(NRBYKIN) :: RBMERGE
726 my_real RBY(NRBY,*)
727 INTEGER NOM_OPT(LNOPT1,*)
728 INTEGER IGRV(NIGRV,*),IBGR(*)
729C-----------------------------------------------
730C L o c a l V a r i a b l e s
731C-----------------------------------------------
732 INTEGER I,J,K,KK,M,N,ID,OFFSET,OFFSETID,FLAG_RB
733 INTEGER IDPILE,INODE, IKREM,ISPHER,
734 . ICDG,CNT,NN,IAD
735 INTEGER,DIMENSION(:),ALLOCATABLE :: PILE
736 INTEGER,DIMENSION(:),ALLOCATABLE :: INDEX
737 INTEGER,DIMENSION(:),ALLOCATABLE :: LPBY_TMP
738 INTEGER,DIMENSION(:,:),ALLOCATABLE :: NPBY_TMP
739 INTEGER,DIMENSION(:,:),ALLOCATABLE :: NOM_OPT_TMP
740 my_real,DIMENSION(:,:),ALLOCATABLE :: rby_tmp
741
742 my_real bid, dx, dy, dz, dmstr, delt, dtmp
743 INTEGER NBSECONDARY, IDIR, NSL, NSL_XTRA
744 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
745 INTEGER, DIMENSION(NXTRA_NODE) :: LIST_XTRA
746 CHARACTER MESS*40
747 CHARACTER(LEN=nchartitle) :: TITR
748C-----------------------------------------------
749! RBMERGE(IRBM)%ID :: Rigid body identifier
750! RBMERGE(IRBM)%NBSECONDARY :: Number of SECONDARY rigid body
751! RBMERGE(IRBM)%IMAIN :: 0 if this rigid body doesn't have a MAIN
752! X : The Rigid body's MAIN
753! RBMERGE(IRBM)%LEVEL :: Rigid body level
754! RBMERGE(IRBM)%FLAG_MAIN :: Flag relating the rigid option merge to the MAIN
755! RBMERGE(IRBM)%IDSECONDARY(J) :: SECONDARY rigid bodys attached to the MAIN
756C-----------------------------------------------
757 CALL my_alloc(pile,nrbykin)
758 CALL my_alloc(npby_tmp,nnpby,nrbykin)
759 CALL my_alloc(index,nrbykin)
760 CALL my_alloc(lpby_tmp,slrbody)
761 CALL my_alloc(nom_opt_tmp,lnopt1,nrbykin)
762 CALL my_alloc(rby_tmp,nrby,nrbykin)
763
764 ALLOCATE(itag(numnod))
765 index(1:nrbykin) = 0
766 offset = 0
767 offsetid = 0
768 itag(1:numnod) = 0
769 lpby_tmp(1:slrbody)=0
770 DO n=1,nrbykin
771 IF(rbmerge(n)%LEVEL == 0) THEN
772 IF(rbmerge(n)%NBSECONDARY > 0) THEN
773 pile(:)=0
774 idpile=0
775 CALL rb_explore(n,rbmerge,pile,idpile)
776 DO k=1,idpile
777 index(offsetid+k)=pile(idpile+1-k)
778 ENDDO
779 offsetid = offsetid+idpile
780 ELSE
781 index(nrbykin-offset)=n
782 offset = offset + 1
783 ENDIF
784 ENDIF
785 nom_opt_tmp(1:lnopt1,n)=nom_opt(1:lnopt1,n)
786 DO j=1,nnpby
787 npby_tmp(j,n)=npby(j,n)
788 ENDDO
789 DO j=1,nrby
790 rby_tmp(j,n)=rby(j,n)
791 ENDDO
792 k=npby(11,n)
793 DO j=1,npby(2,n)
794 lpby_tmp(k+j)=lpby(k+j)
795 ENDDO
796 ENDDO
797 lpby(1:slrbody)=0
798 k=0
799 DO n=1,nrbykin
800 nom_opt(1:lnopt1,n)=nom_opt_tmp(1:lnopt1,index(n))
801 DO j=1,nnpby
802 npby(j,n)=npby_tmp(j,index(n))
803 ENDDO
804 npby(11,n)=k
805 DO j=1,nrby
806 rby(j,n)=rby_tmp(j,index(n))
807 ENDDO
808 DO j=1,npby_tmp(2,index(n))
809 lpby(k+j)=lpby_tmp(npby_tmp(11,index(n))+j)
810 ENDDO
811 k=k+npby_tmp(2,index(n))
812 ENDDO
813c
814C------------------------------------
815c Ajout des XTRA_NODES en triant les doublons
816C entre les RB qui seront fusionnes et ceux
817C qui ne le seront pas
818C------------------------------------
819 inode = 0
820 lpby_tmp(1:slrbody)=0
821 DO n=1,nrbykin
822 k=npby(11,n)
823 npby(11,n)=inode
824 DO j=1,npby(2,n)
825 IF(itag(lpby(k+j)) == 0) THEN
826 inode = inode+1
827 itag(lpby(k+j)) = 1
828 lpby_tmp(inode)=lpby(k+j)
829 ELSE
830 npby(2,n)=npby(2,n)-1
831 ENDIF
832 ENDDO
833 nsl_xtra = 0
834 DO j=1,rbmerge(index(n))%NNODE
835 IF(itag(rbmerge(index(n))%NODE(j)) <= 0) THEN
836 nsl_xtra = nsl_xtra+1
837 inode = inode+1
838 lpby_tmp(inode)=rbmerge(index(n))%NODE(j)
839 IF(rbmerge(index(n))%FLAG_NODE(j) == 1) npby(14,n)=npby(14,n)+1
840 IF(rbmerge(index(n))%FLAG_NODE(j) == 2) npby(15,n)=npby(15,n)+1
841 IF(rbmerge(index(n))%FLAG_NODE(j) == 3) npby(16,n)=npby(16,n)+1
842 IF(itag(rbmerge(index(n))%NODE(j)) == -1) THEN
843 CALL ancmsg(msgid=1644,
844 . msgtype=msgwarning,
845 . anmode=aninfo_blind_1,
846 . i1=itab(rbmerge(index(n))%NODE(j)),
847 . prmod=msg_cumu)
848 ENDIF
849 itag(rbmerge(index(n))%NODE(j)) = 1
850 ENDIF
851 ENDDO
852C
853 npby(2,n)=npby(2,n)+nsl_xtra
854 IF(npby(12,n) == 0) THEN
855 nsl_xtra=npby(14,n)+npby(15,n)+npby(16,n)
856 k=npby(11,n)
857 DO j=1,npby(2,n)-nsl_xtra
858 itag(lpby_tmp(k+j)) = 0
859 ENDDO
860 DO j=npby(2,n)-nsl_xtra+1,npby(2,n)
861 itag(lpby_tmp(k+j)) = -1
862 ENDDO
863 DO i=n-1,1,-1
864 IF((npby(12,i)) < 0) THEN
865 k=npby(11,i)
866 nsl_xtra=npby(14,i)+npby(15,i)+npby(16,i)
867 DO j=1,npby(2,i)-nsl_xtra
868 itag(lpby_tmp(k+j)) = 0
869 ENDDO
870 DO j=npby(2,i)-nsl_xtra+1,npby(2,i)
871 itag(lpby_tmp(k+j)) = -1
872 ENDDO
873 ELSE
874 EXIT
875 ENDIF
876 ENDDO
877 ENDIF
878 ENDDO
879 CALL ancmsg(msgid=1644,
880 . msgtype=msgwarning,
881 . anmode=aninfo_blind_1,
882 . prmod=msg_print)
883
884 lpby(1:slrbody)=0
885 DO n=1,nrbykin
886 k=npby(11,n)
887 DO j=1,npby(2,n)
888 lpby(k+j)=lpby_tmp(k+j)
889 ENDDO
890 ENDDO
891C
892 DO n=1,nrbykin
893 nsl_xtra = npby(14,n)+npby(15,n)+npby(16,n)
894 k = npby(11,n)+npby(2,n)-nsl_xtra
895C------------------------------------
896C SPMD TREATMENT ONLY FOR XTRA_NODES
897C------------------------------------
898 CALL spmdset(n,npby,nnpby,lpby,nsl_xtra,k)
899 ENDDO
900C------------------------------------
901C tag des xtra noeuds SECONDARYs rby avec gravite
902C pour calcul du travail des forces externes
903C-------------------------------------
904 DO i=1,numnod
905 itag(i)=0
906 ENDDO
907 k=0
908 DO n=1,nrbykin
909 nsl_xtra = npby(14,n)+npby(15,n)+npby(16,n)
910 k = npby(11,n)+npby(2,n)-nsl_xtra
911 IF(npby(7,n)/=0)THEN
912 DO i=1,nsl_xtra
913 itag(lpby(i+k))=1
914 ENDDO
915 ENDIF
916 ENDDO
917 DO k=1,ngrav
918 nn =igrv(1,k)
919 iad=igrv(4,k)
920 DO i=1,nn
921 n=ibgr(i+iad-1)
922 IF(n > 0)THEN
923 IF(itag(n) == 1)ibgr(i+iad-1) = -n
924 ENDIF
925 ENDDO
926 ENDDO
927C------------------------------------
928C Sorties dans 0.out des bilans des fusions
929C pour les top level MAIN
930C-------------------------------------
931 DO n=1,nrbykin
932 nbsecondary=0
933 list_xtra(:)=0
934 kk=0
935
936 IF(npby(12,n) == 0) THEN
937 nsl_xtra=npby(14,n)+npby(15,n)+npby(16,n)
938 k = npby(11,n) + npby(2,n) - nsl_xtra
939 DO j=1,nsl_xtra
940 list_xtra(kk+j) = lpby(k+j)
941 ENDDO
942 kk=kk+nsl_xtra
943
944 DO i=n-1,1,-1
945 IF(npby(12,i) == 0) EXIT
946 npby(4,i) = npby(4,n) ! Same ISENS for MAIN RB's SECONDARYs
947 nbsecondary=nbsecondary+1
948
949 nsl_xtra=npby(14,i)+npby(15,i)+npby(16,i)
950 k = npby(11,i) + npby(2,i) - nsl_xtra
951 DO j=1,nsl_xtra
952 list_xtra(kk+j) = lpby(k+j)
953 ENDDO
954 kk=kk+nsl_xtra
955
956 ENDDO
957 ENDIF
958
959 IF((nbsecondary + kk) > 0) THEN
960 WRITE(iout,1000) npby(6,n)
961 IF(nbsecondary > 0) THEN
962 WRITE(iout,1100) (npby(6,n-i),i=1,nbsecondary)
963 ENDIF
964 IF(kk > 0) THEN
965 WRITE(iout,1200) (itab(list_xtra(j)),j=1,nsl_xtra)
966 ENDIF
967 ENDIF
968
969 ENDDO
970C
971 DEALLOCATE(itag)
972 DEALLOCATE(pile)
973 DEALLOCATE(npby_tmp)
974 DEALLOCATE(index)
975 DEALLOCATE(lpby_tmp)
976 DEALLOCATE(nom_opt_tmp)
977 DEALLOCATE(rby_tmp)
978 RETURN
979C
9801000 FORMAT(/5x,'MAIN RIGID BODY ID ',i10)
9811100 FORMAT(5x,'SECONDARY RIGID BODIES ID',10i10)
9821200 FORMAT(5x,'SECONDARY EXTRA NODES ID ',10i10)
983 END
984C
985!||====================================================================
986!|| rb_explore ../starter/source/constraints/general/merge/hm_read_merge.F
987!||--- called by ------------------------------------------------------
988!|| trirbmerge ../starter/source/constraints/general/merge/hm_read_merge.f
989!||--- calls -----------------------------------------------------
990!||--- uses -----------------------------------------------------
991!|| rbmerge_mod ../starter/source/constraints/general/merge/rbmerge_type.F90
992!||====================================================================
993 RECURSIVE SUBROUTINE rb_explore(IDRB,RBMERGE,PILE,IDPILE)
994C-----------------------------------------------
995C M o d u l e s
996C-----------------------------------------------
997 USE rbmerge_mod
998C-----------------------------------------------
999C I m p l i c i t T y p e s
1000C-----------------------------------------------
1001#include "implicit_f.inc"
1002C-----------------------------------------------
1003C C o m m o n B l o c k s
1004C-----------------------------------------------
1005#include "com04_c.inc"
1006C-----------------------------------------------
1007C D u m m y A r g u m e n t s
1008C-----------------------------------------------
1009 INTEGER pile(nrbykin), idpile, idrb
1010 TYPE (rbmerge_) , DIMENSION(*) :: rbmerge
1011C-----------------------------------------------
1012C L o c a l V a r i a b l e s
1013C-----------------------------------------------
1014 INTEGER isecondary, nbsecondary
1015C-----------------------------------------------
1016! RBMERGE(IRBM)%ID :: Rigid body identifier
1017! RBMERGE(IRBM)%NBSECONDARY :: Number of SECONDARY rigid body
1018! RBMERGE(IRBM)%IMAIN :: 0 if this rigid body doesn't have a MAIN
1019! X : The Rigid body's MAIN
1020! RBMERGE(IRBM)%LEVEL :: Rigid body level
1021! RBMERGE(IRBM)%FLAG_MAIN :: Flag relating the rigid option merge to the MAIN
1022! RBMERGE(IRBM)%IDSECONDARY(J) :: SECONDARY rigid bodys attached to the MAIN
1023C-----------------------------------------------
1024 idpile = idpile + 1
1025 pile(idpile) = idrb
1026 nbsecondary = rbmerge(idrb)%NBSECONDARY
1027 isecondary = 0
1028c
1029 DO WHILE (isecondary < nbsecondary)
1030 isecondary = isecondary + 1
1031 CALL rb_explore(rbmerge(idrb)%IDSECONDARY(isecondary),rbmerge,pile,idpile)
1032 ENDDO
1033C
1034 RETURN
1035 END
1036C
1037!||====================================================================
1038!|| retrirby ../starter/source/constraints/general/merge/hm_read_merge.F
1039!||--- called by ------------------------------------------------------
1040!|| initia ../starter/source/elements/initia/initia.F
1041!||--- calls -----------------------------------------------------
1042!||--- uses -----------------------------------------------------
1043!|| message_mod ../starter/share/message_module/message_mod.F
1044!|| rbmerge_mod ../starter/source/constraints/general/merge/rbmerge_type.F90
1045!||====================================================================
1046 SUBROUTINE retrirby(NPBY ,LPBY ,RBY ,NOM_OPT)
1047C-----------------------------------------------
1048C M o d u l e s
1049C-----------------------------------------------
1050 USE my_alloc_mod
1051 USE message_mod
1052 USE rbmerge_mod
1053C-----------------------------------------------
1054C I m p l i c i t T y p e s
1055C-----------------------------------------------
1056#include "implicit_f.inc"
1057C-----------------------------------------------
1058C C o m m o n B l o c k s
1059C-----------------------------------------------
1060#include "scr17_c.inc"
1061#include "com04_c.inc"
1062#include "param_c.inc"
1063#include "lagmult.inc"
1064C-----------------------------------------------
1065C D u m m y A r g u m e n t s
1066C-----------------------------------------------
1067 INTEGER NPBY(NNPBY,*),LPBY(*)
1068 my_real RBY(NRBY,*)
1069 INTEGER NOM_OPT(LNOPT1,*)
1070C-----------------------------------------------
1071C L o c a l V a r i a b l e s
1072C-----------------------------------------------
1073 INTEGER I,J,K,OFFSET,OFFSETEND,NRBYKINM,
1074 . new_size,cpt_rby,cpt_rby_secondary
1075 INTEGER,DIMENSION(:,:),ALLOCATABLE :: NPBY_TMP
1076 INTEGER,DIMENSION(:),ALLOCATABLE :: INDEX
1077 INTEGER,DIMENSION(:,:),ALLOCATABLE :: NOM_OPT_TMP
1078 my_real,DIMENSION(:,:),ALLOCATABLE :: rby_tmp
1079C-----------------------------------------------
1080 CALL my_alloc(npby_tmp,nnpby,nrbykin+nrbylag)
1081 CALL my_alloc(nom_opt_tmp,lnopt1,nrbykin+nrbylag)
1082 CALL my_alloc(index,nrbykin+nrbylag)
1083 CALL my_alloc(rby_tmp,nrby,nrbykin+nrbylag)
1084C
1085 new_size = 0
1086 DO i=1,nrbykin+nrbylag
1087 nom_opt_tmp(1:lnopt1,i)=nom_opt(1:lnopt1,i)
1088 DO j=1,nnpby
1089 npby_tmp(j,i)=npby(j,i)
1090 ENDDO
1091 DO j=1,nrby
1092 rby_tmp(j,i)=rby(j,i)
1093 ENDDO
1094 IF (npby(12,i)==0) new_size = new_size+1
1095 ENDDO
1096C
1097 cpt_rby = new_size
1098 cpt_rby_secondary = nrbykin+nrbylag
1099 DO i=nrbykin+nrbylag,1,-1
1100 IF (npby_tmp(12,i)==0) THEN
1101 nom_opt(1:lnopt1,cpt_rby)=nom_opt_tmp(1:lnopt1,i)
1102 npby(1:nnpby,cpt_rby)=npby_tmp(1:nnpby,i)
1103 rby(1:nrby,cpt_rby)=rby_tmp(1:nrby,i)
1104 cpt_rby = cpt_rby-1
1105 ELSE
1106C-- SECONDARY RBODY - put at the end of the list
1107 nom_opt(1:lnopt1,cpt_rby_secondary)=nom_opt_tmp(1:lnopt1,i)
1108 npby(1:nnpby,cpt_rby_secondary)=0!NPBY_TMP(1:NNPBY,I)
1109 rby(1:nrby,cpt_rby_secondary)=0!RBY_TMP(1:NRBY,I)
1110 npby(6,cpt_rby_secondary) = npby_tmp(6,i)
1111 npby(12,cpt_rby_secondary) = npby_tmp(12,i)
1112 npby(13,cpt_rby_secondary) = cpt_rby+1
1113 cpt_rby_secondary = cpt_rby_secondary-1
1114 ENDIF
1115 ENDDO
1116C
1117 nrbykin=new_size-nrbylag
1118 DEALLOCATE(npby_tmp)
1119 DEALLOCATE(nom_opt_tmp)
1120 DEALLOCATE(index)
1121 DEALLOCATE(rby_tmp)
1122
1123C
1124 RETURN
1125 END
1126C
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
rbleveldown
recursive subroutine rbleveldown(npby, rbmerge, idrb, level)
Definition hm_read_merge.F:641
rbtag1down
recursive subroutine rbtag1down(tabrb, idrb, tag1, nbmerge)
Definition hm_read_merge.F:542
trirbmerge
subroutine trirbmerge(rbmerge, npby, lpby, slrbody, rby, nom_opt, itab, ibgr, igrv)
Definition hm_read_merge.F:703
hm_read_merge
subroutine hm_read_merge(mgrby, smgrby, npby, lpby, slrbody, rby, nom_opt, ptr_nopt_rbmerge, igrnod, itab, itabm1, ibgr, igrv, lsubmodel)
Definition hm_read_merge.F:51
retrirby
subroutine retrirby(npby, lpby, rby, nom_opt)
Definition hm_read_merge.F:1047
rbtag2down
recursive subroutine rbtag2down(idrb, tag2, rbmerge, flag_boucle, tabboucle, idboucle)
Definition hm_read_merge.F:582
rb_explore
recursive subroutine rb_explore(idrb, rbmerge, pile, idpile)
Definition hm_read_merge.F:994
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
merge
subroutine merge(x, itab, itabm1, cmerge, imerge, imerge2, iadmerge2, nmerge_tot)
Definition merge.F:36
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
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
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
spmdset
subroutine spmdset(n, npby, nnpby, lpby, nsl, k)
Definition spmdset.F:34
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
starter
program starter
Definition starter.F:39
groupdef_mod::group_
Definition groupdef_mod.F:700
submodel_mod::submodel_data
Definition submodel_mod.F:723