OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25trc_edg.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!|| i25trc_edg ../engine/source/interfaces/intsort/i25trc_edg.F
25!||--- called by ------------------------------------------------------
26!|| i25main_tri ../engine/source/interfaces/intsort/i25main_tri.F
27!||--- uses -----------------------------------------------------
28!|| tri7box ../engine/share/modules/tri7box.F
29!||====================================================================
30 SUBROUTINE i25trc_edg(
31 1 NEDGE,I_STOK,CAND_S,CAND_M,
32 2 CAND_P,CAND_A,NIN,NEDGE_L,IFQ,
33 3 CAND_FX ,CAND_FY,CAND_FZ,IFPEN)
34C-----------------------------------------------
35 USE tri7box
36C-----------------------------------------------
37C I m p l i c i t T y p e s
38C-----------------------------------------------
39#include "implicit_f.inc"
40C-----------------------------------------------
41C C o m m o n B l o c k s
42C-----------------------------------------------
43#include "assert.inc"
44C-----------------------------------------------
45C ROLE DE LA ROUTINE:
46C ===================
47C TRI sur N de CAND_S CAND_M CAND_F
48C et elimination des noeuds en rebond
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER :: I_STOK,NEDGE,NIN,NEDGE_L,IFQ
53 INTEGER :: CAND_S(I_STOK),CAND_M(I_STOK),CAND_A(*),IFPEN(*)
54 my_real
55 . cand_p(*),cand_fx(*) ,cand_fy(*) ,cand_fz(*)
56C-----------------------------------------------
57C L o c a l V a r i a b l e s
58C-----------------------------------------------
59 INTEGER I, I_ST0,N,NN,K,E,CAND_T,
60 . IGET(I_STOK),IPUT(I_STOK)
61 my_real
62 . cand_tf
63C=======================================================================
64C
65
66 DO n=1,nedge+3
67 cand_a(n) = 0
68 ENDDO
69
70 DO i=1,i_stok
71 nn = cand_s(i)
72 e = cand_m(i)
73
74 assert(cand_s(i) > 0)
75 assert(cand_s(i) <= nedge) ! ici nedge = nedge + nedge_remote
76
77
78C IF(NN<=NEDGE_L)THEN
79 IF (ifq == 0) THEN
80 IF(cand_p(i)==zero)THEN
81 cand_s(i) = nedge+1
82 ENDIF
83 ELSE
84 IF(ifpen(i)==0.AND.cand_p(i)==zero)THEN
85 cand_s(i) = nedge+1
86 ENDIF
87 ENDIF
88C ELSE ! remote
89C ENDIF
90 ENDDO
91
92C=======================================================================
93C CAND_A : DENOMBREMENT DE CHAQUE NOEUD
94C APRES 300 CAND_A[3:NEDGE+3] : OCCURENCE DES NOEUDS [1:NEDGE+1]
95C=======================================================================
96 DO i=1,i_stok
97 nn = cand_s(i) + 2
98 cand_a(nn) = cand_a(nn) + 1
99 ENDDO
100
101C=======================================================================
102C CAND_A : ADRESSE DE CHAQUE NOEUD
103C APRES 400 CAND_A[2:NEDGE+2] : ADRESSE DES NOEUDS [1:NEDGE+1]
104C=======================================================================
105 cand_a(1) = 1
106 cand_a(2) = 1
107 DO n=3,nedge+2
108 cand_a(n) = cand_a(n) + cand_a(n-1)
109 ENDDO
110C=======================================================================
111C IPUT(I) ADRESSE OU DOIT ALLER I
112C IGET(K) ADRESSE D'OU DOIT VENIR K
113C APRES 500 CAND_A[1:NEDGE+1] : ADRESSE DES NOEUDS [1:NEDGE+1]
114C=======================================================================
115 DO i=1,i_stok
116 nn = cand_s(i) + 1
117 k = cand_a(nn)
118 iput(i) = k
119 iget(k) = i
120 assert(i > 0)
121 assert(k > 0)
122 assert(nn < nedge + 4 )
123 cand_a(nn) = cand_a(nn) + 1
124 ENDDO
125C=======================================================================
126C TRI DE CAND_S CAND_M CAND_P
127C SUR N CROISSANT
128C PERMUTATION 1 PASSE
129C=============================================
130 DO k=1,i_stok
131 i = iget(k)
132 assert(i > 0)
133C
134 cand_t = cand_s(k)
135 cand_s(k) = cand_s(i)
136 cand_s(i) = cand_t
137C
138 cand_t = cand_m(k)
139 cand_m(k) = cand_m(i)
140 cand_m(i) = cand_t
141C
142 cand_tf = cand_p(k)
143 cand_p(k) = cand_p(i)
144 cand_p(i) = cand_tf
145C
146 cand_tf = cand_fx(k)
147 cand_fx(k) = cand_fx(i)
148 cand_fx(i) = cand_tf
149C
150 cand_tf = cand_fy(k)
151 cand_fy(k) = cand_fy(i)
152 cand_fy(i) = cand_tf
153C
154 cand_tf = cand_fz(k)
155 cand_fz(k) = cand_fz(i)
156 cand_fz(i) = cand_tf
157C
158 cand_t = ifpen(k)
159 ifpen(k) = ifpen(i)
160 ifpen(i) = cand_t
161C
162 iput(i) = iput(k)
163 assert(iput(i) > 0)
164 assert(iput(i) <= i_stok)
165 iget(iput(i)) = i
166
167 ENDDO
168C=======================================================================
169C CAND_A[NEDGE+1] : ADRESSE DE NEDGE+1
170C=======================================================================
171 i_stok = cand_a(nedge+1) - 1
172 cand_a(nedge+2) = cand_a(nedge+1)
173C
174 RETURN
175 END
i25trc_edg
subroutine i25trc_edg(nedge, i_stok, cand_s, cand_m, cand_p, cand_a, nin, nedge_l, ifq, cand_fx, cand_fy, cand_fz, ifpen)
Definition i25trc_edg.F:34