OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i2tid3.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "scr03_c.inc"

Go to the source code of this file.

Functions/Subroutines

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)

Function/Subroutine Documentation

◆ i2tid3()

subroutine i2tid3 ( x,
integer, dimension(4,*) irect,
st,
integer, dimension(*) msr,
integer, dimension(*) nsv,
integer, dimension(*) irtl,
integer, dimension(*) itab,
integer, dimension(*) ikine,
integer, dimension(*) ikine1,
dmin,
integer, dimension(*) ipari,
tzinf,
integer iddlevel,
integer id,
character(len=nchartitle) titr,
type(intbuf_struct_) intbuf_tab,
dsearch,
integer iproj,
integer, dimension(nixs,*) ixs,
integer, dimension(nixc,*) ixc,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
stb,
integer nsn_multi_connec,
integer, dimension(*) t2_add_connec,
integer, dimension(*) t2_nb_connec,
integer, dimension(*) t2_connec,
integer, dimension(nixtg,*) ixtg )

Definition at line 34 of file i2tid3.F.

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