OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i24sto.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!|| i24sto ../engine/source/interfaces/intsort/i24sto.F
25!||--- called by ------------------------------------------------------
26!|| i24trivox ../engine/source/interfaces/intsort/i24trivox.F
27!||--- calls -----------------------------------------------------
28!|| i24cor3t ../engine/source/interfaces/intsort/i24cor3t.F
29!|| i24edgt ../engine/source/interfaces/intsort/i24sto.F
30!|| i24pen3 ../engine/source/interfaces/intsort/i24pen3.F
31!|| i24s1s2 ../engine/source/interfaces/intsort/i24sto.F
32!||--- uses -----------------------------------------------------
33!|| tri7box ../engine/share/modules/tri7box.F
34!||====================================================================
35 SUBROUTINE i24sto(
36 1 J_STOK,IRECT ,X ,NSV ,II_STOK,
37 2 CAND_N,CAND_E ,MULNSN,NOINT ,MARGE ,
38 3 I_MEM ,PROV_N ,PROV_E,ESHIFT,V ,
39 4 NSN ,GAP_S ,GAP_M ,CURV_MAX,NIN ,
40 5 PENE_OLD,NBINFLG,MBINFLG,ILEV ,MSEGTYP,
41 6 EDGE_L2,IEDGE,ISEADD ,ISEDGE ,CAND_T,itab,
42 7 CAND_A,OLDNUM,NSNROLD,DGAPLOAD)
43C============================================================================
44 USE tri7box
45C-----------------------------------------------
46C I m p l i c i t T y p e s
47C-----------------------------------------------
48#include "implicit_f.inc"
49#include "comlock.inc"
50C-----------------------------------------------
51C G l o b a l P a r a m e t e r s
52C-----------------------------------------------
53#include "mvsiz_p.inc"
54C-----------------------------------------------
55C D u m m y A r g u m e n t s
56C-----------------------------------------------
57 INTEGER I_MEM, NSN, NIN,NBINFLG(*),MBINFLG(*),ILEV
58 INTEGER J_STOK,MULNSN,NOINT,ESHIFT,IEDGE,NSNROLD
59 INTEGER IRECT(4,*),NSV(*),CAND_N(*),CAND_E(*),CAND_T(*)
60 INTEGER PROV_N(MVSIZ),PROV_E(MVSIZ),II_STOK,MSEGTYP(*),ISEADD(*),
61 . ISEDGE(*) ,itab(*), CAND_A(*),OLDNUM(*)
62C REAL
63 my_real , INTENT(IN) :: DGAPLOAD
64 my_real
65 . x(3,*), v(3,*), gap_s(*), gap_m(*),
66 . marge, curv_max(*),pene_old(5,nsn),edge_l2(*)
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I,K_STOK,I_STOK,N,NE,J,ITYPE,ISH
71 INTEGER IX1(MVSIZ), IX2(MVSIZ), IX3(MVSIZ), IX4(MVSIZ)
72C REAL
73 my_real
74 . X1(MVSIZ), X2(MVSIZ), X3(MVSIZ), X4(MVSIZ),
75 . Y1(MVSIZ), Y2(MVSIZ), Y3(MVSIZ), Y4(MVSIZ),
76 . Z1(MVSIZ), Z2(MVSIZ), Z3(MVSIZ), Z4(MVSIZ),
77 . xi(mvsiz), yi(mvsiz), zi(mvsiz), stif(mvsiz),
78 . pene(mvsiz), gapv(mvsiz), gapve(mvsiz), pene_e(mvsiz)
79 DATA itype/24/
80C-----------------------------------------------
81 CALL i24cor3t( j_stok ,x ,irect ,nsv ,prov_e ,
82 1 prov_n ,x1 ,x2 ,
83 2 x3 ,x4 ,y1 ,y2 ,y3 ,
84 3 y4 ,z1 ,z2 ,z3 ,z4 ,
85 4 xi ,yi ,zi ,stif ,ix1 ,
86 5 ix2 ,ix3 ,ix4 ,nsn ,gap_s ,
87 6 gap_m ,gapv ,curv_max,itype ,nin ,
88 7 v ,pene_old,gapve ,edge_l2,iedge ,
89 8 dgapload)
90C-----------------------------------------------
91 CALL i24pen3( j_stok ,marge ,x1 ,x2 ,x3 ,
92 . x4 ,y1 ,y2 ,y3 ,y4 ,
93 . z1 ,z2 ,z3 ,z4 ,xi ,
94 . yi ,zi ,pene ,ix1 ,ix2 ,
95 . ix3 ,ix4 ,gapv ,gapve ,pene_e)
96C-----------------------------------------------
97 IF (ilev==2)
98 . CALL i24s1s2(j_stok,nsn,eshift,prov_n,prov_e,
99 . nbinflg,mbinflg,pene)
100 CALL i24edgt(j_stok ,nsn ,eshift ,prov_n,prov_e,
101 . mbinflg,iseadd ,isedge ,pene_e,iedge )
102
103C-----------------------------------------------
104C SUPPRESSION DES ANCIENS CANDIDATS DEJE STOCKES
105C-----------------------------------------------
106 DO i=1,j_stok
107 IF(pene(i)/=zero)THEN
108 n = prov_n(i)
109 ne = prov_e(i)+eshift
110 IF(n>nsn)THEN
111C numerotation tris precedent pour les noeuds non locaux (SPMD)
112 n = oldnum(n-nsn)+nsn
113 IF(n==nsn) n = nsn+nsnrold+1
114 END IF
115 j = cand_a(n)
116 DO WHILE(j<=cand_a(n+1)-1)
117 IF(cand_e(j)==ne)THEN
118 pene(i)=zero
119 j=cand_a(n+1)
120 ELSE
121 j=j+1
122 ENDIF
123 ENDDO
124 ENDIF
125 ENDDO
126
127 k_stok = 0
128 DO i=1,j_stok
129 IF(pene(i)+pene_e(i)/=zero) THEN
130 k_stok = k_stok + 1
131 IF( msegtyp(prov_e(i)+eshift)>0) k_stok = k_stok + 1
132 END IF
133 ENDDO
134 IF(k_stok==0)RETURN
135C
136#include "lockon.inc"
137 i_stok = ii_stok
138 IF(i_stok+k_stok>mulnsn) THEN
139 i_mem = 2
140#include "lockoff.inc"
141 RETURN
142 ENDIF
143 ii_stok = i_stok + k_stok
144#include "lockoff.inc"
145 IF(iedge==0)THEN
146 DO i=1,j_stok
147 IF(pene(i)/=zero)THEN
148 i_stok = i_stok + 1
149 cand_n(i_stok) = prov_n(i)
150 cand_e(i_stok) = prov_e(i)+eshift
151 ish=msegtyp(cand_e(i_stok))
152 IF( ish > 0 ) THEN
153 i_stok = i_stok + 1
154 cand_n(i_stok) = prov_n(i)
155 cand_e(i_stok) = ish
156 END IF
157 ENDIF
158 ENDDO
159 ELSE
160 DO i=1,j_stok
161 IF(pene(i)+pene_e(i) /= zero )THEN
162 i_stok = i_stok + 1
163 cand_n(i_stok) = prov_n(i)
164 cand_e(i_stok) = prov_e(i)+eshift
165 ish=msegtyp(cand_e(i_stok))
166 IF(pene_e(i) == zero)THEN
167 cand_t(i_stok) = 0 ! only node candidate
168 ELSEIF(pene(i) == zero)THEN
169 cand_t(i_stok) = 2 ! only edge candidate
170 ELSE
171 cand_t(i_stok) = 1 ! edge and node candidate
172 ENDIF
173 IF( ish > 0 ) THEN
174 i_stok = i_stok + 1
175 cand_n(i_stok) = prov_n(i)
176 cand_e(i_stok) = ish
177 IF(pene_e(i) == zero)THEN
178 cand_t(i_stok) = 0 ! only node candidate
179 ELSEIF(pene(i) == zero)THEN
180 cand_t(i_stok) = 2 ! only edge candidate
181 ELSE
182 cand_t(i_stok) = 1 ! edge and node candidate
183 ENDIF
184 END IF
185 ENDIF
186 ENDDO
187 ENDIF
188C-----------------------------------------------
189 RETURN
190 END
191!||====================================================================
192!|| i24s1s2 ../engine/source/interfaces/intsort/i24sto.F
193!||--- called by ------------------------------------------------------
194!|| i24sto ../engine/source/interfaces/intsort/i24sto.F
195!||--- calls -----------------------------------------------------
196!|| bitget ../engine/source/interfaces/intsort/i20sto.F
197!||--- uses -----------------------------------------------------
198!|| tri7box ../engine/share/modules/tri7box.F
199!||====================================================================
200 SUBROUTINE i24s1s2(LLT ,NSN ,ESHIFT,PROV_N,PROV_E,
201 . NBINFLG,MBINFLG,PENE)
202C-----------------------------------------------
203C M o d u l e s
204C-----------------------------------------------
205 USE tri7box
206C-----------------------------------------------
207C I m p l i c i t T y p e s
208C-----------------------------------------------
209#include "implicit_f.inc"
210C-----------------------------------------------
211C D u m m y A r g u m e n t s
212C-----------------------------------------------
213 INTEGER LLT,NSN,ESHIFT,PROV_N(*),PROV_E(*),NBINFLG(*),MBINFLG(*)
214C REAL
215C-----------------------------------------------
216C L o c a l V a r i a b l e s
217C-----------------------------------------------
218 INTEGER I,N,NE,IMS1,IMS2,ISS1,ISS2
219C REAL
220C-----------------------------------------------
221 my_real
222 . pene(*)
223 INTEGER BITGET
224 EXTERNAL BITGET
225C=======================================================================
226 DO i=1,llt
227 n = prov_n(i)
228 ne = prov_e(i)+eshift
229 ims1 = bitget(mbinflg(ne),0)
230 ims2 = bitget(mbinflg(ne),1)
231 IF(n <= nsn) THEN
232 iss1 = bitget(nbinflg(n),0)
233 iss2 = bitget(nbinflg(n),1)
234 ELSE
235 iss1 = bitget(irem(i24iremp+3,n-nsn),0)
236 iss2 = bitget(irem(i24iremp+3,n-nsn),1)
237 ENDIF
238 IF((ims1 == 1 .and. iss1==1).or.
239 . (ims2 == 1 .and. iss2==1))THEN
240 pene(i)=zero
241 ENDIF
242 ENDDO
243C
244 RETURN
245 END
246!||====================================================================
247!|| i24edgt ../engine/source/interfaces/intsort/i24sto.F
248!||--- called by ------------------------------------------------------
249!|| i24sto ../engine/source/interfaces/intsort/i24sto.F
250!||--- calls -----------------------------------------------------
251!|| bitget ../engine/source/interfaces/intsort/i20sto.F
252!||--- uses -----------------------------------------------------
253!|| tri7box ../engine/share/modules/tri7box.F
254!||====================================================================
255 SUBROUTINE i24edgt(LLT ,NSN ,ESHIFT,PROV_N,PROV_E,
256 . MBINFLG,ISEADD ,ISEDGE ,PENE_E,IEDGE )
257C-----------------------------------------------
258C M o d u l e s
259C-----------------------------------------------
260 USE tri7box
261C-----------------------------------------------
262C I m p l i c i t T y p e s
263C-----------------------------------------------
264#include "implicit_f.inc"
265C-----------------------------------------------
266C D u m m y A r g u m e n t s
267C-----------------------------------------------
268 INTEGER LLT,NSN,ESHIFT,PROV_N(*),PROV_E(*),MBINFLG(*),
269 . iseadd(*) ,isedge(*),iedge
270C REAL
271 my_real
272 . pene_e(*)
273C-----------------------------------------------
274C L o c a l V a r i a b l e s
275C-----------------------------------------------
276 INTEGER I,N,NE,IME,NES,IAD
277C REAL
278C-----------------------------------------------
279 INTEGER BITGET
280 EXTERNAL bitget
281C=======================================================================
282 IF(iedge==0)THEN
283 DO i=1,llt
284 pene_e(i)=zero
285 ENDDO
286 ELSE
287 DO i=1,llt
288 n = prov_n(i)
289 ne = prov_e(i)+eshift
290 ime = bitget(mbinflg(ne),8)
291 IF(n <= nsn) THEN
292 iad = iseadd(n)
293 nes = isedge(iad)
294 ELSE
295c a faire !!!!!!!!!!!!!!!!!!!!!!!!!
296 stop 987
297 ENDIF
298 IF(ime /= 1 .or. nes == 0) pene_e(i)=zero
299 ENDDO
300 ENDIF
301
302 RETURN
303 END
my_real
#define my_real
Definition cppsort.cpp:32
i24cor3t
subroutine i24cor3t(jlt, x, irect, nsv, cand_e, cand_n, x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, xi, yi, zi, stif, ix1, ix2, ix3, ix4, nsn, gap_s, gap_m, gapv, curv_max, ityp, nin, v, pene_old, gapve, edge_l2, iedge, dgapload)
Definition i24cor3t.F:39
i24edgt
subroutine i24edgt(llt, nsn, eshift, prov_n, prov_e, mbinflg, iseadd, isedge, pene_e, iedge)
Definition i24sto.F:257
i24s1s2
subroutine i24s1s2(llt, nsn, eshift, prov_n, prov_e, nbinflg, mbinflg, pene)
Definition i24sto.F:202
i24sto
subroutine i24sto(j_stok, irect, x, nsv, ii_stok, cand_n, cand_e, mulnsn, noint, marge, i_mem, prov_n, prov_e, eshift, v, nsn, gap_s, gap_m, curv_max, nin, pene_old, nbinflg, mbinflg, ilev, msegtyp, edge_l2, iedge, iseadd, isedge, cand_t, itab, cand_a, oldnum, nsnrold, dgapload)
Definition i24sto.F:43
tri7box::i24iremp
integer i24iremp
Definition tri7box.F:423
tri7box::irem
integer, dimension(:,:), allocatable irem
Definition tri7box.F:339
i24pen3
subroutine i24pen3(x, irect, gapv, cand_e, cand_n, nsv, inacti, itab, tag, iwpene, nsn, irtlm, msegtyp, iwpene0, pmin, gap_n, mvoisn, ixs, ixs10, ixs16, ixs20, penmax, penmin, id, titr, ilev, pen_old, knod2els, nod2els, ipartns, ipen0, icont_i, xfic, nrtm, irtse, is2se)
Definition i24pen3.F:46