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
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
54#include "implicit_f.inc"
55C-----------------------------------------------
56C C o m m o n B l o c k s
57C-----------------------------------------------
58#include "com04_c.inc"
59#include "units_c.inc"
60#include "param_c.inc"
61#include "scr03_c.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 INTEGER IALLO,INTNITSCHE,NBINFLG(*)
66 INTEGER IPARI(NPARI),
67 . IRECT(4,*), NSV(*),MSEGTYP(*),
68 . MSR(*),ITAB(*),MBINFLG(*),
69 . ISEADD(*) ,ISEDGE(*),ITAG(*),INTPLY,
70 . IXC(*),IXTG(*),KNOD2ELC(*),KNOD2ELTG(*),
71 . NOD2ELC(*),NOD2ELTG(*),KNOD2ELS(*),NOD2ELS(*),
72 . IRTSE(5,*) ,IS2SE(*),IS2PT(*) ,IS2ID(*)
73 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
74 my_real
75 . x(3,*),frigap(*)
76C-----------------------------------------------
77 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
78 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
79C-----------------------------------------------
80C L o c a l V a r i a b l e s
81C-----------------------------------------------
82 INTEGER I,J,K,L,LL,NL,ISU1,ISU2,NOD1,NRTM,NRTS,NSN,NMN,
83 . NLINSA,NLINMA,ILEV,IEDGE,NSNE,NMNE,NLN,ISYM,
84 . NLINS,NLINM,LINE1,LINE2,STAT,IADL,IL,IG
85 INTEGER TAG(NUMNOD),TAGS(NUMNOD),NEXTK(4),IWORK(70000),
86 . ishif,nsu1,nls1,nls2,nrtm_sh,etyp,nrtm_sh1,nrtm0,
87 . imbin,im,l24add,icoq(4),nrtse
88 my_real
89 . edg_cos
90 DATA nextk/1,1,1,-3/
91C-----------------------------------------------
92C E x t e r n a l F u n c t i o n s
93C-----------------------------------------------
94 INTEGER BITSET
95 EXTERNAL BITSET
96C
97 CHARACTER MESS*40
98 DATA mess/'INTERFACE input '/
99 NSN = 0
100 NMN = 0
101 NRTM = 0
102 NRTS = 0
103 NOD1 = IPARI(26)
104 NLN = 0
105 ILEV = IPARI(20)
106 ISU1 = IPARI(45)
107 ISU2 = IPARI(46)
108 IEDGE = IPARI(58)
109 L24ADD = IPARI(59)
110 EDG_COS = FRIGAP(26)
111 NSU1 = 0
112 NLS1 = 0
113 NLS2 = 0
114 NSNE = 0
115 NRTSE = 0
116 IF(ILEV==2 ) THEN
117c IF(IEDGE /= 0.OR. ILEV==2 ) THEN
118 IMBIN=1
119 ELSE
120 IMBIN=0
121 END IF
122C=======================================================================
123c SURFACES
124C=======================================================================
125c-----------------------------------------------------------------
126c surface S1
127c-----------------------------------------------------------------
128c-----------------------------------------------------------------
129c surface S2
130c-----------------------------------------------------------------
131 SELECT CASE (ILEV)
132C-----attention: ISU2=ISU1 /=0
133 CASE(1)
134 NRTM = IGRSURF(ISU1)%NSEG
135 IF(INTNITSCHE>0) NRTS = NRTM
136 CASE(2)
137 NRTM = IGRSURF(ISU1)%NSEG
138 NRTS = IGRSURF(ISU2)%NSEG
139 NRTM = NRTM + NRTS
140 IF(INTNITSCHE>0) NRTS = NRTM
141 CASE(3)
142 NRTM = IGRSURF(ISU2)%NSEG
143 END SELECT
144c ISYM = IPARI(43)
145c---------------------------------------
146c copie des surfaces (IALLO == 2)
147c---------------------------------------
148 IF(IALLO == 2)THEN
149 DO I=1,NRTM
150 MSEGTYP(I)=0
151 ENDDO
152 L = 0
153 IF(ISU1 /= 0)THEN
154 DO J=1,IGRSURF(ISU1)%NSEG
155 L = L+1
156 DO K=1,4
157 IRECT(K,L) = IGRSURF(ISU1)%NODES(J,K)
158 ENDDO
159 MSEGTYP(L) = IGRSURF(ISU1)%ELTYP(J)
160C------------ call anyway, if coating shell MSEGTYP(L)=MSEGTYP(L)+1
161 CALL IN24COQ_SOL3(IRECT(1,L) ,IXC ,IXTG ,MSEGTYP(L) ,X ,
162 . KNOD2ELC ,KNOD2ELTG ,NOD2ELC ,NOD2ELTG,
163 . KNOD2ELS,NOD2ELS,IXS ,IXS10 ,IXS16 ,IXS20 )
164 IF(IMBIN /= 0)MBINFLG(L) = BITSET(MBINFLG(L),0)
165 ENDDO
166 ENDIF
167 NSU1 = L
168.AND. IF(ISU2 /= 0 ILEV /= 1)THEN
169 DO J=1,IGRSURF(ISU2)%NSEG
170 L = L+1
171 DO K=1,4
172 IRECT(K,L) = IGRSURF(ISU2)%NODES(J,K)
173 ENDDO
174 MSEGTYP(L) = IGRSURF(ISU2)%ELTYP(J)
175 CALL IN24COQ_SOL3(IRECT(1,L) ,IXC ,IXTG ,MSEGTYP(L) ,X ,
176 . KNOD2ELC ,KNOD2ELTG ,NOD2ELC ,NOD2ELTG,
177 . KNOD2ELS,NOD2ELS,IXS ,IXS10 ,IXS16 ,IXS20 )
178 IF(IMBIN /= 0) MBINFLG(L) = BITSET(MBINFLG(L),1)
179 ENDDO
180 ENDIF
181#ifndef HYPERMESH_LIB
182 IF(IPRI>=5) THEN
183 WRITE(IOUT,'(/,a,/)')' segments used for main surface: '
184 DO I=1,NRTM
185 WRITE(IOUT,FMT=FMW_4I)(ITAB(IRECT(K,I)),K=1,4)
186 ENDDO
187 ENDIF
188#endif
189 ENDIF
190C=======================================================================
191c NOEUDS
192C=======================================================================
193c-----------------------------------------------------------------
194c tag noeuds 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 noeuds de la surface 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.OR. IF(TAG(I) == 2 TAG(I) == 3)THEN
253 TAG(I) = - TAG(I)
254.AND. IF ( ILEV == 2TAGS(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 noeuds de la surface 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.AND. IF(TAGS(I) == 0 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.or. IF(TAG(I) == 1 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 noeuds du groupe de noeud NOD1: 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.and. IF(IALLO == 2 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.AND. IF(ISU2 /= 0 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.AND. IF(ISU2 /= 0 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 nombre de noeuds dans l'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 pour 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.OR. IF(ETYP ==3 ETYP ==7 ) NRTM_SH = NRTM_SH + 1
393 ENDDO
394 ENDIF
395.AND. IF(ISU2 /= 0 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.OR. IF(ETYP ==3 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 recherche de toutes les lignes dans la 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 suppression des lignes doubles
558c + calcul des angles(sin) inter-facettes
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.or. IF(I2 /= I2M 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 suppression des lignes internes (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 toutes les lignes sont conserves ET actives
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 les bords sont conservs
669c les artes vives sont conservs (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.AND. IF(IALLO == 2 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 nombre de lignes: may keep only NACTIF
731c---------------------------------------
732 NACTIF = NACTIF + NL
733c---------------------------------------
734c setup MBINFLG (IALLO == 2)
735c---------------------------------------
736#ifndef HYPERMESH_LIB
737.AND..AND. IF(IALLO == 2 NL >0 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.OR. IF(ETYP(I) ==3 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.OR. ELSEIF(ETYP(I) ==4 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.OR. IF(ETYP(I) ==3 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!||====================================================================
937 SUBROUTINE IN24COQ_SOL3(IRECT ,IXC ,IXTG ,MSEGTYP ,X ,
938 . KNOD2ELC ,KNOD2ELTG ,NOD2ELC ,NOD2ELTG,
939 . KNOD2ELS,NOD2ELS,IXS ,IXS10 ,IXS16 ,IXS20 )
940C-----------------------------------------------
941C I m p l i c i t T y p e s
942C-----------------------------------------------
943#include "implicit_f.inc"
944C-----------------------------------------------
945C C o m m o n B l o c k s
946C-----------------------------------------------
947#include "com04_c.inc"
948C-----------------------------------------------
949C D u m m y A r g u m e n t s
950C-----------------------------------------------
951 INTEGER MSEGTYP, KNOD2ELS(*),NOD2ELS(*)
952 INTEGER IRECT(4), IXC(NIXC,*), IXTG(NIXTG,*),
953 . KNOD2ELC(*) ,KNOD2ELTG(*) ,NOD2ELC(*) ,NOD2ELTG(*)
954 INTEGER IXS(NIXS,*),IXS10(6,*), IXS16(8,*), IXS20(12,*)
955C REAL
956 my_real
957 . X(3,*)
958C-----------------------------------------------
959C L o c a l V a r i a b l e s
960C-----------------------------------------------
961 INTEGER N, J, II, K, IAD ,NEL,NELTG,NS,NELS,NDS(20),NNOD,JJ,INS
962C REAL
963C-----------------------------------------------
964C-------if coating shell made of two segs, verify the value of MSEGTYP
965C--if MSEGTYP=0, seg define -> if shell look at is also solid ; get at least 3n in sloid
966C--if MSEGTYP shell -> same than before
967C--if MSEGTYP solid -> nothing
968.OR. IF (MSEGTYP==3 MSEGTYP==7) GOTO 300
969 IF (MSEGTYP/=0) RETURN
970 NEL=0
971 NELTG=0
972.AND. IF(IRECT(3)==IRECT(4)NUMELTG/=0)THEN
973 DO 230 IAD=KNOD2ELTG(IRECT(1))+1,KNOD2ELTG(IRECT(1)+1)
974 N = NOD2ELTG(IAD)
975 DO 220 J=1,3
976 II=IRECT(J)
977 DO K=1,3
978 IF(IXTG(K+1,N)==II) GOTO 220
979 END DO
980 GOTO 230
981 220 CONTINUE
982 NELTG = N
983 230 CONTINUE
984 ENDIF
985C
986 IF(NUMELC/=0) THEN
987 DO 430 IAD=KNOD2ELC(IRECT(1))+1,KNOD2ELC(IRECT(1)+1)
988 N = NOD2ELC(IAD)
989 DO 420 J=1,4
990 II=IRECT(J)
991 DO K=1,4
992 IF(IXC(K+1,N)==II) GOTO 420
993 END DO
994 GOTO 430
995 420 CONTINUE
996 NEL = N
997 430 CONTINUE
998 ENDIF
999C----
1000 IF (NEL>0) THEN
1001 MSEGTYP = 3
1002 ELSEIF(NELTG>0) THEN
1003 MSEGTYP = 7
1004 END IF
1005
1006 300 CONTINUE
1007C------solid element
1008.OR. IF(MSEGTYP==0NUMELS==0) RETURN
1009 NELS=0
1010 NS = IRECT(1)
1011C
1012 DO 330 IAD=KNOD2ELS(NS)+1,KNOD2ELS(NS+1)
1013 N = NOD2ELS(IAD)
1014 IF(N <= NUMELS8)THEN
1015 DO 310 JJ=1,4
1016 II=IRECT(JJ)
1017 DO K=1,8
1018 IF(IXS(K+1,N)==II) GOTO 310
1019 ENDDO
1020 GOTO 330
1021 310 CONTINUE
1022 NDS(1:8)=IXS(2:9,N)
1023 NNOD = 8
1024 ELSEIF(N <= NUMELS8+NUMELS10)THEN
1025 DO 320 JJ=1,4
1026 II=IRECT(JJ)
1027 DO K=1,8
1028 IF(IXS(K+1,N)==II) GOTO 320
1029 ENDDO
1030 DO K=1,6
1031 IF(IXS10(K,N-NUMELS8)==II) GOTO 320
1032 ENDDO
1033 GOTO 330
1034 320 CONTINUE
1035 NDS(1)=IXS(2,N)
1036 NDS(2)=IXS(4,N)
1037 NDS(3)=IXS(7,N)
1038 NDS(4)=IXS(6,N)
1039 NDS(5:10)=IXS10(1:6,N-NUMELS8)
1040 NNOD = 10
1041 ELSEIF(N <= NUMELS8+NUMELS10+NUMELS20)THEN
1042 DO 322 JJ=1,4
1043 II=IRECT(JJ)
1044 DO K=1,8
1045 IF(IXS(K+1,N)==II) GOTO 322
1046 ENDDO
1047 DO K=1,12
1048 IF(IXS20(K,N-NUMELS8-NUMELS10)==II) GOTO 322
1049 ENDDO
1050 GOTO 330
1051 322 CONTINUE
1052 NDS(1:8)=IXS(2:9,N)
1053 NDS(9:20)=IXS20(1:12,N-NUMELS8-NUMELS10)
1054 NNOD = 20
1055 ELSEIF(N <= NUMELS8+NUMELS10+NUMELS20+NUMELS16)THEN
1056 DO 324 JJ=1,4
1057 II=IRECT(JJ)
1058 DO K=1,8
1059 IF(IXS(K+1,N)==II) GOTO 324
1060 ENDDO
1061 DO K=1,8
1062 IF(IXS16(K,N-NUMELS8-NUMELS10-NUMELS20)==II) GOTO 324
1063 ENDDO
1064 GOTO 330
1065 324 CONTINUE
1066 NDS(1:8)=IXS(2:9,N)
1067 NDS(9:16)=IXS16(1:8,N-NUMELS8-NUMELS10-NUMELS20)
1068 NNOD = 16
1069 ELSE
1070 GOTO 330
1071 END IF
1072 CALL SEG_INS(IRECT,NDS,NNOD,INS,X )
1073 IF (INS/=0) NELS = N
1074 IF (NELS>0) GOTO 500
1075 330 CONTINUE
1076
1077 500 CONTINUE
1078.AND..OR. IF (NELS>0 (MSEGTYP==3 MSEGTYP==7)) THEN
1079 MSEGTYP = MSEGTYP + 1
1080 IF (INS <0) MSEGTYP=-MSEGTYP
1081 END IF
1082
1083 RETURN
1084 END
1085!||====================================================================
1086!|| seg_ins ../starter/source/interfaces/inter3d1/i24surfi.F
1087!||--- called by ------------------------------------------------------
1088!|| in24coq_sol3 ../starter/source/interfaces/inter3d1/i24surfi.F
1089!||====================================================================
1090 SUBROUTINE SEG_INS(IRECT,NDS,NNOD,INS,X)
1091C----6---------------------------------------------------------------7---------8
1092C I m p l i c i t T y p e s
1093C-----------------------------------------------
1094#include "implicit_f.inc"
1095C-----------------------------------------------------------------
1096C D u m m y A r g u m e n t s
1097C-----------------------------------------------
1098 INTEGER IRECT(4),NDS(*),NNOD,INS
1099 my_real
1100 . X(3,*)
1101C-----------------------------------------------
1102C L o c a l V a r i a b l e s
1103C-----------------------------------------------
1104 INTEGER I,J,II,K,M,LING,NN
1105 my_real
1106 . X1,Y1,Z1,X41,Y41,Z41,X42,Y42,Z42,X43,Y43,Z43,NX,NY,NZ,VOL
1107C--------------------------------------------------------------------
1108 INS =0
1109 NN =0
1110 DO I=1,3
1111 II = IRECT(I)
1112 DO J=1,NNOD
1113 IF (NDS(J)==II) THEN
1114 NN = NN +1
1115 CYCLE
1116 END IF
1117 END DO
1118 END DO !I=1,3
1119 IF (NN>=3) INS =1
1120C--------compute the volume of solid center&IRECT(1-3), if V>0 inverse the normal
1121 IF (INS/=0) THEN
1122 X1=ZERO
1123 Y1=ZERO
1124 Z1=ZERO
1125 DO J=1,NNOD
1126 X1=X1+X(1,NDS(J))
1127 Y1=Y1+X(2,NDS(J))
1128 Z1=Z1+X(3,NDS(J))
1129 END DO
1130 X1=X1/NNOD
1131 Y1=Y1/NNOD
1132 Z1=Z1/NNOD
1133 X41 = X(1,IRECT(3)) - X1
1134 Y41 = X(2,IRECT(3)) - Y1
1135 Z41 = X(3,IRECT(3)) - Z1
1136 X42 = X(1,IRECT(3)) - X(1,IRECT(1))
1137 Y42 = X(2,IRECT(3)) - X(2,IRECT(1))
1138 Z42 = X(3,IRECT(3)) - X(3,IRECT(1))
1139 X43 = X(1,IRECT(3)) - X(1,IRECT(2))
1140 Y43 = X(2,IRECT(3)) - X(2,IRECT(2))
1141 Z43 = X(3,IRECT(3)) - X(3,IRECT(2))
1142C
1143 NX = Y43*Z42 - Y42*Z43
1144 NY = Z43*X42 - Z42*X43
1145 NZ = X43*Y42 - X42*Y43
1146C
1147 VOL = X41*NX + Y41*NY + Z41*NZ
1148 IF (VOL > ZERO) INS= -1
1149 END IF
1150C----6---------------------------------------------------------------7---------8
1151 RETURN
1152 END
1153!||====================================================================
1154!|| i24edge2 ../starter/source/interfaces/inter3d1/i24surfi.F
1155!||--- called by ------------------------------------------------------
1156!|| i24surfi ../starter/source/interfaces/inter3d1/i24surfi.F
1157!||--- calls -----------------------------------------------------
1158!|| ancmsg ../starter/source/output/message/message.F
1159!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
1160!||--- uses -----------------------------------------------------
1161!|| format_mod ../starter/share/modules1/format_mod.F90
1162!|| message_mod ../starter/share/message_module/message_mod.F
1163!||====================================================================
1164 SUBROUTINE I24EDGE2(IALLO ,NSEG ,NACTIF ,
1165 1 SURF_NODES ,ITAB ,ISU ,
1166 2 X ,EDG_COS ,MBINFLG ,IADM ,NLS ,
1167 3 IRECT ,NRTSE ,IRTSE ,NSNE ,IS2SE ,
1168 4 IS2PT ,NSN ,NSV ,IS2ID)
1169C-----------------------------------------------
1170C M o d u l e s
1171C-----------------------------------------------
1172#ifndef HYPERMESH_LIB
1173 USE MESSAGE_MOD
1174#endif
1175 USE FORMAT_MOD , ONLY : FMW_4I
1176C-----------------------------------------------
1177C I m p l i c i t T y p e s
1178C-----------------------------------------------
1179#include "implicit_f.inc"
1180C-----------------------------------------------
1181C C o m m o n B l o c k s
1182C-----------------------------------------------
1183#include "com04_c.inc"
1184#include "units_c.inc"
1185#include "scr03_c.inc"
1186C-----------------------------------------------
1187C D u m m y A r g u m e n t s
1188C-----------------------------------------------
1189 INTEGER IALLO,NACTIF,IADM,NLS,L24ADD,NSN,IFIRST,ISU
1190 INTEGER ITAB(*),MBINFLG(*),IRECT(4,*),NSEG,SURF_NODES(NSEG,4),
1191 . IRTSE(5,*) ,NSV(*),NRTSE,NSNE,IS2SE(2,*),IS2PT(*),IS2ID(*)
1192 my_real
1193 . X(3,*),EDG_COS
1194C-----------------------------------------------
1195C L o c a l V a r i a b l e s
1196C-----------------------------------------------
1197C----- NLS : Num. of element with active edge----
1198 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,NL,IS,
1199 . I3M,I4M,I6,I7,IADD,IM,IP,LI
1200 INTEGER NEXTK(4),KM1(4),KP2(4),IWORK(70000),NLL,NSE,NP_EDGE
1201 my_real
1202 . NX,NY,NZ,MX,MY,MZ,AAA,D1X,D1Y,D1Z,D2X,D2Y,D2Z,IMJ,IPJ
1203 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
1204 . LINEIX,LINEIX2,IXWORK
1205 INTEGER, DIMENSION(:), ALLOCATABLE ::
1206 . INDEX,TAG,ISEADD_L,ISH
1207 my_real, DIMENSION(:,:), ALLOCATABLE ::
1208 . XLINEIX
1209
1210 INTEGER BITSET
1211 EXTERNAL BITSET
1212
1213 DATA NEXTK/2,3,4,1/
1214 DATA KM1/4,1,2,3/
1215 DATA KP2/3,4,1,2/
1216C=======================================================================
1217C--- edges are used only to select SECONDARY segments:IRTSE(5,NRTSE),
1218C----IRTSE(5,*) -> id of edge
1219C=======================================================================
1220 NLMAX = 0
1221 NLS = 0
1222 IF(ISU /= 0)NLMAX = 4*NSEG
1223c---------------------------------------
1224c LINEIX(2,*): LINE; LINEIX2(1,):Id_seg,LINEIX2(2,):Jd_seg(1-4)
1225c IXWORK(8,*): reordered lines; (1-2,)<-LINEIX,(3-4,)or (6-7,) if inverse order of I1,I2
1226c <-LINEIX2,(5):I_bord; (8,):flag of inverse I1,I2
1227c---------------------------------------
1228 ALLOCATE (LINEIX(2,NLMAX) ,STAT=stat)
1229 ALLOCATE (LINEIX2(2,NLMAX) ,STAT=stat)
1230 ALLOCATE (XLINEIX(3,NLMAX) ,STAT=stat)
1231 ALLOCATE (INDEX(2*NLMAX) ,STAT=stat)
1232 ALLOCATE (IXWORK(8,NLMAX) ,STAT=stat)
1233
1234#ifndef HYPERMESH_LIB
1235 IF (STAT /= 0) THEN
1236 CALL ANCMSG(MSGID=268,
1237 . MSGTYPE=MSGERROR,
1238 . ANMODE=ANSTOP,
1239 . C1='lineix')
1240 END IF
1241#endif
1242c---------------------------------------
1243c recherche de toutes les lignes dans la surface
1244c---------------------------------------
1245C initialize IXWORK to zero
1246 IXWORK(4,1:NLMAX)=0
1247
1248
1249 IF(ISU /= 0)THEN
1250 IS = 0
1251 LL = 0
1252 DO J=1,NSEG
1253 IS = IS+1
1254 I1=SURF_NODES(J,1)
1255 I2=SURF_NODES(J,2)
1256 I3=SURF_NODES(J,3)
1257 I4=SURF_NODES(J,4)
1258 D1X = X(1,I3) - X(1,I1)
1259 D1Y = X(2,I3) - X(2,I1)
1260 D1Z = X(3,I3) - X(3,I1)
1261 D2X = X(1,I4) - X(1,I2)
1262 D2Y = X(2,I4) - X(2,I2)
1263 D2Z = X(3,I4) - X(3,I2)
1264 NX = D1Y * D2Z - D1Z * D2Y
1265 NY = D1Z * D2X - D1X * D2Z
1266 NZ = D1X * D2Y - D1Y * D2X
1267 AAA = ONE/MAX(SQRT(NX*NX+NY*NY+NZ*NZ),EM20)
1268 NX = NX * AAA
1269 NY = NY * AAA
1270 NZ = NZ * AAA
1271 DO K=1,4
1272 I1=SURF_NODES(J,K)
1273 I2=SURF_NODES(J,NEXTK(K))
1274 IF (I1==I2) CYCLE
1275 LL = LL+1
1276 IF(I2 > I1)THEN
1277 LINEIX(1,LL) = I1
1278 LINEIX(2,LL) = I2
1279 IXWORK(8,LL) = 0
1280 ELSE
1281 LINEIX(1,LL) = I2
1282 LINEIX(2,LL) = I1
1283C-----------means I1,I2 has been exchanged
1284 IXWORK(8,LL) = 1
1285 ENDIF
1286 LINEIX2(1,LL) = J
1287 LINEIX2(2,LL) = K
1288 XLINEIX(1,LL) = NX
1289 XLINEIX(2,LL) = NY
1290 XLINEIX(3,LL) = NZ
1291 ENDDO
1292 ENDDO
1293C
1294 CALL MY_ORDERS(0,IWORK,LINEIX,INDEX,LL,2)
1295c---------------------------------------
1296c suppression des lignes doubles
1297c + calcul des angles(sin) inter-facettes
1298c---------------------------------------
1299 LI = INDEX(1)
1300 I1M = LINEIX(1,LI)
1301 I2M = LINEIX(2,LI)
1302 I3M = LINEIX2(1,LI)
1303 I4M = LINEIX2(2,LI)
1304 NL = 1
1305 IXWORK(1,NL)=I1M
1306 IXWORK(2,NL)=I2M
1307 IF(IXWORK(8,LI)==0)THEN
1308 IXWORK(3,NL)=I3M
1309 IXWORK(4,NL)=I4M
1310 IXWORK(6,NL)=0
1311 ELSE
1312 IXWORK(6,NL)=I3M
1313 IXWORK(7,NL)=I4M
1314 IXWORK(3,NL)=0
1315 ENDIF
1316C---------first -> border but can be corrected later
1317 IXWORK(5,NL)=1
1318 MX = XLINEIX(1,LI)
1319 MY = XLINEIX(2,LI)
1320 MZ = XLINEIX(3,LI)
1321 DO L=2,LL
1322 LI = INDEX(L)
1323 I1 = LINEIX(1,LI)
1324 I2 = LINEIX(2,LI)
1325 I3 = LINEIX2(1,LI)
1326 I4 = LINEIX2(2,LI)
1327 NX = XLINEIX(1,LI)
1328 NY = XLINEIX(2,LI)
1329 NZ = XLINEIX(3,LI)
1330.or. IF(I2 /= I2M I1 /= I1M)THEN
1331c store new edge
1332 NL = NL + 1
1333 IXWORK(1,NL)=I1
1334 IXWORK(2,NL)=I2
1335 IF(IXWORK(8,LI)==0)THEN
1336 IXWORK(3,NL)=I3
1337 IXWORK(4,NL)=I4
1338 IXWORK(6,NL)=0
1339 ELSE
1340 IXWORK(6,NL)=I3
1341 IXWORK(7,NL)=I4
1342 IXWORK(3,NL)=0
1343 ENDIF
1344 IXWORK(5,NL)=1 ! bord
1345 ELSE
1346C------internal lines are not incremented because they are always double
1347C--------- and the second one does the correction
1348 IXWORK(5,NL)=0 ! interne
1349c second segment
1350 IF(IXWORK(8,LI)==0)THEN
1351 IXWORK(3,NL)=I3
1352 IXWORK(4,NL)=I4
1353 ELSE
1354 IXWORK(6,NL)=I3
1355 IXWORK(7,NL)=I4
1356 ENDIF
1357 AAA = NX*MX + NY * MY + NZ * MZ
1358 IF (AAA < EDG_COS) IXWORK(5,NL) = -1 ! arete vive
1359 ENDIF
1360 I1M = I1
1361 I2M = I2
1362 MX = NX
1363 MY = NY
1364 MZ = NZ
1365 ENDDO
1366c---------------------------------------
1367c suppression des lignes internes (IEDGE == 1)
1368c dimension first
1369c---------------------------------------
1370 LL = NL
1371 NL = 0
1372c les bords sont conservs
1373c les artes vives sont conservs (EDG_COS)
1374 DO L=1,LL
1375 IF(IABS(IXWORK(5,L)) == 1)THEN
1376 NL = NL + 1
1377 I1=IXWORK(1,NL)
1378 I2=IXWORK(2,NL)
1379 I3=IXWORK(3,NL)
1380 I4=IXWORK(4,NL)
1381 I5=IABS(IXWORK(5,NL))
1382 I6=IXWORK(6,NL)
1383 I7=IXWORK(7,NL)
1384 IXWORK(1,NL)=IXWORK(1,L)
1385 IXWORK(2,NL)=IXWORK(2,L)
1386 IXWORK(3,NL)=IXWORK(3,L)
1387 IXWORK(4,NL)=IXWORK(4,L)
1388 IXWORK(5,NL)=IXWORK(5,L)
1389C IXWORK(5,NL)=+-1 ! bord on
1390 IXWORK(6,NL)=IXWORK(6,L)
1391 IXWORK(7,NL)=IXWORK(7,L)
1392 IXWORK(1,L)=I1
1393 IXWORK(2,L)=I2
1394 IXWORK(3,L)=I3
1395 IXWORK(4,L)=I4
1396 IXWORK(5,L)=I5
1397 IXWORK(6,L)=I6
1398 IXWORK(7,L)=I7
1399 ENDIF
1400 ENDDO
1401C
1402 ELSE
1403C pas de surfaces
1404 NL = 0
1405 ENDIF
1406c---------------------------------------
1407c setup MBINFLG (IALLO == 2)
1408c tag segment with active edges
1409c (only SECONDARY segment)
1410c---------------------------------------
1411 NP_EDGE=3
1412C------count NRTSE; each seg has only one edge :multi-seg <=4 if necessary
1413C------(possible to use MBINFLG(*)=IRECTS(5,*) to remove multi-seg, but not easy to read
1414C-------no double fictive SECONDARY nodes----
1415C------NSN<-NSN0+NSNE; 3*4*NRTSE for IEDGE = 2 -> more interesting to coding seg/seg
1416C------
1417 IF(IALLO == 1 )THEN
1418 DO L=1,NL
1419 IF(IABS(IXWORK(5,L)) == 1)THEN
1420 I3 = IXWORK(3,L)
1421 I6 = IXWORK(6,L)
1422c
1423 IF(I3/=0)THEN
1424 NRTSE = NRTSE + 1
1425 NSNE = NSNE + NP_EDGE
1426 END IF
1427 IF(I6/=0)THEN
1428 NRTSE = NRTSE + 1
1429 IF(I3==0) THEN
1430 NSNE = NSNE + NP_EDGE
1431 ELSE
1432 NSNE = NSNE + 1
1433 END IF
1434 END IF
1435 ENDIF
1436 ENDDO
1437 ELSEIF(IALLO == 2 )THEN
1438 DO L=1,NL
1439 IF(IABS(IXWORK(5,L)) == 1)THEN
1440 I3 = IXWORK(3,L)
1441 I6 = IXWORK(6,L)
1442 IF(I3/=0)THEN
1443 I4 = IXWORK(4,L)
1444 J=I3
1445 NRTSE = NRTSE + 1
1446 IRTSE(1:4,NRTSE)=SURF_NODES(J,1:4)
1447 IRTSE(5,NRTSE)=I4
1448 DO I = 1,NP_EDGE
1449 NSNE = NSNE + 1
1450 NSV(NSN+NSNE) = NUMNOD+NSNE
1451 IS2SE(1,NSNE) = NRTSE
1452.AND. IF (I6/=0I/=NP_EDGE) THEN
1453 IS2SE(2,NSNE)=NRTSE+1
1454 ELSE
1455 IS2SE(2,NSNE)=0
1456 END IF
1457 IS2PT(NSNE) = I
1458 END DO
1459c print *,'NRTSE,NSNE=',NRTSE,NSNE
1460C -----IF IS2SE(1,NSNE) >0 and IS2SE(2,NSNE) >0, order is inversed on IS2SE(2
1461 END IF
1462 IF(I6/=0)THEN
1463 I7 = IXWORK(7,L)
1464 J=I6
1465 NRTSE = NRTSE + 1
1466 IRTSE(1:4,NRTSE)=SURF_NODES(J,1:4)
1467 IRTSE(5,NRTSE)=I7
1468 IF(I3==0) THEN
1469 DO I = 1,NP_EDGE
1470 NSNE = NSNE + 1
1471 NSV(NSN+NSNE) = NUMNOD+NSNE
1472 IS2SE(2,NSNE) = NRTSE
1473 IS2SE(1,NSNE) = 0
1474 IS2PT(NSNE) = I
1475 END DO
1476C------------------only NP_EDGE_th node is added
1477 ELSE
1478 NSNE = NSNE + 1
1479 NSV(NSN+NSNE) = NUMNOD+NSNE
1480 IS2SE(1,NSNE) = NRTSE
1481 IS2SE(2,NSNE) = 0
1482 IS2PT(NSNE) = NP_EDGE
1483 END IF
1484 END IF
1485 ENDIF
1486 ENDDO
1487 ENDIF
1488c---------------------------------------
1489c edge number: may keep only NACTIF
1490c---------------------------------------
1491 NACTIF = NACTIF + NL
1492c---------------------------------------
1493c setup MBINFLG (IALLO == 2)
1494c---------------------------------------
1495#ifndef HYPERMESH_LIB
1496.AND. IF(IALLO == 2 NL >0 )THEN
1497 IF(IPRI >= 5) THEN
1498 WRITE(IOUT,'(/,a,/)')' activ segments used for edge'
1499 DO I=1,NL
1500 WRITE(IOUT,FMT=FMW_4I)(ITAB(IXWORK(K,I)),K=1,2)
1501 ENDDO
1502 ENDIF
1503 END IF
1504#endif
1505c---------------------------------------
1506c edges on SECONDARY segments
1507c---------------------------------------
1508c
1509c +-------------+-------------+ I=I1:first SECONDARY node on edge IJ
1510c | J|I2 | J=I2:first SECONDARY node on edge IJ
1511c | | | S1=I3: left SECONDARY segment
1512c | | | K1=I4: local segment edge K1=[1-4]
1513c | I3 | I6 | I5=1 border edge => S2=K2=0
1514c | I4|I7 | I5=-1 internal edge
1515c | | | S2=I6: right SECONDARY segment
1516c | | | K2=I7: local segment edge K2=[1-4]
1517c |IM I|I1 IP| IM : previous SECONDARY node on seg S1
1518c +-------------+-------------+ IP : next SECONDARY node on seg S2
1519c
1520c---------------------------------------
1521c SECONDARY edges array
1522c---------------------------------------
1523C------Change to simplify SPMD
1524 IF(IALLO ==2)THEN
1525 DO I = 1,NSNE
1526.AND. IF (IS2SE(1,I)==0 IS2SE(2,I)/=0) THEN
1527 IS2SE(1,I) = IS2SE(2,I)
1528 IS2SE(2,I) = 0
1529 END IF
1530C IS2ID Give global internal ID for Each Fictive node.
1531C Useful in SPMD to easily find the SECONDARY
1532 IS2ID(I)=I
1533 END DO !I = 1,NSNE
1534 ENDIF
1535c---------------------------------------
1536 DEALLOCATE (INDEX)
1537 DEALLOCATE (IXWORK)
1538 DEALLOCATE (LINEIX)
1539 DEALLOCATE (LINEIX2)
1540 DEALLOCATE (XLINEIX)
1541
1542C-----------
1543 RETURN
1544 END
1545!||====================================================================
1546!|| i24xfic_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1547!||--- called by ------------------------------------------------------
1548!|| i24buc1 ../starter/source/interfaces/inter3d1/i24buc1.F
1549!||--- calls -----------------------------------------------------
1550!|| i24fic_getn ../starter/source/interfaces/inter3d1/i24surfi.F
1551!||====================================================================
1552 SUBROUTINE I24XFIC_INI(NRTSE ,IRTSE ,NSNE ,IS2SE ,IS2PT ,
1553 4 NSN ,NSV ,X ,XFIC ,NPT )
1554C============================================================================
1555C I m p l i c i t T y p e s
1556C-----------------------------------------------
1557#include "implicit_f.inc"
1558C-----------------------------------------------
1559C C o m m o n B l o c k s
1560C-----------------------------------------------
1561#include "com04_c.inc"
1562C-----------------------------------------------
1563C D u m m y A r g u m e n t s
1564C-----------------------------------------------
1565 INTEGER IRTSE(5,*) ,NSV(*),NRTSE,NSNE,IS2SE(2,*),IS2PT(*),NSN,NPT
1566 my_real
1567 . X(3,*),XFIC(3,*)
1568C-----------------------------------------------
1569C L o c a l V a r i a b l e s
1570C-----------------------------------------------
1571! 4---------------3
1572! | . . |
1573! | . . |
1574! | . . |
1575! | . |
1576! | . . |
1577! | . . |
1578! | . o3 . |
1579! 1---o1------o2--2 NPT=3
1580C----- NLS : Num. of element with active edge----
1581 INTEGER I,J,K,NSN0,NS,IP,IK1(4),IK2(4),IE1,IE2,IED,NS1,NS2,IE,NP0
1582 DATA IK1 /1,2,3,4/
1583 DATA IK2 /2,3,4,1/
1584 my_real
1585 . X0,Y0,Z0,XE0,YE0,ZE0,S
1586C=======================================================================
1587C----IRTSE(5,*) -> id of edge
1588C=======================================================================
1589 NSN0 = NSN-NSNE
1590 DO I=NSN0+1,NSN
1591 NS=NSV(I)-NUMNOD
1592 IF (NS<=0) print *,'!!!!error, NSV(I),I=',NSV(I),I
1593 CALL i24fic_getn(ns ,irtse ,is2se ,ie ,ns1 ,
1594 + ns2 )
1595 ip = is2pt(ns)
1596 IF (ip==npt) THEN
1597C-------seg center-------
1598 IF (irtse(3,ie)==irtse(4,ie)) THEN
1599 x0=third*(x(1,irtse(1,ie))+x(1,irtse(2,ie))+x(1,irtse(3,ie)))
1600 y0=third*(x(2,irtse(1,ie))+x(2,irtse(2,ie))+x(2,irtse(3,ie)))
1601 z0=third*(x(3,irtse(1,ie))+x(3,irtse(2,ie))+x(3,irtse(3,ie)))
1602 ELSE
1603 x0=fourth*(x(1,irtse(1,ie))+x(1,irtse(2,ie))+x(1,irtse(3,ie))+
1604 + x(1,irtse(4,ie)))
1605 y0=fourth*(x(2,irtse(1,ie))+x(2,irtse(2,ie))+x(2,irtse(3,ie))+
1606 + x(2,irtse(4,ie)))
1607 z0=fourth*(x(3,irtse(1,ie))+x(3,irtse(2,ie))+x(3,irtse(3,ie))+
1608 + x(3,irtse(4,ie)))
1609 END IF
1610C-------edge center-------
1611 xe0=half*(x(1,ns1)+x(1,ns2))
1612 ye0=half*(x(2,ns1)+x(2,ns2))
1613 ze0=half*(x(3,ns1)+x(3,ns2))
1614C
1615 xfic(1,ns) = third*(x0+two*xe0)
1616 xfic(2,ns) = third*(y0+two*ye0)
1617 xfic(3,ns) = third*(z0+two*ze0)
1618C-------NPT should be unpair: 3,5,7
1619 ELSEIF (ip > 0 ) THEN
1620C-------edge center-------
1621 xe0=half*(x(1,ns1)+x(1,ns2))
1622 ye0=half*(x(2,ns1)+x(2,ns2))
1623 ze0=half*(x(3,ns1)+x(3,ns2))
1624 np0 = (npt-1)/2
1625 IF (ip > np0) THEN
1626C---------right side
1627 s = (ip-np0)*one/(npt-1)
1628 xfic(1,ns) = xe0 +s*(x(1,ns2)-xe0)
1629 xfic(2,ns) = ye0 +s*(x(2,ns2)-ye0)
1630 xfic(3,ns) = ze0 +s*(x(3,ns2)-ze0)
1631 ELSE
1632C---------left side
1633 s = ip*one/(npt-1)
1634 xfic(1,ns) = x(1,ns1) +s*(xe0 -x(1,ns1))
1635 xfic(2,ns) = x(2,ns1) +s*(ye0 -x(2,ns1))
1636 xfic(3,ns) = x(3,ns1) +s*(ze0 -x(3,ns1))
1637 END IF
1638 END IF
1639 END DO
1640C-----------
1641 RETURN
1642 END
1643!||====================================================================
1644!|| i24fics_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1645!||--- called by ------------------------------------------------------
1646!|| i24stsecnd ../starter/source/interfaces/inter3d1/i24stslav.F
1647!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1648!||====================================================================
1649 SUBROUTINE i24fics_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1650 4 NSN ,FIC_S )
1651C============================================================================
1652C I m p l i c i t T y p e s
1653C-----------------------------------------------
1654#include "implicit_f.inc"
1655C-----------------------------------------------
1656C C o m m o n B l o c k s
1657C-----------------------------------------------
1658#include "com04_c.inc"
1659C-----------------------------------------------
1660C D u m m y A r g u m e n t s
1661C-----------------------------------------------
1662 INTEGER IRTSE(5,*) ,NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN
1663 my_real
1664 . FIC_S(*)
1665C------FIC_S could be GAP or STIFF-----------------------------------------
1666C L o c a l V a r i a b l e s
1667C-----------------------------------------------
1668! 4---------------3
1669! | . . |
1670! | . . |
1671! | . . |
1672! | . |
1673! | . . |
1674! | . . |
1675! | . o3 . |
1676! 1---o1------o2--2 NPT=3
1677C----- NLS : Num. of element with active edge----
1678 INTEGER I,J,K,NSN0,NS,NSF,IE1,IE2,IED,NS1,NS2,IE,NP0,N
1679 INTEGER ITAG(NUMNOD),IK1(4),IK2(4)
1680 DATA IK1 /1,2,3,4/
1681 DATA IK2 /2,3,4,1/
1682 my_real
1683 . X0,Y0,Z0,XE0,YE0,ZE0,S
1684C=======================================================================
1685C----IRTSE(5,*) -> id of edge
1686C=======================================================================
1687 nsn0 = nsn -nsne
1688 DO i=1,nsn0
1689 n= nsv(i)
1690 itag(n) = i
1691 END DO
1692 DO i=1,nsne
1693 ie1 = is2se(1,i)
1694 ie2 = is2se(2,i)
1695 IF (ie1 > 0) THEN
1696 ie = ie1
1697 ied=irtse(5,ie)
1698 ns1= irtse(ik1(ied),ie)
1699 ns2= irtse(ik2(ied),ie)
1700 ELSEIF(ie2 > 0) THEN
1701 ie = ie2
1702 ied=irtse(5,ie)
1703 ns1= irtse(ik2(ied),ie)
1704 ns2= irtse(ik1(ied),ie)
1705 ELSE
1706 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
1707 END IF
1708 s = max(fic_s(itag(ns1)),fic_s(itag(ns2)))
1709 fic_s(i+nsn0) = s
1710 END DO ! I=1,NSNE
1711C-----------
1712 RETURN
1713 END
1714!||====================================================================
1715!|| i24fici_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1716!||--- called by ------------------------------------------------------
1717!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1718!||====================================================================
1719 SUBROUTINE i24fici_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1720 4 NSN ,FIC_I )
1721C============================================================================
1722C I m p l i c i t T y p e s
1723C-----------------------------------------------
1724#include "implicit_f.inc"
1725C-----------------------------------------------
1726C C o m m o n B l o c k s
1727C-----------------------------------------------
1728#include "com04_c.inc"
1729C-----------------------------------------------
1730C D u m m y A r g u m e n t s
1731C-----------------------------------------------
1732 INTEGER IRTSE(5,*),NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN,
1733 . FIC_I(*)
1734C------FIC_S could be GAP or STIFF-----------------------------------------
1735C L o c a l V a r i a b l e s
1736C-----------------------------------------------
1737! 4---------------3
1738! | . . |
1739! | . . |
1740! | . . |
1741! | . |
1742! | . . |
1743! | . . |
1744! | . o3 . |
1745! 1---o1------o2--2 NPT=3
1746C----- NLS : Num. of element with active edge----
1747 INTEGER I,J,K,NSN0,NS,NSF,IE1,IE2,IED,NS1,NS2,IE,NP0,N,IS
1748 INTEGER ITAG(NUMNOD),IK1(4),IK2(4)
1749 DATA IK1 /1,2,3,4/
1750 DATA IK2 /2,3,4,1/
1751 my_real
1752 . X0,Y0,Z0,XE0,YE0,ZE0
1753C=======================================================================
1754C----IRTSE(5,*) -> id of edge
1755C=======================================================================
1756 NSN0 = nsn -nsne
1757 DO i=1,nsn0
1758 n= nsv(i)
1759 itag(n) = i
1760 END DO
1761 DO i=1,nsne
1762 ie1 = is2se(1,i)
1763 ie2 = is2se(2,i)
1764 IF (ie1 > 0) THEN
1765 ie = ie1
1766 ied=irtse(5,ie)
1767 ns1= irtse(ik1(ied),ie)
1768 ns2= irtse(ik2(ied),ie)
1769 ELSEIF(ie2 > 0) THEN
1770 ie = ie2
1771 ied=irtse(5,ie)
1772 ns1= irtse(ik2(ied),ie)
1773 ns2= irtse(ik1(ied),ie)
1774 ELSE
1775 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
1776 END IF
1777 is = max(fic_i(itag(ns1)),fic_i(itag(ns2)))
1778 fic_i(i+nsn0) = is
1779 END DO ! I=1,NSNE
1780C-----------
1781 RETURN
1782 END
1783!||====================================================================
1784!|| i24isegpt_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1785!||--- called by ------------------------------------------------------
1786!|| inint3 ../starter/source/interfaces/inter3d1/inint3.f
1787!||--- calls -----------------------------------------------------
1788!|| i24fic_getn ../starter/source/interfaces/inter3d1/i24surfi.F
1789!||====================================================================
1790 SUBROUTINE i24isegpt_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1791 4 NSN ,ISEGPT ,NPT , ISPT2)
1792C============================================================================
1793C I m p l i c i t T y p e s
1794C-----------------------------------------------
1795#include "implicit_f.inc"
1796C-----------------------------------------------
1797C C o m m o n B l o c k s
1798C-----------------------------------------------
1799#include "com04_c.inc"
1800C-----------------------------------------------
1801C D u m m y A r g u m e n t s
1802C-----------------------------------------------
1803 INTEGER IRTSE(5,*),NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN,
1804 . ISEGPT(*), ISPT2(*)
1805C------FIC_S could be GAP or STIFF-----------------------------------------
1806C-----------------------------------------------
1807C L o c a l V a r i a b l e s
1808C-----------------------------------------------
1809! 4---------------3
1810! | . . |
1811! | . . |
1812! | . . |
1813! | . |
1814! | . . |
1815! | . . |
1816! | . o3 . |
1817! 1---o1------o2--2 NPT=3
1818C----- NLS : Num. of element with active edge----
1819 INTEGER I,J,K,NSN0,NS,IP,NS1,NS2,IE,NP0,N,IS1,IS2,IPT
1820 INTEGER ITAG(NUMNOD)
1821C=======================================================================
1822C----IRTSE(5,*) -> id of edge
1823C=======================================================================
1824 NSN0 = nsn -nsne
1825 DO i=1,nsn0
1826 n= nsv(i)
1827 itag(n) = i
1828 isegpt(i) = 0
1829 ispt2(i) = 0
1830 END DO
1831C------fictive nodes first -----
1832 DO i=nsn0+1,nsn
1833 ispt2(i) = 1
1834 ns=nsv(i)-numnod
1835 ip = is2pt(ns)
1836 IF (ip == npt) THEN
1837C-------internal is negative of id him-self
1838 isegpt(i) = -i
1839 ELSEIF (ip == 1.OR.(ip == npt-1)) THEN
1840 CALL i24fic_getn(ns ,irtse ,is2se ,ie ,ns1 ,
1841 + ns2 )
1842C-------on the edge is positive of id him-self
1843C IPT = I + NPT -IP
1844 isegpt(i) = i
1845C-------------ISEGPT(IS1,IS2) have not unique seg, takes the first one
1846 IF (ip==1) THEN
1847 is1 = itag(ns1)
1848 IF (isegpt(is1) ==0) isegpt(is1)=i
1849 ELSE
1850 is2 = itag(ns2)
1851 IF (isegpt(is2) ==0) isegpt(is2)=i
1852 END IF
1853 ELSE
1854 isegpt(i) = i
1855 END IF
1856 END DO
1857C-----------
1858 RETURN
1859 END
1860
1861!||====================================================================
1862!|| ispt2_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1863!||--- called by ------------------------------------------------------
1864!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1865!||====================================================================
1866 SUBROUTINE ispt2_ini(CAND_N, I_STOK, NSN, IRTLM,
1867 * ISEGPT, ISPT2)
1868C-----------------------------------------------
1869C I m p l i c i t T y p e s
1870C-----------------------------------------------
1871#include "implicit_f.inc"
1872C-----------------------------------------------
1873C D u m m y A r g u m e n t s
1874C-----------------------------------------------
1875 INTEGER, INTENT(IN) :: CAND_N(*)
1876 INTEGER, INTENT(IN) :: I_STOK
1877 INTEGER, INTENT(IN) :: NSN
1878 INTEGER, INTENT(IN) :: IRTLM(NSN)
1879 INTEGER, INTENT(IN) :: ISEGPT(NSN)
1880 INTEGER, INTENT(INOUT) :: ISPT2(NSN)
1881C-----------------------------------------------
1882C L o c a l V a r i a b l e s
1883C-----------------------------------------------
1884 INTEGER I,NI,NSI
1885C-----------------------------------------------
1886 ISPT2(1:NSN) = 0
1887 DO i=1,i_stok
1888 ni=cand_n(i)
1889 IF(ni <= nsn)THEN
1890 nsi = isegpt(ni)
1891 IF(nsi > 0)THEN
1892 IF(irtlm(nsi) /=0)THEN
1893 ispt2(ni) = 0
1894 ELSE
1895 ispt2(ni) = 1
1896 ENDIF
1897 ELSEIF(nsi<0)THEN
1898 ispt2(ni) = 1
1899 ENDIF
1900 ENDIF
1901
1902 ENDDO
1903
1904
1905 END
1906
1907!||====================================================================
1908!|| i24fic_getn ../starter/source/interfaces/inter3d1/i24surfi.F
1909!||--- called by ------------------------------------------------------
1910!|| i24isegpt_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1911!|| i24pen3 ../starter/source/interfaces/inter3d1/i24pen3.F
1912!|| i24tri ../starter/source/interfaces/inter3d1/i24tri.F
1913!|| i24xfic_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1914!|| iwcontdd_type24 ../starter/source/spmd/domain_decomposition/iwcontdd_type24.F
1915!|| update_weight_inter_type_24_25 ../starter/source/spmd/domain_decomposition/update_weight_inter_type_24_25.F
1916!||--- calls -----------------------------------------------------
1917!|| arret ../starter/source/system/arret.F
1918!||====================================================================
1919 SUBROUTINE i24fic_getn(NS ,IRTSE ,IS2SE ,IE ,NS1 ,
1920 4 NS2 )
1921C============================================================================
1922C I m p l i c i t T y p e s
1923C-----------------------------------------------
1924#include "implicit_f.inc"
1925C-----------------------------------------------
1926C D u m m y A r g u m e n t s
1927C-----------------------------------------------
1928 INTEGER IRTSE(5,*) ,NS,IS2SE(2,*),NS1,NS2,IE
1929C-----------------------------------------------
1930C L o c a l V a r i a b l e s
1931C-----------------------------------------------
1932C----- get edge NS1,NS2 and--SECONDARY seg id :IE-
1933 INTEGER IK1(4),IK2(4),IE1,IE2,IED
1934 DATA IK1 /1,2,3,4/
1935 DATA IK2 /2,3,4,1/
1936C=======================================================================
1937C----IRTSE(5,*) -> id of edge
1938C=======================================================================
1939 IE1 = is2se(1,ns)
1940 ie2 = is2se(2,ns)
1941 IF (ie1 > 0) THEN
1942 ie = ie1
1943 ied=irtse(5,ie)
1944 ns1= irtse(ik1(ied),ie)
1945 ns2= irtse(ik2(ied),ie)
1946 ELSEIF(ie2 > 0) THEN
1947 ie = ie2
1948 ied=irtse(5,ie)
1949 ns1= irtse(ik2(ied),ie)
1950 ns2= irtse(ik1(ied),ie)
1951 ELSE
1952 print *,'problem EDGE IE1,IE2=',ie1,ie2
1953#ifndef HYPERMESH_LIB
1954 call arret(2)
1955#endif
1956 END IF
1957C-----------
1958 RETURN
1959 END
1960!||====================================================================
1961!|| i24ficv_ini ../starter/source/interfaces/inter3d1/i24surfi.F
1962!||--- called by ------------------------------------------------------
1963!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
1964!||====================================================================
1965 SUBROUTINE i24ficv_ini(IRTSE ,NSNE ,IS2SE ,NSV ,IS2PT ,
1966 + NSN ,FIC_V ,NPT )
1967C============================================================================
1968C I m p l i c i t T y p e s
1969C-----------------------------------------------
1970#include "implicit_f.inc"
1971C-----------------------------------------------
1972C C o m m o n B l o c k s
1973C-----------------------------------------------
1974#include "com04_c.inc"
1975C-----------------------------------------------
1976C D u m m y A r g u m e n t s
1977C-----------------------------------------------
1978 INTEGER IRTSE(5,*) ,NSV(*),NSNE,IS2SE(2,*),NPT,IS2PT(*),NSN
1979C-------due to the using of PENE_OLD(5,*)-----
1980 my_real
1981 . fic_v(5,*)
1982C------FIC_S could be GAP or STIFF-----------------------------------------
1983C L o c a l V a r i a b l e s
1984C-----------------------------------------------
1985! 4---------------3
1986! | . . |
1987! | . . |
1988! | . . |
1989! | . |
1990! | . . |
1991! | . . |
1992! | . o3 . |
1993! 1---o1------o2--2 NPT=3
1994C----- NLS : Num. of element with active edge----
1995 INTEGER I,J,K,NSN0,NS,NSF,IE1,IE2,IED,NS1,NS2,IE,NP0,N
1996 INTEGER ITAG(NUMNOD),IK1(4),IK2(4),IP
1997 DATA IK1 /1,2,3,4/
1998 DATA IK2 /2,3,4,1/
1999 my_real
2000 . NX,NY,NZ,DET
2001C=======================================================================
2002C----IRTSE(5,*) -> id of edge
2003C=======================================================================
2004 NSN0 = nsn -nsne
2005 DO i=1,nsn0
2006 n= nsv(i)
2007 itag(n) = i
2008 END DO
2009 DO i=1,nsne
2010 ie1 = is2se(1,i)
2011 ie2 = is2se(2,i)
2012 IF (ie1 > 0) THEN
2013 ie = ie1
2014 ied=irtse(5,ie)
2015 ns1= irtse(ik1(ied),ie)
2016 ns2= irtse(ik2(ied),ie)
2017 ELSEIF(ie2 > 0) THEN
2018 ie = ie2
2019 ied=irtse(5,ie)
2020 ns1= irtse(ik2(ied),ie)
2021 ns2= irtse(ik1(ied),ie)
2022 ELSE
2023 print *,'problem EDGE **** IE1,IE2=',ie1,ie2
2024 END IF
2025 ip = is2pt(i)
2026 nx=zero
2027 ny=zero
2028 nz=zero
2029C------mean value of IE
2030 IF (ip==npt) THEN
2031C------mean value of NS1,NS2
2032 DO j=1,3
2033 n = itag(irtse(j,ie))
2034 nx = nx + fic_v(1,n)
2035 ny = ny + fic_v(2,n)
2036 nz = nz + fic_v(3,n)
2037 END DO
2038 IF (irtse(3,ie)/=irtse(4,ie)) THEN
2039 n = itag(irtse(4,ie))
2040 nx = nx + fic_v(1,n)
2041 ny = ny + fic_v(2,n)
2042 nz = nz + fic_v(3,n)
2043 END IF
2044 ELSE
2045 n = itag(ns1)
2046 nx = nx + fic_v(1,n)
2047 ny = ny + fic_v(2,n)
2048 nz = nz + fic_v(3,n)
2049 n = itag(ns2)
2050 nx = nx + fic_v(1,n)
2051 ny = ny + fic_v(2,n)
2052 nz = nz + fic_v(3,n)
2053 END IF
2054 det = one/max(em20,sqrt(nx*nx+ ny*ny+ nz*nz))
2055 n = i + nsn0
2056 fic_v(1,n) = det*nx
2057 fic_v(2,n) = det*ny
2058 fic_v(3,n) = det*nz
2059 END DO ! I=1,NSNE
2060C-----------
2061 RETURN
2062 END
2063
2064
2065
2066
2067
2068
2069
my_real
#define my_real
Definition cppsort.cpp:32
i24fici_ini
subroutine i24fici_ini(irtse, nsne, is2se, nsv, is2pt, nsn, fic_i)
Definition i24surfi.F:1721
i24fics_ini
subroutine i24fics_ini(irtse, nsne, is2se, nsv, is2pt, nsn, fic_s)
Definition i24surfi.F:1651
i24isegpt_ini
subroutine i24isegpt_ini(irtse, nsne, is2se, nsv, is2pt, nsn, isegpt, npt, ispt2)
Definition i24surfi.F:1792
i24ficv_ini
subroutine i24ficv_ini(irtse, nsne, is2se, nsv, is2pt, nsn, fic_v, npt)
Definition i24surfi.F:1967
i24fic_getn
subroutine i24fic_getn(ns, irtse, is2se, ie, ns1, ns2)
Definition i24surfi.F:1921
ispt2_ini
subroutine ispt2_ini(cand_n, i_stok, nsn, irtlm, isegpt, ispt2)
Definition i24surfi.F:1868
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
inint3
subroutine inint3(inscr, x, ixs, ixc, pm, geo, ipari, nin, itab, ms, mwa, rwa, ixtg, iwrn, ikine, ixt, ixp, ixr, nelemint, iddlevel, ifiend, ale_connectivity, nsnet, nmnet, igrbric, iwcont, nsnt, nmnt, nsn2t, nmn2t, iwcin2, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, igrsurf, ikine1, ielem21, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, nod2el1d, knod2el1d, ixs10, i_mem, resort, inter_cand, ixs16, ixs20, id, titr, iremnode, nremnode, iparts, kxx, ixx, igeo, intercep, lelx, intbuf_tab, fillsol, pm_stack, iworksh, kxig3d, ixig3d, tagprt_fric, intbuf_fric_tab, ipartt, ipartp, ipartx, ipartr, nsn_multi_connec, t2_add_connec, t2_nb_connec, t2_connec, nom_opt, icode, iskew, iremnode_edg, s_append_array, x_append, mass_append, n2d, flag_removed_node, nspmd, inter_type2_number, elem_linked_to_segment, sinscr, sicode, sitab, nin25, flag_elem_inter25, multi_fvm)
Definition inint3.F:144
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
groupdef_mod
Definition groupdef_mod.F:662
main
int main(int argc, char *argv[])
Definition CMakeCCompilerId.c:841
arret
subroutine arret(nn)
Definition arret.F:87
starter
program starter
Definition starter.F:39