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, N, K, NSL, NSLT, ITYP, NUSER, NM,M, NI,
91 . ISK, ISENS, INGU, IGM, J, P,IAD,NS,NN,J6(6),JJ,II,
92 . ic,ic1,ic2,irot,isks,iads,ierr1,nc,id,idir,
93 . ikine1(3*numnod),irad,nrb,icp,ier,nmove,sub_index
94 INTEGER, DIMENSION(NUMNOD) :: ITAGM,ITAGIC
95 CHARACTER(LEN=NCHARTITLE) :: TITR
96 CHARACTER(LEN=NCHARKEY) :: KEY
97 CHARACTER :: MESS*40
98 LOGICAL IS_AVAILABLE
99C-----------------------------------------------
100C E x t e r n a l F u n c t i o n s
101C-----------------------------------------------
102 INTEGER USR2SYS,NODGRNR6
103 INTEGER FMAIN(PARASIZ)
104 INTEGER NLOCAL
105 EXTERNAL nlocal
106C
107 DATA mess/'RBE2 RIGID BODY '/
108C-----------------------------------------------
109C IRBE2(1,I) : IAD0 for LRBE2
110C IRBE2(2,I) : TYPE usr' id temporaire (print)
111C IRBE2(3,I) : INDEPENDENT NODE
112C IRBE2(4,I) : REF_DOF
113C IRBE2(5,I) : NUMBER OF DEPENDENT NODES
114C IRBE2(6,I) : m_iad if same node as several Rbe2 main (init.in engine)
115C IRBE2(7,I) : iskew
116C IRBE2(8,I) : SBE2
117C IRBE2(9,I) : hierarchy level 0-NHRBE2
118C IRBE2(10,I) : id for modif/spmd
119C IRBE2(11,I) : flag to associate REF_DOF to main node
120C========================================================================|
121 WRITE(iout,1000)
122 IF (ipri<5) WRITE(iout,1201)
123C
124 nrb = 0
125C
126 DO i=1,3*numnod
127 ikine1(i) = 0
128 ENDDO
129 k = 0
130C
131 CALL hm_option_start('/RBE2')
132 iad = 0
133 DO i=1,nrbe2
134 nrb=nrb+1
135C----------Multidomaines --> on ignore les rbe3 non tages---------
136 IF(nsubdom>0)THEN
137 IF(tagrb2(nrb)==0)CALL hm_sz_r2r(tagrb2,nrb,lsubmodel)
138 END IF
139C-----------------------------------------------------------------
140 CALL hm_option_read_key(lsubmodel,
141 . option_id = nuser,
142 . submodel_index = sub_index,
143 . option_titr = titr)
144
145 nom_opt(1,i)=nuser
146 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
147 irbe2(2,i) = nuser
148 irbe2(10,i) = i
149 CALL hm_get_intv('independentnode',nm,is_available,lsubmodel)
150 CALL hm_get_intv('VX',j6(1),is_available,lsubmodel)
151 CALL hm_get_intv('VY',j6(2),is_available,lsubmodel)
152 CALL hm_get_intv('vz',J6(3),IS_AVAILABLE,LSUBMODEL)
153 CALL HM_GET_INTV('wx',J6(4),IS_AVAILABLE,LSUBMODEL)
154 CALL HM_GET_INTV('wy',J6(5),IS_AVAILABLE,LSUBMODEL)
155 CALL HM_GET_INTV('wz',J6(6),IS_AVAILABLE,LSUBMODEL)
156 CALL HM_GET_INTV('skew_csid',ISK,IS_AVAILABLE,LSUBMODEL)
157 CALL HM_GET_INTV('dependentnodeset',INGU,IS_AVAILABLE,LSUBMODEL)
158 CALL HM_GET_INTV('iflag',IRAD,IS_AVAILABLE,LSUBMODEL)
159C
160.and. IF (ISK == 0 SUB_INDEX > 0) ISK = LSUBMODEL(SUB_INDEX)%SKEW
161C
162 M = USR2SYS(NM,ITABM1,MESS,NUSER)
163 IC1=J6(1)*4 +J6(2)*2 +J6(3)
164 IC2=J6(4)*4 +J6(5)*2 +J6(6)
165 IC =IC1*512+IC2*64
166 IF (IC==0) IC =7*512+7*64
167 IRBE2(3,I) = M
168 IRBE2(4,I) = IC
169 IRBE2(1,I) = IAD
170 IRBE2(11,I) = IRAD
171 NS = NODGRNR6(M ,INGU ,IGM ,LRBE2(IAD+1),IGRNOD,
172 . ITABM1,MESS,NUSER)
173 IF (NS10E > 0) THEN
174C----partial dof of RBE2 will be treated correctly
175C
176 IF (ITAGND(M)/=0) THEN
177 CALL ANCMSG(MSGID=1211,
178 . MSGTYPE=MSGERROR,
179 . ANMODE=ANINFO,
180 . I1=ITAB(M),
181 . C1='rbe2',
182 . I2=NUSER,
183 . C2='rbe2')
184 END IF
185 END IF
186 ISKS = 0
187 IF ((J6(1)+J6(2)+J6(3)+J6(4)+J6(5)+J6(6))==0) THEN
188 J6(1)=1
189 J6(2)=1
190 J6(3)=1
191 J6(4)=1
192 J6(5)=1
193 J6(6)=1
194 ENDIF
195 IF (ISK/=0) THEN
196 DO JJ=0,NUMSKW+MIN(1,NSPCOND)*NUMSPH+NSUBMOD
197 IF(ISK==ISKN(4,JJ+1)) THEN
198 ISKS=JJ+1
199 GO TO 10
200 ENDIF
201 ENDDO
202 CALL ANCMSG(MSGID=184,
203 . MSGTYPE=MSGERROR,
204 . ANMODE=ANINFO,
205 . C1='rbe2',
206 . I1=NUSER,
207 . C2='rbe2',
208 . C3=TITR,
209 . I2=ISK)
210 10 CONTINUE
211 ENDIF
212 IRBE2(7,I) = ISKS
213C
214 IF (IDDLEVEL == 0) THEN
215 DO J=1,NS
216 DO IDIR=1,6
217 IF ( J6(IDIR) == 1)
218 . CALL KINSET(2048,ITAB(LRBE2(J+K)),IKINE(LRBE2(J+K)),IDIR,ISK,
219 . IKINE1(LRBE2(J+K)))
220 ENDDO
221 ENDDO
222 ENDIF
223 IAD = IAD+NS
224 IRBE2(5,I) = NS
225 IF (IPRI>=5) THEN
226 WRITE(IOUT,1100) NUSER,NM,J6,ISK,NS,IRAD
227 ELSE
228 WRITE(IOUT,1200) NUSER,NM,J6,ISK,NS,IRAD
229 END IF
230 K = K + NS
231 END DO
232C------treatment compatibility w/ Itetra10=2
233 IF (NS10E > 0) THEN
234C------can have the same MAIN node in several RBE2
235 ITAGM(1:NUMNOD)=0
236 ITAGIC(1:NUMNOD)=0
237 DO I=1,NRBE2
238 IAD = IRBE2(1,I)
239 M = IRBE2(3,I)
240 NSL = IRBE2(5,I)
241 IC = IRBE2(4,I)
242 DO J=1,NSL
243 NS =LRBE2(IAD+J)
244 IF (ITAGM(NS)==0) THEN
245 ITAGM(NS) = M
246 ELSEIF (ITAGM(NS)/=M) THEN
247C------- error-out
248 END IF
249 ITAGIC(NS) = ITAGIC(NS) + IC
250 END DO
251 END DO
252 NMOVE = 0
253 DO I=1,NRBE2
254 IAD = IRBE2(1,I)
255 M = IRBE2(3,I)
256 NSL = IRBE2(5,I)
257 NUSER = IRBE2(2,I)
258 CALL RBE2MODIF_ND(NSL,LRBE2(IAD+1),ITAGND,ICDNS10,NUSER,ITAB,
259 . ITAGM,M,ITAGIC)
260 IF (IRBE2(5,I)>NSL) THEN
261 NMOVE = NMOVE+IRBE2(5,I)-NSL
262 IRBE2(5,I) = NSL
263 END IF
264 END DO
265 IF (NMOVE>0) THEN
266 CALL ANCMSG(MSGID=1729,
267 . MSGTYPE=MSGINFO,
268 . ANMODE=ANINFO_BLIND_1,
269 . I1=NMOVE)
270 END IF
271 END IF
272C--------for decompo
273 IF (IDDLEVEL > 0) THEN
274 DO I=1,NRBE2
275 IAD = IRBE2(1,I)
276 M = IRBE2(3,I)
277 NS = IRBE2(5,I)
278.AND. IF (NSPMD > 1NS>0) THEN
279 FMAIN(1:NSPMD) = 0
280 DO P = 1, NSPMD
281 DO J = 1, NS
282 IF (NLOCAL(LRBE2(IAD+J),P)/=0)THEN
283 FMAIN(P) = 1
284 GO TO 85
285 ENDIF
286 ENDDO
287 85 CONTINUE
288 END DO
289C noeud main sur les procs ayant au moins 1 SECONDARY
290 DO P = 1, NSPMD
291 IF (FMAIN(P)==1) THEN
292 CALL IFRONTPLUS(M,P)
293 ENDIF
294 ENDDO
295 ENDIF
296 END DO
297 END IF !(IDDLEVEL > 0) THEN
298C
299 RETURN
300C
301 1000 FORMAT(//
302 .' rigid element(rbe2) '/
303 . ' ---------------------- ')
304 1100 FORMAT(/10X,'number . . . . . . . . . . .',I10,/,
305 . /10X,'independent node number . . ',I10,
306 . /10X,'dof( x,y,z, xx,yy,zz). . . . ',3I1,2X,3I1
307 . /10X,'skew number . . . . . . . . .',I10,
308 . /10X,'number of dependent nodes. . .',i10,
309 . /10x,'FORMULATION FLAG . . . . . . ',i10,//)
310 1201 FORMAT(' RBE2_ID IND._NODE REF_DOF SKEW_ID #SECONDARY IFLAG'/)
311 1200 FORMAT(3x,2i10,3x,3i1,1x,3i1,3i10)
312 END SUBROUTINE hm_read_rbe2
313!||====================================================================
314!|| hm_preread_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
315!||--- called by ------------------------------------------------------
316!|| lectur ../starter/source/starter/lectur.F
317!||--- calls -----------------------------------------------------
318!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
319!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
320!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
321!|| hm_sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
322!|| ngr2usrn ../starter/source/system/nintrr.F
323!||--- uses -----------------------------------------------------
324!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
325!|| r2r_mod ../starter/share/modules1/r2r_mod.F
326!|| submodel_mod ../starter/share/modules1/submodel_mod.F
327!||====================================================================
328 SUBROUTINE hm_preread_rbe2(LNUM ,LREAL, IGRNOD, LSUBMODEL)
329C-----------------------------------------------
330C M o d u l e s
331C-----------------------------------------------
332 USE r2r_mod
333 USE groupdef_mod
334 USE submodel_mod
335 USE hm_option_read_mod
336 USE names_and_titles_mod , ONLY : nchartitle
337C-----------------------------------------------
338C I m p l i c i t T y p e s
339C-----------------------------------------------
340#include "implicit_f.inc"
341C-----------------------------------------------
342C C o m m o n B l o c k s
343C-----------------------------------------------
344#include "param_c.inc"
345#include "com04_c.inc"
346#include "r2r_c.inc"
347C-----------------------------------------------
348C D u m m y A r g u m e n t s
349C-----------------------------------------------
350 INTEGER LNUM ,LREAL
351C-----------------------------------------------
352 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
353 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
354C-----------------------------------------------
355C L o c a l V a r i a b l e s
356C-----------------------------------------------
357 INTEGER I,J,K,IGU,IGS,NI,NN,NJ,JJ, NUSER, NUM,NRB
358 CHARACTER(LEN=NCHARTITLE) :: TITR
359 INTEGER NGR2USRN,ISK
360 LOGICAL IS_AVAILABLE
361C========================================================================|
362 lnum = 0
363 lreal = 0
364 IF (nrbe2==0) RETURN
365
366 nrb = 0
367
368 CALL hm_option_start('/RBE2')
369 DO i=1,nrbe2
370 nrb=nrb+1
371C----------Multidomaines --> on ignore les rbe2 non tages---------
372 IF(nsubdom>0)THEN
373 IF(tagrb2(nrb)==0)CALL hm_sz_r2r(tagrb2,nrb,lsubmodel)
374 END IF
375C-----------------------------------------------------------------
376 CALL hm_option_read_key(lsubmodel,
377 . option_id = nuser,
378 . option_titr = titr)
379
380 CALL hm_get_intv('dependentnodeset',igu,is_available,lsubmodel)
381 igs = ngr2usrn(igu,igrnod,ngrnod,nn)
382C
383 lreal = lreal + nn
384 lnum = lnum +nrbe2l
385 ENDDO
386C-----------
387 RETURN
388 END SUBROUTINE hm_preread_rbe2
389!||====================================================================
390!|| reorbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
391!||--- called by ------------------------------------------------------
392!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
393!||--- calls -----------------------------------------------------
394!|| setiadm ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
395!||====================================================================
396 SUBROUTINE reorbe2(IRBE2 ,LRBE2 ,NC )
397C-----------------------------------------------
398C I m p l i c i t T y p e s
399C-----------------------------------------------
400#include "implicit_f.inc"
401C-----------------------------------------------
402C C o m m o n B l o c k s
403C-----------------------------------------------
404#include "com04_c.inc"
405#include "param_c.inc"
406#include "tabsiz_c.inc"
407C-----------------------------------------------
408C D u m m y A r g u m e n t s
409C-----------------------------------------------
410 INTEGER IRBE2(NRBE2L,*), LRBE2(*),NC
411C-----------------------------------------------
412C L o c a l V a r i a b l e s
413C-----------------------------------------------
414 INTEGER I, N, K, NSL,NM, NI, NMT,M,IROT,ID,IMO,IC0,NZ,
415 . J, P,IAD,NS,NN,II,IT,IADS,IERR1,IAD1,IC,NIT,I0,I1
416C
417 INTEGER LCOPY(SLRBE2),ICOPY(NRBE2L,NRBE2),
418 . NHIE,IORDER(NRBE2),INDICE(NRBE2),ITAG1(NRBE2)
419 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG,IAD_N
420C========================================================================|
421C--------re-ordering if with hierarchy---------------------------------------
422 ALLOCATE(itag(numnod))
423 ALLOCATE(iad_n(numnod+1))
424 nc=0
425 DO i=1,numnod
426 itag(i)=0
427 ENDDO
428C--------if same node as several IND. of /RBE2---------------------------------------
429 nz=0
430 DO i=1,nrbe2
431 m = irbe2(3,i)
432 IF (itag(m)==0) THEN
433 itag(m)=i
434 ELSE
435 nz=nz+1
436 itag1(nz)=i
437 ENDIF
438 ENDDO
439 CALL setiadm(itag1,nz,iad_n,irbe2)
440C--------- if hierarchy
441 DO i=1,nrbe2
442 iad = irbe2(1,i)
443 m = irbe2(3,i)
444 nsl = irbe2(5,i)
445 DO j =1,nsl
446 ns = lrbe2(iad+j)
447 IF (itag(ns)>i) nc=nc+1
448 DO k=iad_n(ns),iad_n(ns+1)-1
449 IF (itag1(k)>i) nc=nc+1
450 ENDDO
451 ENDDO
452 ENDDO
453 IF (nc==0) RETURN
454C---------
455 DO i=1,nrbe2
456 iorder(i) = i
457 indice(i) = i
458 ENDDO
459 nc = 0
460C--------- ite=
461 ierr1 = 0
462 nit =5
463 DO it=1,nit
464 ii = nc
465 DO i=1,nrbe2
466 iad = irbe2(1,i)
467 m = irbe2(3,i)
468 nsl = irbe2(5,i)
469 DO j =1,nsl
470 ns = lrbe2(iad+j)
471 IF (itag(ns)==0) cycle
472 ic=indice(itag(ns))
473 i1=indice(i)
474C-----
475 IF (ic>i1) THEN
476 nc = nc+1
477C-------exchange IORDER(IC) & IORDER(I) --
478 i0 = iorder(i1)
479 iorder(i1) = iorder(ic)
480 iorder(ic) = i0
481 ic0 = indice(i)
482 indice(i) = ic
483 indice(itag(ns)) = i1
484 IF (it==nit) ierr1 = irbe2(2,i)
485 ENDIF
486 DO k=iad_n(ns),iad_n(ns+1)-1
487 ic=indice(itag1(k))
488 i1=indice(i)
489 IF (ic>i1) THEN
490 nc = nc+1
491C--exchange IORDER(IC) & IORDER(I) --
492 i0 = iorder(i1)
493 iorder(i1) = iorder(ic)
494 iorder(ic) = i0
495 indice(i) = ic
496 indice(itag1(k)) = i1
497 ENDIF
498 ENDDO
499 ENDDO
500 ENDDO
501 ii = nc -ii
502 IF (ii<=0) GOTO 100
503 ENDDO
504 100 CONTINUE
505C
506 IF (ierr1>0) nc=-ierr1
507C----------copy---
508 DO i=1,nrbe2
509 iad = irbe2(1,i)
510 m = irbe2(3,i)
511 nsl = irbe2(5,i)
512 DO j =1,nrbe2l
513 icopy(j,i) = irbe2(j,i)
514 ENDDO
515 DO j =1,nsl
516 lcopy(iad+j) = lrbe2(iad+j)
517 ENDDO
518 ENDDO
519C----------reodering---
520 iad1 = 0
521 DO n=1,nrbe2
522 i = iorder(n)
523 iad = icopy(1,i)
524 m = icopy(3,i)
525 nsl = icopy(5,i)
526 irbe2(1,n) = iad1
527 DO j =2,nrbe2l
528 irbe2(j,n) = icopy(j,i)
529 ENDDO
530 DO j =1,nsl
531 lrbe2(iad1+j)=lcopy(iad+j)
532 ENDDO
533 iad1 =iad1+nsl
534 ENDDO
535 DEALLOCATE(itag,iad_n)
536
537C
538 RETURN
539 END SUBROUTINE reorbe2
540!||====================================================================
541!|| setiadm ../starter/source/constraints/general/rbe2/hm_read_rbe2.f
542!||--- called by ------------------------------------------------------
543!|| hierarbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
544!|| reorbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
545!||====================================================================
546 SUBROUTINE setiadm(IADM,NZ,IAD_N,IRBE2)
547C-----------------------------------------------
548C I m p l i c i t T y p e s
549C-----------------------------------------------
550#include "implicit_f.inc"
551C-----------------------------------------------
552C C o m m o n B l o c k s
553C-----------------------------------------------
554#include "com04_c.inc"
555#include "param_c.inc"
556C-----------------------------------------------
557C D u m m y A r g u m e n t s
558C-----------------------------------------------
559 INTEGER IRBE2(NRBE2L,*), IADM(*),NZ,IAD_N(*)
560C-----------------------------------------------
561C L o c a l V a r i a b l e s
562C-----------------------------------------------
563 INTEGER I, N, NM,NS,J,NSL,IAD,M
564C
565 INTEGER IADM_CP(NZ)
566 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
567C========================================================================|
568 ALLOCATE(itag(numnod))
569C========================================================================|
570 DO i=1,numnod
571 itag(i)=0
572 ENDDO
573 DO j=1,nz
574 i = iadm(j)
575 m = irbe2(3,i)
576 itag(m)=itag(m)+1
577 ENDDO
578 nm =0
579 iad_n(1)=1
580 DO n=1,numnod
581 IF (itag(n)>0) THEN
582 DO j=1,nz
583 i = iadm(j)
584 m = irbe2(3,i)
585 IF (m==n) THEN
586 nm=nm+1
587 iadm_cp(nm)=i
588 ENDIF
589 END DO
590 ENDIF
591 iad_n(n+1)=nm+1
592 ENDDO
593 DO j=1,nz
594 iadm(j)=iadm_cp(j)
595 ENDDO
596 DEALLOCATE(itag)
597C
598 RETURN
599 END SUBROUTINE setiadm
600!||====================================================================
601!|| hierarbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
602!||--- called by ------------------------------------------------------
603!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
604!||--- calls -----------------------------------------------------
605!|| setiadm ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
606!||====================================================================
607 SUBROUTINE hierarbe2(IRBE2 ,LRBE2)
608C-----------------------------------------------
609C I m p l i c i t T y p e s
610C-----------------------------------------------
611#include "implicit_f.inc"
612C-----------------------------------------------
613C C o m m o n B l o c k s
614C-----------------------------------------------
615#include "com04_c.inc"
616#include "param_c.inc"
617#include "tabsiz_c.inc"
618C-----------------------------------------------
619C D u m m y A r g u m e n t s
620C-----------------------------------------------
621 INTEGER IRBE2(NRBE2L,*), LRBE2(*)
622C-----------------------------------------------
623C L o c a l V a r i a b l e s
624C-----------------------------------------------
625 INTEGER I, N, IM1,NS,J,NSL,IAD,M,IH1,K,NZ,II,IAD1
626C
627 INTEGER ITAG1(NRBE2),
628 . LCOPY(SLRBE2),ICOPY(NRBE2L,NRBE2)
629 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG, IAD_N
630C========================================================================|
631C--------defining hierarchy---------------------------------------
632 ALLOCATE(itag(numnod))
633 ALLOCATE(iad_n(numnod+1))
634 DO i=1,numnod
635 itag(i)=0
636 ENDDO
637C--------if same node as several MAINs---------------------------------------
638 nz=0
639 DO i=1,nrbe2
640 m = irbe2(3,i)
641 IF (itag(m)==0) THEN
642 itag(m)=i
643 ELSE
644 nz=nz+1
645 itag1(nz)=i
646 ENDIF
647 ENDDO
648 CALL setiadm(itag1,nz,iad_n,irbe2)
649C--------------------------------------------
650 DO i=1,nrbe2
651 iad = irbe2(1,i)
652 m = irbe2(3,i)
653 nsl = irbe2(5,i)
654 DO j =1,nsl
655 ns = lrbe2(iad+j)
656 IF (itag(ns)>0) THEN
657 im1=itag(ns)
658 ih1 = irbe2(9,im1)+1
659 irbe2(9,i) = max(irbe2(9,i),ih1)
660 DO k=iad_n(ns),iad_n(ns+1)-1
661 im1=itag1(k)
662 ih1 = irbe2(9,im1)+1
663 irbe2(9,i) = max(irbe2(9,i),ih1)
664 ENDDO
665 ENDIF
666 ENDDO
667 ENDDO
668 nhrbe2=0
669 DO i=1,nrbe2
670 nhrbe2 = max(nhrbe2,irbe2(9,i))
671 m = irbe2(3,i)
672 ENDDO
673 IF (nhrbe2==0) RETURN
674C-------reordering according hiera---
675 DO i=1,nrbe2
676 iad = irbe2(1,i)
677 m = irbe2(3,i)
678 nsl = irbe2(5,i)
679 DO j =1,nrbe2l
680 icopy(j,i) = irbe2(j,i)
681 ENDDO
682 DO j =1,nsl
683 lcopy(iad+j) = lrbe2(iad+j)
684 ENDDO
685 ENDDO
686C----------reodering---
687 iad1 = 0
688 ii = 0
689 DO n=0,nhrbe2
690 DO i=1,nrbe2
691 IF (icopy(9,i)/=n) cycle
692 ii = ii + 1
693 iad = icopy(1,i)
694 m = icopy(3,i)
695 nsl = icopy(5,i)
696 irbe2(1,ii) = iad1
697 DO j =2,nrbe2l
698 irbe2(j,ii) = icopy(j,i)
699 ENDDO
700 DO j =1,nsl
701 lrbe2(iad1+j)=lcopy(iad+j)
702 ENDDO
703 iad1 =iad1+nsl
704 ENDDO
705 ENDDO
706C
707 DEALLOCATE(itag,iad_n)
708 RETURN
709 END SUBROUTINE hierarbe2
710!||====================================================================
711!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
712!||--- called by ------------------------------------------------------
713!|| initia ../starter/source/elements/initia/initia.f
714!||--- calls -----------------------------------------------------
715!|| ancmsg ../starter/source/output/message/message.F
716!|| fretitl2 ../starter/source/starter/freform.F
717!|| hierarbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
718!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
719!|| reorbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
720!||--- uses -----------------------------------------------------
721!|| message_mod ../starter/share/message_module/message_mod.F
722!||====================================================================
723 SUBROUTINE inirbe2(IRBE2 ,LRBE2 ,ITAB ,X ,MS ,
724 . IN ,STIFN ,STIFR ,TOTMAS,XGT ,
725 . YGT ,ZGT ,B1 ,B2 ,B3 ,
726 . B5 ,B6 ,B9 ,NOM_OPT,ITAGND )
727 USE message_mod
728 USE names_and_titles_mod , ONLY : nchartitle
729C-----------------------------------------------
730C I m p l i c i t T y p e s
731C-----------------------------------------------
732#include "implicit_f.inc"
733C-----------------------------------------------
734C C o m m o n B l o c k s
735C-----------------------------------------------
736#include "scr17_c.inc"
737#include "com01_c.inc"
738#include "com04_c.inc"
739#include "units_c.inc"
740#include "param_c.inc"
741#include "scr03_c.inc"
742C-----------------------------------------------
743C D u m m y A r g u m e n t s
744C-----------------------------------------------
745 INTEGER IRBE2(NRBE2L,*), LRBE2(*),ITAB(*),ITAGND(*)
746 my_real
747 . X(3,*),MS(*),IN(*),STIFN(*) ,STIFR(*),TOTMAS,
748 . B1, B2, B3, B5, B6, B9,XGT ,YGT ,ZGT
749 INTEGER NOM_OPT(LNOPT1,*)
750C-----------------------------------------------
751C L o c a l V a r i a b l e s
752C-----------------------------------------------
753 INTEGER I, J ,N, K, NSL,M, NC,NS,ICT,ICR,IC,IAD,ID,J6(6),IRAD
754C
755 my_real xx, xy, xz, yy, yz, zz,ixx,iyy,izz,dd,masrb,inrb,ins,ins0
756 CHARACTER(LEN=NCHARTITLE) :: TITR
757C========================================================================|
758 CALL rbe2_merge(irbe2 ,lrbe2 )
759 CALL reorbe2(irbe2 ,lrbe2 ,nc )
760 CALL hierarbe2(irbe2 ,lrbe2 )
761 IF (nc<0) THEN
762 id= -nc
763 CALL ancmsg(msgid=803,
764 . msgtype=msgerror,
765 . anmode=aninfo,
766 . i1=id)
767 ELSEIF(nhrbe2>0) THEN
768 WRITE(iout,1200) nhrbe2
769 IF (ipri>=5) THEN
770 WRITE(iout,1000)
771 DO i=1,nrbe2
772 m = itab(irbe2(3,i))
773 nsl = irbe2(5,i)
774 ic=irbe2(4,i)
775 ict=ic/512
776 icr=(ic-512*(ict))/64
777 DO j =1,6
778 j6(j)=0
779 ENDDO
780 SELECT CASE (ict)
781 CASE(1)
782 j6(3)=1
783 CASE(2)
784 j6(2)=1
785 CASE(3)
786 j6(2)=1
787 j6(3)=1
788 CASE(4)
789 j6(1)=1
790 CASE(5)
791 j6(1)=1
792 j6(3)=1
793 CASE(6)
794 j6(1)=1
795 j6(2)=1
796 CASE(7)
797 j6(1)=1
798 j6(2)=1
799 j6(3)=1
800 END SELECT
801 SELECT CASE (icr)
802 CASE(1)
803 j6(6)=1
804 CASE(2)
805 j6(5)=1
806 CASE(3)
807 j6(5)=1
808 j6(6)=1
809 CASE(4)
810 j6(4)=1
811 CASE(5)
812 j6(4)=1
813 j6(6)=1
814 CASE(6)
815 j6(4)=1
816 j6(5)=1
817 CASE(7)
818 j6(4)=1
819 j6(5)=1
820 j6(6)=1
821 END SELECT
822 WRITE(iout,1100) irbe2(2,i),irbe2(9,i),m,j6,irbe2(7,i),nsl
823 ENDDO
824 END IF
825 ENDIF
826C
827 inrb=zero
828 DO i=1,nrbe2
829 iad = irbe2(1,i)
830 nom_opt(1,i) = irbe2(2,i)
831 m = irbe2(3,i)
832 nsl = irbe2(5,i)
833 ic=irbe2(4,i)
834 irad = irbe2(11,i)
835 ict=ic/512
836 IF (ict>0) THEN
837 IF (ns10e>0) THEN
838 DO j =1,nsl
839 ns = lrbe2(iad+j)
840 IF (itagnd(ns)/=0) cycle
841 ms(m) = ms(m)+ms(ns)
842 stifn(m)= stifn(m)+stifn(ns)
843 ENDDO
844 ELSE
845 DO j =1,nsl
846 ns = lrbe2(iad+j)
847 ms(m) = ms(m)+ms(ns)
848 stifn(m)= stifn(m)+stifn(ns)
849 ENDDO
850 END IF !(NS10E>0) THEN
851 ENDIF
852 icr=(ic-512*(ict))/64
853 IF (iroddl==0) icr =0
854 IF (icr>0.OR.irad==0) THEN
855 IF (icr>0) THEN
856 DO j =1,nsl
857 ns = lrbe2(iad+j)
858 in(m) = in(m)+in(ns)
859 stifr(m)= stifr(m)+stifr(ns)
860 ENDDO
861 END IF
862 IF (ict>0) THEN
863 IF (ns10e>0) THEN
864 DO j =1,nsl
865 ns = lrbe2(iad+j)
866 IF (itagnd(ns)/=0) cycle
867 xx=(x(1,ns)-x(1,m))*(x(1,ns)-x(1,m))
868 yy=(x(2,ns)-x(2,m))*(x(2,ns)-x(2,m))
869 zz=(x(3,ns)-x(3,m))*(x(3,ns)-x(3,m))
870 ixx=yy+zz
871 iyy=zz+xx
872 izz=xx+yy
873 ins = (ixx+iyy+izz)*ms(ns)
874 in(m) = in(m)+ ins
875 IF (ict==7) inrb = inrb+ins
876 dd = xx+yy+zz
877 stifr(m)= stifr(m)+dd*stifn(ns)
878 ENDDO
879 ELSE
880 DO j =1,nsl
881 ns = lrbe2(iad+j)
882 xx=(x(1,ns)-x(1,m))*(x(1,ns)-x(1,m))
883 yy=(x(2,ns)-x(2,m))*(x(2,ns)-x(2,m))
884 zz=(x(3,ns)-x(3,m))*(x(3,ns)-x(3,m))
885 ixx=yy+zz
886 iyy=zz+xx
887 izz=xx+yy
888 ins = (ixx+iyy+izz)*ms(ns)
889 in(m) = in(m)+ ins
890 IF (ict==7) inrb = inrb+ins
891 dd = xx+yy+zz
892 stifr(m)= stifr(m)+dd*stifn(ns)
893 ENDDO
894 END IF !(NS10E>0) THEN
895 ENDIF
896 ENDIF
897 ENDDO
898C-----Correction -only for the case 111---
899 masrb=zero
900 DO i=1,nrbe2
901 iad = irbe2(1,i)
902 nsl = irbe2(5,i)
903 ic=irbe2(4,i)
904 ict=ic/512
905 IF (ict==7) THEN
906 DO j =1,nsl
907 ns = lrbe2(iad+j)
908 stifn(ns)= em20
909 masrb = masrb+ms(ns)
910 xx=(x(1,ns))*(x(1,ns))
911 xy=(x(1,ns))*(x(2,ns))
912 xz=(x(1,ns))*(x(3,ns))
913 yy=(x(2,ns))*(x(2,ns))
914 yz=(x(2,ns))*(x(3,ns))
915 zz=(x(3,ns))*(x(3,ns))
916 b1 = b1 -(yy+zz)*ms(ns)
917 b2 = b2 + xy*ms(ns)
918 b3 = b3 + xz*ms(ns)
919 b5 = b5 -(zz+xx)*ms(ns)
920 b6 = b6 + yz*ms(ns)
921 b9 = b9 - (xx+yy)*ms(ns)
922 xgt = xgt - ms(ns)*x(1,ns)
923 ygt = ygt - ms(ns)*x(2,ns)
924 zgt = zgt - ms(ns)*x(3,ns)
925 ENDDO
926 ENDIF
927 icr=(ic-512*(ict))/64
928 IF (icr==7.AND.iroddl>0) THEN
929 DO j =1,nsl
930 ns = lrbe2(iad+j)
931 stifr(ns)= em20
932 inrb=inrb+in(ns)
933 b1 = b1 -in(ns)
934 b5 = b5 -in(ns)
935 b9 = b9 -in(ns)
936 ENDDO
937 ENDIF
938 ENDDO
939 totmas = totmas - masrb
940C------INRB will not be taken into account due to solide elements as dependent nodes but defined as 111 111
941C
942 DO i=1,nrbe2
943 id=nom_opt(1,i)
944 CALL fretitl2(titr,
945 . nom_opt(lnopt1-ltitr+1,i),ltitr)
946
947 m = irbe2(3,i)
948 IF(ms(m)<=1.0e-25) THEN
949 CALL ancmsg(msgid=804,
950 . msgtype=msgerror,
951 . anmode=aninfo_blind_1,
952 . i1=id,
953 . c1=titr)
954 RETURN
955 ENDIF
956 IF (ipri>=3) THEN
957 WRITE(iout,1300)
958 IF (iroddl==0) THEN
959 WRITE(iout,1600) irbe2(2,i),itab(irbe2(3,i)),ms(m)
960 ELSE
961 WRITE(iout,1400) irbe2(2,i),itab(irbe2(3,i)),ms(m),in(m)
962 END IF
963 ENDIF
964 ENDDO
965C
966 RETURN
967 1000 FORMAT(//
968 .' RIGID ELEMENT(RBE2) WITH HIERARCHY LEVEL AFTER REORDERING:'/
969 . ' --------------------------------------------------------- ')
970 1100 FORMAT(/10x,'NUMBER . . . . . . . . . . .',i10,/,
971 . /10x,'HIERARCHY LEVEL. . . . . . ',i10,
972 . /10x,'INDEPENDENT NODE NUMBER. . .',i10,
973 . /10x,'DOF ( X,Y,Z, XX,YY,ZZ). . . . ',3i1,2x,3i1
974 . /10x,'SKEW NUMBER (LOCAL) . . . . .',i10,
975 . /10x,'NUMBER OF DEPENDENT NODES . .',i10,//)
976 1200 FORMAT(/10x,'RBE2 HIERARCHY LEVEL . . . . =',i5,2x,//)
977 1300 FORMAT(//
978 .' RIGID ELEMENT(RBE2) INDEPENDENT NODE MASSES AND INERTIA (NEW):'/
979 . ' --------------------------------------------------------- ')
980 1400 FORMAT(/10X,'number . . . . . . . . . . .',I10,/,
981 . /10X,'independent node number. . .',I10,
982 . /10X,'new mass. . . . . . . . . . .',1PG20.13,
983 . /10X,'new spheric inertia. . . . . ',1PG20.13,//)
984 1600 FORMAT(/10X,'number . . . . . . . . . . .',I10,/,
985 . /10X,'independent node number. . .',I10,
986 . /10X,'new mass. . . . . . . . . . .',1PG20.13,//)
987 END SUBROUTINE INIRBE2
988!||====================================================================
989!|| contrbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
990!||--- called by ------------------------------------------------------
991!|| contrl ../starter/source/starter/contrl.F
992!||--- calls -----------------------------------------------------
993!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
994!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
995!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
996!||--- uses -----------------------------------------------------
997!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
998!|| submodel_mod ../starter/share/modules1/submodel_mod.F
999!||====================================================================
1000 SUBROUTINE CONTRBE2(ICR,LSUBMODEL)
1001C-----------------------------------------------
1002C M o d u l e s
1003C-----------------------------------------------
1004 USE HM_OPTION_READ_MOD
1005 USE SUBMODEL_MOD
1006 USE NAMES_AND_TITLES_MOD , ONLY : NCHARTITLE, NCHARKEY
1007C-----------------------------------------------
1008C I m p l i c i t T y p e s
1009C-----------------------------------------------
1010#include "implicit_f.inc"
1011C-----------------------------------------------
1012C C o m m o n B l o c k s
1013C-----------------------------------------------
1014#include "com04_c.inc"
1015C-----------------------------------------------
1016C D u m m y A r g u m e n t s
1017C-----------------------------------------------
1018 INTEGER ICR
1019 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
1020C-----------------------------------------------
1021C L o c a l V a r i a b l e s
1022C-----------------------------------------------
1023 INTEGER I, N, K, NSL, NSLT, ITYP, NUSER, NM,M, NI,
1024 . ISK, ISENS, INGU, IGM, J, P,IAD,NS,NN,J6(6),JJ,II,
1025 . IC,IC1,IC2,IROT,ISKS,IADS,IERR1,NC,ID,IRAD
1026 CHARACTER(LEN=NCHARTITLE) :: TITR
1027 CHARACTER(LEN=NCHARKEY) :: KEY
1028 LOGICAL IS_AVAILABLE
1029C-----------------------------------------------
1030C E x t e r n a l F u n c t i o n s
1031C-----------------------------------------------
1032C
1033C=====================================================================|
1034C
1035C-----initialise NHRBE2--au cas no rbe2---add new option-----------
1036 NHRBE2 = 0
1037 ICR =0
1038 CALL HM_OPTION_START('/rbe2')
1039 DO I=1,NRBE2
1040 CALL HM_OPTION_READ_KEY(LSUBMODEL,
1041 . OPTION_ID = NUSER,
1042 . OPTION_TITR = TITR)
1043C
1044 CALL HM_GET_INTV('independentnode',NM,IS_AVAILABLE,LSUBMODEL)
1045 CALL HM_GET_INTV('vx',J6(1),IS_AVAILABLE,LSUBMODEL)
1046 CALL HM_GET_INTV('vy',J6(2),IS_AVAILABLE,LSUBMODEL)
1047 CALL HM_GET_INTV('vz',J6(3),IS_AVAILABLE,LSUBMODEL)
1048 CALL HM_GET_INTV('wx',J6(4),IS_AVAILABLE,LSUBMODEL)
1049 CALL HM_GET_INTV('wy',J6(5),IS_AVAILABLE,LSUBMODEL)
1050 CALL HM_GET_INTV('wz',J6(6),IS_AVAILABLE,LSUBMODEL)
1051 CALL HM_GET_INTV('skew_csid',ISK,IS_AVAILABLE,LSUBMODEL)
1052 CALL HM_GET_INTV('dependentnodeset',INGU,IS_AVAILABLE,LSUBMODEL)
1053 CALL HM_GET_INTV('iflag',IRAD,IS_AVAILABLE,LSUBMODEL)
1054C
1055 IF ((J6(1)+J6(2)+J6(3)+J6(4)+J6(5)+J6(6))==0) THEN
1056 J6(4)=1
1057 J6(5)=1
1058 J6(6)=1
1059 ENDIF
1060 ICR = J6(4) + J6(5) + J6(6)
1061 IF (IRAD == 0) ICR = 1
1062 IF (ICR >0) RETURN
1063 ENDDO
1064C
1065 RETURN
1066C
1067 END SUBROUTINE CONTRBE2
1068!||====================================================================
1069!|| seteloff2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1070!||--- called by ------------------------------------------------------
1071!|| lectur ../starter/source/starter/lectur.F
1072!||--- uses -----------------------------------------------------
1073!||====================================================================
1074 SUBROUTINE SETELOFF2(IXS ,IXC ,IXT ,IXP ,IXR ,
1075 2 IXTG ,IPARG ,ISOLOFF,ISHEOFF,
1076 3 ITRUOFF,IPOUOFF,IRESOFF,ITRIOFF,IGRNRB2,
1077 4 IGRNOD ,IRBE2 )
1078C-----------------------------------------------
1079C M o d u l e s
1080C-----------------------------------------------
1081 USE GROUPDEF_MOD
1082C-------------------------------------
1083C PRE LECTURE STRUCTURE RIGIDES POUR OPTIMIZATION
1084C-----------------------------------------------
1085C I m p l i c i t T y p e s
1086C-----------------------------------------------
1087#include "implicit_f.inc"
1088C-----------------------------------------------
1089C C o m m o n B l o c k s
1090C-----------------------------------------------
1091#include "com04_c.inc"
1092#include "units_c.inc"
1093#include "scr03_c.inc"
1094#include "param_c.inc"
1095C-----------------------------------------------
1096C D u m m y A r g u m e n t s
1097C-----------------------------------------------
1098 INTEGER ISOLOFF(*), ISHEOFF(*), ITRIOFF(*),ITRUOFF(*),
1099 . IPOUOFF(*), IRESOFF(*),
1100 . IXS(NIXS,*), IXC(NIXC,*), IXTG(NIXTG,*), IXT(NIXT,*),
1101 . IXP(NIXP,*), IXR(NIXR,*),
1102 . IPARG(NPARG,*),IGRNRB2(*),
1103 . IRBE2(NRBE2L,*)
1104C-----------------------------------------------
1105 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
1106C-----------------------------------------------
1107C L o c a l V a r i a b l e s
1108C-----------------------------------------------
1109 INTEGER NG, MLW, ITY, NEL, NFT, IAD, I, II, IGOF, NR, IG,
1110 . NSN, NALL, ISHFT, IOK, IRBYON,M,IC,IC0,
1111 . ITAG(NUMNOD)
1112C-----------------------
1113C MISE DE OFF A -OFF
1114C======================================================================|
1115 IF (NRBE2==0) RETURN
1116 IF(IPRI>=5) THEN
1117 WRITE(IOUT,*)' '
1118
1119 WRITE(IOUT,*)' list of deactivated elements from rbe2'
1120 WRITE(IOUT,*)' ----------------------------------------------'
1121 END IF
1122C
1123 IRBYON = 20
1124 IC0 = 7*512+7*64
1125C
1126 DO NR = 1, NRBE2
1127 IG = IGRNRB2(NR)
1128 M = IRBE2(3,NR)
1129 IC = IRBE2(4,NR)
1130.AND. IF(IG>0IC==IC0)THEN
1131 NSN = IGRNOD(IG)%NENTITY
1132 DO I=1,NUMNOD
1133 ITAG(I)=0
1134 ENDDO
1135 ITAG(M)=1
1136 DO I=1,NSN
1137 ITAG(IGRNOD(IG)%ENTITY(I))=1
1138 END DO
1139C
1140 DO II = 1, NUMELT
1141 NALL = ITAG(IXT(2,II)) * ITAG(IXT(3,II))
1142 IF(NALL/=0)THEN
1143 ITRUOFF(II) = IRBYON
1144 END IF
1145 END DO
1146C
1147 DO II = 1, NUMELP
1148 NALL = ITAG(IXP(2,II)) * ITAG(IXP(3,II))
1149 IF(NALL/=0)THEN
1150 IPOUOFF(II) = IRBYON
1151 END IF
1152 END DO
1153C
1154 DO II = 1, NUMELR
1155 NALL = ITAG(IXR(2,II)) * ITAG(IXR(3,II))
1156 IF(NALL/=0)THEN
1157 IRESOFF(II) = IRBYON
1158 END IF
1159 END DO
1160 END IF
1161C
1162 END DO
1163C -----DEACTIVATED ELEMENTS will done in SETELOFF------
1164 RETURN
1165 END SUBROUTINE SETELOFF2
1166!||====================================================================
1167!|| setrb2on ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1168!||--- called by ------------------------------------------------------
1169!|| lectur ../starter/source/starter/lectur.F
1170!||--- calls -----------------------------------------------------
1171!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
1172!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
1173!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
1174!|| ngr2usr ../starter/source/system/nintrr.F
1175!|| ngr2usrn ../starter/source/system/nintrr.F
1176!|| usr2sys ../starter/source/system/sysfus.F
1177!||--- uses -----------------------------------------------------
1178!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
1179!|| submodel_mod ../starter/share/modules1/submodel_mod.F
1180!||====================================================================
1181 SUBROUTINE SETRB2ON(IXS ,IXC ,IXTG ,IGRNOD ,
1182 2 IGRNRB2,ISOLOFF,ISHEOFF,ITRIOFF,ITABM1,
1183 3 LSUBMODEL)
1184C-----------------------------------------------
1185C M o d u l e s
1186C-----------------------------------------------
1187 USE GROUPDEF_MOD
1188 USE HM_OPTION_READ_MOD
1189 USE SUBMODEL_MOD
1190 USE NAMES_AND_TITLES_MOD , ONLY : NCHARTITLE
1191C-------------------------------------
1192C PRE LECTURE STRUCTURE RIGIDES POUR OPTIMIZATION
1193C-----------------------------------------------
1194C I m p l i c i t T y p e s
1195C-----------------------------------------------
1196#include "implicit_f.inc"
1197C-----------------------------------------------
1198C C o m m o n B l o c k s
1199C-----------------------------------------------
1200#include "com04_c.inc"
1201C-----------------------------------------------
1202C D u m m y A r g u m e n t s
1203C-----------------------------------------------
1204 INTEGER IGRNRB2(*),ISOLOFF(*),ISHEOFF(*),ITRIOFF(*),
1205 . IXS(NIXS,*), IXC(NIXC,*), IXTG(NIXTG,*),ITABM1(*)
1206C-----------------------------------------------
1207 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
1208 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
1209C-----------------------------------------------
1210C L o c a l V a r i a b l e s
1211C-----------------------------------------------
1212 INTEGER NR, IDUM, I, L, ISENS, IGS,NSN,IAD,II,NALL,
1213 . IGU,ID,ILAGM,ISU,UID,IRBYON,
1214 . ITAG(NUMNOD),NN,NM, NUSER, NUM,M,J6(6),IC
1215 CHARACTER(LEN=NCHARTITLE) :: TITR
1216 CHARACTER :: MESS*40
1217 INTEGER NGR2USRN
1218 LOGICAL IS_AVAILABLE
1219C-----------------------------------------------
1220C E x t e r n a l F u n c t i o n s
1221C-----------------------------------------------
1222 INTEGER USR2SYS,NODGRNR,NGR2USR
1223C-----------------------------------
1224 IF (NRBE2==0) RETURN
1225C
1226 CALL HM_OPTION_START('/rbe2')
1227 IRBYON = 20
1228 DO NR=1,NRBE2
1229 IGRNRB2(NR)=0
1230 CALL HM_OPTION_READ_KEY(LSUBMODEL,
1231 . OPTION_ID = NUSER,
1232 . OPTION_TITR = TITR)
1233C
1234 CALL HM_GET_INTV('independentnode',NM,IS_AVAILABLE,LSUBMODEL)
1235 CALL HM_GET_INTV('vx',J6(1),IS_AVAILABLE,LSUBMODEL)
1236 CALL HM_GET_INTV('vy',J6(2),IS_AVAILABLE,LSUBMODEL)
1237 CALL HM_GET_INTV('vz',J6(3),IS_AVAILABLE,LSUBMODEL)
1238 CALL HM_GET_INTV('wx',J6(4),IS_AVAILABLE,LSUBMODEL)
1239 CALL HM_GET_INTV('wy',J6(5),IS_AVAILABLE,LSUBMODEL)
1240 CALL HM_GET_INTV('wz',J6(6),IS_AVAILABLE,LSUBMODEL)
1241 CALL HM_GET_INTV('dependentnodeset',IGU,IS_AVAILABLE,LSUBMODEL)
1242C
1243 M = USR2SYS(NM,ITABM1,MESS,NUSER)
1244 IGS = NGR2USRN(IGU,IGRNOD,NGRNOD,NN)
1245 IC= J6(1)+J6(2)+J6(3)+J6(4)+J6(5)+J6(6)
1246C
1247.AND..OR. IF(IGS/=0(IC==0IC==6)) THEN
1248C
1249 DO I=1,NUMNOD
1250 ITAG(I)=0
1251 ENDDO
1252 IGRNRB2(NR)=IGS
1253 NSN = IGRNOD(IGS)%NENTITY
1254 ITAG(M)=1
1255 DO I=1,NSN
1256 ITAG(IGRNOD(IGS)%ENTITY(I))=1
1257 END DO
1258C
1259 DO II = 1, NUMELC
1260 NALL = ITAG(IXC(2,II)) * ITAG(IXC(3,II)) *
1261 + ITAG(IXC(4,II)) * ITAG(IXC(5,II))
1262 IF(NALL/=0)THEN
1263 ISHEOFF(II) = IRBYON
1264 END IF
1265 END DO
1266C
1267 DO II = 1, NUMELTG
1268 NALL = ITAG(IXTG(2,II)) * ITAG(IXTG(3,II)) *
1269 + ITAG(IXTG(4,II))
1270 IF(NALL/=0)THEN
1271 ITRIOFF(II) = IRBYON
1272 END IF
1273 END DO
1274 END IF
1275C
1276 END DO
1277C------------solid elements
1278C
1279 CALL HM_OPTION_START('/rbe2')
1280 DO NR=1,NRBE2
1281 IGRNRB2(NR)=0
1282 CALL HM_OPTION_READ_KEY(LSUBMODEL,
1283 . OPTION_ID = NUSER,
1284 . OPTION_TITR = TITR)
1285C
1286 CALL HM_GET_INTV('independentnode',NM,IS_AVAILABLE,LSUBMODEL)
1287 CALL HM_GET_INTV('vx',J6(1),IS_AVAILABLE,LSUBMODEL)
1288 CALL HM_GET_INTV('vy',J6(2),IS_AVAILABLE,LSUBMODEL)
1289 CALL HM_GET_INTV('vz',J6(3),IS_AVAILABLE,LSUBMODEL)
1290 CALL HM_GET_INTV('wx',J6(4),IS_AVAILABLE,LSUBMODEL)
1291 CALL HM_GET_INTV('wy',J6(5),IS_AVAILABLE,LSUBMODEL)
1292 CALL HM_GET_INTV('wz',J6(6),IS_AVAILABLE,LSUBMODEL)
1293 CALL HM_GET_INTV('dependentnodeset',IGU,IS_AVAILABLE,LSUBMODEL)
1294C
1295 M = USR2SYS(NM,ITABM1,MESS,NUSER)
1296 IGS = NGR2USRN(IGU,IGRNOD,NGRNOD,NN)
1297 IC= J6(1)+J6(2)+J6(3)
1298C
1299.AND..OR. IF(IGS/=0(IC==0IC==3)) THEN
1300C
1301 DO I=1,NUMNOD
1302 ITAG(I)=0
1303 ENDDO
1304 IGRNRB2(NR)=IGS
1305 NSN = IGRNOD(IGS)%NENTITY
1306 ITAG(M)=1
1307 DO I=1,NSN
1308 ITAG(IGRNOD(IGS)%ENTITY(I))=1
1309 END DO
1310C
1311 DO II = 1, NUMELS
1312 NALL = ITAG(IXS(2,II)) * ITAG(IXS(3,II)) *
1313 + ITAG(IXS(4,II)) * ITAG(IXS(5,II)) *
1314 + ITAG(IXS(6,II)) * ITAG(IXS(7,II)) *
1315 + ITAG(IXS(8,II)) * ITAG(IXS(9,II))
1316 IF(NALL/=0)THEN
1317 ISOLOFF(II) = IRBYON
1318 END IF
1319 END DO
1320 END IF
1321C
1322 END DO
1323C
1324 RETURN
1325 END
1326C
1327!||====================================================================
1328!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1329!||--- called by ------------------------------------------------------
1330!|| inirbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1331!||--- calls -----------------------------------------------------
1332!|| ic_mrg ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1333!|| same_nsn ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1334!||====================================================================
1335 SUBROUTINE RBE2_MERGE(IRBE2 ,LRBE2 )
1336C-----------------------------------------------
1337C I m p l i c i t T y p e s
1338C-----------------------------------------------
1339#include "implicit_f.inc"
1340C-----------------------------------------------
1341C C o m m o n B l o c k s
1342C-----------------------------------------------
1343#include "com04_c.inc"
1344#include "param_c.inc"
1345C-----------------------------------------------
1346C D u m m y A r g u m e n t s
1347C-----------------------------------------------
1348 INTEGER IRBE2(NRBE2L,*), LRBE2(*)
1349C-----------------------------------------------
1350C L o c a l V a r i a b l e s
1351C-----------------------------------------------
1352 INTEGER I, N, K, NSL,NM, NI, NMT,M,IROT,ID,IMO,IC0,NZ,NSLN,NSLJ,
1353 . J, P,IAD,NS,NN,II,IT,IADS,IERR1,IAD1,IC,MJ,ICJ,NSJ,IADJ
1354C
1355 INTEGER ISAME
1356 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
1357
1358C========================================================================|
1359C--------merging RBE2 w/ the same NS/M (separated IC)--------------------
1360 ALLOCATE(ITAG(NUMNOD))
1361 ITAG(1:NUMNOD)=0
1362C--------if same node as several IND. of /RBE2------------
1363 NZ=0
1364 DO I=1,NRBE2
1365 IAD = IRBE2(1,I)
1366 NSL = IRBE2(5,I)
1367 DO J =1,NSL
1368 NS = LRBE2(IAD+J)
1369 IF (ITAG(NS)>0) NZ = NZ + 1
1370 ITAG(NS)=ITAG(NS)+1
1371 ENDDO
1372 ENDDO
1373 IF (NZ==0) THEN
1374 DEALLOCATE(ITAG)
1375 RETURN
1376 ENDIF
1377C --------merge if same all excepting IC
1378 DO I=1,NRBE2
1379 IAD = IRBE2(1,I)
1380 NSL = IRBE2(5,I)
1381 M = IRBE2(3,I)
1382 IF (NSL==0) CYCLE
1383 DO II=I+1,NRBE2
1384 IADJ = IRBE2(1,II)
1385 NSLJ = IRBE2(5,II)
1386 MJ = IRBE2(3,II)
1387.OR. IF (MJ/=MNSLJ/=NSL) CYCLE
1388 CALL SAME_NSN(NSL,LRBE2(IAD+1),LRBE2(IADJ+1),ITAG,ISAME)
1389 IF (ISAME==1) THEN
1390 CALL IC_MRG(IC,IRBE2(4,I),IRBE2(4,II))
1391 IRBE2(4,I) = IC
1392 IRBE2(5,II) = 0
1393 END IF
1394 ENDDO
1395 ENDDO
1396C
1397 DEALLOCATE(ITAG)
1398 RETURN
1399 END SUBROUTINE RBE2_MERGE
1400!||====================================================================
1401!|| same_nsn ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1402!||--- called by ------------------------------------------------------
1403!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1404!||====================================================================
1405 SUBROUTINE SAME_NSN(NSL,LRBE2_1 ,LRBE2_2,ITAG,ISAME)
1406C-----------------------------------------------
1407C I m p l i c i t T y p e s
1408C-----------------------------------------------
1409#include "implicit_f.inc"
1410C-----------------------------------------------
1411C D u m m y A r g u m e n t s
1412C-----------------------------------------------
1413 INTEGER NSL,LRBE2_1(*) ,LRBE2_2(*),ITAG(*),ISAME
1414C-----------------------------------------------
1415C L o c a l V a r i a b l e s
1416C-----------------------------------------------
1417 INTEGER I,NS1,NS2
1418C========================================================================|
1419 ISAME=1
1420 DO I=1,NSL
1421 NS1=LRBE2_1(I)
1422 NS2=LRBE2_2(I)
1423.OR..OR. IF (NS1/=NS2ITAG(NS1)/=ITAG(NS2)ITAG(NS1)<=1) THEN
1424 ISAME=0
1425 CYCLE
1426 END IF
1427 ENDDO
1428C
1429 RETURN
1430 END SUBROUTINE SAME_NSN
1431!||====================================================================
1432!|| ic_mrg ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1433!||--- called by ------------------------------------------------------
1434!|| rbe2_merge ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1435!||--- calls -----------------------------------------------------
1436!|| ict2jt ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1437!||====================================================================
1438 SUBROUTINE IC_MRG(IC_N,IC1 ,IC2)
1439C-----------------------------------------------
1440C I m p l i c i t T y p e s
1441C-----------------------------------------------
1442#include "implicit_f.inc"
1443C-----------------------------------------------
1444C D u m m y A r g u m e n t s
1445C-----------------------------------------------
1446 INTEGER IC_N,IC1 ,IC2
1447C-----------------------------------------------
1448C L o c a l V a r i a b l e s
1449C-----------------------------------------------
1450 INTEGER I,ICT,ICR,JT1(3),JR1(3),JT2(3),JR2(3),IUN
1451C========================================================================|
1452 ICT=IC1/512
1453 ICR=(IC1-512*(ICT))/64
1454 CALL ICT2JT(ICT,JT1)
1455 CALL ICT2JT(ICR,JR1)
1456 ICT=IC2/512
1457 ICR=(IC2-512*(ICT))/64
1458 CALL ICT2JT(ICT,JT2)
1459 CALL ICT2JT(ICR,JR2)
1460 IUN=1
1461 DO I =1,3
1462 JT1(I) = JT1(I)+JT2(I)
1463 JR1(I) = JR1(I)+JR2(I)
1464 JT1(I) = MIN(IUN,JT1(I))
1465 JR1(I) = MIN(IUN,JR1(I))
1466 END DO
1467 ICT=JT1(1)*4 +JT1(2)*2 +JT1(3)
1468 ICR=JR1(1)*4 +JR1(2)*2 +JR1(3)
1469 IC_N =ICT*512+ICR*64
1470C
1471 RETURN
1472 END SUBROUTINE IC_MRG
1473!||====================================================================
1474!|| ict2jt ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1475!||--- called by ------------------------------------------------------
1476!|| ic_mrg ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
1477!||====================================================================
1478 SUBROUTINE ICT2JT(ICT,JT)
1479C-----------------------------------------------
1480C I m p l i c i t T y p e s
1481C-----------------------------------------------
1482#include "implicit_f.inc"
1483C-----------------------------------------------
1484C D u m m y A r g u m e n t s
1485C-----------------------------------------------
1486 INTEGER ICT,JT(3)
1487C REAL
1488C-----------------------------------------------
1489C L o c a l V a r i a b l e s
1490C-----------------------------------------------
1491 INTEGER I, J
1492C======================================================================|
1493C ICT=IC/512
1494C ICR=(IC-512*(ICT))/64
1495 JT(1:3)= 0
1496 SELECT CASE (ICT)
1497 CASE(1)
1498 JT(3)=1
1499 CASE(2)
1500 JT(2)=1
1501 CASE(3)
1502 JT(2)=1
1503 JT(3)=1
1504 CASE(4)
1505 JT(1)=1
1506 CASE(5)
1507 JT(1)=1
1508 JT(3)=1
1509 CASE(6)
1510 JT(1)=1
1511 JT(2)=1
1512 CASE(7)
1513 JT(1)=1
1514 JT(2)=1
1515 JT(3)=1
1516 END SELECT
1517C---
1518 RETURN
1519 END SUBROUTINE ICT2JT
1520
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
setiadm
subroutine setiadm(iadm, nz, iad_n, irbe2)
Definition hm_read_rbe2.F:547
rbe2_merge
subroutine rbe2_merge(irbe2, lrbe2)
Definition hm_read_rbe2.F:1336
hierarbe2
subroutine hierarbe2(irbe2, lrbe2)
Definition hm_read_rbe2.F:608
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:329
reorbe2
subroutine reorbe2(irbe2, lrbe2, nc)
Definition hm_read_rbe2.F:397
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:727
initia
subroutine initia(iparg, elbuf, ms, in, v, x, ixs, ixq, ixc, ixt, ixp, ixr, detonators, geo, pm, rby, npby, lpby, npc, npts, pld, veul, ale_connectivity, skew, fill, ipart, itab, sensors, skvol, ixtg, thk, nloc_dmg, group_param_tab, glob_therm, igrnod, igrsurf, bufsf, vr, bufmat, xlas, las, dtelem, mss, msq, msc, mst, msp, msr, mstg, ptg, inc, nod2eltg, knod2eltg, inp, inr, intg, index, itri, kxx, ixx, xelemwa, iwa, nod2elq, knod2elq, nod2els, knod2els, kxsp, ixsp, nod2sp, ispcond, icode, iskew, iskn, ispsym, xframe, isptag, spbuf, mssx, nsigi, npbyl, lpbyl, rbyl, msnf, mssf, nsigsh, igeo, ipm, nsigs, nsigsph, vns, vnsx, stc, stt, stp, str, sttg, stur, bns, bnsx, volnod, bvolnod, etnod, nshnod, stifint, fxbdep, fxbvit, fxbacc, fxbipm, fxbrpm, fxbelm, fxbsig, fxbmod, ins, ptshel, ptsh3n, ptsol, ptquad, wma, ptsph, fxbnod, mbufel, mdepl, fxani, numel, nsigrs, sh4tree, sh3tree, mcp, temp, imerge2, iadmerge2, slnrbm, nslnrbm, rmstifn, rmstifr, ms_layer, zi_layer, itag, itagel, mcpc, mcptg, xrefc, xreftg, xrefs, mssa, msrt, irbe2, lrbe2, inivol, kvol, nbsubmat, ixs10, ixs16, ixs20, totaddmas, ipmas, stifn, msz2, itagn, sitage, itage, ixr_kj, elbuf_tab, nom_opt, ptr_nopt_rbe2, ptr_nopt_adm, ptr_nopt_fun, sol2sph, irst, sh3trim, xfem_tab, kxig3d, ixig3d, msig3d, knot, nctrlmax, wige, stack, rnoise, drape, sh4ang, sh3ang, geo_stack, igeo_stack, stifintr, strc, strp, strr, strtg, perturb, itagnd, nativ_sms, iloadp, facload, ptspri, nsigbeam, ptbeam, nsigtruss, pttruss, multi_fvm, sigi, sigsh, sigsp, sigsph, sigrs, sigbeam, sigtruss, strsglob, straglob, orthoglob, isigsh, iyldini, ksigsh3, fail_ini, iusolyld, iuser, iddlevel, inimap1d, inimap2d, func2d, fvm_inivel, tagprt_sms, igrbric, igrquad, igrsh4n, igrsh3n, igrpart, totmas, knotlocpc, knotlocel, vnige, bnige, fxbglm, fxbcpm, fxbcps, fxblm, fxbfls, fxbdls, fxb_matrix, fxb_matrix_add, fxb_last_adress, ptr_nopt_fxb, r_skew, knod2el1d, nod2el1d, ebcs_tab, rby_iniaxis, alea, knod2elc, nod2elc, dr, slrbody, drapeg, ipari, intbuf_tab, interfaces, mat_param, npreload_a, preload_a, fail_fractal, fail_brokmann, defaults, ndamp_freq_range, dampr, ibeam_vector, rbeam_vector, ikine)
Definition initia.F:188
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
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
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:712
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:300
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