OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i2tid3.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!|| i2tid3 ../starter/source/interfaces/inter3d1/i2tid3.F
25!||--- called by ------------------------------------------------------
26!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| kinset ../starter/source/constraints/general/kinset.F
30!||--- uses -----------------------------------------------------
31!|| message_mod ../starter/share/message_module/message_mod.F
32!|| nod2el_mod ../starter/share/modules1/nod2el_mod.f
33!||====================================================================
34 SUBROUTINE i2tid3(X ,IRECT ,ST ,MSR ,NSV ,
35 2 IRTL ,ITAB ,IKINE ,IKINE1,DMIN ,
36 3 IPARI ,TZINF ,IDDLEVEL,
37 4 ID,TITR,INTBUF_TAB ,DSEARCH, IPROJ,
38 5 IXS,IXC,IXS10,IXS16,IXS20,STB ,
39 6 NSN_MULTI_CONNEC,T2_ADD_CONNEC,T2_NB_CONNEC,T2_CONNEC,IXTG)
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE message_mod
44 USE intbufdef_mod
45 USE nod2el_mod
46 USE names_and_titles_mod , ONLY : nchartitle
47 use element_mod , only :nixs,nixc,nixtg
48C============================================================================
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52#include "com04_c.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "units_c.inc"
57#include "scr03_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER IRECT(4,*), MSR(*), NSV(*),IRTL(*),
62 . ITAB(*),IKINE(*),IKINE1(*),IPARI(*),
63 . IXS(NIXS,*),IXC(NIXC,*),IXS10(6,*),IXS16(8,*),IXS20(12,*),IXTG(NIXTG,*)
64 INTEGER IDDLEVEL,IPROJ,NSN_MULTI_CONNEC,T2_ADD_CONNEC(*),T2_CONNEC(*),T2_NB_CONNEC(*)
65C REAL
66 my_real
67 . x(3,*),st(2,*),dmin(*),tzinf,dsearch,stb(2,*)
68 INTEGER ID
69 CHARACTER(LEN=NCHARTITLE) :: TITR
70
71 TYPE(intbuf_struct_) INTBUF_TAB
72C-----------------------------------------------
73C L o c a l V a r i a b l e s
74C-----------------------------------------------
75 INTEGER II,JJ,I,J,K,L,M,IGNORE,ILEV,NUVAR,IDEL7N,
76 . nsn, nmn,nsnu,nmnu,nrtm,intth,iib,kk,common_nodes,doublon,iadd,idip
77 INTEGER CPT,N1,N2,N3,N4,FLAG_SOLID,FLAG_SHELL,NNOD,NB_LIST_COMPT,
78 . LIST_COMPT(2,NINTER),FOUND,FOUND_NOD(4)
79 my_real
80 . lb1,lc1,la1,aaa
81 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGS,TAGM
82C=======================================================================
83 ALLOCATE( tags(numnod),tagm(numnod) )
84 nrtm = ipari(4)
85 nsn = ipari(5)
86 nmn = ipari(6)
87 ilev = ipari(20)
88 ignore = ipari(34)
89 intth = ipari(47)
90 list_compt = 0
91 nb_list_compt = 0
92C
93 tags(1:numnod) = 0
94 l=0
95C
96 cpt = 0
97 DO ii=1,nsn
98 i = nsv(ii)
99 l = irtl(ii)
100C
101 IF (ilev /= 25 .and. ilev /= 26 .and. ilev /= 27 .and. ilev /= 28 .and. l /= 0) THEN
102 CALL kinset(2,itab(i),ikine(i),1,0,ikine1(i))
103 CALL kinset(2,itab(i),ikine(i),2,0,ikine1(i))
104 CALL kinset(2,itab(i),ikine(i),3,0,ikine1(i))
105 CALL kinset(2,itab(i),ikine(i),4,0,ikine1(i))
106 CALL kinset(2,itab(i),ikine(i),5,0,ikine1(i))
107 CALL kinset(2,itab(i),ikine(i),6,0,ikine1(i))
108 ENDIF
109 IF (l == 0 .AND. ignore == 0) THEN
110 CALL ancmsg(msgid=1078,
111 . msgtype=msgerror,
112 . anmode=aninfo_blind_1,
113 . r1=tzinf,
114 . i1=itab(i) ,
115 . prmod=msg_cumu)
116 ELSEIF (l == 0 .AND. ignore >= 2 .AND. dsearch == 0) THEN
117 CALL ancmsg(msgid=1071,
118 . msgtype=msgwarning,
119 . anmode=aninfo_blind_1,
120 . i1=itab(i),
121 . prmod=msg_cumu)
122 cpt = cpt + 1
123 ELSEIF (l == 0 .AND. ignore >= 1) THEN
124 CALL ancmsg(msgid=1157,
125 . msgtype=msgwarning,
126 . anmode=aninfo_blind_1,
127 . r1=tzinf,
128 . i1=itab(i) ,
129 . prmod=msg_cumu)
130 cpt = cpt + 1
131
132 ELSEIF ((ilev == 25 .OR. ((ilev == 27).AND.(irect(3,l)/=irect(4,l))) .OR. ilev == 26 .OR. ilev == 28) .and.
133 . (st(1,ii) > onep5 .OR. st(2,ii) > onep5 .OR.
134 . st(1,ii) <-onep5 .OR. st(2,ii) <-onep5)) THEN
135 irtl(ii)=0
136 CALL ancmsg(msgid=1158,
137 . msgtype=msgwarning,
138 . anmode=aninfo_blind_1,
139 . i1=itab(i),
140 . i2=l,
141 . i3=itab(irect(1,l)),
142 . i4=itab(irect(2,l)),
143 . i5=itab(irect(3,l)),
144 . i6=itab(irect(4,l)),
145 . r1= st(1,ii) ,
146 . r2= st(2,ii) ,
147 . r3=dmin(ii) ,
148 . prmod=msg_cumu)
149 ELSEIF ((ilev == 27).AND.(irect(3,l)==irect(4,l))
150 . .and.(st(1,ii) < -fourth .OR. st(2,ii) < -fourth .OR.
151 . st(1,ii)+ st(2,ii) > onep25)) THEN
152C-- shape funnction in space of triangle - node removed
153 irtl(ii)=0
154 CALL ancmsg(msgid=1872,
155 . msgtype=msgwarning,
156 . anmode=aninfo_blind_1,
157 . i1=itab(i),
158 . i2=l,
159 . i3=itab(irect(1,l)),
160 . i4=itab(irect(2,l)),
161 . i5=itab(irect(3,l)),
162 . r1= st(1,ii) ,
163 . r2= st(2,ii) ,
164 . r3=dmin(ii) ,
165 . prmod=msg_cumu)
166 ELSEIF ((ilev == 27).AND.(irect(3,l)==irect(4,l))
167 . .and.(st(1,ii) < -zep01 .OR. st(2,ii) < -zep01 .OR.
168 . st(1,ii) + st(2,ii) > onep01)) THEN
169C-- shape funnction in space of triangle - warning node outside
170 CALL ancmsg(msgid=1873,
171 . msgtype=msgwarning,
172 . anmode=aninfo_blind_1,
173 . i1=itab(i),
174 . i2=l,
175 . i3=itab(irect(1,l)),
176 . i4=itab(irect(2,l)),
177 . i5=itab(irect(3,l)),
178 . r1= st(1,ii) ,
179 . r2= st(2,ii) ,
180 . r3=dmin(ii) ,
181 . prmod=msg_cumu)
182 ELSEIF (st(1,ii) > onep02 .OR. st(2,ii) > onep02 .OR.
183 . st(1,ii) <-onep02 .OR. st(2,ii) <-onep02) THEN
184 CALL ancmsg(msgid=1079,
185 . msgtype=msgwarning,
186 . anmode=aninfo_blind_1,
187 . i1=itab(i),
188 . i2=l,
189 . i3=itab(irect(1,l)),
190 . i4=itab(irect(2,l)),
191 . i5=itab(irect(3,l)),
192 . i6=itab(irect(4,l)),
193 . r1= st(1,ii) ,
194 . r2= st(2,ii) ,
195 . r3=dmin(ii) ,
196 . prmod=msg_cumu)
197 ELSE
198 IF ((ilev==27).and.(irect(3,l)==irect(4,l))) THEN
199C-- specific printout for triangles
200 tags(i) = 2
201 ELSE
202 tags(i) = 1
203 ENDIF
204 ENDIF
205 ENDDO
206C
207C----------------------------------------------
208C printout of tied connections
209C----------------------------------------------
210C
211 IF (ipri > 0) THEN
212 IF (ilev /= 27) THEN
213 WRITE(iout,2022)
214 DO ii=1,nsn
215 i = nsv(ii)
216 l = irtl(ii)
217 IF (tags(i) == 1) WRITE(iout,'(6I10,2F8.4,1PG20.13)') itab(i),l,(itab(irect(jj,l)),jj=1,4),st(1,ii),st(2,ii),dmin(ii)
218 ENDDO
219 ELSE
220C-- printout for quadrangles
221 WRITE(iout,2023)
222 DO ii=1,nsn
223 i = nsv(ii)
224 l = irtl(ii)
225 IF (tags(i) == 1) WRITE(iout,'(6I10,2F8.4,1PG20.13)') itab(i),l,(itab(irect(jj,l)),jj=1,4),st(1,ii),st(2,ii),dmin(ii)
226 ENDDO
227C-- printout for triangles
228 WRITE(iout,2024)
229 DO ii=1,nsn
230 i = nsv(ii)
231 l = irtl(ii)
232 IF (tags(i) == 2) WRITE(iout,'(5I10,2F8.4,1PG20.13)') itab(i),l,(itab(irect(jj,l)),jj=1,3),st(1,ii),st(2,ii),dmin(ii)
233 ENDDO
234 ENDIF
235 ENDIF
236C
237 DO ii=1,nsn
238 dmin(ii) = 0
239 ENDDO
240C
241 CALL ancmsg(msgid=1071,
242 . msgtype=msgwarning,
243 . anmode=aninfo_blind_1,
244 . i1=id,
245 . c1=titr ,
246 . prmod=msg_print )
247
248 IF(cpt == nsn) THEN
249 IF (l == 0 .AND. ignore >= 2 .AND. dsearch == 0) THEN
250 CALL ancmsg(msgid=1217,
251 . msgtype=msgwarning,
252 . anmode=aninfo_blind_1,
253 . i1=id,
254 . c1=titr)
255
256
257 ELSEIF (l == 0 .AND. ignore >= 1) THEN
258
259 CALL ancmsg(msgid=1218,
260 . msgtype=msgwarning,
261 . anmode=aninfo_blind_1,
262 . i1=id,
263 . c1=titr)
264 ENDIF
265 ENDIF
266
267
268
269 CALL ancmsg(msgid=1078,
270 . msgtype=msgerror,
271 . anmode=aninfo_blind_1,
272 . i1=id,
273 . c1=titr ,
274 . prmod=msg_print)
275
276
277 CALL ancmsg(msgid=1079,
278 . msgtype=msgwarning,
279 . anmode=aninfo_blind_1,
280 . i1=id,
281 . c1=titr ,
282 . prmod=msg_print )
283
284 CALL ancmsg(msgid=1873,
285 . msgtype=msgwarning,
286 . anmode=aninfo_blind_1,
287 . i1=id,
288 . c1=titr ,
289 . prmod=msg_print )
290
291 CALL ancmsg(msgid=1157,
292 . msgtype=msgwarning,
293 . anmode=aninfo_blind_1,
294 . i1=id,
295 . c1=titr ,
296 . prmod=msg_print )
297
298 CALL ancmsg(msgid=1158,
299 . msgtype=msgwarning,
300 . anmode=aninfo_blind_1,
301 . i1=id,
302 . c1=titr ,
303 . prmod=msg_print )
304
305 CALL ancmsg(msgid=1872,
306 . msgtype=msgwarning,
307 . anmode=aninfo_blind_1,
308 . i1=id,
309 . c1=titr ,
310 . prmod=msg_print )
311C
312C----------------------------------------------
313c tag valid SECONDARY and MAIN nodes
314c----------------------------------------------
315C
316 tags(1:numnod) = 0
317C
318 DO i = 1, nmn
319 tagm(msr(i)) = 0
320 ENDDO
321C
322 DO ii = 1,nsn
323 i = nsv(ii)
324 j = irtl(ii)
325 IF (i > 0 .AND. j > 0) THEN
326 tags(ii) = 1
327 DO k = 1, 4
328 m = irect(k,j)
329 IF (m > 0) tagm(m) = 1
330 ENDDO
331 ENDIF
332 ENDDO
333C----------------------------------------------
334c Check if the same MAIN/SECONDARY connection is defined in several T2 interfaces
335c----------------------------------------------
336 IF (((ilev == 27).OR.(ilev == 28)).AND.(nsn_multi_connec > 0)) THEN
337C
338 DO ii = 1,nsn
339 i = nsv(ii)
340 j = irtl(ii)
341 IF ((tags(ii) == 1).AND.(t2_nb_connec(i)>1)) THEN
342 iadd = t2_add_connec(i)
343 doublon = 0
344C
345 DO idip=1,t2_connec(iadd)
346C-- loop on already stored connections if any
347 common_nodes = 0
348 DO k = 1, 4
349 DO kk = 1,4
350 IF (t2_connec(iadd+5*(idip-1)+k) == irect(kk,j)) common_nodes = common_nodes + 1
351 ENDDO
352 ENDDO
353 IF (common_nodes == 4) THEN
354C-- connection deactivated - doublon
355 tags(ii) = 0
356 doublon = 1
357 DO k = 1, 4
358 m = irect(k,j)
359 IF (m > 0) tagm(m) = 0
360 ENDDO
361C-- List of interfaces for output of common connections
362 found = 0
363 DO k=1,nb_list_compt
364 IF (list_compt(1,k)==t2_connec(iadd+5*(idip-1)+5)) found=k
365 ENDDO
366 IF (found == 0) THEN
367 nb_list_compt = nb_list_compt + 1
368 list_compt(1,nb_list_compt)=t2_connec(iadd+5*(idip-1)+5)
369 list_compt(2,nb_list_compt)= 1
370 ELSE
371 list_compt(2,found) = list_compt(2,found) + 1
372 ENDIF
373 EXIT
374 ENDIF
375 ENDDO
376C
377 IF (doublon == 0) THEN
378C-- New connection - is stored
379 idip = t2_connec(iadd)
380 t2_connec(iadd) = t2_connec(iadd) + 1
381 DO k = 1, 3
382 t2_connec(iadd+5*idip+k) = irect(k,j)
383 ENDDO
384 IF (irect(3,j) /= irect(4,j)) t2_connec(iadd+5*idip+4) = irect(4,j)
385 t2_connec(iadd+5*idip+5) = id
386 ENDIF
387C
388 ENDIF
389 ENDDO
390C
391 IF (nb_list_compt > 0) THEN
392C------ Warning printout --------------
393 DO i = 1,nb_list_compt
394 CALL ancmsg(msgid=1630,
395 . msgtype=msgwarning,
396 . anmode=aninfo_blind_1,
397 . i1=list_compt(2,i),
398 . i2=list_compt(1,i),
399 . prmod=msg_cumu)
400 ENDDO
401C
402 CALL ancmsg(msgid=1630,
403 . msgtype=msgwarning,
404 . anmode=aninfo_blind_1,
405 . i1=id,
406 . c1=titr,
407 . prmod=msg_print)
408 ENDIF
409C
410 ENDIF
411C----------------------------------------------
412c projection on edges for valid SECONDARY nodes outside of MAIN element
413c----------------------------------------------
414 IF (iproj == 1 .and. ilev/=1 .and. ilev/=30 .and. ilev/=28) THEN
415C--- Projection on edges is used only for the distribution of masses and inertia to avoid negative masses / inertia on MAIN nodes
416 DO ii= 1,nsn
417 IF (tags(ii) == 1) THEN
418 j = irtl(ii)
419 IF (irect(3,j)/=irect(4,j)) THEN
420C-- square
421 stb(1,ii)= min(one,max(-1*one,st(1,ii)))
422 stb(2,ii)= min(one,max(-1*one,st(2,ii)))
423 ELSE
424C-- triangle
425 stb(1,ii)= st(1,ii)
426 stb(2,ii)= st(2,ii)
427 IF (ilev == 27) THEN
428C-- hape functions in space of the triangle
429 lb1=st(1,ii)
430 lc1=st(2,ii)
431 ELSE
432C-- shape functions in space of quadrangle
433 lb1=fourth*(one - st(2,ii))*(one - st(1,ii))
434 lc1=fourth*(one - st(2,ii))*(one + st(1,ii))
435 ENDIF
436 la1= one - lb1 - lc1
437 IF(la1 < zero .or. lb1 < zero .or. lc1 < zero)THEN
438 IF(la1<zero.and.lb1<zero)THEN
439 la1 = zero
440 lb1 = zero
441 lc1 = one
442 ELSEIF(lb1<zero.and.lc1<zero)THEN
443 lb1 = zero
444 lc1 = zero
445 la1 = one
446 ELSEIF(lc1<zero.and.la1<zero)THEN
447 lc1 = zero
448 la1 = zero
449 lb1 = one
450 ELSEIF(la1<zero)THEN
451 la1 = zero
452 aaa = lb1 + lc1
453 lb1 = lb1/aaa
454 lc1 = lc1/aaa
455 ELSEIF(lb1<zero)THEN
456 lb1 = zero
457 aaa = lc1 + la1
458 lc1 = lc1/aaa
459 la1 = la1/aaa
460 ELSEIF(lc1<zero)THEN
461 lc1 = zero
462 aaa = la1 + lb1
463 la1 = la1/aaa
464 lb1 = lb1/aaa
465 ENDIF
466C
467 IF (ilev == 27) THEN
468C-- shape functions in space of the triangle
469 stb(1,ii) = lb1
470 stb(2,ii) = lc1
471 ELSE
472C-- shape functions in space of the quadrangle
473 stb(2,ii) = one - two*lb1 - two*lc1
474 IF (stb(2,ii) < one-em10) THEN
475 stb(1,ii)= (lc1-lb1)/(lc1+lb1)
476 ELSEIF (lb1 < -em10) THEN
477 stb(1,ii)= two
478 ELSEIF (lc1 < -em10) THEN
479 stb(1,ii)= -two
480 ELSE
481 stb(1,ii)= zero
482 ENDIF
483 ENDIF
484C
485 END IF
486 ENDIF
487 ENDIF
488 ENDDO
489 ELSEIF (iproj == 3 .and. ilev/=1 .and. ilev/=30 .and. ilev/=28) THEN
490C--- Projection on edges - used only for retrocompatibility with old iproj=1 flag
491 DO ii= 1,nsn
492 IF (tags(ii) == 1) THEN
493 j = irtl(ii)
494 IF (irect(3,j)/=irect(4,j)) THEN
495C-- square
496 st(1,ii)= min(one,max(-1*one,st(1,ii)))
497 st(2,ii)= min(one,max(-1*one,st(2,ii)))
498 ELSE
499C-- triangle
500 IF (ilev == 27) THEN
501C-- shape functions in space of the triangle
502 lb1=st(1,ii)
503 lc1=st(2,ii)
504 ELSE
505C-- shape functions in space of quadrangle
506 lb1=fourth*(one - st(2,ii))*(one - st(1,ii))
507 lc1=fourth*(one - st(2,ii))*(one + st(1,ii))
508 ENDIF
509 la1= one - lb1 - lc1
510 IF(la1 < zero .or. lb1 < zero .or. lc1 < zero)THEN
511 IF(la1<zero.and.lb1<zero)THEN
512 la1 = zero
513 lb1 = zero
514 lc1 = one
515 ELSEIF(lb1<zero.and.lc1<zero)THEN
516 lb1 = zero
517 lc1 = zero
518 la1 = one
519 ELSEIF(lc1<zero.and.la1<zero)THEN
520 lc1 = zero
521 la1 = zero
522 lb1 = one
523 ELSEIF(la1<zero)THEN
524 la1 = zero
525 aaa = lb1 + lc1
526 lb1 = lb1/aaa
527 lc1 = lc1/aaa
528 ELSEIF(lb1<zero)THEN
529 lb1 = zero
530 aaa = lc1 + la1
531 lc1 = lc1/aaa
532 la1 = la1/aaa
533 ELSEIF(lc1<zero)THEN
534 lc1 = zero
535 aaa = la1 + lb1
536 la1 = la1/aaa
537 lb1 = lb1/aaa
538 ENDIF
539C
540 IF (ilev == 27) THEN
541C-- shape functions in space of the triangle
542 st(1,ii) = lb1
543 st(2,ii) = lc1
544 ELSE
545C-- shape functions in space of the quadrangle
546 st(2,ii) = one - two*lb1 - two*lc1
547 IF (st(2,ii) < one-em10) THEN
548 st(1,ii)= (lc1-lb1)/(lc1+lb1)
549 ELSEIF (lb1 < -em10) THEN
550 st(1,ii)= two
551 ELSEIF (lc1 < -em10) THEN
552 st(1,ii)= -two
553 ELSE
554 st(1,ii)= zero
555 ENDIF
556 ENDIF
557C
558 END IF
559 ENDIF
560 stb(1,ii)=st(1,ii)
561 stb(2,ii)=st(2,ii)
562 ENDIF
563 ENDDO
564 ELSE
565 DO ii= 1,nsn
566 stb(1,ii)=st(1,ii)
567 stb(2,ii)=st(2,ii)
568 ENDDO
569 ENDIF
570C
571C----------------------------------------------
572c Update NSN and MNM
573C----------------------------------------------
574 nsnu = 0
575 DO i = 1,nsn
576 IF (tags(i) == 1) THEN
577 nsnu = nsnu+1
578 intbuf_tab%NSV(nsnu) = intbuf_tab%NSV(i)
579 ENDIF
580 ENDDO
581C
582 nmnu = 0
583 DO i = 1, nmn
584 m = msr(i)
585 IF (tagm(m) == 1) THEN
586 nmnu = nmnu+1
587 intbuf_tab%MSR(nmnu) = intbuf_tab%MSR(i)
588 ENDIF
589 ENDDO
590 ipari(5) = nsnu
591 ipari(6) = nmnu
592C-----------------------------------------------
593C Compact INT BUFFER
594C-----------------------------------------------
595C
596 j = 0
597 DO i = 1,nsn
598 IF (tags(i) == 1) THEN
599 j=j+1
600 intbuf_tab%IRTLM(j) = intbuf_tab%IRTLM(i)
601 ENDIF
602 ENDDO
603 IF (ilev == 10 .OR. ilev == 11 .OR. ilev == 12 .OR.
604 . ilev == 20 .OR. ilev == 21 .OR. ilev == 22) THEN
605 j = 0
606 DO i = 1,nsn
607 IF (tags(i) == 1) THEN
608 j = j+1
609 intbuf_tab%IRUPT(j) = intbuf_tab%IRUPT(i)
610 ENDIF
611 ENDDO
612 ELSEIF ((ilev == 27).OR.(ilev == 28)) THEN
613 j = 0
614 DO i = 1,nsn
615 IF (tags(i) == 1) THEN
616 j = j+1
617 intbuf_tab%IRUPT(j) = intbuf_tab%IRUPT(i)
618 ENDIF
619 ENDDO
620 ENDIF
621C-----------------------------------------------
622C Compact REAL BUFFER
623C-----------------------------------------------
624 idel7n = ipari(17)
625 nuvar = ipari(35)
626C-----------------------------------------------
627 j = 0
628 DO i= 1,nsn
629 IF (tags(i) == 1) THEN
630 j = j+1
631 intbuf_tab%CSTS(1+2*(j-1)) = intbuf_tab%CSTS(1+2*(i-1))
632 intbuf_tab%CSTS(1+2*(j-1)+1) = intbuf_tab%CSTS(1+2*(i-1)+1)
633 intbuf_tab%CSTS_BIS(1+2*(j-1)) = intbuf_tab%CSTS_BIS(1+2*(i-1))
634 intbuf_tab%CSTS_BIS(1+2*(j-1)+1) = intbuf_tab%CSTS_BIS(1+2*(i-1)+1)
635 ENDIF
636 ENDDO
637 j = 0
638 DO i = 1,nsn
639 IF (tags(i) == 1) THEN
640 j=j+1
641 intbuf_tab%DPARA(1+7*(j-1)) = intbuf_tab%DPARA(1+7*(i-1))
642 intbuf_tab%DPARA(1+7*(j-1)+1) = intbuf_tab%DPARA(1+7*(i-1)+1)
643 intbuf_tab%DPARA(1+7*(j-1)+2) = intbuf_tab%DPARA(1+7*(i-1)+2)
644 intbuf_tab%DPARA(1+7*(j-1)+3) = intbuf_tab%DPARA(1+7*(i-1)+3)
645 intbuf_tab%DPARA(1+7*(j-1)+4) = intbuf_tab%DPARA(1+7*(i-1)+4)
646 intbuf_tab%DPARA(1+7*(j-1)+5) = intbuf_tab%DPARA(1+7*(i-1)+5)
647 intbuf_tab%DPARA(1+7*(j-1)+6) = intbuf_tab%DPARA(1+7*(i-1)+6)
648 ENDIF
649 ENDDO
650 j = 0
651 DO i = 1,nmn
652 IF (tagm(msr(i)) == 1) THEN
653 j=j+1
654 intbuf_tab%NMAS(j) = intbuf_tab%NMAS(i)
655 intbuf_tab%NMAS(nmnu+j) = intbuf_tab%NMAS(nmn+i)
656 ENDIF
657 ENDDO
658 IF (idel7n /= 0)THEN
659 j = 0
660 DO i = 1,nsn
661 IF (tags(i) == 1) THEN
662 j=j+1
663 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
664 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
665 ENDIF
666 ENDDO
667 ENDIF
668C-----------------------------------------------
669 IF (ilev==10 .OR. ilev==11 .OR. ilev==12 .OR. ilev==20 .OR.
670 . ilev==21 .OR. ilev==22 .OR. intth > 0) THEN
671 j = 0
672 DO i = 1,nsn
673 IF (tags(i) == 1) THEN
674 j=j+1
675 intbuf_tab%AREAS2(j) = intbuf_tab%AREAS2(i)
676 DO k = 0,nuvar-1
677 intbuf_tab%UVAR(1+nuvar*(j-1)+k) =
678 . intbuf_tab%UVAR(1+nuvar*(i-1)+k)
679 ENDDO
680 ENDIF
681 ENDDO
682 ENDIF
683 IF (ilev==10 .OR. ilev==11 .OR. ilev==12) THEN
684 j = 0
685 DO i = 1,nsn
686 IF (tags(i) == 1) THEN
687 j=j+1
688 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
689 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
690c INTBUF_TAB%AREAS2(J) = INTBUF_TAB%AREAS2(I)
691 DO k = 0,nuvar-1
692 intbuf_tab%UVAR(1+nuvar*(j-1)+k) =
693 . intbuf_tab%UVAR(1+nuvar*(i-1)+k)
694 ENDDO
695 DO k = 0,2
696 intbuf_tab%XM0(1+3*(j-1)+k) = intbuf_tab%XM0(1+3*(i-1)+k)
697 intbuf_tab%DSM(1+3*(j-1)+k) = intbuf_tab%DSM(1+3*(i-1)+k)
698 intbuf_tab%FSM(1+3*(j-1)+k) = intbuf_tab%FSM(1+3*(i-1)+k)
699 ENDDO
700 ENDIF
701 ENDDO
702 ELSEIF (ilev==20 .OR. ilev==21 .OR. ilev==22) THEN
703 j = 0
704 DO i = 1,nsn
705 IF (tags(i) == 1) THEN
706 j = j+1
707 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
708 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
709c INTBUF_TAB%AREAS2(J) = INTBUF_TAB%AREAS2(I)
710 DO k = 0,nuvar-1
711 intbuf_tab%UVAR(1+nuvar*(j-1)+k) =
712 . intbuf_tab%UVAR(1+nuvar*(i-1)+k)
713 ENDDO
714 DO k = 0,2
715 intbuf_tab%XM0(1+3*(j-1)+k) = intbuf_tab%XM0(1+3*(i-1)+k)
716 intbuf_tab%DSM(1+3*(j-1)+k) = intbuf_tab%DSM(1+3*(i-1)+k)
717 intbuf_tab%FSM(1+3*(j-1)+k) = intbuf_tab%FSM(1+3*(i-1)+k)
718 ENDDO
719 ENDIF
720 ENDDO
721 DO k = 0,5
722 intbuf_tab%RUPT(1+k) = intbuf_tab%RUPT(1+k)
723 ENDDO
724 ELSEIF (ilev == 25) THEN
725 j = 0
726 DO i = 1,nsn
727 IF (tags(i) == 1) THEN
728 j = j+1
729 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
730 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
731 intbuf_tab%SPENALTY(j) = intbuf_tab%SPENALTY(i)
732 intbuf_tab%STFR_PENALTY(j) = intbuf_tab%STFR_PENALTY(i)
733 DO k = 0,8
734 intbuf_tab%SKEW(1+9*(j-1)+k) = intbuf_tab%SKEW(1+9*(i-1)+k)
735 ENDDO
736 DO k = 0,2
737 intbuf_tab%DSM(1+3*(j-1)+k) = intbuf_tab%DSM(1+3*(i-1)+k)
738 intbuf_tab%FSM(1+3*(j-1)+k) = intbuf_tab%FSM(1+3*(i-1)+k)
739 intbuf_tab%FINI(1+3*(j-1)+k) = intbuf_tab%FINI(1+3*(i-1)+k)
740 ENDDO
741 ENDIF
742 ENDDO
743 ELSEIF (ilev == 26) THEN
744 j = 0
745 DO i = 1,nsn
746 IF (tags(i) == 1) THEN
747 j = j+1
748 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
749 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
750 intbuf_tab%SPENALTY(j) = intbuf_tab%SPENALTY(i)
751 intbuf_tab%STFR_PENALTY(j) = intbuf_tab%STFR_PENALTY(i)
752 DO k = 0,8
753 intbuf_tab%SKEW(1+9*(j-1)+k) = intbuf_tab%SKEW(1+9*(i-1)+k)
754 ENDDO
755 DO k = 0,11
756 intbuf_tab%DSM(1+12*(j-1)+k) = intbuf_tab%DSM(1+12*(i-1)+k)
757 intbuf_tab%FSM(1+12*(j-1)+k) = intbuf_tab%FSM(1+12*(i-1)+k)
758 ENDDO
759 DO k = 0,23
760 intbuf_tab%FINI(1+24*(j-1)+k) = intbuf_tab%FINI(1+24*(i-1)+k)
761 ENDDO
762 ENDIF
763 ENDDO
764 ELSEIF (ilev == 27) THEN
765 j = 0
766 DO i = 1,nsn
767 IF (tags(i) == 1) THEN
768 j = j+1
769 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
770 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
771 intbuf_tab%SPENALTY(j) = intbuf_tab%SPENALTY(i)
772 intbuf_tab%STFR_PENALTY(j) = intbuf_tab%STFR_PENALTY(i)
773 DO k = 0,8
774 intbuf_tab%SKEW(1+9*(j-1)+k) = intbuf_tab%SKEW(1+9*(i-1)+k)
775 ENDDO
776 DO k = 0,2
777 intbuf_tab%DSM(1+3*(j-1)+k) = intbuf_tab%DSM(1+3*(i-1)+k)
778 intbuf_tab%FSM(1+3*(j-1)+k) = intbuf_tab%FSM(1+3*(i-1)+k)
779 intbuf_tab%FINI(1+3*(j-1)+k) = intbuf_tab%FINI(1+3*(i-1)+k)
780 ENDDO
781 ENDIF
782 ENDDO
783C
784C-----------------------------------------------
785C--- Check MAIN segment type :
786C solid MAIN surface -> MSEGTYP2 = 0
787C shell MAIN surface -> MSEGTYP2 = 1
788C coating shell treated as solid MAIN surface -> MSEGTYP2 = 0
789C-----------------------------------------------
790C
791 DO i = 1,nrtm
792 intbuf_tab%MSEGTYP2(i) = 0
793 n1 = irect(1,i)
794 n2 = irect(2,i)
795 n3 = irect(3,i)
796 n4 = irect(4,i)
797 IF(n4 == 0) n4 = n3
798C--> Check of solids elements connected to 1st node
799C Warning : if the segment is inside the solid it's also considered as a solid segment
800 flag_solid = 0
801 DO j = knod2els(n1)+1,knod2els(n1+1)
802 ii = nod2els(j)
803 found_nod(1)=1
804 found_nod(2:4)=0
805 DO k = 2,9
806 IF (ixs(k,ii)==n2) found_nod(2) = 1
807 IF (ixs(k,ii)==n3) found_nod(3) = 1
808 IF (ixs(k,ii)==n4) found_nod(4) = 1
809 END DO
810 IF ((ii>numels8).AND.(ii<=numels8+numels10)) THEN
811 iib = ii-numels8
812 DO k = 1,6
813 IF (ixs10(k,iib)==n2) found_nod(2) = 1
814 IF (ixs10(k,iib)==n3) found_nod(3) = 1
815 IF (ixs10(k,iib)==n4) found_nod(4) = 1
816 END DO
817 ELSEIF ((ii>numels8+numels10).AND.(ii<= numels8+numels10+numels16)) THEN
818 iib = ii-numels8-numels10
819 DO k = 1,8
820 IF (ixs16(k,iib)==n2) found_nod(2) = 1
821 IF (ixs16(k,iib)==n3) found_nod(3) = 1
822 IF (ixs16(k,iib)==n4) found_nod(4) = 1
823 END DO
824 ELSEIF (ii>numels8+numels10+numels16) THEN
825 iib = ii-numels8-numels10-numels16
826 DO k = 1,12
827 IF (ixs20(k,iib)==n2) found_nod(2) = 1
828 IF (ixs20(k,iib)==n3) found_nod(3) = 1
829 IF (ixs20(k,iib)==n4) found_nod(4) = 1
830 END DO
831 ENDIF
832 nnod = found_nod(1)+found_nod(2)+found_nod(3)+found_nod(4)
833 IF (nnod == 4) flag_solid = 1
834 ENDDO
835C--> Check of shells elements connected to 1st node
836 flag_shell = 0
837 DO j = knod2elc(n1)+1,knod2elc(n1+1)
838 ii = nod2elc(j)
839 found_nod(1)=1
840 found_nod(2:4)=0
841 DO k = 2,5
842 IF (ixc(k,ii)==n2) found_nod(2) = 1
843 IF (ixc(k,ii)==n3) found_nod(3) = 1
844 IF (ixc(k,ii)==n4) found_nod(4) = 1
845 END DO
846 nnod = found_nod(1)+found_nod(2)+found_nod(3)+found_nod(4)
847 IF (nnod == 4) flag_shell = 1
848 ENDDO
849 DO j = knod2eltg(n1)+1,knod2eltg(n1+1)
850 ii = nod2eltg(j)
851 found_nod(1)=1
852 found_nod(2:4)=0
853 DO k = 2,4
854 IF (ixtg(k,ii)==n2) found_nod(2) = 1
855 IF (ixtg(k,ii)==n3) found_nod(3) = 1
856 IF (ixtg(k,ii)==n4) found_nod(4) = 1
857 END DO
858 nnod = found_nod(1)+found_nod(2)+found_nod(3)+found_nod(4)
859 IF (nnod == 4) flag_shell = 1
860 ENDDO
861C-->
862 IF ((flag_shell == 1).AND.(flag_solid == 0)) THEN
863C--> shell MAIN segment
864 intbuf_tab%MSEGTYP2(i) = 1
865 ELSE
866C--> solid MAIN segment or coating shell
867 intbuf_tab%MSEGTYP2(i) = 0
868 ENDIF
869 ENDDO
870C
871 ELSEIF (ilev == 28) THEN
872 j = 0
873 DO i = 1,nsn
874 IF (tags(i) == 1) THEN
875 j = j+1
876 intbuf_tab%SMAS(j) = intbuf_tab%SMAS(i)
877 intbuf_tab%SINER(j) = intbuf_tab%SINER(i)
878 intbuf_tab%SPENALTY(j) = intbuf_tab%SPENALTY(i)
879 intbuf_tab%STFR_PENALTY(j) = intbuf_tab%STFR_PENALTY(i)
880 DO k = 0,8
881 intbuf_tab%SKEW(1+9*(j-1)+k) = intbuf_tab%SKEW(1+9*(i-1)+k)
882 ENDDO
883 DO k = 0,2
884 intbuf_tab%DSM(1+3*(j-1)+k) = intbuf_tab%DSM(1+3*(i-1)+k)
885 intbuf_tab%FSM(1+3*(j-1)+k) = intbuf_tab%FSM(1+3*(i-1)+k)
886 intbuf_tab%FINI(1+3*(j-1)+k) = intbuf_tab%FINI(1+3*(i-1)+k)
887 ENDDO
888 ENDIF
889 ENDDO
890 ENDIF
891C-----------
892 1000 FORMAT(
893 + /,
894 + ' SECONDARY NODE NEAREST SEGMENT MAIN NODES',
895 +' S T ',
896 +' DIST'/
897 + /)
898 2022 FORMAT(//
899 +' SECONDARY NEAREST MAIN NODES SECONDARY '/
900 +' NODE SEGMENT S T DIST')
901 2023 FORMAT(//' PROJECTION ON 4 NODES SEGMENTS '//
902 +' SECONDARY NEAREST MAIN NODES SECONDARY '/
903 +' NODE SEGMENT S T DIST')
904 2024 FORMAT(//' PROJECTION ON 3 NODES SEGMENTS '//
905 +' SECONDARY NEAREST MAIN NODES SECONDARY '/
906 +' NODE SEGMENT S T DIST')
907C-----------
908
909 DEALLOCATE( tags,tagm )
910 RETURN
911 END
my_real
#define my_real
Definition cppsort.cpp:32
i2tid3
subroutine i2tid3(x, irect, st, msr, nsv, irtl, itab, ikine, ikine1, dmin, ipari, tzinf, iddlevel, id, titr, intbuf_tab, dsearch, iproj, ixs, ixc, ixs10, ixs16, ixs20, stb, nsn_multi_connec, t2_add_connec, t2_nb_connec, t2_connec, ixtg)
Definition i2tid3.F:40
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
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
nod2el_mod
Definition nod2el_mod.F:36
nod2el_mod::knod2elc
integer, dimension(:), allocatable knod2elc
Definition nod2el_mod.F:58
nod2el_mod::knod2els
integer, dimension(:), allocatable knod2els
Definition nod2el_mod.F:58
nod2el_mod::nod2eltg
integer, dimension(:), allocatable nod2eltg
Definition nod2el_mod.F:58
nod2el_mod::nod2elc
integer, dimension(:), allocatable nod2elc
Definition nod2el_mod.F:58
nod2el_mod::nod2els
integer, dimension(:), allocatable nod2els
Definition nod2el_mod.F:58
nod2el_mod::knod2eltg
integer, dimension(:), allocatable knod2eltg
Definition nod2el_mod.F:58
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
starter
program starter
Definition starter.F:39