OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i24surfi.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!|| i24surfi ../starter/source/interfaces/inter3d1/i24surfi.F
25!||--- called by ------------------------------------------------------
26!|| lecins ../starter/source/interfaces/interf1/lecins.F
27!|| lecint ../starter/source/interfaces/interf1/lecint.F
28!||--- calls -----------------------------------------------------
29!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
30!|| i24edge1 ../starter/source/interfaces/inter3d1/i24surfi.F
31!|| i24edge2 ../starter/source/interfaces/inter3d1/i24surfi.F
32!|| in24coq_sol3 ../starter/source/interfaces/inter3d1/i24surfi.F
33!|| sh2surf ../starter/source/interfaces/inter3d1/i24surfi.F
34!||--- uses -----------------------------------------------------
35!|| format_mod ../starter/share/modules1/format_mod.F90
36!||====================================================================
37 SUBROUTINE i24surfi(IALLO ,IPARI ,IGRNOD ,IGRSURF ,
38 1 IRECT ,FRIGAP ,
39 2 NSV ,MSR ,ITAB ,X ,
40 3 NBINFLG ,MBINFLG ,MSEGTYP ,ISEADD ,
41 4 ISEDGE ,ITAG ,INTPLY ,IXC ,
42 5 IXTG ,KNOD2ELC,KNOD2ELTG,NOD2ELC,
43 6 NOD2ELTG,KNOD2ELS,NOD2ELS ,IXS ,
44 7 IXS10 ,IXS16 ,IXS20 ,IRTSE ,
45 8 IS2SE ,IS2PT ,IS2ID ,INTNITSCHE)
46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE groupdef_mod
50 USE format_mod , ONLY : fmw_10i, fmw_4i
51 use element_mod , only :nixs
52C-----------------------------------------------
53C I m p l i c i t T y p e s
54C-----------------------------------------------
55#include "implicit_f.inc"
56C-----------------------------------------------
57C C o m m o n B l o c k s
58C-----------------------------------------------
59#include "com04_c.inc"
60#include "units_c.inc"
61#include "param_c.inc"
62#include "scr03_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER IALLO,INTNITSCHE,NBINFLG(*)
67 INTEGER IPARI(NPARI),
68 . IRECT(4,*), NSV(*),MSEGTYP(*),
69 . MSR(*),ITAB(*),MBINFLG(*),
70 . ISEADD(*) ,ISEDGE(*),ITAG(*),INTPLY,
71 . IXC(*),IXTG(*),KNOD2ELC(*),KNOD2ELTG(*),
72 . NOD2ELC(*),NOD2ELTG(*),KNOD2ELS(*),NOD2ELS(*),
73 . IRTSE(5,*) ,IS2SE(*),IS2PT(*) ,IS2ID(*)
74 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
75 my_real
76 . x(3,*),frigap(*)
77C-----------------------------------------------
78 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
79 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
80C-----------------------------------------------
81C L o c a l V a r i a b l e s
82C-----------------------------------------------
83 INTEGER I,J,K,L,LL,NL,ISU1,ISU2,NOD1,NRTM,NRTS,NSN,NMN,
84 . NLINSA,NLINMA,ILEV,IEDGE,NSNE,NMNE,NLN,ISYM,
85 . NLINS,NLINM,LINE1,LINE2,STAT,IADL,IL,IG
86 INTEGER TAG(NUMNOD),TAGS(NUMNOD),NEXTK(4),IWORK(70000),
87 . ishif,nsu1,nls1,nls2,nrtm_sh,etyp,nrtm_sh1,nrtm0,
88 . imbin,im,l24add,icoq(4),nrtse
89 my_real
90 . edg_cos
91 DATA nextk/1,1,1,-3/
92C-----------------------------------------------
93C E x t e r n a l F u n c t i o n s
94C-----------------------------------------------
95 INTEGER BITSET
96 EXTERNAL BITSET
97C
98 CHARACTER MESS*40
99 DATA mess/'INTERFACE INPUT '/
100 nsn = 0
101 nmn = 0
102 nrtm = 0
103 nrts = 0
104 nod1 = ipari(26)
105 nln = 0
106 ilev = ipari(20)
107 isu1 = ipari(45)
108 isu2 = ipari(46)
109 iedge = ipari(58)
110 l24add = ipari(59)
111 edg_cos = frigap(26)
112 nsu1 = 0
113 nls1 = 0
114 nls2 = 0
115 nsne = 0
116 nrtse = 0
117 IF(ilev==2 ) THEN
118c IF(IEDGE /= 0.OR. ILEV==2 ) THEN
119 imbin=1
120 ELSE
121 imbin=0
122 END IF
123C=======================================================================
124c SURFACES
125C=======================================================================
126c-----------------------------------------------------------------
127c surface S1
128c-----------------------------------------------------------------
129c-----------------------------------------------------------------
130c surface S2
131c-----------------------------------------------------------------
132 SELECT CASE (ilev)
133C-----attention: ISU2=ISU1 /=0
134 CASE(1)
135 nrtm = igrsurf(isu1)%NSEG
136 IF(intnitsche>0) nrts = nrtm
137 CASE(2)
138 nrtm = igrsurf(isu1)%NSEG
139 nrts = igrsurf(isu2)%NSEG
140 nrtm = nrtm + nrts
141 IF(intnitsche>0) nrts = nrtm
142 CASE(3)
143 nrtm = igrsurf(isu2)%NSEG
144 END SELECT
145c ISYM = IPARI(43)
146c---------------------------------------
147c Copy of surfaces (Iallo == 2)
148c---------------------------------------
149 IF(iallo == 2)THEN
150 DO i=1,nrtm
151 msegtyp(i)=0
152 ENDDO
153 l = 0
154 IF(isu1 /= 0)THEN
155 DO j=1,igrsurf(isu1)%NSEG
156 l = l+1
157 DO k=1,4
158 irect(k,l) = igrsurf(isu1)%NODES(j,k)
159 ENDDO
160 msegtyp(l) = igrsurf(isu1)%ELTYP(j)
161C------------ call anyway, if coating shell MSEGTYP(L)=MSEGTYP(L)+1
162 CALL in24coq_sol3(irect(1,l) ,ixc ,ixtg ,msegtyp(l) ,x ,
163 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
164 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
165 IF(imbin /= 0)mbinflg(l) = bitset(mbinflg(l),0)
166 ENDDO
167 ENDIF
168 nsu1 = l
169 IF(isu2 /= 0 .AND.ilev /= 1)THEN
170 DO j=1,igrsurf(isu2)%NSEG
171 l = l+1
172 DO k=1,4
173 irect(k,l) = igrsurf(isu2)%NODES(j,k)
174 ENDDO
175 msegtyp(l) = igrsurf(isu2)%ELTYP(j)
176 CALL in24coq_sol3(irect(1,l) ,ixc ,ixtg ,msegtyp(l) ,x ,
177 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
178 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
179 IF(imbin /= 0) mbinflg(l) = bitset(mbinflg(l),1)
180 ENDDO
181 ENDIF
182#ifndef HYPERMESH_LIB
183 IF(ipri>=5) THEN
184 WRITE(iout,'(/,A,/)')' SEGMENTS USED FOR MAIN SURFACE: '
185 DO i=1,nrtm
186 WRITE(iout,fmt=fmw_4i)(itab(irect(k,i)),k=1,4)
187 ENDDO
188 ENDIF
189#endif
190 ENDIF
191C=======================================================================
192c NODES C=======================================================================
193c-----------------------------------------------------------------
194c tag nodes surfaces S1 S2; 1,2 on S1,S2, 3 on both (ILEV=1)
195c-----------------------------------------------------------------
196 DO i=1,numnod
197 tag(i)=0 ! initialisation
198 tags(i)=0 ! initialisation
199 ENDDO
200 IF(isu2 /= 0)THEN
201 DO j=1,igrsurf(isu2)%NSEG
202 DO k=1,4
203 tag(igrsurf(isu2)%NODES(j,k)) = 2
204 ENDDO
205 ENDDO
206 ENDIF
207 IF(isu1 /= 0)THEN
208 DO j=1,igrsurf(isu1)%NSEG
209 DO k=1,4
210 i=igrsurf(isu1)%NODES(j,k)
211 IF(tag(i) == 0)THEN
212 tag(i) = 1
213 ELSEIF(tag(i) == 2)THEN
214 tag(i) = 3
215 ENDIF
216 ENDDO
217 ENDDO
218 ENDIF
219C for inteply activation needed for Plyxfem + Type24
220 IF(iallo == 1) THEN
221 IF(isu2 /= 0)THEN
222 DO j=1,igrsurf(isu2)%NSEG
223 DO k=1,4
224!! IF(ITAG(IBUFSSG(IAD)) > 0) INTPLY = 1
225 i=igrsurf(isu2)%NODES(j,k)
226 IF(itag(i) > 0) intply = 1
227 ENDDO
228 ENDDO
229 ENDIF
230 IF(isu1 /= 0)THEN
231 DO j=1,igrsurf(isu1)%NSEG
232 DO k=1,4
233 i=igrsurf(isu1)%NODES(j,k)
234 IF(itag(i) > 0) intply = 1
235 ENDDO
236 ENDDO
237 ENDIF
238 ENDIF
239c-----------------------------------------------------------------
240c Surface nodes S2: Build Tags, Set NSV, Msr If Iallo = 2
241c-----------------------------------------------------------------
242 IF(isu2 /= 0)THEN
243 DO j=1,igrsurf(isu2)%NSEG
244 DO k=1,4
245 i=igrsurf(isu2)%NODES(j,k)
246 IF(tag(i) == 2 )THEN
247 nmn = nmn + 1
248 IF(iallo == 2)msr(nmn) = i
249c TAGB(I) = BITSET(TAGB(I),4)
250 ENDIF
251c tagged nodes on S2 -> negative value
252 IF(tag(i) == 2 .OR. tag(i) == 3)THEN
253 tag(i) = - tag(i)
254 IF ( ilev == 2.AND.tags(i) == 0 ) THEN
255 tags(i) = 1
256 nsn = nsn + 1
257 IF(iallo == 2) THEN
258 nsv(nsn) = i
259 IF(ilev == 2)nbinflg(nsn) = bitset(nbinflg(nsn),1)
260 END IF
261 END IF !( ILEV == 2 ) THEN
262 ENDIF
263 ENDDO
264 ENDDO
265 ENDIF
266c-----------------------------------------------------------------
267c Surface nodes S1: Build Tags, Set NSV, Msr If Iallo = 2
268c-----------------------------------------------------------------
269 IF(isu1 /= 0)THEN
270 DO j=1,igrsurf(isu1)%NSEG
271 DO k=1,4
272 i=igrsurf(isu1)%NODES(j,k)
273 IF(tags(i) == 0 .AND. ilev /= 3 ) THEN
274 tags(i) = 1
275 nsn = nsn + 1
276 IF(iallo == 2) THEN
277 nsv(nsn) = i
278 IF(ilev == 2)nbinflg(nsn) = bitset(nbinflg(nsn),0)
279 END IF
280 ENDIF
281c tagged nodes on S1 -> negative value, ->+3 for nodes on both
282 IF(tag(i) == 1 .or. tag(i) == -3)THEN
283 tag(i) = - tag(i)
284 nmn = nmn + 1
285 IF(iallo == 2)msr(nmn) = i
286 ENDIF
287 ENDDO
288 ENDDO
289 ENDIF
290c-----------------------------------------------------------------
291c nodes of the nod1 nod group: build tags, set nsv if iallo = 2
292c-----------------------------------------------------------------
293 IF(nod1 /= 0)THEN
294 DO j=1,igrnod(nod1)%NENTITY
295 i = igrnod(nod1)%ENTITY(j)
296 IF(tags(i) == 0)THEN
297 tags(i) = 1
298 nsn = nsn+1
299 IF(iallo == 2) THEN
300 nsv(nsn) = i
301 IF(ilev == 2)nbinflg(nsn) = bitset(nbinflg(nsn),2)
302 END IF
303 ENDIF
304 ENDDO
305 ENDIF
306
307#ifndef HYPERMESH_LIB
308 IF(iallo == 2 .and. ipri >= 5) THEN
309 WRITE(iout,'(/,A,/)')' NODES USED FOR SECONDARY SIDE'
310 WRITE(iout,fmt=fmw_10i)(itab(nsv(i)),i=1,nsn)
311 ENDIF
312#endif
313C=======================================================================
314c EDGES
315C=======================================================================
316C-----new subsuf/suf on edge-----
317 IF(iedge == 4)THEN
318 ishif=0
319 CALL i24edge2(iallo ,igrsurf(isu1)%NSEG,nln ,
320 1 igrsurf(isu1)%NODES ,itab ,isu1 ,
321 2 x ,edg_cos ,mbinflg ,ishif ,nls1 ,
322 3 irect ,nrtse ,irtse ,nsne ,is2se ,
323 4 is2pt ,nsn ,nsv ,is2id)
324 ishif=nsu1
325 IF(isu2 /= 0 .AND. ilev /= 1) THEN
326 CALL i24edge2(iallo ,igrsurf(isu2)%NSEG,nln ,
327 1 igrsurf(isu2)%NODES ,itab ,isu2 ,
328 2 x ,edg_cos ,mbinflg ,ishif ,nls2 ,
329 3 irect ,nrtse ,irtse ,nsne ,is2se ,
330 4 is2pt ,nsn ,nsv ,is2id)
331 END IF
332 nsn = nsn + nsne
333 ELSEIF(iedge /= 0)THEN
334 ishif=0
335 CALL i24edge1(iallo,igrsurf(isu1)%NSEG,nln ,iedge ,
336 1 igrsurf(isu1)%NODES ,itab ,isu1 ,
337 2 x ,edg_cos ,mbinflg ,ishif ,nls1 ,
338 3 irect ,l24add ,iseadd ,isedge ,nsn ,
339 4 1 ,nsv )
340 ishif=nsu1
341 IF(isu2 /= 0 .AND. ilev /= 1) THEN
342 CALL i24edge1(iallo,igrsurf(isu2)%NSEG,nln ,iedge ,
343 1 igrsurf(isu2)%NODES ,itab ,isu2 ,
344 2 x ,edg_cos ,mbinflg ,ishif ,nls2 ,
345 3 irect ,l24add ,iseadd ,isedge ,nsn ,
346 4 2 ,nsv )
347 END IF
348 ENDIF
349C=======================================================================
350C=======================================================================
351c-----------------------------------------------------------------
352c number of nodes in the interface (SECONDARY + MAIN + edge)
353c-----------------------------------------------------------------
354 IF(iallo == 2) THEN
355 nln = ipari(35)
356 ipari(51) = nls1
357 ipari(52) = nls2
358 IF (iedge == 4) ipari(52) = nrtse
359 ipari(55) = nsne
360C------initialization of doubler M_seg for shells add ISU1>0
361 nrtm_sh= ipari(42)
362 nrtm0 = ipari(4) - nrtm_sh
363 CALL sh2surf(nrtm0,irect,imbin,mbinflg,msegtyp,ipari(4))
364C-----temporairement set IEDGE=0 for Engine
365 IF (iedge == 4) ipari(58) = 0
366C
367 ELSE
368C----------due the fact that NRTM is modified w/ shell seg
369 IF(intnitsche > 0) THEN
370 ipari(3) = nrts
371 ELSE
372 ipari(3) = 0
373 ENDIF
374 ipari(4) = nrtm
375 ipari(5) = nsn
376 ipari(6) = nmn
377 ipari(35) = nln
378 ipari(59) = l24add
379 IF (iedge == 4) ipari(52) = nrtse
380 ipari(55) = nsne
381C----------doubling shell segments-excepting coating shell-----------
382 nrtm_sh=0
383 IF(isu1 /= 0)THEN
384 DO j=1,igrsurf(isu1)%NSEG
385 DO k=1,4
386 icoq(k) = igrsurf(isu1)%NODES(j,k)
387 ENDDO
388 etyp = igrsurf(isu1)%ELTYP(j)
389 CALL in24coq_sol3(icoq ,ixc ,ixtg ,etyp ,x ,
390 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
391 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
392 IF(etyp ==3 .OR. etyp ==7 ) nrtm_sh = nrtm_sh + 1
393 ENDDO
394 ENDIF
395 IF(isu2 /= 0 .AND. ilev /= 1)THEN
396 DO j=1,igrsurf(isu2)%NSEG
397 DO k=1,4
398 icoq(k) = igrsurf(isu2)%NODES(j,k)
399 ENDDO
400 etyp = igrsurf(isu2)%ELTYP(j)
401 CALL in24coq_sol3(icoq ,ixc ,ixtg ,etyp ,x ,
402 . knod2elc ,knod2eltg ,nod2elc ,nod2eltg,
403 . knod2els,nod2els,ixs ,ixs10 ,ixs16 ,ixs20 )
404 IF(etyp ==3 .OR. etyp ==7 ) nrtm_sh = nrtm_sh + 1
405 ENDDO
406 ENDIF
407 ipari(42) = nrtm_sh
408 END IF
409C
410 RETURN
411 END
412!||====================================================================
413!|| i24edge1 ../starter/source/interfaces/inter3d1/i24surfi.F
414!||--- called by ------------------------------------------------------
415!|| i24surfi ../starter/source/interfaces/inter3d1/i24surfi.f
416!||--- calls -----------------------------------------------------
417!|| ancmsg ../starter/source/output/message/message.F
418!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
419!||--- uses -----------------------------------------------------
420!|| format_mod ../starter/share/modules1/format_mod.F90
421!|| message_mod ../starter/share/message_module/message_mod.F
422!||====================================================================
423 SUBROUTINE i24edge1(IALLO ,NSEG ,NACTIF ,IEDGE ,
424 1 SURF_NODES ,ITAB ,ISU ,
425 2 X ,EDG_COS ,MBINFLG ,IADM ,NLS ,
426 3 IRECT ,L24ADD ,ISEADD ,ISEDGE ,NSN ,
427 4 IFIRST ,NSV )
428C-----------------------------------------------
429C M o d u l e s
430C-----------------------------------------------
431#ifndef HYPERMESH_LIB
432 USE message_mod
433#endif
434 USE format_mod , ONLY : fmw_4i
435C-----------------------------------------------
436C I m p l i c i t T y p e s
437C-----------------------------------------------
438#include "implicit_f.inc"
439C-----------------------------------------------
440C C o m m o n B l o c k s
441C-----------------------------------------------
442#include "com04_c.inc"
443#include "units_c.inc"
444#include "scr03_c.inc"
445C-----------------------------------------------
446C D u m m y A r g u m e n t s
447C-----------------------------------------------
448 INTEGER IALLO,NACTIF,IEDGE,IADM,NLS,L24ADD,NSN,IFIRST,ISU
449 INTEGER ITAB(*),MBINFLG(*),IRECT(4,*),NSEG,SURF_NODES(NSEG,4),
450 . ISEADD(*) ,ISEDGE(*),NSV(*)
451 my_real
452 . X(3,*),EDG_COS
453C-----------------------------------------------
454C L o c a l V a r i a b l e s
455C-----------------------------------------------
456C----- NLS : Num. of element with active edge----
457 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,NL,IS,
458 . I3M,I4M,I6,I7,IADD,IM,IP,LI
459 INTEGER NEXTK(4),KM1(4),KP2(4),IWORK(70000),NLL,NSE
460 my_real
461 . nx,ny,nz,mx,my,mz,aaa,d1x,d1y,d1z,d2x,d2y,d2z,imj,ipj
462 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
463 . lineix,lineix2,ixwork
464 INTEGER, DIMENSION(:), ALLOCATABLE ::
465 . INDEX,TAG,ISEADD_L,ISH
466 my_real, DIMENSION(:,:), ALLOCATABLE ::
467 . XLINEIX
468
469 INTEGER BITSET
470 EXTERNAL BITSET
471
472 DATA nextk/2,3,4,1/
473 DATA km1/4,1,2,3/
474 DATA kp2/3,4,1,2/
475C=======================================================================
476 nlmax = 0
477 nls = 0
478 IF(isu /= 0)nlmax = 4*nseg
479c---------------------------------------
480c LINEIX(2,*): LINE; LINEIX2(1,):Id_seg,LINEIX2(2,):Jd_seg(1-4)
481c IXWORK(8,*): reordered lines; (1-2,):LINEIX,(3-4,)or (6-7,) if inverse order of I1,I2
482c :LINEIX2,(5):I_bord; (8,):flag of inverse I1,I2
483c---------------------------------------
484 ALLOCATE (lineix(2,nlmax) ,stat=stat)
485 ALLOCATE (lineix2(2,nlmax) ,stat=stat)
486 ALLOCATE (xlineix(3,nlmax) ,stat=stat)
487 ALLOCATE (index(2*nlmax) ,stat=stat)
488c ALLOCATE (TAG(NUMNOD) ,STAT=stat)
489 ALLOCATE (iseadd_l(numnod) ,stat=stat)
490 ALLOCATE (ish(numnod) ,stat=stat)
491 ALLOCATE (ixwork(8,nlmax) ,stat=stat)
492
493
494#ifndef HYPERMESH_LIB
495 IF (stat /= 0) THEN
496 CALL ancmsg(msgid=268,
497 . msgtype=msgerror,
498 . anmode=anstop,
499 . c1='LINEIX')
500 END IF
501#endif
502
503c---------------------------------------
504c search for all lines on the surface
505c---------------------------------------
506C initialize IXWORK to zero
507 ixwork(4,1:nlmax)=0
508
509
510 IF(isu /= 0)THEN
511 is = 0
512 ll = 0
513 DO j=1,nseg
514 is = is+1
515 i1=surf_nodes(j,1)
516 i2=surf_nodes(j,2)
517 i3=surf_nodes(j,3)
518 i4=surf_nodes(j,4)
519 d1x = x(1,i3) - x(1,i1)
520 d1y = x(2,i3) - x(2,i1)
521 d1z = x(3,i3) - x(3,i1)
522 d2x = x(1,i4) - x(1,i2)
523 d2y = x(2,i4) - x(2,i2)
524 d2z = x(3,i4) - x(3,i2)
525 nx = d1y * d2z - d1z * d2y
526 ny = d1z * d2x - d1x * d2z
527 nz = d1x * d2y - d1y * d2x
528 aaa = one/max(sqrt(nx*nx+ny*ny+nz*nz),em20)
529 nx = nx * aaa
530 ny = ny * aaa
531 nz = nz * aaa
532 DO k=1,4
533 i1=surf_nodes(j,k)
534 i2=surf_nodes(j,nextk(k))
535 ll = ll+1
536 IF(i2 > i1)THEN
537 lineix(1,ll) = i1
538 lineix(2,ll) = i2
539 ixwork(8,ll) = 0
540 ELSE
541 lineix(1,ll) = i2
542 lineix(2,ll) = i1
543C-----------means I1,I2 has been exchanged
544 ixwork(8,ll) = 1
545 ENDIF
546 lineix2(1,ll) = j
547 lineix2(2,ll) = k
548 xlineix(1,ll) = nx
549 xlineix(2,ll) = ny
550 xlineix(3,ll) = nz
551 ENDDO
552 ENDDO
553C
554 CALL my_orders(0,iwork,lineix,index,ll,2)
555
556c---------------------------------------
557c removal of duplicate lines
558c + Calculation of angles (sin) inter-facet
559c---------------------------------------
560 li = index(1)
561 i1m = lineix(1,li)
562 i2m = lineix(2,li)
563 i3m = lineix2(1,li)
564 i4m = lineix2(2,li)
565 nl = 1
566 ixwork(1,nl)=i1m
567 ixwork(2,nl)=i2m
568 IF(ixwork(8,li)==0)THEN
569 ixwork(3,nl)=i3m
570 ixwork(4,nl)=i4m
571 ixwork(6,nl)=0
572 ELSE
573 ixwork(6,nl)=i3m
574 ixwork(7,nl)=i4m
575 ixwork(3,nl)=0
576 ENDIF
577C---------first -> border but can be corrected later
578 ixwork(5,nl)=1
579 mx = xlineix(1,li)
580 my = xlineix(2,li)
581 mz = xlineix(3,li)
582 DO l=2,ll
583 li = index(l)
584 i1 = lineix(1,li)
585 i2 = lineix(2,li)
586 i3 = lineix2(1,li)
587 i4 = lineix2(2,li)
588 nx = xlineix(1,li)
589 ny = xlineix(2,li)
590 nz = xlineix(3,li)
591 IF(i2 /= i2m .or. i1 /= i1m)THEN
592c store new edge
593 nl = nl + 1
594 ixwork(1,nl)=i1
595 ixwork(2,nl)=i2
596 IF(ixwork(8,li)==0)THEN
597 ixwork(3,nl)=i3
598 ixwork(4,nl)=i4
599 ixwork(6,nl)=0
600 ELSE
601 ixwork(6,nl)=i3
602 ixwork(7,nl)=i4
603 ixwork(3,nl)=0
604 ENDIF
605 ixwork(5,nl)=1 ! bord
606 ELSE
607C------internal lines are not incremented because they are always double
608C--------- and the second one does the correction
609 ixwork(5,nl)=0 ! interne
610c second segment
611 IF(ixwork(8,li)==0)THEN
612 ixwork(3,nl)=i3
613 ixwork(4,nl)=i4
614 ELSE
615 ixwork(6,nl)=i3
616 ixwork(7,nl)=i4
617 ENDIF
618 aaa = nx*mx + ny * my + nz * mz
619 IF (aaa < edg_cos) ixwork(5,nl) = -1 ! arete vive
620 ENDIF
621 i1m = i1
622 i2m = i2
623 mx = nx
624 my = ny
625 mz = nz
626 ENDDO
627c---------------------------------------
628c Deletion of internal lines (iedge == 1)
629c dimension first
630c---------------------------------------
631 ll = nl
632 nl = 0
633 IF(iedge == 1)THEN
634c keep only border edges (IXWORK(5,L) == 1)
635 DO l=1,ll
636 IF(ixwork(5,l) == 1)THEN
637 nl = nl + 1
638 i1=ixwork(1,nl)
639 i2=ixwork(2,nl)
640 i3=ixwork(3,nl)
641 i4=ixwork(4,nl)
642 i5=ixwork(5,nl)
643 i6=ixwork(6,nl)
644 i7=ixwork(7,nl)
645 ixwork(1,nl)=ixwork(1,l)
646 ixwork(2,nl)=ixwork(2,l)
647 ixwork(3,nl)=ixwork(3,l)
648 ixwork(4,nl)=ixwork(4,l)
649 ixwork(5,nl)=1 ! border
650 ixwork(6,nl)=ixwork(6,l)
651 ixwork(7,nl)=ixwork(7,l)
652 ixwork(1,l)=i1
653 ixwork(2,l)=i2
654 ixwork(3,l)=i3
655 ixwork(4,l)=i4
656 ixwork(5,l)=i5
657 ixwork(6,l)=i6
658 ixwork(7,l)=i7
659 ENDIF
660 ENDDO
661 ELSEIF(iedge == 2)THEN
662c all lines are kept AND active
663 DO l=1,ll
664 nl = nl + 1
665 IF(ixwork(5,l) == 0)ixwork(5,l)=-1 ! all on +-1
666 ENDDO
667 ELSEIF(iedge == 3)THEN
668c the edges are preserved
669c the live edges are preserved (EDG_COS)
670 DO l=1,ll
671 IF(iabs(ixwork(5,l)) == 1)THEN
672 nl = nl + 1
673 i1=ixwork(1,nl)
674 i2=ixwork(2,nl)
675 i3=ixwork(3,nl)
676 i4=ixwork(4,nl)
677 i5=iabs(ixwork(5,nl))
678 i6=ixwork(6,nl)
679 i7=ixwork(7,nl)
680 ixwork(1,nl)=ixwork(1,l)
681 ixwork(2,nl)=ixwork(2,l)
682 ixwork(3,nl)=ixwork(3,l)
683 ixwork(4,nl)=ixwork(4,l)
684C IXWORK(5,NL)=+-1 ! bord on
685 ixwork(6,nl)=ixwork(6,l)
686 ixwork(7,nl)=ixwork(7,l)
687 ixwork(1,l)=i1
688 ixwork(2,l)=i2
689 ixwork(3,l)=i3
690 ixwork(4,l)=i4
691 ixwork(5,l)=i5
692 ixwork(6,l)=i6
693 ixwork(7,l)=i7
694 ENDIF
695 ENDDO
696 ENDIF
697C
698 ELSE
699 ! no surface
700 nl = 0
701 ENDIF
702c---------------------------------------
703c setup MBINFLG (IALLO == 2)
704c tag segment with active edges
705c (only MAIN segment)
706c---------------------------------------
707 IF(iallo == 2 .AND. ifirst==1)THEN
708 DO l=1,ll
709 IF(iabs(ixwork(5,l)) == 1)THEN
710 i3 = ixwork(3,l)
711 i6 = ixwork(6,l)
712c print *,'edge I,J=',itab(IXWORK(1,L)),itab(IXWORK(2,L)),L
713 IF(i3/=0)THEN
714 i4 = ixwork(4,l)
715 j=i3+iadm
716 mbinflg(j) = bitset(mbinflg(j),i4)
717 IF(ixwork(5,l) == 1)mbinflg(j) = bitset(mbinflg(j),6)
718 mbinflg(j) = bitset(mbinflg(j),8)
719 END IF
720 IF(i6/=0)THEN
721 i7 = ixwork(7,l)
722 j=i6+iadm
723 mbinflg(j) = bitset(mbinflg(j),i7)
724 IF(ixwork(5,l) == 1)mbinflg(j) = bitset(mbinflg(j),6)
725 END IF
726 ENDIF
727 ENDDO
728 ENDIF
729c---------------------------------------
730c number de lignes: may keep only NACTIF
731c---------------------------------------
732 nactif = nactif + nl
733c---------------------------------------
734c setup MBINFLG (IALLO == 2)
735c---------------------------------------
736#ifndef HYPERMESH_LIB
737 IF(iallo == 2 .AND. nl >0 .AND. ifirst==1 )THEN
738 IF(ipri >= 5) THEN
739 WRITE(iout,'(/,A,/)')' ACTIV SEGMENTS USED FOR EDGE'
740 DO i=1,nl
741 WRITE(iout,fmt=fmw_4i)(itab(ixwork(k,i)),k=1,2)
742 ENDDO
743 ENDIF
744 END IF
745#endif
746c---------------------------------------
747c edges on SECONDARY segments
748c---------------------------------------
749c
750c +-------------+-------------+ I=I1:first SECONDARY node on edge IJ
751c | J|I2 | J=I2:first SECONDARY node on edge IJ
752c | | | S1=I3: left SECONDARY segment
753c | | | K1=I4: local segment edge K1=[1-4]
754c | I3 | I6 | I5=1 border edge => S2=K2=0
755c | I4|I7 | I5=-1 internal edge
756c | | | S2=I6: right SECONDARY segment
757c | | | K2=I7: local segment edge K2=[1-4]
758c |IM I|I1 IP| IM : previous SECONDARY node on seg S1
759c +-------------+-------------+ IP : next SECONDARY node on seg S2
760c
761c---------------------------------------
762c SECONDARY edges array
763c---------------------------------------
764C------re-look at the case IEDGE=2,3, et structure IXWORK, max_J for each I1_I2=2
765 IF(ifirst==2)THEN
766 DO i=1,numnod
767 iseadd_l(i) = 0
768 ish(i)=1
769 ENDDO
770 IF(iallo/=2)THEN
771 DO ll=1,nl
772c count number of edges per SECONDARY node
773 i1=ixwork(1,ll)
774 i2=ixwork(2,ll)
775 iseadd_l(i1) = iseadd_l(i1) + 1
776 iseadd_l(i2) = iseadd_l(i2) + 1
777 ENDDO
778 iadd=1
779 DO i=1,nsn
780 nse = iseadd_l(i)
781 iadd = iadd+1+3*nse
782 ENDDO
783 l24add = iadd-1
784 ELSE
785 DO i=1,nsn
786 iseadd(i) = 0
787 ENDDO
788 DO ll=1,nl
789c count number of edges per SECONDARY node
790 i1=ixwork(1,ll)
791 i2=ixwork(2,ll)
792 iseadd_l(i1) = iseadd_l(i1) + 1
793 iseadd_l(i2) = iseadd_l(i2) + 1
794 ENDDO
795 iadd=1
796 DO i=1,nsn
797 nse = iseadd_l(nsv(i))
798 iseadd(i) = iadd
799 isedge(iadd) = nse
800 iadd = iadd+1+3*nse
801 ENDDO
802 DO i=1,nsn
803 iseadd_l(nsv(i)) = iseadd(i)
804 ENDDO
805 DO ll=1,nl
806c store SECONDARY node in ISEDGE
807 i1=ixwork(1,ll)
808 i2=ixwork(2,ll)
809 i3=ixwork(3,ll)
810 i4=ixwork(4,ll)
811 i5=ixwork(5,ll)
812 i6=ixwork(6,ll)
813 i7=ixwork(7,ll)
814 iadd = iseadd_l(i1)
815 nse = isedge(iadd)
816 isedge(iadd+ish(i1)) = i2
817 IF(i3==0)THEN
818 im=0
819 imj=0
820 ELSE
821 k=km1(i4)
822 im = irect(k,i3+iadm)
823 k=kp2(i4)
824 imj = irect(k,i3+iadm)
825 END IF
826 isedge(iadd+nse+ish(i1)) = im
827 IF(i6==0)THEN
828 ip = 0
829 ipj= 0
830 ELSE
831 k=kp2(i7)
832 ip = irect(k,i6+iadm)
833 k=km1(i7)
834 ipj = irect(k,i6+iadm)
835 ENDIF
836 isedge(iadd+2*nse+ish(i1)) = ip
837 ish(i1)=ish(i1)+1
838
839 iadd = iseadd_l(i2)
840 nse = isedge(iadd)
841 isedge(iadd+ish(i2)) = i1
842 isedge(iadd+nse+ish(i2)) = ipj
843 isedge(iadd+2*nse+ish(i2)) = imj
844 ish(i2)=ish(i2)+1
845 ENDDO
846
847 ENDIF
848
849 ENDIF
850c---------------------------------------
851 DEALLOCATE (index)
852c DEALLOCATE (TAG)
853 DEALLOCATE (iseadd_l)
854 DEALLOCATE (ish)
855 DEALLOCATE (ixwork)
856 DEALLOCATE (lineix)
857 DEALLOCATE (lineix2)
858 DEALLOCATE (xlineix)
859
860C-----------
861 RETURN
862 END
863!||====================================================================
864!|| sh2surf ../starter/source/interfaces/inter3d1/i24surfi.F
865!||--- called by ------------------------------------------------------
866!|| i24surfi ../starter/source/interfaces/inter3d1/i24surfi.F
867!||====================================================================
868 SUBROUTINE sh2surf(NRTM0,IRECT,IEDG,MBINFLG,MSEGTYP,NRTM )
869C-----------------------------------------------
870C I m p l i c i t T y p e s
871C-----------------------------------------------
872#include "implicit_f.inc"
873C-----------------------------------------------
874C D u m m y A r g u m e n t s
875C-----------------------------------------------
876 INTEGER NRTM0,IEDG,NRTM
877 INTEGER IRECT(4,*),MBINFLG(*),MSEGTYP(*)
878C-----------------------------------------------
879C L o c a l V a r i a b l e s
880C-----------------------------------------------
881 INTEGER I, NR, IT, J, ETYP(NRTM0),ITYPE,NRTM1
882C=======================================================================
883C------add asymmetric shell segs at end, change MSEGTYP
884 DO I=1,nrtm0
885 etyp(i) = msegtyp(i)
886 END DO
887C
888 nr=nrtm0
889 DO i=1,nrtm0
890 msegtyp(i)=0
891 IF(etyp(i) ==3 .OR. etyp(i) ==7 ) THEN
892 nr =nr +1
893 irect(1,nr)=irect(2,i)
894 irect(2,nr)=irect(1,i)
895 irect(3,nr)=irect(4,i)
896 irect(4,nr)=irect(3,i)
897 msegtyp(i)=nr
898 msegtyp(nr)=-i
899C------coating shell don't be doubled--
900 ELSEIF(etyp(i) <0 ) THEN
901C------but changing ordering--
902 it= irect(1,i)
903 irect(1,i)=irect(2,i)
904 irect(2,i)=it
905 it= irect(3,i)
906 irect(3,i)=irect(4,i)
907 irect(4,i)=it
908C------ coating shell tagged for STIF_ini, reset to zero after
909C--------coating shell >NRTM : avoid conflict
910 msegtyp(i)=-etyp(i)+nrtm
911 ELSEIF(etyp(i) ==4 .OR. etyp(i) ==8) THEN
912 msegtyp(i)=etyp(i)+nrtm
913 END IF
914 END DO
915 nrtm1 = nr
916 IF (iedg> 0) THEN
917 nr=nrtm0
918 DO i=1,nrtm0
919 IF(etyp(i) ==3 .OR. etyp(i) ==7 ) THEN
920 nr =nr +1
921 mbinflg(nr)=mbinflg(i)
922 END IF
923 END DO
924 END IF !(IEDGE> 1) THEN
925c print *,'!!!NRTM0,NRTM1=', NRTM0,NRTM1
926C------------------------------------------------------------
927 RETURN
928 END
929!||====================================================================
930!|| in24coq_sol3 ../starter/source/interfaces/inter3d1/i24surfi.F
931!||--- called by ------------------------------------------------------
932!|| i24surfi ../starter/source/interfaces/inter3d1/i24surfi.F
933!|| i25surfi ../starter/source/interfaces/inter3d1/i25surfi.F
934!||--- calls -----------------------------------------------------
935!|| seg_ins ../starter/source/interfaces/inter3d1/i24surfi.F
936!||--- uses -----------------------------------------------------
937!||====================================================================
938 SUBROUTINE in24coq_sol3(IRECT ,IXC ,IXTG ,MSEGTYP ,X ,
939 . KNOD2ELC ,KNOD2ELTG ,NOD2ELC ,NOD2ELTG,
940 . KNOD2ELS,NOD2ELS,IXS ,IXS10 ,IXS16 ,IXS20 )
941 use element_mod , only : nixs,nixc,nixtg
942C-----------------------------------------------
943C I m p l i c i t T y p e s
944C-----------------------------------------------
945#include "implicit_f.inc"
946C-----------------------------------------------
947C C o m m o n B l o c k s
948C-----------------------------------------------
949#include "com04_c.inc"
950C-----------------------------------------------
951C D u m m y A r g u m e n t s
952C-----------------------------------------------
953 INTEGER MSEGTYP, KNOD2ELS(*),NOD2ELS(*)
954 INTEGER IRECT(4), IXC(NIXC,*), IXTG(NIXTG,*),
955 . knod2elc(*) ,knod2eltg(*) ,nod2elc(*) ,nod2eltg(*)
956 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
957C REAL
958 my_real
959 . X(3,*)
960C-----------------------------------------------
961C L o c a l V a r i a b l e s
962C-----------------------------------------------
963 INTEGER N, J, II, K, IAD ,NEL,NELTG,NS,NELS,NDS(20),NNOD,JJ,INS
964C REAL
965C-----------------------------------------------
966C-------if coating shell made of two segs, verify the value of MSEGTYP
967C--if MSEGTYP=0, seg define -> if shell look at is also solid ; get at least 3n in sloid
968C--if MSEGTYP shell -> same than before
969C--if MSEGTYP solid -> nothing
970 IF (msegtyp==3 .OR. msegtyp==7) GOTO 300
971 IF (msegtyp/=0) RETURN
972 nel=0
973 neltg=0
974 IF(irect(3)==irect(4).AND.numeltg/=0)THEN
975 DO 230 iad=knod2eltg(irect(1))+1,knod2eltg(irect(1)+1)
976 n = nod2eltg(iad)
977 DO 220 j=1,3
978 ii=irect(j)
979 DO k=1,3
980 IF(ixtg(k+1,n)==ii) GOTO 220
981 END DO
982 GOTO 230
983 220 CONTINUE
984 neltg = n
985 230 CONTINUE
986 ENDIF
987C
988 IF(numelc/=0) THEN
989 DO 430 iad=knod2elc(irect(1))+1,knod2elc(irect(1)+1)
990 n = nod2elc(iad)
991 DO 420 j=1,4
992 ii=irect(j)
993 DO k=1,4
994 IF(ixc(k+1,n)==ii) GOTO 420
995 END DO
996 GOTO 430
997 420 CONTINUE
998 nel = n
999 430 CONTINUE
1000 ENDIF
1001C----
1002 IF (nel>0) THEN
1003 msegtyp = 3
1004 ELSEIF(neltg>0) THEN
1005 msegtyp = 7
1006 END IF
1007
1008 300 CONTINUE
1009C------solid element
1010 IF(msegtyp==0.OR.numels==0) RETURN
1011 nels=0
1012 ns = irect(1)
1013C
1014 DO 330 iad=knod2els(ns)+1,knod2els(ns+1)
1015 n = nod2els(iad)
1016 IF(n <= numels8)THEN
1017 DO 310 jj=1,4
1018 ii=irect(jj)
1019 DO k=1,8
1020 IF(ixs(k+1,n)==ii) GOTO 310
1021 ENDDO
1022 GOTO 330
1023 310 CONTINUE
1024 nds(1:8)=ixs(2:9,n)
1025 nnod = 8
1026 ELSEIF(n <= numels8+numels10)THEN
1027 DO 320 jj=1,4
1028 ii=irect(jj)
1029 DO k=1,8
1030 IF(ixs(k+1,n)==ii) GOTO 320
1031 ENDDO
1032 DO k=1,6
1033 IF(ixs10(k,n-numels8)==ii) GOTO 320
1034 ENDDO
1035 GOTO 330
1036 320 CONTINUE
1037 nds(1)=ixs(2,n)
1038 nds(2)=ixs(4,n)
1039 nds(3)=ixs(7,n)
1040 nds(4)=ixs(6,n)
1041 nds(5:10)=ixs10(1:6,n-numels8)
1042 nnod = 10
1043 ELSEIF(n <= numels8+numels10+numels20)THEN
1044 DO 322 jj=1,4
1045 ii=irect(jj)
1046 DO k=1,8
1047 IF(ixs(k+1,n)==ii) GOTO 322
1048 ENDDO
1049 DO k=1,12
1050 IF(ixs20(k,n-numels8-numels10)==ii) GOTO 322
1051 ENDDO
1052 GOTO 330
1053 322 CONTINUE
1054 nds(1:8)=ixs(2:9,n)
1055 nds(9:20)=ixs20(1:12,n-numels8-numels10)
1056 nnod = 20
1057 ELSEIF(n <= numels8+numels10+numels20+numels16)THEN
1058 DO 324 jj=1,4
1059 ii=irect(jj)
1060 DO k=1,8
1061 IF(ixs(k+1,n)==ii) GOTO 324
1062 ENDDO
1063 DO k=1,8
1064 IF(ixs16(k,n-numels8-numels10-numels20)==ii) GOTO 324
1065 ENDDO
1066 GOTO 330
1067 324 CONTINUE
1068 nds(1:8)=ixs(2:9,n)
1069 nds(9:16)=ixs16(1:8,n-numels8-numels10-numels20)
1070 nnod = 16
1071 ELSE
1072 GOTO 330
1073 END IF
1074 CALL seg_ins(irect,nds,nnod,ins,x )
1075 IF (ins/=0) nels = n
1076 IF (nels>0) GOTO 500
1077 330 CONTINUE
1078
1079 500 CONTINUE
1080 IF (nels>0 .AND. (msegtyp==3 .OR. msegtyp==7)) THEN
1081 msegtyp = msegtyp + 1
1082 IF (ins <0) msegtyp=-msegtyp
1083 END IF
1084
1085 RETURN
1086 END
1087!||====================================================================
1088!|| seg_ins ../starter/source/interfaces/inter3d1/i24surfi.F
1089!||--- called by ------------------------------------------------------
1090!|| in24coq_sol3 ../starter/source/interfaces/inter3d1/i24surfi.F
1091!||====================================================================
1092 SUBROUTINE seg_ins(IRECT,NDS,NNOD,INS,X)
1093C----6---------------------------------------------------------------7---------8
1094C I m p l i c i t T y p e s
1095C-----------------------------------------------
1096#include "implicit_f.inc"
1097C-----------------------------------------------------------------
1098C D u m m y A r g u m e n t s
1099C-----------------------------------------------
1100 INTEGER IRECT(4),NDS(*),NNOD,INS
1101 my_real
1102 . X(3,*)
1103C-----------------------------------------------
1104C L o c a l V a r i a b l e s
1105C-----------------------------------------------
1106 INTEGER I,J,II,K,M,LING,NN
1107 my_real
1108 . X1,Y1,Z1,X41,Y41,Z41,X42,Y42,Z42,X43,Y43,Z43,NX,NY,NZ,VOL
1109C--------------------------------------------------------------------
1110 INS =0
1111 nn =0
1112 DO i=1,3
1113 ii = irect(i)
1114 DO j=1,nnod
1115 IF (nds(j)==ii) THEN
1116 nn = nn +1
1117 cycle
1118 END IF
1119 END DO
1120 END DO !I=1,3
1121 IF (nn>=3) ins =1
1122C--------compute the volume of solid center&IRECT(1-3), if V>0 inverse the normal
1123 IF (ins/=0) THEN
1124 x1=zero
1125 y1=zero
1126 z1=zero
1127 DO j=1,nnod
1128 x1=x1+x(1,nds(j))
1129 y1=y1+x(2,nds(j))
1130 z1=z1+x(3,nds(j))
1131 END DO
1132 x1=x1/nnod
1133 y1=y1/nnod
1134 z1=z1/nnod
1135 x41 = x(1,irect(3)) - x1
1136 y41 = x(2,irect(3)) - y1
1137 z41 = x(3,irect(3)) - z1
1138 x42 = x(1,irect(3)) - x(1,irect(1))
1139 y42 = x(2,irect(3)) - x(2,irect(1))
1140 z42 = x(3,irect(3)) - x(3,irect(1))
1141 x43 = x(1,irect(3)) - x(1,irect(2))
1142 y43 = x(2,irect(3)) - x(2,irect(2))
1143 z43 = x(3,irect(3)) - x(3,irect(2))
1144C
1145 nx = y43*z42 - y42*z43
1146 ny = z43*x42 - z42*x43
1147 nz = x43*y42 - x42*y43
1148C
1149 vol = x41*nx + y41*ny + z41*nz
1150 IF (vol > zero) ins= -1
1151 END IF
1152C----6---------------------------------------------------------------7---------8
1153 RETURN
1154 END
1155!||====================================================================
1156!|| i24edge2 ../starter/source/interfaces/inter3d1/i24surfi.F
1157!||--- called by ------------------------------------------------------
1158!|| i24surfi ../starter/source/interfaces/inter3d1/i24surfi.F
1159!||--- calls -----------------------------------------------------
1160!|| ancmsg ../starter/source/output/message/message.F
1161!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
1162!||--- uses -----------------------------------------------------
1163!|| format_mod ../starter/share/modules1/format_mod.F90
1164!|| message_mod ../starter/share/message_module/message_mod.F
1165!||====================================================================
1166 SUBROUTINE i24edge2(IALLO ,NSEG ,NACTIF ,
1167 1 SURF_NODES ,ITAB ,ISU ,
1168 2 X ,EDG_COS ,MBINFLG ,IADM ,NLS ,
1169 3 IRECT ,NRTSE ,IRTSE ,NSNE ,IS2SE ,
1170 4 IS2PT ,NSN ,NSV ,IS2ID)
1171C-----------------------------------------------
1172C M o d u l e s
1173C-----------------------------------------------
1174#ifndef HYPERMESH_LIB
1175 USE message_mod
1176#endif
1177 USE format_mod , ONLY : fmw_4i
1178C-----------------------------------------------
1179C I m p l i c i t T y p e s
1180C-----------------------------------------------
1181#include "implicit_f.inc"
1182C-----------------------------------------------
1183C C o m m o n B l o c k s
1184C-----------------------------------------------
1185#include "com04_c.inc"
1186#include "units_c.inc"
1187#include "scr03_c.inc"
1188C-----------------------------------------------
1189C D u m m y A r g u m e n t s
1190C-----------------------------------------------
1191 INTEGER IALLO,NACTIF,IADM,NLS,L24ADD,NSN,IFIRST,ISU
1192 INTEGER ITAB(*),MBINFLG(*),IRECT(4,*),NSEG,SURF_NODES(NSEG,4),
1193 . irtse(5,*) ,nsv(*),nrtse,nsne,is2se(2,*),is2pt(*),is2id(*)
1194 my_real
1195 . x(3,*),edg_cos
1196C-----------------------------------------------
1197C L o c a l V a r i a b l e s
1198C-----------------------------------------------
1199C----- NLS : Num. of element with active edge----
1200 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,NL,IS,
1201 . I3M,I4M,I6,I7,IADD,IM,IP,LI
1202 INTEGER NEXTK(4),KM1(4),KP2(4),IWORK(70000),NLL,NSE,NP_EDGE
1203 my_real
1204 . NX,NY,NZ,MX,MY,MZ,AAA,D1X,D1Y,D1Z,D2X,D2Y,D2Z,IMJ,IPJ
1205 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
1206 . LINEIX,LINEIX2,IXWORK
1207 INTEGER, DIMENSION(:), ALLOCATABLE ::
1208 . INDEX,TAG,ISEADD_L,ISH
1209 my_real, DIMENSION(:,:), ALLOCATABLE ::
1210 . xlineix
1211
1212 INTEGER BITSET
1213 EXTERNAL BITSET
1214
1215 DATA NEXTK/2,3,4,1/
1216 DATA KM1/4,1,2,3/
1217 DATA KP2/3,4,1,2/
1218C=======================================================================
1219C--- edges are used only to select SECONDARY segments:IRTSE(5,NRTSE),
1220C----IRTSE(5,*) -> id of edge
1221C=======================================================================
1222 nlmax = 0
1223 nls = 0
1224 IF(isu /= 0)nlmax = 4*nseg
1225c---------------------------------------
1226c LINEIX(2,*): LINE; LINEIX2(1,):Id_seg,LINEIX2(2,):Jd_seg(1-4)
1227c IXWORK(8,*): reordered lines; (1-2,)<-LINEIX,(3-4,)or (6-7,) if inverse order of I1,I2
1228c <-LINEIX2,(5):I_bord; (8,):flag of inverse I1,I2
1229c---------------------------------------
1230 ALLOCATE (lineix(2,nlmax) ,stat=stat)
1231 ALLOCATE (lineix2(2,nlmax) ,stat=stat)
1232 ALLOCATE (xlineix(3,nlmax) ,stat=stat)
1233 ALLOCATE (index(2*nlmax) ,stat=stat)
1234 ALLOCATE (ixwork(8,nlmax) ,stat=stat)
1235
1236#ifndef HYPERMESH_LIB
1237 IF (stat /= 0) THEN
1238 CALL ancmsg(msgid=268,
1239 . msgtype=msgerror,
1240 . anmode=anstop,
1241 . c1='LINEIX')
1242 END IF
1243#endif
1244c---------------------------------------
1245c search for all lines on the surface
1246c---------------------------------------
1247C initialize IXWORK to zero
1248 ixwork(4,1:nlmax)=0
1249
1250
1251 IF(isu /= 0)THEN
1252 is = 0
1253 ll = 0
1254 DO j=1,nseg
1255 is = is+1
1256 i1=surf_nodes(j,1)
1257 i2=surf_nodes(j,2)
1258 i3=surf_nodes(j,3)
1259 i4=surf_nodes(j,4)
1260 d1x = x(1,i3) - x(1,i1)
1261 d1y = x(2,i3) - x(2,i1)
1262 d1z = x(3,i3) - x(3,i1)
1263 d2x = x(1,i4) - x(1,i2)
1264 d2y = x(2,i4) - x(2,i2)
1265 d2z = x(3,i4) - x(3,i2)
1266 nx = d1y * d2z - d1z * d2y
1267 ny = d1z * d2x - d1x * d2z
1268 nz = d1x * d2y - d1y * d2x
1269 aaa = one/max(sqrt(nx*nx+ny*ny+nz*nz),em20)
1270 nx = nx * aaa
1271 ny = ny * aaa
1272 nz = nz * aaa
1273 DO k=1,4
1274 i1=surf_nodes(j,k)
1275 i2=surf_nodes(j,nextk(k))
1276 IF (i1==i2) cycle
1277 ll = ll+1
1278 IF(i2 > i1)THEN
1279 lineix(1,ll) = i1
1280 lineix(2,ll) = i2
1281 ixwork(8,ll) = 0
1282 ELSE
1283 lineix(1,ll) = i2
1284 lineix(2,ll) = i1
1285C-----------means I1,I2 has been exchanged
1286 ixwork(8,ll) = 1
1287 ENDIF
1288 lineix2(1,ll) = j
1289 lineix2(2,ll) = k
1290 xlineix(1,ll) = nx
1291 xlineix(2,ll) = ny
1292 xlineix(3,ll) = nz
1293 ENDDO
1294 ENDDO
1295C
1296 CALL my_orders(0,iwork,lineix,index,ll,2)
1297c---------------------------------------
1298c removal of duplicate lines
1299c + Calculation of angles (sin) inter-facet
1300c---------------------------------------
1301 li = index(1)
1302 i1m = lineix(1,li)
1303 i2m = lineix(2,li)
1304 i3m = lineix2(1,li)
1305 i4m = lineix2(2,li)
1306 nl = 1
1307 ixwork(1,nl)=i1m
1308 ixwork(2,nl)=i2m
1309 IF(ixwork(8,li)==0)THEN
1310 ixwork(3,nl)=i3m
1311 ixwork(4,nl)=i4m
1312 ixwork(6,nl)=0
1313 ELSE
1314 ixwork(6,nl)=i3m
1315 ixwork(7,nl)=i4m
1316 ixwork(3,nl)=0
1317 ENDIF
1318C---------first -> border but can be corrected later
1319 ixwork(5,nl)=1
1320 mx = xlineix(1,li)
1321 my = xlineix(2,li)
1322 mz = xlineix(3,li)
1323 DO l=2,ll
1324 li = index(l)
1325 i1 = lineix(1,li)
1326 i2 = lineix(2,li)
1327 i3 = lineix2(1,li)
1328 i4 = lineix2(2,li)
1329 nx = xlineix(1,li)
1330 ny = xlineix(2,li)
1331 nz = xlineix(3,li)
1332 IF(i2 /= i2m .or. i1 /= i1m)THEN
1333c store new edge
1334 nl = nl + 1
1335 ixwork(1,nl)=i1
1336 ixwork(2,nl)=i2
1337 IF(ixwork(8,li)==0)THEN
1338 ixwork(3,nl)=i3
1339 ixwork(4,nl)=i4
1340 ixwork(6,nl)=0
1341 ELSE
1342 ixwork(6,nl)=i3
1343 ixwork(7,nl)=i4
1344 ixwork(3,nl)=0
1345 ENDIF
1346 ixwork(5,nl)=1 ! bord
1347 ELSE
1348C------internal lines are not incremented because they are always double
1349C--------- and the second one does the correction
1350 ixwork(5,nl)=0 ! interne
1351c second segment
1352 IF(ixwork(8,li)==0)THEN
1353 ixwork(3,nl)=i3
1354 ixwork(4,nl)=i4
1355 ELSE
1356 ixwork(6,nl)=i3
1357 ixwork(7,nl)=i4
1358 ENDIF
1359 aaa = nx*mx + ny * my + nz * mz
1360 IF (aaa < edg_cos) ixwork(5,nl) = -1 ! arete vive
1361 ENDIF
1362 i1m = i1
1363 i2m = i2
1364 mx = nx
1365 my = ny
1366 mz = nz
1367 ENDDO
1368c---------------------------------------
1369c Deletion of internal lines (iedge == 1)
1370c dimension first
1371c---------------------------------------
1372 ll = nl
1373 nl = 0
1374c the edges are preserved
1375c the live edges are preserved (EDG_COS)
1376 DO l=1,ll
1377 IF(iabs(ixwork(5,l)) == 1)THEN
1378 nl = nl + 1
1379 i1=ixwork(1,nl)
1380 i2=ixwork(2,nl)
1381 i3=ixwork(3,nl)
1382 i4=ixwork(4,nl)
1383 i5=iabs(ixwork(5,nl))
1384 i6=ixwork(6,nl)
1385 i7=ixwork(7,nl)
1386 ixwork(1,nl)=ixwork(1,l)
1387 ixwork(2,nl)=ixwork(2,l)
1388 ixwork(3,nl)=ixwork(3,l)
1389 ixwork(4,nl)=ixwork(4,l)
1390 ixwork(5,nl)=ixwork(5,l)
1391C IXWORK(5,NL)=+-1 ! bord on
1392 ixwork(6,nl)=ixwork(6,l)
1393 ixwork(7,nl)=ixwork(7,l)
1394 ixwork(1,l)=i1
1395 ixwork(2,l)=i2
1396 ixwork(3,l)=i3
1397 ixwork(4,l)=i4
1398 ixwork(5,l)=i5
1399 ixwork(6,l)=i6
1400 ixwork(7,l)=i7
1401 ENDIF
1402 ENDDO
1403C
1404 ELSE
1405C no surfaces
1406 nl = 0
1407 ENDIF
1408c---------------------------------------
1409c setup MBINFLG (IALLO == 2)
1410c tag segment with active edges
1411c (only SECONDARY segment)
1412c---------------------------------------
1413 np_edge=3
1414C------count NRTSE; each seg has only one edge :multi-seg <=4 if necessary
1415C------(possible to use MBINFLG(*)=IRECTS(5,*) to remove multi-seg, but not easy to read
1416C-------no double fictive SECONDARY nodes----
1417C------NSN<-NSN0+NSNE; 3*4*NRTSE for IEDGE = 2 -> more interesting to coding seg/seg
1418C------
1419 IF(iallo == 1 )THEN
1420 DO l=1,nl
1421 IF(iabs(ixwork(5,l)) == 1)THEN
1422 i3 = ixwork(3,l)
1423 i6 = ixwork(6,l)
1424c
1425 IF(i3/=0)THEN
1426 nrtse = nrtse + 1
1427 nsne = nsne + np_edge
1428 END IF
1429 IF(i6/=0)THEN
1430 nrtse = nrtse + 1
1431 IF(i3==0) THEN
1432 nsne = nsne + np_edge
1433 ELSE
1434 nsne = nsne + 1
1435 END IF
1436 END IF
1437 ENDIF
1438 ENDDO
1439 ELSEIF(iallo == 2 )THEN
1440 DO l=1,nl
1441 IF(iabs(ixwork(5,l)) == 1)THEN
1442 i3 = ixwork(3,l)
1443 i6 = ixwork(6,l)
1444 IF(i3/=0)THEN
1445 i4 = ixwork(4,l)
1446 j=i3
1447 nrtse = nrtse + 1
1448 irtse(1:4,nrtse)=surf_nodes(j,1:4)
1449 irtse(5,nrtse)=i4
1450 DO i = 1,np_edge
1451 nsne = nsne + 1
1452 nsv(nsn+nsne) = numnod+nsne
1453 is2se(1,nsne) = nrtse
1454 IF (i6/=0.AND.i/=np_edge) THEN
1455 is2se(2,nsne)=nrtse+1
1456 ELSE
1457 is2se(2,nsne)=0
1458 END IF
1459 is2pt(nsne) = i
1460 END DO
1461c print *,'NRTSE,NSNE=',NRTSE,NSNE
1462C -----IF IS2SE(1,NSNE) >0 and IS2SE(2,NSNE) >0, order is inversed on IS2SE(2
1463 END IF
1464 IF(i6/=0)THEN
1465 i7 = ixwork(7,l)
1466 j=i6
1467 nrtse = nrtse + 1
1468 irtse(1:4,nrtse)=surf_nodes(j,1:4)
1469 irtse(5,nrtse)=i7
1470 IF(i3==0) THEN
1471 DO i = 1,np_edge
1472 nsne = nsne + 1
1473 nsv(nsn+nsne) = numnod+nsne
1474 is2se(2,nsne) = nrtse
1475 is2se(1,nsne) = 0
1476 is2pt(nsne) = i
1477 END DO
1478C------------------only NP_EDGE_th node is added
1479 ELSE
1480 nsne = nsne + 1
1481 nsv(nsn+nsne) = numnod+nsne
1482 is2se(1,nsne) = nrtse
1483 is2se(2,nsne) = 0
1484 is2pt(nsne) = np_edge
1485 END IF
1486 END IF
1487 ENDIF
1488 ENDDO
1489 ENDIF
1490c---------------------------------------
1491c edge number: may keep only NACTIF
1492c---------------------------------------
1493 nactif = nactif + nl
1494c---------------------------------------
1495c setup MBINFLG (IALLO == 2)
1496c---------------------------------------
1497#ifndef HYPERMESH_LIB
1498 IF(iallo == 2 .AND. nl >0 )THEN
1499 IF(ipri >= 5) THEN
1500 WRITE(iout,'(/,A,/)')' ACTIV SEGMENTS USED FOR EDGE'
1501 DO i=1,nl
1502 WRITE(iout,fmt=fmw_4i)(itab(ixwork(k,i)),k=1,2)
1503 ENDDO
1504 ENDIF
1505 END IF
1506#endif
1507c---------------------------------------
1508c edges on SECONDARY segments
1509c---------------------------------------
1510c
1511c +-------------+-------------+ I=I1:first SECONDARY node on edge IJ
1512c | J|I2 | J=I2:first SECONDARY node on edge IJ
1513c | | | S1=I3: left SECONDARY segment
1514c | | | K1=I4: local segment edge K1=[1-4]
1515c | I3 | I6 | I5=1 border edge => S2=K2=0
1516c | I4|I7 | I5=-1 internal edge
1517c | | | S2=I6: right SECONDARY segment
1518c | | | K2=I7: local segment edge K2=[1-4]
1519c |IM I|I1 IP| IM : previous SECONDARY node on seg S1
1520c +-------------+-------------+ IP : next SECONDARY node on seg S2
1521c
1522c---------------------------------------
1523c SECONDARY edges array
1524c---------------------------------------
1525C------Change to simplify SPMD
1526 IF(iallo ==2)THEN
1527 DO i = 1,nsne
1528 IF (is2se(1,i)==0 .AND.is2se(2,i)/=0) THEN
1529 is2se(1,i) = is2se(2,i)
1530 is2se(2,i) = 0
1531 END IF
1532C IS2ID Give global internal ID for Each Fictive node.
1533C Useful in SPMD to easily find the SECONDARY
1534 is2id(i)=i
1535 END DO !I = 1,NSNE
1536 ENDIF
1537c---------------------------------------
1538 DEALLOCATE (index)
1539 DEALLOCATE (ixwork)
1540 DEALLOCATE (lineix)
1541 DEALLOCATE (lineix2)
1542 DEALLOCATE (xlineix)
1543
1544C-----------
1545 RETURN
1546 END
1547!||====================================================================
1548!|| i24xfic_ini ../starter/source/interfaces/inter3d1/i24surfi.f
1549!||--- called by ------------------------------------------------------
1550!|| i24buc1 ../starter/source/interfaces/inter3d1/i24buc1.F
1551!||--- calls -----------------------------------------------------
1552!|| i24fic_getn ../starter/source/interfaces/inter3d1/i24surfi.F
1553!||====================================================================
1554 SUBROUTINE i24xfic_ini(NRTSE ,IRTSE ,NSNE ,IS2SE ,IS2PT ,
1555 4 NSN ,NSV ,X ,XFIC ,NPT )
1556C============================================================================
1557C I m p l i c i t T y p e s
1558C-----------------------------------------------
1559#include "implicit_f.inc"
1560C-----------------------------------------------
1561C C o m m o n B l o c k s
1562C-----------------------------------------------
1563#include "com04_c.inc"
1564C-----------------------------------------------
1565C D u m m y A r g u m e n t s
1566C-----------------------------------------------
1567 INTEGER IRTSE(5,*) ,NSV(*),NRTSE,NSNE,IS2SE(2,*),IS2PT(*),NSN,NPT
1568 my_real
1569 . X(3,*),XFIC(3,*)
1570C-----------------------------------------------
1571C L o c a l V a r i a b l e s
1572C-----------------------------------------------
1573! 4---------------3
1574! | . . |
1575! | . . |
1576! | . . |
1577! | . |
1578! | . . |
1579! | . . |
1580! | . o3 . |
1581! 1---o1------o2--2 NPT=3
1582C----- NLS : Num. of element with active edge----
1583 INTEGER I,J,K,NSN0,NS,IP,IK1(4),IK2(4),IE1,IE2,IED,NS1,NS2,IE,NP0
1584 DATA IK1 /1,2,3,4/
1585 DATA IK2 /2,3,4,1/
1586 my_real
1587 . x0,y0,z0,xe0,ye0,ze0,s
1588C=======================================================================
1589C----IRTSE(5,*) -> id of edge
1590C=======================================================================
1591 nsn0 = nsn-nsne
1592 DO i=nsn0+1,nsn
1593 ns=nsv(i)-numnod
1594 IF (ns<=0) print *,'!!!!error, NSV(I),I=',nsv(i),i
1595 CALL i24fic_getn(ns ,irtse ,is2se ,ie ,ns1 ,
1596 + ns2 )
1597 ip = is2pt(ns)
1598 IF (ip==npt) THEN
1599C-------seg center-------
1600 IF (irtse(3,ie)==irtse(4,ie)) THEN
1601 x0=third*(x(1,irtse(1,ie))+x(1,irtse(2,ie))+x(1,irtse(3,ie)))
1602 y0=third*(x(2,irtse(1,ie))+x(2,irtse(2,ie))+x(2,irtse(3,ie)))
1603 z0=third*(x(3,irtse(1,ie))+x(3,irtse(2,ie))+x(3,irtse(3,ie)))
1604 ELSE
1605 x0=fourth*(x(1,irtse(1,ie))+x(1,irtse(2,ie))+x(1,irtse(3,ie))+
1606 + x(1,irtse(4,ie)))
1607 y0=fourth*(x(2,irtse(1,ie))+x(2,irtse(2,ie))+x(2,irtse(3,ie))+
1608 + x(2,irtse(4,ie)))
1609 z0=fourth*(x(3,irtse(1,ie))+x(3,irtse(2,ie))+x(3,irtse(3,ie))+
1610 + x(3,irtse(4,ie)))
1611 END IF
1612C-------edge center-------
1613 xe0=half*(x(1,ns1)+x(1,ns2))
1614 ye0=half*(x(2,ns1)+x(2,ns2))
1615 ze0=half*(x(3,ns1)+x(3,ns2))
1616C
1617 xfic(1,ns) = third*(x0+two*xe0)
1618 xfic(2,ns) = third*(y0+two*ye0)
1619 xfic(3,ns) = third*(z0+two*ze0)
1620C-------NPT should be unpair: 3,5,7
1621 ELSEIF (ip > 0 ) THEN
1622C-------edge center-------
1623 xe0=half*(x(1,ns1)+x(1,ns2))
1624 ye0=half*(x(2,ns1)+x(2,ns2))
1625 ze0=half*(x(3,ns1)+x(3,ns2))
1626 np0 = (npt-1)/2
1627 IF (ip > np0) THEN
1628C---------right side
1629 s = (ip-np0)*one/(npt-1)
1630 xfic(1,ns) = xe0 +s*(x(1,ns2)-xe0)
1631 xfic(2,ns) = ye0 +s*(x(2,ns2)-ye0)
1632 xfic(3,ns) = ze0 +s*(x(3,ns2)-ze0)
1633 ELSE
1634C---------left side
1635 s = ip*one/(npt-1)
1636 xfic(1,ns) = x(1,ns1) +s*(xe0 -x(1,ns1))
1637 xfic(2,ns) = x(2,ns1) +s*(ye0 -x(2,ns1))
1638 xfic(3,ns) = x(3,ns1) +s*(ze0 -x(3,ns1))
1639 END IF
1640 END IF
1641 END DO
1642C-----------
1643 RETURN
1644 END
1645!||====================================================================
1646!|| i24fics_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1647!||--- called by ------------------------------------------------------
1648!|| i24stsecnd ../starter/source/interfaces/inter3d1/i24stslav.F
1649!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1650!||====================================================================
1651 SUBROUTINE i24fics_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1652 4 NSN ,FIC_S )
1653C============================================================================
1654C I m p l i c i t T y p e s
1655C-----------------------------------------------
1656#include "implicit_f.inc"
1657C-----------------------------------------------
1658C C o m m o n B l o c k s
1659C-----------------------------------------------
1660#include "com04_c.inc"
1661C-----------------------------------------------
1662C D u m m y A r g u m e n t s
1663C-----------------------------------------------
1664 INTEGER IRTSE(5,*) ,NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN
1665 my_real
1666 . FIC_S(*)
1667C------FIC_S could be GAP or STIFF-----------------------------------------
1668C L o c a l V a r i a b l e s
1669C-----------------------------------------------
1670! 4---------------3
1671! | . . |
1672! | . . |
1673! | . . |
1674! | . |
1675! | . . |
1676! | . . |
1677! | . o3 . |
1678! 1---o1------o2--2 NPT=3
1679C----- NLS : Num. of element with active edge----
1680 INTEGER I,J,K,NSN0,NS,NSF,IE1,IE2,IED,NS1,NS2,IE,NP0,N
1681 INTEGER ITAG(NUMNOD),IK1(4),IK2(4)
1682 DATA IK1 /1,2,3,4/
1683 DATA IK2 /2,3,4,1/
1684 my_real
1685 . x0,y0,z0,xe0,ye0,ze0,s
1686C=======================================================================
1687C----IRTSE(5,*) -> id of edge
1688C=======================================================================
1689 nsn0 = nsn -nsne
1690 DO i=1,nsn0
1691 n= nsv(i)
1692 itag(n) = i
1693 END DO
1694 DO i=1,nsne
1695 ie1 = is2se(1,i)
1696 ie2 = is2se(2,i)
1697 IF (ie1 > 0) THEN
1698 ie = ie1
1699 ied=irtse(5,ie)
1700 ns1= irtse(ik1(ied),ie)
1701 ns2= irtse(ik2(ied),ie)
1702 ELSEIF(ie2 > 0) THEN
1703 ie = ie2
1704 ied=irtse(5,ie)
1705 ns1= irtse(ik2(ied),ie)
1706 ns2= irtse(ik1(ied),ie)
1707 ELSE
1708 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
1709 END IF
1710 s = max(fic_s(itag(ns1)),fic_s(itag(ns2)))
1711 fic_s(i+nsn0) = s
1712 END DO ! I=1,NSNE
1713C-----------
1714 RETURN
1715 END
1716!||====================================================================
1717!|| i24fici_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1718!||--- called by ------------------------------------------------------
1719!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1720!||====================================================================
1721 SUBROUTINE i24fici_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1722 4 NSN ,FIC_I )
1723C============================================================================
1724C I m p l i c i t T y p e s
1725C-----------------------------------------------
1726#include "implicit_f.inc"
1727C-----------------------------------------------
1728C C o m m o n B l o c k s
1729C-----------------------------------------------
1730#include "com04_c.inc"
1731C-----------------------------------------------
1732C D u m m y A r g u m e n t s
1733C-----------------------------------------------
1734 INTEGER IRTSE(5,*),NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN,
1735 . fic_i(*)
1736C------FIC_S could be GAP or STIFF-----------------------------------------
1737C L o c a l V a r i a b l e s
1738C-----------------------------------------------
1739! 4---------------3
1740! | . . |
1741! | . . |
1742! | . . |
1743! | . |
1744! | . . |
1745! | . . |
1746! | . o3 . |
1747! 1---o1------o2--2 NPT=3
1748C----- NLS : Num. of element with active edge----
1749 INTEGER I,J,K,NSN0,NS,NSF,IE1,IE2,IED,NS1,NS2,IE,NP0,N,IS
1750 INTEGER ITAG(NUMNOD),IK1(4),IK2(4)
1751 DATA IK1 /1,2,3,4/
1752 DATA IK2 /2,3,4,1/
1753 my_real
1754 . X0,Y0,Z0,XE0,YE0,ZE0
1755C=======================================================================
1756C----IRTSE(5,*) -> id of edge
1757C=======================================================================
1758 nsn0 = nsn -nsne
1759 DO i=1,nsn0
1760 n= nsv(i)
1761 itag(n) = i
1762 END DO
1763 DO i=1,nsne
1764 ie1 = is2se(1,i)
1765 ie2 = is2se(2,i)
1766 IF (ie1 > 0) THEN
1767 ie = ie1
1768 ied=irtse(5,ie)
1769 ns1= irtse(ik1(ied),ie)
1770 ns2= irtse(ik2(ied),ie)
1771 ELSEIF(ie2 > 0) THEN
1772 ie = ie2
1773 ied=irtse(5,ie)
1774 ns1= irtse(ik2(ied),ie)
1775 ns2= irtse(ik1(ied),ie)
1776 ELSE
1777 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
1778 END IF
1779 is = max(fic_i(itag(ns1)),fic_i(itag(ns2)))
1780 fic_i(i+nsn0) = is
1781 END DO ! I=1,NSNE
1782C-----------
1783 RETURN
1784 END
1785!||====================================================================
1786!|| i24isegpt_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1787!||--- called by ------------------------------------------------------
1788!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1789!||--- calls -----------------------------------------------------
1790!|| i24fic_getn ../starter/source/interfaces/inter3d1/i24surfi.F
1791!||====================================================================
1792 SUBROUTINE i24isegpt_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1793 4 NSN ,ISEGPT ,NPT , ISPT2)
1794C============================================================================
1795C I m p l i c i t T y p e s
1796C-----------------------------------------------
1797#include "implicit_f.inc"
1798C-----------------------------------------------
1799C C o m m o n B l o c k s
1800C-----------------------------------------------
1801#include "com04_c.inc"
1802C-----------------------------------------------
1803C D u m m y A r g u m e n t s
1804C-----------------------------------------------
1805 INTEGER IRTSE(5,*),NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN,
1806 . isegpt(*), ispt2(*)
1807C------FIC_S could be GAP or STIFF-----------------------------------------
1808C-----------------------------------------------
1809C L o c a l V a r i a b l e s
1810C-----------------------------------------------
1811! 4---------------3
1812! | . . |
1813! | . . |
1814! | . . |
1815! | . |
1816! | . . |
1817! | . . |
1818! | . o3 . |
1819! 1---o1------o2--2 NPT=3
1820C----- NLS : Num. of element with active edge----
1821 INTEGER I,J,K,NSN0,NS,IP,NS1,NS2,IE,NP0,N,IS1,IS2,IPT
1822 INTEGER ITAG(NUMNOD)
1823C=======================================================================
1824C----IRTSE(5,*) -> id of edge
1825C=======================================================================
1826 NSN0 = nsn -nsne
1827 DO i=1,nsn0
1828 n= nsv(i)
1829 itag(n) = i
1830 isegpt(i) = 0
1831 ispt2(i) = 0
1832 END DO
1833C------fictive nodes first -----
1834 DO i=nsn0+1,nsn
1835 ispt2(i) = 1
1836 ns=nsv(i)-numnod
1837 ip = is2pt(ns)
1838 IF (ip == npt) THEN
1839C-------internal is negative of id him-self
1840 isegpt(i) = -i
1841 ELSEIF (ip == 1.OR.(ip == npt-1)) THEN
1842 CALL i24fic_getn(ns ,irtse ,is2se ,ie ,ns1 ,
1843 + ns2 )
1844C-------on the edge is positive of id him-self
1845C IPT = I + NPT -IP
1846 isegpt(i) = i
1847C-------------ISEGPT(IS1,IS2) have not unique seg, takes the first one
1848 IF (ip==1) THEN
1849 is1 = itag(ns1)
1850 IF (isegpt(is1) ==0) isegpt(is1)=i
1851 ELSE
1852 is2 = itag(ns2)
1853 IF (isegpt(is2) ==0) isegpt(is2)=i
1854 END IF
1855 ELSE
1856 isegpt(i) = i
1857 END IF
1858 END DO
1859C-----------
1860 RETURN
1861 END
1862
1863!||====================================================================
1864!|| ispt2_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1865!||--- called by ------------------------------------------------------
1866!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1867!||====================================================================
1868 SUBROUTINE ispt2_ini(CAND_N, I_STOK, NSN, IRTLM,
1869 * ISEGPT, ISPT2)
1870C-----------------------------------------------
1871C I m p l i c i t T y p e s
1872C-----------------------------------------------
1873#include "implicit_f.inc"
1874C-----------------------------------------------
1875C D u m m y A r g u m e n t s
1876C-----------------------------------------------
1877 INTEGER, INTENT(IN) :: CAND_N(*)
1878 INTEGER, INTENT(IN) :: I_STOK
1879 INTEGER, INTENT(IN) :: NSN
1880 INTEGER, INTENT(IN) :: IRTLM(NSN)
1881 INTEGER, INTENT(IN) :: ISEGPT(NSN)
1882 INTEGER, INTENT(INOUT) :: ISPT2(NSN)
1883C-----------------------------------------------
1884C L o c a l V a r i a b l e s
1885C-----------------------------------------------
1886 INTEGER I,NI,NSI
1887C-----------------------------------------------
1888 ISPT2(1:NSN) = 0
1889 do i=1,i_stok
1890 ni=cand_n(i)
1891 IF(ni <= nsn)THEN
1892 nsi = isegpt(ni)
1893 IF(nsi > 0)THEN
1894 IF(irtlm(nsi) /=0)THEN
1895 ispt2(ni) = 0
1896 ELSE
1897 ispt2(ni) = 1
1898 ENDIF
1899 ELSEIF(nsi<0)THEN
1900 ispt2(ni) = 1
1901 ENDIF
1902 ENDIF
1903
1904 ENDDO
1905
1906
1907 END
1908
1909!||====================================================================
1910!|| i24fic_getn ../starter/source/interfaces/inter3d1/i24surfi.F
1911!||--- called by ------------------------------------------------------
1912!|| i24isegpt_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1913!|| i24pen3 ../starter/source/interfaces/inter3d1/i24pen3.F
1914!|| i24tri ../starter/source/interfaces/inter3d1/i24tri.F
1915!|| i24xfic_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1916!|| iwcontdd_type24 ../starter/source/spmd/domain_decomposition/iwcontdd_type24.F
1917!|| update_weight_inter_type_24_25 ../starter/source/spmd/domain_decomposition/update_weight_inter_type_24_25.F
1918!||--- calls -----------------------------------------------------
1919!|| arret ../starter/source/system/arret.F
1920!||====================================================================
1921 SUBROUTINE i24fic_getn(NS ,IRTSE ,IS2SE ,IE ,NS1 ,
1922 4 NS2 )
1923C============================================================================
1924C I m p l i c i t T y p e s
1925C-----------------------------------------------
1926#include "implicit_f.inc"
1927C-----------------------------------------------
1928C D u m m y A r g u m e n t s
1929C-----------------------------------------------
1930 INTEGER IRTSE(5,*) ,NS,IS2SE(2,*),NS1,NS2,IE
1931C-----------------------------------------------
1932C L o c a l V a r i a b l e s
1933C-----------------------------------------------
1934C----- get edge NS1,NS2 and--SECONDARY seg id :IE-
1935 INTEGER IK1(4),IK2(4),IE1,IE2,IED
1936 DATA IK1 /1,2,3,4/
1937 DATA IK2 /2,3,4,1/
1938C=======================================================================
1939C----IRTSE(5,*) -> id of edge
1940C=======================================================================
1941 IE1 = is2se(1,ns)
1942 ie2 = is2se(2,ns)
1943 IF (ie1 > 0) THEN
1944 ie = ie1
1945 ied=irtse(5,ie)
1946 ns1= irtse(ik1(ied),ie)
1947 ns2= irtse(ik2(ied),ie)
1948 ELSEIF(ie2 > 0) THEN
1949 ie = ie2
1950 ied=irtse(5,ie)
1951 ns1= irtse(ik2(ied),ie)
1952 ns2= irtse(ik1(ied),ie)
1953 ELSE
1954 print *,'problem EDGE IE1,IE2=',ie1,ie2
1955#ifndef HYPERMESH_LIB
1956 call arret(2)
1957#endif
1958 END IF
1959C-----------
1960 RETURN
1961 END
1962!||====================================================================
1963!|| i24ficv_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1964!||--- called by ------------------------------------------------------
1965!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1966!||====================================================================
1967 SUBROUTINE i24ficv_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1968 + NSN ,FIC_V ,NPT )
1969C============================================================================
1970C I m p l i c i t T y p e s
1971C-----------------------------------------------
1972#include "implicit_f.inc"
1973C-----------------------------------------------
1974C C o m m o n B l o c k s
1975C-----------------------------------------------
1976#include "com04_c.inc"
1977C-----------------------------------------------
1978C D u m m y A r g u m e n t s
1979C-----------------------------------------------
1980 INTEGER IRTSE(5,*) ,NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN
1981C-------due to the using of PENE_OLD(5,*)-----
1982 my_real
1983 . fic_v(5,*)
1984C------FIC_S could be GAP or STIFF-----------------------------------------
1985C L o c a l V a r i a b l e s
1986C-----------------------------------------------
1987! 4---------------3
1988! | . . |
1989! | . . |
1990! | . . |
1991! | . |
1992! | . . |
1993! | . . |
1994! | . o3 . |
1995! 1---o1------o2--2 NPT=3
1996C----- NLS : Num. of element with active edge----
1997 INTEGER I,J,K,NSN0,NS,NSF,IE1,IE2,IED,NS1,NS2,IE,NP0,N
1998 INTEGER ITAG(NUMNOD),IK1(4),IK2(4),IP
1999 DATA IK1 /1,2,3,4/
2000 DATA IK2 /2,3,4,1/
2001 my_real
2002 . NX,NY,NZ,DET
2003C=======================================================================
2004C----IRTSE(5,*) -> id of edge
2005C=======================================================================
2006 nsn0 = nsn -nsne
2007 DO i=1,nsn0
2008 n= nsv(i)
2009 itag(n) = i
2010 END DO
2011 DO i=1,nsne
2012 ie1 = is2se(1,i)
2013 ie2 = is2se(2,i)
2014 IF (ie1 > 0) THEN
2015 ie = ie1
2016 ied=irtse(5,ie)
2017 ns1= irtse(ik1(ied),ie)
2018 ns2= irtse(ik2(ied),ie)
2019 ELSEIF(ie2 > 0) THEN
2020 ie = ie2
2021 ied=irtse(5,ie)
2022 ns1= irtse(ik2(ied),ie)
2023 ns2= irtse(ik1(ied),ie)
2024 ELSE
2025 print *,'problem EDGE **** IE1,IE2=',ie1,ie2
2026 END IF
2027 ip = is2pt(i)
2028 nx=zero
2029 ny=zero
2030 nz=zero
2031C------mean value of IE
2032 IF (ip==npt) THEN
2033C------mean value of NS1,NS2
2034 DO j=1,3
2035 n = itag(irtse(j,ie))
2036 nx = nx + fic_v(1,n)
2037 ny = ny + fic_v(2,n)
2038 nz = nz + fic_v(3,n)
2039 END DO
2040 IF (irtse(3,ie)/=irtse(4,ie)) THEN
2041 n = itag(irtse(4,ie))
2042 nx = nx + fic_v(1,n)
2043 ny = ny + fic_v(2,n)
2044 nz = nz + fic_v(3,n)
2045 END IF
2046 ELSE
2047 n = itag(ns1)
2048 nx = nx + fic_v(1,n)
2049 ny = ny + fic_v(2,n)
2050 nz = nz + fic_v(3,n)
2051 n = itag(ns2)
2052 nx = nx + fic_v(1,n)
2053 ny = ny + fic_v(2,n)
2054 nz = nz + fic_v(3,n)
2055 END IF
2056 det = one/max(em20,sqrt(nx*nx+ ny*ny+ nz*nz))
2057 n = i + nsn0
2058 fic_v(1,n) = det*nx
2059 fic_v(2,n) = det*ny
2060 fic_v(3,n) = det*nz
2061 END DO ! I=1,NSNE
2062C-----------
2063 RETURN
2064 END
2065
2066
2067
2068
2069
2070
2071
my_real
#define my_real
Definition cppsort.cpp:32
seg_ins
subroutine seg_ins(irect, nds, nnod, ins, x)
Definition i24surfi.F:1093
sh2surf
subroutine sh2surf(nrtm0, irect, iedg, mbinflg, msegtyp, nrtm)
Definition i24surfi.F:869
i24fici_ini
subroutine i24fici_ini(irtse, nsne, is2se, nsv, is2pt, nsn, fic_i)
Definition i24surfi.F:1723
in24coq_sol3
subroutine in24coq_sol3(irect, ixc, ixtg, msegtyp, x, knod2elc, knod2eltg, nod2elc, nod2eltg, knod2els, nod2els, ixs, ixs10, ixs16, ixs20)
Definition i24surfi.F:941
i24xfic_ini
subroutine i24xfic_ini(nrtse, irtse, nsne, is2se, is2pt, nsn, nsv, x, xfic, npt)
Definition i24surfi.F:1556
i24fics_ini
subroutine i24fics_ini(irtse, nsne, is2se, nsv, is2pt, nsn, fic_s)
Definition i24surfi.F:1653
i24edge2
subroutine i24edge2(iallo, nseg, nactif, surf_nodes, itab, isu, x, edg_cos, mbinflg, iadm, nls, irect, nrtse, irtse, nsne, is2se, is2pt, nsn, nsv, is2id)
Definition i24surfi.F:1171
i24edge1
subroutine i24edge1(iallo, nseg, nactif, iedge, surf_nodes, itab, isu, x, edg_cos, mbinflg, iadm, nls, irect, l24add, iseadd, isedge, nsn, ifirst, nsv)
Definition i24surfi.F:428
i24isegpt_ini
subroutine i24isegpt_ini(irtse, nsne, is2se, nsv, is2pt, nsn, isegpt, npt, ispt2)
Definition i24surfi.F:1794
i24ficv_ini
subroutine i24ficv_ini(irtse, nsne, is2se, nsv, is2pt, nsn, fic_v, npt)
Definition i24surfi.F:1969
i24fic_getn
subroutine i24fic_getn(ns, irtse, is2se, ie, ns1, ns2)
Definition i24surfi.F:1923
ispt2_ini
subroutine ispt2_ini(cand_n, i_stok, nsn, irtlm, isegpt, ispt2)
Definition i24surfi.F:1870
i24surfi
subroutine i24surfi(iallo, ipari, igrnod, igrsurf, irect, frigap, nsv, msr, itab, x, nbinflg, mbinflg, msegtyp, iseadd, isedge, itag, intply, ixc, ixtg, knod2elc, knod2eltg, nod2elc, nod2eltg, knod2els, nod2els, ixs, ixs10, ixs16, ixs20, irtse, is2se, is2pt, is2id, intnitsche)
Definition i24surfi.F:46
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
groupdef_mod
Definition groupdef_mod.F:668
message_mod
Definition message_mod.F:1257
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
arret
subroutine arret(nn)
Definition arret.F:86
starter
program starter
Definition starter.F:39