OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_rbe2.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_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.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!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
31!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
32!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
33!|| hm_sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
34!|| ifrontplus ../starter/source/spmd/node/frontplus.F
35!|| kinset ../starter/source/constraints/general/kinset.F
36!|| nlocal ../starter/source/spmd/node/ddtools.F
37!|| nodgrnr6 ../starter/source/starter/freform.F
38!|| rbe2modif_nd ../starter/source/elements/solid/solide10/dim_s10edg.F
39!|| usr2sys ../starter/source/system/sysfus.f
40!||--- uses -----------------------------------------------------
41!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
42!|| message_mod ../starter/share/message_module/message_mod.F
43!|| r2r_mod ../starter/share/modules1/r2r_mod.F
44!|| submodel_mod ../starter/share/modules1/submodel_mod.F
45!||====================================================================
46 SUBROUTINE hm_read_rbe2(IRBE2 ,LRBE2 ,ITAB ,ITABM1 ,IGRNOD,
47 . ISKN ,IKINE ,IDDLEVEL,NOM_OPT ,ITAGND,
48 . ICDNS10 ,LSUBMODEL)
49C-----------------------------------------------
50C M o d u l e s
51C-----------------------------------------------
52 USE message_mod
53 USE groupdef_mod
54 USE hm_option_read_mod
55 USE submodel_mod
56 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
57C-----------------------------------------------
58C M o d u l e s
59C-----------------------------------------------
60 USE r2r_mod
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 "scr05_c.inc"
69#include "scr17_c.inc"
70#include "com01_c.inc"
71#include "com04_c.inc"
72#include "units_c.inc"
73#include "param_c.inc"
74#include "r2r_c.inc"
75#include "sphcom.inc"
76#include "scr03_c.inc"
77C-----------------------------------------------
78C D u m m y A r g u m e n t s
79C-----------------------------------------------
80 INTEGER IRBE2(NRBE2L,*), LRBE2(*), ITAB(*),ITABM1(*),
81 . ISKN(LISKN,*),
82 . ikine(*),iddlevel,itagnd(*),icdns10(*)
83 INTEGER NOM_OPT(LNOPT1,*)
84C-----------------------------------------------
85 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
86 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90 INTEGER I, K, NUSER, NM,M,
91 . ISK, INGU, IGM, J, P,IAD,NS,J6(6),JJ,
92 . ic,ic1,ic2,isks,idir,
93 . ikine1(3*numnod),irad,nrb,nmove,sub_index,nsl
94 INTEGER, DIMENSION(NUMNOD) :: ITAGM,ITAGIC
95 CHARACTER(LEN=NCHARTITLE) :: TITR
96 CHARACTER :: MESS*40
97 LOGICAL IS_AVAILABLE
98C-----------------------------------------------
99C E x t e r n a l F u n c t i o n s
100C-----------------------------------------------
101 INTEGER USR2SYS,NODGRNR6
102 INTEGER FMAIN(PARASIZ)
103 INTEGER NLOCAL
104 EXTERNAL nlocal
105C
106 DATA mess/'RBE2 RIGID BODY '/
107C-----------------------------------------------
108C IRBE2(1,I) : IAD0 for LRBE2
109C IRBE2(2,I) : TYPE usr' id temporaire (print)
110C IRBE2(3,I) : INDEPENDENT NODE
111C IRBE2(4,I) : REF_DOF
112C IRBE2(5,I) : NUMBER OF DEPENDENT NODES
113C IRBE2(6,I) : m_iad if same node as several Rbe2 main (init.in engine)
114C IRBE2(7,I) : iskew
115C IRBE2(8,I) : SBE2
116C IRBE2(9,I) : hierarchy level 0-NHRBE2
117C IRBE2(10,I) : id for modif/spmd
118C IRBE2(11,I) : flag to associate REF_DOF to main node
119C========================================================================|
120 WRITE(iout,1000)
121 IF (ipri<5) WRITE(iout,1201)
122C
123 nrb = 0
124C
125 DO i=1,3*numnod
126 ikine1(i) = 0
127 ENDDO
128 k = 0
129C
130 CALL hm_option_start('/RBE2')
131 iad = 0
132 DO i=1,nrbe2
133 nrb=nrb+1
134C----------Multidomaines --> on ignore les rbe3 non tages---------
135 IF(nsubdom>0)THEN
136 IF(tagrb2(nrb)==0)CALL hm_sz_r2r(tagrb2,nrb,lsubmodel)
137 END IF
138C-----------------------------------------------------------------
139 CALL hm_option_read_key(lsubmodel,
140 . option_id = nuser,
141 . submodel_index = sub_index,
142 . option_titr = titr)
143
144 nom_opt(1,i)=nuser
145 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
146 irbe2(2,i) = nuser
147 irbe2(10,i) = i
148 CALL hm_get_intv('independentnode',nm,is_available,lsubmodel)
149 CALL hm_get_intv('VX',j6(1),is_available,lsubmodel)
150 CALL hm_get_intv('VY',j6(2),is_available,lsubmodel)
151 CALL hm_get_intv('VZ',j6(3),is_available,lsubmodel)
152 CALL hm_get_intv('WX',j6(4),is_available,lsubmodel)
153 CALL hm_get_intv('WY',j6(5),is_available,lsubmodel)
154 CALL hm_get_intv('WZ',j6(6),is_available,lsubmodel)
155 CALL hm_get_intv('SKEW_CSID',isk,is_available,lsubmodel)
156 CALL hm_get_intv('dependentnodeset',ingu,is_available,lsubmodel)
157 CALL hm_get_intv('Iflag',irad,is_available,lsubmodel)
158C
159 IF (isk == 0 .and. sub_index > 0) isk = lsubmodel(sub_index)%SKEW
160C
161 m = usr2sys(nm,itabm1,mess,nuser)
162 ic1=j6(1)*4 +j6(2)*2 +j6(3)
163 ic2=j6(4)*4 +j6(5)*2 +j6(6)
164 ic =ic1*512+ic2*64
165 IF (ic==0) ic =7*512+7*64
166 irbe2(3,i) = m
167 irbe2(4,i) = ic
168 irbe2(1,i) = iad
169 irbe2(11,i) = irad
170 ns = nodgrnr6(m ,ingu ,igm ,lrbe2(iad+1),igrnod,
171 . itabm1,mess,nuser)
172 IF (ns10e > 0) THEN
173C----partial dof of RBE2 will be treated correctly
174C
175 IF (itagnd(m)/=0) THEN
176 CALL ancmsg(msgid=1211,
177 . msgtype=msgerror,
178 . anmode=aninfo,
179 . i1=itab(m),
180 . c1='RBE2',
181 . i2=nuser,
182 . c2='RBE2')
183 END IF
184 END IF
185 isks = 0
186 IF ((j6(1)+j6(2)+j6(3)+j6(4)+j6(5)+j6(6))==0) THEN
187 j6(1)=1
188 j6(2)=1
189 j6(3)=1
190 j6(4)=1
191 j6(5)=1
192 j6(6)=1
193 ENDIF
194 IF (isk/=0) THEN
195 DO jj=0,numskw+min(1,nspcond)*numsph+nsubmod
196 IF(isk==iskn(4,jj+1)) THEN
197 isks=jj+1
198 GO TO 10
199 ENDIF
200 ENDDO
201 CALL ancmsg(msgid=184,
202 . msgtype=msgerror,
203 . anmode=aninfo,
204 . c1='RBE2',
205 . i1=nuser,
206 . c2='RBE2',
207 . c3=titr,
208 . i2=isk)
209 10 CONTINUE
210 ENDIF
211 irbe2(7,i) = isks
212C
213 IF (iddlevel == 0) THEN
214 DO j=1,ns
215 DO idir=1,6
216 IF ( j6(idir) == 1)
217 . CALL kinset(2048,itab(lrbe2(j+k)),ikine(lrbe2(j+k)),idir,isk,
218 . ikine1(lrbe2(j+k)))
219 ENDDO
220 ENDDO
221 ENDIF
222 iad = iad+ns
223 irbe2(5,i) = ns
224 IF (ipri>=5) THEN
225 WRITE(iout,1100) nuser,nm,j6,isk,ns,irad
226 ELSE
227 WRITE(iout,1200) nuser,nm,j6,isk,ns,irad
228 END IF
229 k = k + ns
230 END DO
231C------treatment compatibility w/ Itetra10=2
232 IF (ns10e > 0) THEN
233C------can have the same MAIN node in several RBE2
234 itagm(1:numnod)=0
235 itagic(1:numnod)=0
236 DO i=1,nrbe2
237 iad = irbe2(1,i)
238 m = irbe2(3,i)
239 nsl = irbe2(5,i)
240 ic = irbe2(4,i)
241 DO j=1,nsl
242 ns =lrbe2(iad+j)
243 IF (itagm(ns)==0) THEN
244 itagm(ns) = m
245 ELSEIF (itagm(ns)/=m) THEN
246C------- error-out
247 END IF
248 itagic(ns) = itagic(ns) + ic
249 END DO
250 END DO
251 nmove = 0
252 DO i=1,nrbe2
253 iad = irbe2(1,i)
254 m = irbe2(3,i)
255 nsl = irbe2(5,i)
256 nuser = irbe2(2,i)
257 CALL rbe2modif_nd(nsl,lrbe2(iad+1),itagnd,icdns10,nuser,itab,
258 . itagm,m,itagic)
259 IF (irbe2(5,i)>nsl) THEN
260 nmove = nmove+irbe2(5,i)-nsl
261 irbe2(5,i) = nsl
262 END IF
263 END DO
264 IF (nmove>0) THEN
265 CALL ancmsg(msgid=1729,
266 . msgtype=msginfo,
267 . anmode=aninfo_blind_1,
268 . i1=nmove)
269 END IF
270 END IF
271C--------for decompo
272 IF (iddlevel > 0) THEN
273 DO i=1,nrbe2
274 iad = irbe2(1,i)
275 m = irbe2(3,i)
276 ns = irbe2(5,i)
277 IF (nspmd > 1.AND.ns>0) THEN
278 fmain(1:nspmd) = 0
279 DO p = 1, nspmd
280 DO j = 1, ns
281 IF (nlocal(lrbe2(iad+j),p)/=0)THEN
282 fmain(p) = 1
283 GO TO 85
284 ENDIF
285 ENDDO
286 85 CONTINUE
287 END DO
288C noeud main sur les procs ayant au moins 1 SECONDARY
289 DO p = 1, nspmd
290 IF (fmain(p)==1) THEN
291 CALL ifrontplus(m,p)
292 ENDIF
293 ENDDO
294 ENDIF
295 END DO
296 END IF !(IDDLEVEL > 0) THEN
297C
298 RETURN
299C
300 1000 FORMAT(//
301 .' RIGID ELEMENT (RBE2) '/
302 . ' ---------------------- ')
303 1100 FORMAT(/10x,'NUMBER . . . . . . . . . . .',i10,/,
304 . /10x,'independent node number . . ',I10,
305 . /10X,'dof( x,y,z, xx,yy,zz). . . . ',3I1,2X,3I1
306 . /10X,'skew number . . . . . . . . .',I10,
307 . /10X,'number of dependent nodes. . .',I10,
308 . /10X,'formulation flag . . . . . . ',I10,//)
309 1201 FORMAT(' rbe2_id ind._node ref_dof skew_id #SECONDARY IFLAG'/)
310 1200 FORMAT(3x,2i10,3x,3i1,1x,3i1,3i10)
311 END SUBROUTINE hm_read_rbe2
312!||====================================================================
313!|| hm_preread_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
314!||--- called by ------------------------------------------------------
315!|| lectur ../starter/source/starter/lectur.F
316!||--- calls -----------------------------------------------------
317!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
318!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
319!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
320!|| hm_sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
321!|| ngr2usrn ../starter/source/system/nintrr.F
322!||--- uses -----------------------------------------------------
323!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
324!|| r2r_mod ../starter/share/modules1/r2r_mod.F
325!|| submodel_mod ../starter/share/modules1/submodel_mod.F
326!||====================================================================
327 SUBROUTINE hm_preread_rbe2(LNUM ,LREAL, IGRNOD, LSUBMODEL)
328C-----------------------------------------------
329C M o d u l e s
330C-----------------------------------------------
331 USE r2r_mod
332 USE groupdef_mod
333 USE submodel_mod
334 USE hm_option_read_mod
335 USE names_and_titles_mod , ONLY : nchartitle
336C-----------------------------------------------
337C I m p l i c i t T y p e s
338C-----------------------------------------------
339#include "implicit_f.inc"
340C-----------------------------------------------
341C C o m m o n B l o c k s
342C-----------------------------------------------
343#include "param_c.inc"
344#include "com04_c.inc"
345#include "r2r_c.inc"
346C-----------------------------------------------
347C D u m m y A r g u m e n t s
348C-----------------------------------------------
349 INTEGER LNUM ,LREAL
350C-----------------------------------------------
351 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
352 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
353C-----------------------------------------------
354C L o c a l V a r i a b l e s
355C-----------------------------------------------
356 INTEGER I,IGU,IGS,NN, NUSER, NRB
357 CHARACTER(LEN=NCHARTITLE) :: TITR
358 INTEGER NGR2USRN
359 LOGICAL IS_AVAILABLE
360C========================================================================|
361 lnum = 0
362 lreal = 0
363 IF (nrbe2==0) RETURN
364
365 nrb = 0
366
367 CALL hm_option_start('/RBE2')
368 DO i=1,nrbe2
369 nrb=nrb+1
370C----------Multidomaines --> on ignore les rbe2 non tages---------
371 IF(nsubdom>0)THEN
372 IF(tagrb2(nrb)==0)CALL hm_sz_r2r(tagrb2,nrb,lsubmodel)
373 END IF
374C-----------------------------------------------------------------
375 CALL hm_option_read_key(lsubmodel,
376 . option_id = nuser,
377 . option_titr = titr)
378
379 CALL hm_get_intv('dependentnodeset',igu,is_available,lsubmodel)
380 igs = ngr2usrn(igu,igrnod,ngrnod,nn)
381C
382 lreal = lreal + nn
383 lnum = lnum +nrbe2l
384 ENDDO
385C-----------
386 RETURN
387 END SUBROUTINE hm_preread_rbe2
388!||====================================================================
389!|| reorbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
390!||--- called by ------------------------------------------------------
391!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
392!||--- calls -----------------------------------------------------
393!|| setiadm ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
394!||====================================================================
395 SUBROUTINE reorbe2(IRBE2 ,LRBE2 ,NC )
396C-----------------------------------------------
397C I m p l i c i t T y p e s
398C-----------------------------------------------
399#include "implicit_f.inc"
400C-----------------------------------------------
401C C o m m o n B l o c k s
402C-----------------------------------------------
403#include "com04_c.inc"
404#include "param_c.inc"
405#include "tabsiz_c.inc"
406C-----------------------------------------------
407C D u m m y A r g u m e n t s
408C-----------------------------------------------
409 INTEGER IRBE2(NRBE2L,*), LRBE2(*),NC
410C-----------------------------------------------
411C L o c a l V a r i a b l e s
412C-----------------------------------------------
413 INTEGER I, N, K, NSL,M,IC0,NZ,
414 . J, IAD,NS,II,IT,IERR1,IAD1,IC,NIT,I0,I1
415C
416 INTEGER LCOPY(SLRBE2),ICOPY(NRBE2L,NRBE2),
417 . IORDER(NRBE2),INDICE(NRBE2),ITAG1(NRBE2)
418 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG,IAD_N
419C========================================================================|
420C--------re-ordering if with hierarchy---------------------------------------
421 ALLOCATE(itag(numnod))
422 ALLOCATE(iad_n(numnod+1))
423 nc=0
424 DO i=1,numnod
425 itag(i)=0
426 ENDDO
427C--------if same node as several IND. of /RBE2---------------------------------------
428 nz=0
429 DO i=1,nrbe2
430 m = irbe2(3,i)
431 IF (itag(m)==0) THEN
432 itag(m)=i
433 ELSE
434 nz=nz+1
435 itag1(nz)=i
436 ENDIF
437 ENDDO
438 CALL setiadm(itag1,nz,iad_n,irbe2)
439C--------- if hierarchy
440 DO i=1,nrbe2
441 iad = irbe2(1,i)
442 m = irbe2(3,i)
443 nsl = irbe2(5,i)
444 DO j =1,nsl
445 ns = lrbe2(iad+j)
446 IF (itag(ns)>i) nc=nc+1
447 DO k=iad_n(ns),iad_n(ns+1)-1
448 IF (itag1(k)>i) nc=nc+1
449 ENDDO
450 ENDDO
451 ENDDO
452 IF (nc==0) RETURN
453C---------
454 DO i=1,nrbe2
455 iorder(i) = i
456 indice(i) = i
457 ENDDO
458 nc = 0
459C--------- ite=
460 ierr1 = 0
461 nit =5
462 DO it=1,nit
463 ii = nc
464 DO i=1,nrbe2
465 iad = irbe2(1,i)
466 m = irbe2(3,i)
467 nsl = irbe2(5,i)
468 DO j =1,nsl
469 ns = lrbe2(iad+j)
470 IF (itag(ns)==0) cycle
471 ic=indice(itag(ns))
472 i1=indice(i)
473C-----
474 IF (ic>i1) THEN
475 nc = nc+1
476C-------exchange IORDER(IC) & IORDER(I) --
477 i0 = iorder(i1)
478 iorder(i1) = iorder(ic)
479 iorder(ic) = i0
480 ic0 = indice(i)
481 indice(i) = ic
482 indice(itag(ns)) = i1
483 IF (it==nit) ierr1 = irbe2(2,i)
484 ENDIF
485 DO k=iad_n(ns),iad_n(ns+1)-1
486 ic=indice(itag1(k))
487 i1=indice(i)
488 IF (ic>i1) THEN
489 nc = nc+1
490C--exchange IORDER(IC) & IORDER(I) --
491 i0 = iorder(i1)
492 iorder(i1) = iorder(ic)
493 iorder(ic) = i0
494 indice(i) = ic
495 indice(itag1(k)) = i1
496 ENDIF
497 ENDDO
498 ENDDO
499 ENDDO
500 ii = nc -ii
501 IF (ii<=0) GOTO 100
502 ENDDO
503 100 CONTINUE
504C
505 IF (ierr1>0) nc=-ierr1
506C----------copy---
507 DO i=1,nrbe2
508 iad = irbe2(1,i)
509 m = irbe2(3,i)
510 nsl = irbe2(5,i)
511 DO j =1,nrbe2l
512 icopy(j,i) = irbe2(j,i)
513 ENDDO
514 DO j =1,nsl
515 lcopy(iad+j) = lrbe2(iad+j)
516 ENDDO
517 ENDDO
518C----------reodering---
519 iad1 = 0
520 DO n=1,nrbe2
521 i = iorder(n)
522 iad = icopy(1,i)
523 m = icopy(3,i)
524 nsl = icopy(5,i)
525 irbe2(1,n) = iad1
526 DO j =2,nrbe2l
527 irbe2(j,n) = icopy(j,i)
528 ENDDO
529 DO j =1,nsl
530 lrbe2(iad1+j)=lcopy(iad+j)
531 ENDDO
532 iad1 =iad1+nsl
533 ENDDO
534 DEALLOCATE(itag,iad_n)
535
536C
537 RETURN
538 END SUBROUTINE reorbe2
539!||====================================================================
540!|| setiadm ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
541!||--- called by ------------------------------------------------------
542!|| hierarbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.f
543!|| reorbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
544!||====================================================================
545 SUBROUTINE setiadm(IADM,NZ,IAD_N,IRBE2)
546C-----------------------------------------------
547C I m p l i c i t T y p e s
548C-----------------------------------------------
549#include "implicit_f.inc"
550C-----------------------------------------------
551C C o m m o n B l o c k s
552C-----------------------------------------------
553#include "com04_c.inc"
554#include "param_c.inc"
555C-----------------------------------------------
556C D u m m y A r g u m e n t s
557C-----------------------------------------------
558 INTEGER IRBE2(NRBE2L,*), IADM(*),NZ,IAD_N(*)
559C-----------------------------------------------
560C L o c a l V a r i a b l e s
561C-----------------------------------------------
562 INTEGER I, N, NM,J,M
563C
564 INTEGER IADM_CP(NZ)
565 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
566C========================================================================|
567 ALLOCATE(itag(numnod))
568C========================================================================|
569 DO i=1,numnod
570 itag(i)=0
571 ENDDO
572 DO j=1,nz
573 i = iadm(j)
574 m = irbe2(3,i)
575 itag(m)=itag(m)+1
576 ENDDO
577 nm =0
578 iad_n(1)=1
579 DO n=1,numnod
580 IF (itag(n)>0) THEN
581 DO j=1,nz
582 i = iadm(j)
583 m = irbe2(3,i)
584 IF (m==n) THEN
585 nm=nm+1
586 iadm_cp(nm)=i
587 ENDIF
588 END DO
589 ENDIF
590 iad_n(n+1)=nm+1
591 ENDDO
592 DO j=1,nz
593 iadm(j)=iadm_cp(j)
594 ENDDO
595 DEALLOCATE(itag)
596C
597 RETURN
598 END SUBROUTINE setiadm
599!||====================================================================
600!|| hierarbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
601!||--- called by ------------------------------------------------------
602!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
603!||--- calls -----------------------------------------------------
604!|| setiadm ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
605!||====================================================================
606 SUBROUTINE hierarbe2(IRBE2 ,LRBE2)
607C-----------------------------------------------
608C I m p l i c i t T y p e s
609C-----------------------------------------------
610#include "implicit_f.inc"
611C-----------------------------------------------
612C C o m m o n B l o c k s
613C-----------------------------------------------
614#include "com04_c.inc"
615#include "param_c.inc"
616#include "tabsiz_c.inc"
617C-----------------------------------------------
618C D u m m y A r g u m e n t s
619C-----------------------------------------------
620 INTEGER IRBE2(NRBE2L,*), LRBE2(*)
621C-----------------------------------------------
622C L o c a l V a r i a b l e s
623C-----------------------------------------------
624 INTEGER I, N, IM1,NS,J,NSL,IAD,M,IH1,K,NZ,II,IAD1
625C
626 INTEGER ITAG1(NRBE2),
627 . LCOPY(SLRBE2),ICOPY(NRBE2L,NRBE2)
628 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG, IAD_N
629C========================================================================|
630C--------defining hierarchy---------------------------------------
631 ALLOCATE(itag(numnod))
632 ALLOCATE(iad_n(numnod+1))
633 DO i=1,numnod
634 itag(i)=0
635 ENDDO
636C--------if same node as several MAINs---------------------------------------
637 nz=0
638 DO i=1,nrbe2
639 m = irbe2(3,i)
640 IF (itag(m)==0) THEN
641 itag(m)=i
642 ELSE
643 nz=nz+1
644 itag1(nz)=i
645 ENDIF
646 ENDDO
647 CALL setiadm(itag1,nz,iad_n,irbe2)
648C--------------------------------------------
649 DO i=1,nrbe2
650 iad = irbe2(1,i)
651 m = irbe2(3,i)
652 nsl = irbe2(5,i)
653 DO j =1,nsl
654 ns = lrbe2(iad+j)
655 IF (itag(ns)>0) THEN
656 im1=itag(ns)
657 ih1 = irbe2(9,im1)+1
658 irbe2(9,i) = max(irbe2(9,i),ih1)
659 DO k=iad_n(ns),iad_n(ns+1)-1
660 im1=itag1(k)
661 ih1 = irbe2(9,im1)+1
662 irbe2(9,i) = max(irbe2(9,i),ih1)
663 ENDDO
664 ENDIF
665 ENDDO
666 ENDDO
667 nhrbe2=0
668 DO i=1,nrbe2
669 nhrbe2 = max(nhrbe2,irbe2(9,i))
670 m = irbe2(3,i)
671 ENDDO
672 IF (nhrbe2==0) RETURN
673C-------reordering according hiera---
674 DO i=1,nrbe2
675 iad = irbe2(1,i)
676 m = irbe2(3,i)
677 nsl = irbe2(5,i)
678 DO j =1,nrbe2l
679 icopy(j,i) = irbe2(j,i)
680 ENDDO
681 DO j =1,nsl
682 lcopy(iad+j) = lrbe2(iad+j)
683 ENDDO
684 ENDDO
685C----------reodering---
686 iad1 = 0
687 ii = 0
688 DO n=0,nhrbe2
689 DO i=1,nrbe2
690 IF (icopy(9,i)/=n) cycle
691 ii = ii + 1
692 iad = icopy(1,i)
693 m = icopy(3,i)
694 nsl = icopy(5,i)
695 irbe2(1,ii) = iad1
696 DO j =2,nrbe2l
697 irbe2(j,ii) = icopy(j,i)
698 ENDDO
699 DO j =1,nsl
700 lrbe2(iad1+j)=lcopy(iad+j)
701 ENDDO
702 iad1 =iad1+nsl
703 ENDDO
704 ENDDO
705C
706 DEALLOCATE(itag,iad_n)
707 RETURN
708 END SUBROUTINE hierarbe2
709!||====================================================================
710!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
711!||--- called by ------------------------------------------------------
712!|| initia ../starter/source/elements/initia/initia.F
713!||--- calls -----------------------------------------------------
714!|| ancmsg ../starter/source/output/message/message.F
715!|| fretitl2 ../starter/source/starter/freform.F
716!|| hierarbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
717!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
718!|| reorbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
719!||--- uses -----------------------------------------------------
720!|| message_mod ../starter/share/message_module/message_mod.F
721!||====================================================================
722 SUBROUTINE inirbe2(IRBE2 ,LRBE2 ,ITAB ,X ,MS ,
723 . IN ,STIFN ,STIFR ,TOTMAS,XGT ,
724 . YGT ,ZGT ,B1 ,B2 ,B3 ,
725 . B5 ,B6 ,B9 ,NOM_OPT,ITAGND )
726 USE message_mod
727 USE names_and_titles_mod , ONLY : nchartitle
728C-----------------------------------------------
729C I m p l i c i t T y p e s
730C-----------------------------------------------
731#include "implicit_f.inc"
732C-----------------------------------------------
733C C o m m o n B l o c k s
734C-----------------------------------------------
735#include "scr17_c.inc"
736#include "com01_c.inc"
737#include "com04_c.inc"
738#include "units_c.inc"
739#include "param_c.inc"
740#include "scr03_c.inc"
741C-----------------------------------------------
742C D u m m y A r g u m e n t s
743C-----------------------------------------------
744 INTEGER IRBE2(NRBE2L,*), LRBE2(*),ITAB(*),ITAGND(*)
745 my_real
746 . X(3,*),MS(*),IN(*),STIFN(*) ,STIFR(*),TOTMAS,
747 . B1, B2, B3, B5, B6, B9,XGT ,YGT ,ZGT
748 INTEGER NOM_OPT(LNOPT1,*)
749C-----------------------------------------------
750C L o c a l V a r i a b l e s
751C-----------------------------------------------
752 INTEGER I, J, NSL,M, NC,NS,ICT,ICR,IC,IAD,ID,J6(6),IRAD
753C
754 my_real xx, xy, xz, yy, yz, zz,ixx,iyy,izz,dd,masrb,inrb,ins
755 CHARACTER(LEN=NCHARTITLE) :: TITR
756C========================================================================|
757 CALL rbe2_merge(irbe2 ,lrbe2 )
758 CALL reorbe2(irbe2 ,lrbe2 ,nc )
759 CALL hierarbe2(irbe2 ,lrbe2 )
760 IF (nc<0) THEN
761 id= -nc
762 CALL ancmsg(msgid=803,
763 . msgtype=msgerror,
764 . anmode=aninfo,
765 . i1=id)
766 ELSEIF(nhrbe2>0) THEN
767 WRITE(iout,1200) nhrbe2
768 IF (ipri>=5) THEN
769 WRITE(iout,1000)
770 DO i=1,nrbe2
771 m = itab(irbe2(3,i))
772 nsl = irbe2(5,i)
773 ic=irbe2(4,i)
774 ict=ic/512
775 icr=(ic-512*(ict))/64
776 DO j =1,6
777 j6(j)=0
778 ENDDO
779 SELECT CASE (ict)
780 CASE(1)
781 j6(3)=1
782 CASE(2)
783 j6(2)=1
784 CASE(3)
785 j6(2)=1
786 j6(3)=1
787 CASE(4)
788 j6(1)=1
789 CASE(5)
790 j6(1)=1
791 j6(3)=1
792 CASE(6)
793 j6(1)=1
794 j6(2)=1
795 CASE(7)
796 j6(1)=1
797 j6(2)=1
798 j6(3)=1
799 END SELECT
800 SELECT CASE (icr)
801 CASE(1)
802 j6(6)=1
803 CASE(2)
804 j6(5)=1
805 CASE(3)
806 j6(5)=1
807 j6(6)=1
808 CASE(4)
809 j6(4)=1
810 CASE(5)
811 j6(4)=1
812 j6(6)=1
813 CASE(6)
814 j6(4)=1
815 j6(5)=1
816 CASE(7)
817 j6(4)=1
818 j6(5)=1
819 j6(6)=1
820 END SELECT
821 WRITE(iout,1100) irbe2(2,i),irbe2(9,i),m,j6,irbe2(7,i),nsl
822 ENDDO
823 END IF
824 ENDIF
825C
826 inrb=zero
827 DO i=1,nrbe2
828 iad = irbe2(1,i)
829 nom_opt(1,i) = irbe2(2,i)
830 m = irbe2(3,i)
831 nsl = irbe2(5,i)
832 ic=irbe2(4,i)
833 irad = irbe2(11,i)
834 ict=ic/512
835 IF (ict>0) THEN
836 IF (ns10e>0) THEN
837 DO j =1,nsl
838 ns = lrbe2(iad+j)
839 IF (itagnd(ns)/=0) cycle
840 ms(m) = ms(m)+ms(ns)
841 stifn(m)= stifn(m)+stifn(ns)
842 ENDDO
843 ELSE
844 DO j =1,nsl
845 ns = lrbe2(iad+j)
846 ms(m) = ms(m)+ms(ns)
847 stifn(m)= stifn(m)+stifn(ns)
848 ENDDO
849 END IF !(NS10E>0) THEN
850 ENDIF
851 icr=(ic-512*(ict))/64
852 IF (iroddl==0) icr =0
853 IF (icr>0.OR.irad==0) THEN
854 IF (icr>0) THEN
855 DO j =1,nsl
856 ns = lrbe2(iad+j)
857 in(m) = in(m)+in(ns)
858 stifr(m)= stifr(m)+stifr(ns)
859 ENDDO
860 END IF
861 IF (ict>0) THEN
862 IF (ns10e>0) THEN
863 DO j =1,nsl
864 ns = lrbe2(iad+j)
865 IF (itagnd(ns)/=0) cycle
866 xx=(x(1,ns)-x(1,m))*(x(1,ns)-x(1,m))
867 yy=(x(2,ns)-x(2,m))*(x(2,ns)-x(2,m))
868 zz=(x(3,ns)-x(3,m))*(x(3,ns)-x(3,m))
869 ixx=yy+zz
870 iyy=zz+xx
871 izz=xx+yy
872 ins = (ixx+iyy+izz)*ms(ns)
873 in(m) = in(m)+ ins
874 IF (ict==7) inrb = inrb+ins
875 dd = xx+yy+zz
876 stifr(m)= stifr(m)+dd*stifn(ns)
877 ENDDO
878 ELSE
879 DO j =1,nsl
880 ns = lrbe2(iad+j)
881 xx=(x(1,ns)-x(1,m))*(x(1,ns)-x(1,m))
882 yy=(x(2,ns)-x(2,m))*(x(2,ns)-x(2,m))
883 zz=(x(3,ns)-x(3,m))*(x(3,ns)-x(3,m))
884 ixx=yy+zz
885 iyy=zz+xx
886 izz=xx+yy
887 ins = (ixx+iyy+izz)*ms(ns)
888 in(m) = in(m)+ ins
889 IF (ict==7) inrb = inrb+ins
890 dd = xx+yy+zz
891 stifr(m)= stifr(m)+dd*stifn(ns)
892 ENDDO
893 END IF !(NS10E>0) THEN
894 ENDIF
895 ENDIF
896 ENDDO
897C-----Correction -only for the case 111---
898 masrb=zero
899 DO i=1,nrbe2
900 iad = irbe2(1,i)
901 nsl = irbe2(5,i)
902 ic=irbe2(4,i)
903 ict=ic/512
904 IF (ict==7) THEN
905 DO j =1,nsl
906 ns = lrbe2(iad+j)
907 stifn(ns)= em20
908 masrb = masrb+ms(ns)
909 xx=(x(1,ns))*(x(1,ns))
910 xy=(x(1,ns))*(x(2,ns))
911 xz=(x(1,ns))*(x(3,ns))
912 yy=(x(2,ns))*(x(2,ns))
913 yz=(x(2,ns))*(x(3,ns))
914 zz=(x(3,ns))*(x(3,ns))
915 b1 = b1 -(yy+zz)*ms(ns)
916 b2 = b2 + xy*ms(ns)
917 b3 = b3 + xz*ms(ns)
918 b5 = b5 -(zz+xx)*ms(ns)
919 b6 = b6 + yz*ms(ns)
920 b9 = b9 - (xx+yy)*ms(ns)
921 xgt = xgt - ms(ns)*x(1,ns)
922 ygt = ygt - ms(ns)*x(2,ns)
923 zgt = zgt - ms(ns)*x(3,ns)
924 ENDDO
925 ENDIF
926 icr=(ic-512*(ict))/64
927 IF (icr==7.AND.iroddl>0) THEN
928 DO j =1,nsl
929 ns = lrbe2(iad+j)
930 stifr(ns)= em20
931 inrb=inrb+in(ns)
932 b1 = b1 -in(ns)
933 b5 = b5 -in(ns)
934 b9 = b9 -in(ns)
935 ENDDO
936 ENDIF
937 ENDDO
938 totmas = totmas - masrb
939C------INRB will not be taken into account due to solide elements as dependent nodes but defined as 111 111
940C
941 DO i=1,nrbe2
942 id=nom_opt(1,i)
943 CALL fretitl2(titr,
944 . nom_opt(lnopt1-ltitr+1,i),ltitr)
945
946 m = irbe2(3,i)
947 IF(ms(m)<=1.0e-25) THEN
948 CALL ancmsg(msgid=804,
949 . msgtype=msgerror,
950 . anmode=aninfo_blind_1,
951 . i1=id,
952 . c1=titr)
953 RETURN
954 ENDIF
955 IF (ipri>=3) THEN
956 WRITE(iout,1300)
957 IF (iroddl==0) THEN
958 WRITE(iout,1600) irbe2(2,i),itab(irbe2(3,i)),ms(m)
959 ELSE
960 WRITE(iout,1400) irbe2(2,i),itab(irbe2(3,i)),ms(m),in(m)
961 END IF
962 ENDIF
963 ENDDO
964C
965 RETURN
966 1000 FORMAT(//
967 .' RIGID ELEMENT(RBE2) WITH HIERARCHY LEVEL AFTER REORDERING:'/
968 . ' --------------------------------------------------------- ')
969 1100 FORMAT(/10x,'NUMBER . . . . . . . . . . .',i10,/,
970 . /10x,'HIERARCHY LEVEL. . . . . . ',i10,
971 . /10x,'INDEPENDENT NODE NUMBER. . .',i10,
972 . /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . . . ',3i1,2x,3i1
973 . /10x,'SKEW NUMBER (LOCAL) . . . . .',i10,
974 . /10x,'NUMBER OF DEPENDENT NODES . .',i10,//)
975 1200 FORMAT(/10x,'RBE2 HIERARCHY LEVEL . . . . =',i5,2x,//)
976 1300 FORMAT(//
977 .' RIGID ELEMENT(RBE2) INDEPENDENT NODE MASSES AND INERTIA (NEW):'/
978 . ' --------------------------------------------------------- ')
979 1400 FORMAT(/10x,'NUMBER . . . . . . . . . . .',i10,/,
980 . /10x,'INDEPENDENT NODE NUMBER. . .',i10,
981 . /10x,'NEW MASS. . . . . . . . . . .',1pg20.13,
982 . /10x,'NEW SPHERIC INERTIA. . . . . ',1pg20.13,//)
983 1600 FORMAT(/10x,'NUMBER . . . . . . . . . . .',i10,/,
984 . /10x,'INDEPENDENT NODE NUMBER. . .',i10,
985 . /10x,'NEW MASS. . . . . . . . . . .',1pg20.13,//)
986 END SUBROUTINE inirbe2
987!||====================================================================
988!|| contrbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
989!||--- called by ------------------------------------------------------
990!|| contrl ../starter/source/starter/contrl.F
991!||--- calls -----------------------------------------------------
992!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
993!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
994!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
995!||--- uses -----------------------------------------------------
996!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
997!|| submodel_mod ../starter/share/modules1/submodel_mod.F
998!||====================================================================
999 SUBROUTINE contrbe2(ICR,LSUBMODEL)
1000C-----------------------------------------------
1001C M o d u l e s
1002C-----------------------------------------------
1003 USE hm_option_read_mod
1004 USE submodel_mod
1005 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
1006C-----------------------------------------------
1007C I m p l i c i t T y p e s
1008C-----------------------------------------------
1009#include "implicit_f.inc"
1010C-----------------------------------------------
1011C C o m m o n B l o c k s
1012C-----------------------------------------------
1013#include "com04_c.inc"
1014C-----------------------------------------------
1015C D u m m y A r g u m e n t s
1016C-----------------------------------------------
1017 INTEGER ICR
1018 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
1019C-----------------------------------------------
1020C L o c a l V a r i a b l e s
1021C-----------------------------------------------
1022 INTEGER I, NUSER, NM,
1023 . isk, ingu, j6(6),irad
1024 CHARACTER(LEN=NCHARTITLE) :: TITR
1025 LOGICAL IS_AVAILABLE
1026C-----------------------------------------------
1027C E x t e r n a l F u n c t i o n s
1028C-----------------------------------------------
1029C
1030C=====================================================================|
1031C
1032C-----initialise NHRBE2--au cas no rbe2---add new option-----------
1033 nhrbe2 = 0
1034 icr =0
1035 CALL hm_option_start('/RBE2')
1036 DO i=1,nrbe2
1037 CALL hm_option_read_key(lsubmodel,
1038 . option_id = nuser,
1039 . option_titr = titr)
1040C
1041 CALL hm_get_intv('independentnode',nm,is_available,lsubmodel)
1042 CALL hm_get_intv('VX',j6(1),is_available,lsubmodel)
1043 CALL hm_get_intv('VY',j6(2),is_available,lsubmodel)
1044 CALL hm_get_intv('VZ',j6(3),is_available,lsubmodel)
1045 CALL hm_get_intv('WX',j6(4),is_available,lsubmodel)
1046 CALL hm_get_intv('WY',j6(5),is_available,lsubmodel)
1047 CALL hm_get_intv('WZ',j6(6),is_available,lsubmodel)
1048 CALL hm_get_intv('SKEW_CSID',isk,is_available,lsubmodel)
1049 CALL hm_get_intv('dependentnodeset',ingu,is_available,lsubmodel)
1050 CALL hm_get_intv('Iflag',irad,is_available,lsubmodel)
1051C
1052 IF ((j6(1)+j6(2)+j6(3)+j6(4)+j6(5)+j6(6))==0) THEN
1053 j6(4)=1
1054 j6(5)=1
1055 j6(6)=1
1056 ENDIF
1057 icr = j6(4) + j6(5) + j6(6)
1058 IF (irad == 0) icr = 1
1059 IF (icr >0) RETURN
1060 ENDDO
1061C
1062 RETURN
1063C
1064 END SUBROUTINE contrbe2
1065!||====================================================================
1066!|| seteloff2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1067!||--- called by ------------------------------------------------------
1068!|| lectur ../starter/source/starter/lectur.F
1069!||--- uses -----------------------------------------------------
1070!||====================================================================
1071 SUBROUTINE seteloff2(IXS ,IXC ,IXT ,IXP ,IXR ,
1072 2 IXTG ,IPARG ,ISOLOFF,ISHEOFF,
1073 3 ITRUOFF,IPOUOFF,IRESOFF,ITRIOFF,IGRNRB2,
1074 4 IGRNOD ,IRBE2 )
1075C-----------------------------------------------
1076C M o d u l e s
1077C-----------------------------------------------
1078 USE groupdef_mod
1079 use element_mod , only : nixs,nixc,nixtg,nixt,nixp,nixr
1080C-------------------------------------
1081C PRE-READ RIGID STRUCTURE FOR OPTIMIZATION
1082C-----------------------------------------------
1083C I m p l i c i t T y p e s
1084C-----------------------------------------------
1085#include "implicit_f.inc"
1086C-----------------------------------------------
1087C C o m m o n B l o c k s
1088C-----------------------------------------------
1089#include "com04_c.inc"
1090#include "units_c.inc"
1091#include "scr03_c.inc"
1092#include "param_c.inc"
1093C-----------------------------------------------
1094C D u m m y A r g u m e n t s
1095C-----------------------------------------------
1096 INTEGER ISOLOFF(*), ISHEOFF(*), ITRIOFF(*),ITRUOFF(*),
1097 . IPOUOFF(*), IRESOFF(*),
1098 . IXS(NIXS,*), IXC(NIXC,*), IXTG(NIXTG,*), IXT(NIXT,*),
1099 . IXP(NIXP,*), IXR(NIXR,*),
1100 . IPARG(NPARG,*),IGRNRB2(*),
1101 . IRBE2(NRBE2L,*)
1102C-----------------------------------------------
1103 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
1104C-----------------------------------------------
1105C L o c a l V a r i a b l e s
1106C-----------------------------------------------
1107 INTEGER I, II, NR, IG,
1108 . NSN, NALL, IRBYON,M,IC,IC0,
1109 . ITAG(NUMNOD)
1110C-----------------------
1111C MISE DE OFF A -OFF
1112C======================================================================|
1113 IF (nrbe2==0) RETURN
1114 IF(ipri>=5) THEN
1115 WRITE(iout,*)' '
1116
1117 WRITE(iout,*)' LIST OF DEACTIVATED ELEMENTS FROM RBE2'
1118 WRITE(iout,*)' ----------------------------------------------'
1119 END IF
1120C
1121 irbyon = 20
1122 ic0 = 7*512+7*64
1123C
1124 DO nr = 1, nrbe2
1125 ig = igrnrb2(nr)
1126 m = irbe2(3,nr)
1127 ic = irbe2(4,nr)
1128 IF(ig>0.AND.ic==ic0)THEN
1129 nsn = igrnod(ig)%NENTITY
1130 DO i=1,numnod
1131 itag(i)=0
1132 ENDDO
1133 itag(m)=1
1134 DO i=1,nsn
1135 itag(igrnod(ig)%ENTITY(i))=1
1136 END DO
1137C
1138 DO ii = 1, numelt
1139 nall = itag(ixt(2,ii)) * itag(ixt(3,ii))
1140 IF(nall/=0)THEN
1141 itruoff(ii) = irbyon
1142 END IF
1143 END DO
1144C
1145 DO ii = 1, numelp
1146 nall = itag(ixp(2,ii)) * itag(ixp(3,ii))
1147 IF(nall/=0)THEN
1148 ipouoff(ii) = irbyon
1149 END IF
1150 END DO
1151C
1152 DO ii = 1, numelr
1153 nall = itag(ixr(2,ii)) * itag(ixr(3,ii))
1154 IF(nall/=0)THEN
1155 iresoff(ii) = irbyon
1156 END IF
1157 END DO
1158 END IF
1159C
1160 END DO
1161C -----DEACTIVATED ELEMENTS will done in SETELOFF------
1162 RETURN
1163 END SUBROUTINE seteloff2
1164!||====================================================================
1165!|| setrb2on ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1166!||--- called by ------------------------------------------------------
1167!|| lectur ../starter/source/starter/lectur.F
1168!||--- calls -----------------------------------------------------
1169!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
1170!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
1171!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
1172!|| ngr2usrn ../starter/source/system/nintrr.F
1173!|| usr2sys ../starter/source/system/sysfus.F
1174!||--- uses -----------------------------------------------------
1175!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
1176!|| submodel_mod ../starter/share/modules1/submodel_mod.F
1177!||====================================================================
1178 SUBROUTINE setrb2on(IXS ,IXC ,IXTG ,IGRNOD ,
1179 2 IGRNRB2,ISOLOFF,ISHEOFF,ITRIOFF,ITABM1,
1180 3 LSUBMODEL)
1181C-----------------------------------------------
1182C M o d u l e s
1183C-----------------------------------------------
1184 USE groupdef_mod
1185 USE hm_option_read_mod
1186 USE submodel_mod
1187 USE names_and_titles_mod , ONLY : nchartitle
1188 use element_mod , only : nixs,nixc,nixtg
1189C-------------------------------------
1190C PRE-READ RIGID STRUCTURE FOR OPTIMIZATION
1191C-----------------------------------------------
1192C I m p l i c i t T y p e s
1193C-----------------------------------------------
1194#include "implicit_f.inc"
1195C-----------------------------------------------
1196C C o m m o n B l o c k s
1197C-----------------------------------------------
1198#include "com04_c.inc"
1199C-----------------------------------------------
1200C D u m m y A r g u m e n t s
1201C-----------------------------------------------
1202 INTEGER IGRNRB2(*),ISOLOFF(*),ISHEOFF(*),ITRIOFF(*),
1203 . IXS(NIXS,*), IXC(NIXC,*), IXTG(NIXTG,*),ITABM1(*)
1204C-----------------------------------------------
1205 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
1206 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
1207C-----------------------------------------------
1208C L o c a l V a r i a b l e s
1209C-----------------------------------------------
1210 INTEGER NR, I, IGS,NSN,II,NALL,
1211 . IGU,IRBYON,
1212 . itag(numnod),nn,nm, nuser, m,j6(6),ic
1213 CHARACTER(LEN=NCHARTITLE) :: TITR
1214 CHARACTER :: MESS*40
1215 INTEGER NGR2USRN
1216 LOGICAL IS_AVAILABLE
1217C-----------------------------------------------
1218C E x t e r n a l F u n c t i o n s
1219C-----------------------------------------------
1220 INTEGER USR2SYS
1221C-----------------------------------
1222 IF (NRBE2==0) return
1223C
1224 CALL hm_option_start('/RBE2')
1225 irbyon = 20
1226 DO nr=1,nrbe2
1227 igrnrb2(nr)=0
1228 CALL hm_option_read_key(lsubmodel,
1229 . option_id = nuser,
1230 . option_titr = titr)
1231C
1232 CALL hm_get_intv('independentnode',nm,is_available,lsubmodel)
1233 CALL hm_get_intv('VX',j6(1),is_available,lsubmodel)
1234 CALL hm_get_intv('VY',j6(2),is_available,lsubmodel)
1235 CALL hm_get_intv('VZ',j6(3),is_available,lsubmodel)
1236 CALL hm_get_intv('WX',j6(4),is_available,lsubmodel)
1237 CALL hm_get_intv('WY',j6(5),is_available,lsubmodel)
1238 CALL hm_get_intv('WZ',j6(6),is_available,lsubmodel)
1239 CALL hm_get_intv('dependentnodeset',igu,is_available,lsubmodel)
1240C
1241 m = usr2sys(nm,itabm1,mess,nuser)
1242 igs = ngr2usrn(igu,igrnod,ngrnod,nn)
1243 ic= j6(1)+j6(2)+j6(3)+j6(4)+j6(5)+j6(6)
1244C
1245 IF(igs/=0.AND.(ic==0.OR.ic==6)) THEN
1246C
1247 DO i=1,numnod
1248 itag(i)=0
1249 ENDDO
1250 igrnrb2(nr)=igs
1251 nsn = igrnod(igs)%NENTITY
1252 itag(m)=1
1253 DO i=1,nsn
1254 itag(igrnod(igs)%ENTITY(i))=1
1255 END DO
1256C
1257 DO ii = 1, numelc
1258 nall = itag(ixc(2,ii)) * itag(ixc(3,ii)) *
1259 + itag(ixc(4,ii)) * itag(ixc(5,ii))
1260 IF(nall/=0)THEN
1261 isheoff(ii) = irbyon
1262 END IF
1263 END DO
1264C
1265 DO ii = 1, numeltg
1266 nall = itag(ixtg(2,ii)) * itag(ixtg(3,ii)) *
1267 + itag(ixtg(4,ii))
1268 IF(nall/=0)THEN
1269 itrioff(ii) = irbyon
1270 END IF
1271 END DO
1272 END IF
1273C
1274 END DO
1275C------------solid elements
1276C
1277 CALL hm_option_start('/RBE2')
1278 DO nr=1,nrbe2
1279 igrnrb2(nr)=0
1280 CALL hm_option_read_key(lsubmodel,
1281 . option_id = nuser,
1282 . option_titr = titr)
1283C
1284 CALL hm_get_intv('independentnode',nm,is_available,lsubmodel)
1285 CALL hm_get_intv('VX',j6(1),is_available,lsubmodel)
1286 CALL hm_get_intv('VY',j6(2),is_available,lsubmodel)
1287 CALL hm_get_intv('VZ',j6(3),is_available,lsubmodel)
1288 CALL hm_get_intv('WX',j6(4),is_available,lsubmodel)
1289 CALL hm_get_intv('WY',j6(5),is_available,lsubmodel)
1290 CALL hm_get_intv('WZ',j6(6),is_available,lsubmodel)
1291 CALL hm_get_intv('dependentnodeset',igu,is_available,lsubmodel)
1292C
1293 m = usr2sys(nm,itabm1,mess,nuser)
1294 igs = ngr2usrn(igu,igrnod,ngrnod,nn)
1295 ic= j6(1)+j6(2)+j6(3)
1296C
1297 IF(igs/=0.AND.(ic==0.OR.ic==3)) THEN
1298C
1299 DO i=1,numnod
1300 itag(i)=0
1301 ENDDO
1302 igrnrb2(nr)=igs
1303 nsn = igrnod(igs)%NENTITY
1304 itag(m)=1
1305 DO i=1,nsn
1306 itag(igrnod(igs)%ENTITY(i))=1
1307 END DO
1308C
1309 DO ii = 1, numels
1310 nall = itag(ixs(2,ii)) * itag(ixs(3,ii)) *
1311 + itag(ixs(4,ii)) * itag(ixs(5,ii)) *
1312 + itag(ixs(6,ii)) * itag(ixs(7,ii)) *
1313 + itag(ixs(8,ii)) * itag(ixs(9,ii))
1314 IF(nall/=0)THEN
1315 isoloff(ii) = irbyon
1316 END IF
1317 END DO
1318 END IF
1319C
1320 END DO
1321C
1322 RETURN
1323 END
1324C
1325!||====================================================================
1326!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1327!||--- called by ------------------------------------------------------
1328!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1329!||--- calls -----------------------------------------------------
1330!|| ic_mrg ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1331!|| same_nsn ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1332!||====================================================================
1333 SUBROUTINE rbe2_merge(IRBE2 ,LRBE2 )
1334C-----------------------------------------------
1335C I m p l i c i t T y p e s
1336C-----------------------------------------------
1337#include "implicit_f.inc"
1338C-----------------------------------------------
1339C C o m m o n B l o c k s
1340C-----------------------------------------------
1341#include "com04_c.inc"
1342#include "param_c.inc"
1343C-----------------------------------------------
1344C D u m m y A r g u m e n t s
1345C-----------------------------------------------
1346 INTEGER IRBE2(NRBE2L,*), LRBE2(*)
1347C-----------------------------------------------
1348C L o c a l V a r i a b l e s
1349C-----------------------------------------------
1350 INTEGER I, NSL,M,NZ,NSLJ,
1351 . J, IAD,NS,II,IC,MJ,IADJ
1352C
1353 INTEGER ISAME
1354 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
1355
1356C========================================================================|
1357C--------merging RBE2 w/ the same NS/M (separated IC)--------------------
1358 ALLOCATE(itag(numnod))
1359 itag(1:numnod)=0
1360C--------if same node as several IND. of /RBE2------------
1361 nz=0
1362 DO i=1,nrbe2
1363 iad = irbe2(1,i)
1364 nsl = irbe2(5,i)
1365 DO j =1,nsl
1366 ns = lrbe2(iad+j)
1367 IF (itag(ns)>0) nz = nz + 1
1368 itag(ns)=itag(ns)+1
1369 ENDDO
1370 ENDDO
1371 IF (nz==0) THEN
1372 DEALLOCATE(itag)
1373 RETURN
1374 ENDIF
1375C --------merge if same all excepting IC
1376 DO i=1,nrbe2
1377 iad = irbe2(1,i)
1378 nsl = irbe2(5,i)
1379 m = irbe2(3,i)
1380 IF (nsl==0) cycle
1381 DO ii=i+1,nrbe2
1382 iadj = irbe2(1,ii)
1383 nslj = irbe2(5,ii)
1384 mj = irbe2(3,ii)
1385 IF (mj/=m.OR.nslj/=nsl) cycle
1386 CALL same_nsn(nsl,lrbe2(iad+1),lrbe2(iadj+1),itag,isame)
1387 IF (isame==1) THEN
1388 CALL ic_mrg(ic,irbe2(4,i),irbe2(4,ii))
1389 irbe2(4,i) = ic
1390 irbe2(5,ii) = 0
1391 END IF
1392 ENDDO
1393 ENDDO
1394C
1395 DEALLOCATE(itag)
1396 RETURN
1397 END SUBROUTINE rbe2_merge
1398!||====================================================================
1399!|| same_nsn ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1400!||--- called by ------------------------------------------------------
1401!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1402!||====================================================================
1403 SUBROUTINE same_nsn(NSL,LRBE2_1 ,LRBE2_2,ITAG,ISAME)
1404C-----------------------------------------------
1405C I m p l i c i t T y p e s
1406C-----------------------------------------------
1407#include "implicit_f.inc"
1408C-----------------------------------------------
1409C D u m m y A r g u m e n t s
1410C-----------------------------------------------
1411 INTEGER NSL,LRBE2_1(*) ,LRBE2_2(*),ITAG(*),ISAME
1412C-----------------------------------------------
1413C L o c a l V a r i a b l e s
1414C-----------------------------------------------
1415 INTEGER I,NS1,NS2
1416C========================================================================|
1417 ISAME=1
1418 do i=1,nsl
1419 ns1=lrbe2_1(i)
1420 ns2=lrbe2_2(i)
1421 IF (ns1/=ns2.OR.itag(ns1)/=itag(ns2).OR.itag(ns1)<=1) THEN
1422 isame=0
1423 cycle
1424 END IF
1425 ENDDO
1426C
1427 RETURN
1428 END SUBROUTINE same_nsn
1429!||====================================================================
1430!|| ic_mrg ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1431!||--- called by ------------------------------------------------------
1432!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1433!||--- calls -----------------------------------------------------
1434!|| ict2jt ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1435!||====================================================================
1436 SUBROUTINE ic_mrg(IC_N,IC1 ,IC2)
1437C-----------------------------------------------
1438C I m p l i c i t T y p e s
1439C-----------------------------------------------
1440#include "implicit_f.inc"
1441C-----------------------------------------------
1442C D u m m y A r g u m e n t s
1443C-----------------------------------------------
1444 INTEGER IC_N,IC1 ,IC2
1445C-----------------------------------------------
1446C L o c a l V a r i a b l e s
1447C-----------------------------------------------
1448 INTEGER I,ICT,ICR,JT1(3),JR1(3),JT2(3),JR2(3),IUN
1449C========================================================================|
1450 ICT=ic1/512
1451 icr=(ic1-512*(ict))/64
1452 CALL ict2jt(ict,jt1)
1453 CALL ict2jt(icr,jr1)
1454 ict=ic2/512
1455 icr=(ic2-512*(ict))/64
1456 CALL ict2jt(ict,jt2)
1457 CALL ict2jt(icr,jr2)
1458 iun=1
1459 DO i =1,3
1460 jt1(i) = jt1(i)+jt2(i)
1461 jr1(i) = jr1(i)+jr2(i)
1462 jt1(i) = min(iun,jt1(i))
1463 jr1(i) = min(iun,jr1(i))
1464 END DO
1465 ict=jt1(1)*4 +jt1(2)*2 +jt1(3)
1466 icr=jr1(1)*4 +jr1(2)*2 +jr1(3)
1467 ic_n =ict*512+icr*64
1468C
1469 RETURN
1470 END SUBROUTINE ic_mrg
1471!||====================================================================
1472!|| ict2jt ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1473!||--- called by ------------------------------------------------------
1474!|| ic_mrg ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1475!||====================================================================
1476 SUBROUTINE ict2jt(ICT,JT)
1477C-----------------------------------------------
1478C I m p l i c i t T y p e s
1479C-----------------------------------------------
1480#include "implicit_f.inc"
1481C-----------------------------------------------
1482C D u m m y A r g u m e n t s
1483C-----------------------------------------------
1484 INTEGER ICT,JT(3)
1485C REAL
1486C-----------------------------------------------
1487C L o c a l V a r i a b l e s
1488C-----------------------------------------------
1489C======================================================================|
1490C ICT=IC/512
1491C ICR=(IC-512*(ICT))/64
1492 jt(1:3)= 0
1493 SELECT CASE (ict)
1494 CASE(1)
1495 jt(3)=1
1496 CASE(2)
1497 jt(2)=1
1498 CASE(3)
1499 jt(2)=1
1500 jt(3)=1
1501 CASE(4)
1502 jt(1)=1
1503 CASE(5)
1504 jt(1)=1
1505 jt(3)=1
1506 CASE(6)
1507 jt(1)=1
1508 jt(2)=1
1509 CASE(7)
1510 jt(1)=1
1511 jt(2)=1
1512 jt(3)=1
1513 END SELECT
1514C---
1515 RETURN
1516 END SUBROUTINE ict2jt
1517
rbe2modif_nd
subroutine rbe2modif_nd(nn, inn, itagnd, icnds10, iu, itab, itagm, m, itagic)
Definition dim_s10edg.F:458
ifrontplus
subroutine ifrontplus(n, p)
Definition frontplus.F:101
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
setiadm
subroutine setiadm(iadm, nz, iad_n, irbe2)
Definition hm_read_rbe2.F:546
setrb2on
subroutine setrb2on(ixs, ixc, ixtg, igrnod, igrnrb2, isoloff, isheoff, itrioff, itabm1, lsubmodel)
Definition hm_read_rbe2.F:1181
seteloff2
subroutine seteloff2(ixs, ixc, ixt, ixp, ixr, ixtg, iparg, isoloff, isheoff, itruoff, ipouoff, iresoff, itrioff, igrnrb2, igrnod, irbe2)
Definition hm_read_rbe2.F:1075
ic_mrg
subroutine ic_mrg(ic_n, ic1, ic2)
Definition hm_read_rbe2.F:1437
rbe2_merge
subroutine rbe2_merge(irbe2, lrbe2)
Definition hm_read_rbe2.F:1334
contrbe2
subroutine contrbe2(icr, lsubmodel)
Definition hm_read_rbe2.F:1000
ict2jt
subroutine ict2jt(ict, jt)
Definition hm_read_rbe2.F:1477
hierarbe2
subroutine hierarbe2(irbe2, lrbe2)
Definition hm_read_rbe2.F:607
hm_read_rbe2
subroutine hm_read_rbe2(irbe2, lrbe2, itab, itabm1, igrnod, iskn, ikine, iddlevel, nom_opt, itagnd, icdns10, lsubmodel)
Definition hm_read_rbe2.F:49
hm_preread_rbe2
subroutine hm_preread_rbe2(lnum, lreal, igrnod, lsubmodel)
Definition hm_read_rbe2.F:328
reorbe2
subroutine reorbe2(irbe2, lrbe2, nc)
Definition hm_read_rbe2.F:396
inirbe2
subroutine inirbe2(irbe2, lrbe2, itab, x, ms, in, stifn, stifr, totmas, xgt, ygt, zgt, b1, b2, b3, b5, b6, b9, nom_opt, itagnd)
Definition hm_read_rbe2.F:726
same_nsn
subroutine same_nsn(nsl, lrbe2_1, lrbe2_2, itag, isame)
Definition hm_read_rbe2.F:1404
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
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
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tagrb2
integer, dimension(:), allocatable tagrb2
Definition r2r_mod.F:138
submodel_mod
Definition submodel_mod.F:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:299
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:799
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:146
starter
program starter
Definition starter.F:39