OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
itagsl2.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!|| itagsl2 ../starter/source/interfaces/inter3d1/itagsl2.F
25!||--- called by ------------------------------------------------------
26!|| inintr2 ../starter/source/interfaces/inter3d1/inintr2.f
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.f
29!|| fretitl2 ../starter/source/starter/freform.F
30!|| intab ../starter/source/interfaces/inter3d1/i24tools.F
31!|| kinset ../starter/source/constraints/general/kinset.F
32!||--- uses -----------------------------------------------------
33!|| message_mod ../starter/share/message_module/message_mod.f
34!||====================================================================
35 SUBROUTINE itagsl2(IPARI ,NOM_OPT,ITAB ,IKINE ,INTBUF_TAB,
36 . ITAGND,ICNDS10,NSTRF ,ITAGCYC,IRBE2 ,
37 . IRBE3 ,LRBE3 )
38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE message_mod
42 USE intbufdef_mod
43 USE names_and_titles_mod , ONLY : nchartitle
44C-----------------------------------------------
45C I m p l i c i t T y p e s
46C-----------------------------------------------
47#include "implicit_f.inc"
48C-----------------------------------------------
49C C o m m o n B l o c k s
50C-----------------------------------------------
51#include "units_c.inc"
52#include "param_c.inc"
53#include "scr17_c.inc"
54#include "com04_c.inc"
55#include "kincod_c.inc"
56#include "tabsiz_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER IPARI(NPARI,NINTER),ITAB(*),IKINE(*),ITAGND(*),ICNDS10(3,*)
61 INTEGER NOM_OPT(LNOPT1,*),NSTRF(*),ITAGCYC(*)
62 INTEGER , DIMENSION(NRBE2L,NRBE2), INTENT(IN) :: IRBE2
63 INTEGER , DIMENSION(NRBE3L,NRBE3), INTENT(IN) :: IRBE3
64 INTEGER , DIMENSION(SLRBE3), INTENT(IN) :: LRBE3
65 TYPE(intbuf_struct_), DIMENSION(NINTER) :: INTBUF_TAB
66C-----------------------------------------------
67C L o c a l V a r i a b l e s
68C-----------------------------------------------
69 INTEGER I,J,N,NTY,ILEV,NSN,NMN,ISL,NKIN,NOINT,NINT,KCOND,IML,NNOD,NBINTER,TYP,K0
70 INTEGER, DIMENSION(:), ALLOCATABLE :: PENTAG,TAGNOS,ITAGMD
71 INTEGER, DIMENSION(:), ALLOCATABLE :: IKINE1
72 CHARACTER(LEN=NCHARTITLE)::TITR
73 INTEGER II,N1,N2,IAD,M
74 LOGICAL IS1,IS2
75C-----------------------------------------------
76C External function
77C-----------------------------------------------
78 LOGICAL INTAB
79 EXTERNAL INTAB
80C=======================================================================
81 ALLOCATE( pentag(numnod),tagnos(numnod),itagmd(numnod) )
82 ALLOCATE( ikine1(3*numnod) )
83 pentag(1:numnod) = 0
84 tagnos(1:numnod) = 0
85 ikine1(1:3*numnod) = 0
86C
87C Tag des Secnds
88C
89 DO n=1,ninter
90 nty = ipari(7,n)
91 ilev = ipari(20,n)
92 IF (nty == 2 .and. (ilev == 27 .or. ilev == 28)) THEN
93 nsn = ipari(5,n)
94 noint = ipari(15,n)
95 DO i=1,nsn
96 isl = intbuf_tab(n)%NSV(i)
97 nkin = ikine(isl)
98C
99 kcond = ibc(nkin)+itf(nkin)+irb(nkin)+irb2(nkin)+ivf(nkin)+irv(nkin)+ijo(nkin)
100 . + irbm(nkin)+ilmult(nkin)+irlk(nkin)+ikrbe2(nkin)+ikrbe3(nkin)
101 . + tagnos(isl)
102 IF (nbcscyc > 0) kcond = kcond +itagcyc(isl)
103C
104 IF (kcond /= 0) pentag(isl) = 1
105C-- Check of incompatibility with other spt27 or spt28 t2 interfaces - multiple connections with the same main on several interfaces already cleaned
106 tagnos(isl) = 1
107 ENDDO
108 ENDIF
109 ENDDO
110C
111C Tag des noeuds de section (section = IMPDISP dans certains cas)
112C
113
114 IF(nsect > 0) THEN
115 k0 = nstrf(25)
116 DO n=1,nsect
117 typ = nstrf(k0)
118 nnod = nstrf(k0+6)
119 nbinter = nstrf(k0+14)
120 IF ((typ == 100).OR.(typ == 101)) THEN
121 DO i=1,nnod
122 isl = nstrf(k0+30+nbinter-1+i)
123 IF (tagnos(isl) == 1) pentag(isl) = 1
124 ENDDO
125 ENDIF
126 k0 = nstrf(k0+24)
127 ENDDO
128 ENDIF
129C
130C Tag des mains pour TYPE2 symetrisees
131C
132 DO n=1,ninter
133 nty = ipari(7,n)
134 IF (nty == 2) THEN
135 nmn = ipari(6,n)
136 ilev = ipari(20,n)
137c
138 DO i=1,nmn
139 j = intbuf_tab(n)%MSR(i)
140 IF ((ilev == 0 .OR. ilev == 1 .OR. ilev == 27 .OR. ilev == 28) .AND. pentag(j) == 0) THEN
141 pentag(j) = 1
142 ENDIF
143 ENDDO
144 ENDIF
145 ENDDO
146C-------if only middle node (Itet=2 of tetra10) is the salve ILEV == 27 .or. ILEV == 28 change to penality,
147 IF (ns10e>0) THEN
148 DO n=1,ninter
149 nty = ipari(7,n)
150 ilev = ipari(20,n)
151 IF (nty == 2.AND.(ilev == 27 .or. ilev == 28)) THEN
152 nsn = ipari(5,n)
153 noint = ipari(15,n)
154 DO i=1,nsn
155 isl = intbuf_tab(n)%NSV(i)
156 IF (itagnd(isl)/=0 .AND.pentag(isl) /= 1) THEN
157 ii = iabs(itagnd(isl))
158 n1 = icnds10(2,ii)
159 n2 = icnds10(3,ii)
160 is1 = intab(nsn,intbuf_tab(n)%NSV,n1)
161 is2 = intab(nsn,intbuf_tab(n)%NSV,n2)
162 IF (.NOT.(is1).OR..NOT.(is2)) pentag(isl) = 1
163 END IF
164 ENDDO
165 END IF !(NTY == 2 )
166 ENDDO
167C----------------------------------------------------------
168 itagmd(1:numnod) = 0
169 DO i = 1, ns10e
170 n = iabs(icnds10(1,i))
171 itagmd(n) = i
172 END DO
173C---- ITAGMD :tag nd M of int2 > NS10E
174C---- <0 tag n1,n2 S w/o penality of int2
175 DO n=1,ninter
176 nty = ipari(7,n)
177 IF (nty == 2 ) THEN
178 nmn =ipari(6,n)
179 nsn = ipari(5,n)
180 ilev = ipari(20,n)
181 IF (ilev == 27 .or. ilev == 28) THEN
182 DO i=1,nsn
183 isl = intbuf_tab(n)%NSV(i)
184 IF (pentag(isl) /= 1.AND.itagmd(isl)==0) itagmd(isl)=-1
185 END DO
186 DO i=1,nmn
187 iml = intbuf_tab(n)%MSR(i)
188 IF (itagmd(iml)>0) itagmd(iml) = itagmd(iml) + ns10e
189 ENDDO
190 END IF
191 END IF
192 END DO
193 DO i = 1, ns10e
194 n = iabs(icnds10(1,i))
195 n1 = icnds10(2,i)
196 n2 = icnds10(3,i)
197 IF (itagmd(n)>ns10e.OR.pentag(n)==1) THEN
198 IF (itagmd(n1)<0) pentag(n1)=1
199 IF (itagmd(n2)<0) pentag(n2)=1
200 END IF
201 END DO
202 END IF !(NS10E>0) THEN
203C----------------------------------------------------------
204C - not-autorised hierarchy :RBE3/INT2
205C----------------------------------------------------------
206 DO i=1,nrbe3
207 iad = irbe3(1,i)
208 nmn = irbe3(5,i)
209 DO j =1,nmn
210 m = lrbe3(iad+j)
211 IF (pentag(m)==0) pentag(m)=1
212 END DO
213 END DO
214C----------------------------------------------------------
215C - not-autorised hierarchy :RBE2/INT2
216C----------------------------------------------------------
217 DO i=1,nrbe2
218 m = irbe2(3,i)
219 IF (pentag(m)==0) pentag(m)=1
220 END DO
221C
222 DO n=1,ninter
223 nty = ipari(7,n)
224 ilev = ipari(20,n)
225 IF (nty == 2 .and. (ilev == 27.or. ilev == 28)) THEN
226 nsn = ipari(5,n)
227 noint = ipari(15,n)
228 nint = n
229
230c ID=NOM_OPT(1,NINT)
231 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,nint),ltitr)
232 DO i=1,nsn
233 isl = intbuf_tab(n)%NSV(i)
234 IF (pentag(isl) == 1) THEN
235C penalty node - set penalty flag
236 intbuf_tab(n)%IRUPT(i) = 1
237 itf(ikine(isl)) = 0
238 CALL ancmsg(msgid=1179,
239 . msgtype=msgwarning,
240 . anmode=aninfo_blind_1,
241 . i1=itab(isl),
242 . prmod=msg_cumu)
243 ELSE
244C kinematic node - set kine flag for RWALL deactivation in Kinchk
245 CALL kinset(2,itab(isl),ikine(isl),1,0,ikine1(isl))
246 CALL kinset(2,itab(isl),ikine(isl),2,0,ikine1(isl))
247 CALL kinset(2,itab(isl),ikine(isl),3,0,ikine1(isl))
248 CALL kinset(2,itab(isl),ikine(isl),4,0,ikine1(isl))
249 CALL kinset(2,itab(isl),ikine(isl),5,0,ikine1(isl))
250 CALL kinset(2,itab(isl),ikine(isl),6,0,ikine1(isl))
251 ENDIF
252 ENDDO
253 ENDIF
254 CALL ancmsg(msgid=1179,
255 . msgtype=msgwarning,
256 . anmode=aninfo_blind_1,
257 . i1=noint,
258 . c1=titr,
259 . prmod=msg_print)
260 ENDDO
261C
262 WRITE(iout,*)''
263 DEALLOCATE( pentag,tagnos,itagmd )
264 DEALLOCATE( ikine1 )
265c-----------
266 RETURN
267 END
inintr2
subroutine inintr2(ipari, inscr, x, ixs, ixq, ixc, pm, geo, intc, itab, ms, npby, lpby, mwa, ikine, i2nsnt, in, stifn, stifint, nom_opt, inod_pxfem, ms_ply, intbuf_tab, stifintr, itagnd, icnds10, ms_b, in_b, nstrf, itagcyc, irbe2, irbe3, lrbe3, knod2els, nod2els, ixs10, ixs16, ixs20, s_nod2els)
Definition inintr2.F:58
itagsl2
subroutine itagsl2(ipari, nom_opt, itab, ikine, intbuf_tab, itagnd, icnds10, nstrf, itagcyc, irbe2, irbe3, lrbe3)
Definition itagsl2.F:38
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
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
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
starter
program starter
Definition starter.F:39