OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
polyhedr.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!|| polyhedr ../starter/source/airbag/polyhedr.F
25!||--- called by ------------------------------------------------------
26!|| fvmesh1 ../starter/source/airbag/fvmesh.F
27!||====================================================================
28 SUBROUTINE polyhedr(IPOLY, RPOLY , POLB , NPOLB, POLH,
29 . NPOLH, NRPMAX , NPHMAX, IBRIC, LMIN,
30 . INFO , NPOLHMAX, NPPMAX)
31C-----------------------------------------------
32C I m p l i c i t T y p e s
33C-----------------------------------------------
34#include "implicit_f.inc"
35C-----------------------------------------------
36C D u m m y A r g u m e n t s
37C-----------------------------------------------
38 INTEGER NPPMAX, IPOLY(6+NPPMAX,*), POLB(*), NPOLB, NPHMAX,
39 . POLH(NPHMAX+2,*),NPOLH, NRPMAX, IBRIC, INFO, NPOLHMAX
40 my_real
41 . rpoly(nrpmax,*), lmin
42C-----------------------------------------------
43C L o c a l V a r i a b l e s
44C-----------------------------------------------
45 INTEGER I, ITAG(NPOLB), ICMAX, ICUR, II, J, JJ, K, KK, ISTOP,
46 . L, LL, ICUR_OLD, ITY, JMIN, PMIN, POLD
47 my_real
48 . x1, y1, z1, x2, y2, z2, xx1, yy1, zz1, xx2, yy2, zz2,
49 . dd11, dd12, dd21, dd22, tole
50C
51 my_real
52 . dlamch_rd
53 EXTERNAL dlamch_rd
54C
55 tole=epsilon(zero)*0.5*lmin*lmin
56C
57 DO i=1,npolb
58 itag(i)=0
59 ENDDO
60C
61 icmax=0
62 DO i=1,npolb
63 IF (itag(i)==0) THEN
64 icmax=icmax+1
65 itag(i)=icmax
66 icur=icmax
67 ELSE
68 icur=itag(i)
69 ENDIF
70 ii=polb(i)
71 DO j=1,ipoly(2,ii)
72 IF (j/=ipoly(2,ii)) THEN
73 jj=j+1
74 ELSE
75 jj=1
76 ENDIF
77 x1=rpoly(4+3*(j-1)+1,ii)
78 y1=rpoly(4+3*(j-1)+2,ii)
79 z1=rpoly(4+3*(j-1)+3,ii)
80 x2=rpoly(4+3*(jj-1)+1,ii)
81 y2=rpoly(4+3*(jj-1)+2,ii)
82 z2=rpoly(4+3*(jj-1)+3,ii)
83 DO k=1,npolb
84 IF (k==i) cycle
85 kk=polb(k)
86 istop=0
87 l=0
88 DO WHILE (istop==0.AND.l<ipoly(2,kk))
89 l=l+1
90 IF (l/=ipoly(2,kk)) THEN
91 ll=l+1
92 ELSE
93 ll=1
94 ENDIF
95 xx1=rpoly(4+3*(l-1)+1,kk)
96 yy1=rpoly(4+3*(l-1)+2,kk)
97 zz1=rpoly(4+3*(l-1)+3,kk)
98 xx2=rpoly(4+3*(ll-1)+1,kk)
99 yy2=rpoly(4+3*(ll-1)+2,kk)
100 zz2=rpoly(4+3*(ll-1)+3,kk)
101 dd11=(xx1-x1)**2+(yy1-y1)**2+(zz1-z1)**2
102 dd21=(xx2-x1)**2+(yy2-y1)**2+(zz2-z1)**2
103 dd12=(xx1-x2)**2+(yy1-y2)**2+(zz1-z2)**2
104 dd22=(xx2-x2)**2+(yy2-y2)**2+(zz2-z2)**2
105 IF ((dd11<=tole.AND.dd22<=tole).OR.
106 . (dd21<=tole.AND.dd12<=tole)) istop=l
107 ENDDO
108 IF (istop/=0) THEN
109 IF (itag(k)==0) THEN
110 itag(k)=icur
111 ELSE
112 icur_old=icur
113 icur=itag(k)
114 DO l=1,npolb
115 IF (itag(l)==icur_old) itag(l)=icur
116 ENDDO
117 ENDIF
118 ENDIF
119 ENDDO
120 ENDDO
121 ENDDO
122C
123 npolh=0
124 DO i=1,icmax
125 ii=0
126 DO j=1,npolb
127 IF (itag(j)==i) ii=ii+1
128 ENDDO
129 IF (ii/=0) npolh=npolh+1
130 ENDDO
131 IF (npolh>npolhmax) THEN
132 info=1
133 npolhmax=npolh
134 RETURN
135 ENDIF
136C
137 npolh=0
138 DO i=1,icmax
139 ii=0
140 DO j=1,npolb
141 IF (itag(j)==i) ii=ii+1
142 ENDDO
143 IF (ii/=0) THEN
144 npolh=npolh+1
145 polh(1,npolh)=ii
146 polh(2,npolh)=ibric
147 ii=0
148 DO j=1,npolb
149 IF (itag(j)==i) THEN
150 ii=ii+1
151 jj=polb(j)
152 polh(2+ii,npolh)=jj
153 ity=ipoly(1,jj)
154 IF (ity==1) THEN
155 ipoly(5,jj)=npolh
156 cycle
157 ENDIF
158 IF (ipoly(5,jj)==0) THEN
159 ipoly(5,jj)=npolh
160 ELSE
161 ipoly(6,jj)=npolh
162 ENDIF
163 ENDIF
164 ENDDO
165C Tri par ordre croissant de polh
166 DO j=1,polh(1,npolh)
167 jmin=j
168 pmin=polh(2+j,npolh)
169 DO k=j+1,polh(1,npolh)
170 IF (polh(2+k,npolh)<pmin) THEN
171 jmin=k
172 pmin=polh(2+k,npolh)
173 ENDIF
174 ENDDO
175 pold=polh(2+j,npolh)
176 polh(2+j,npolh)=pmin
177 polh(2+jmin,npolh)=pold
178 ENDDO
179 ENDIF
180 ENDDO
181C
182 info=0
183 RETURN
184 END
my_real
#define my_real
Definition cppsort.cpp:32
polyhedr
subroutine polyhedr(ipoly, rpoly, polb, npolb, polh, npolh, nrpmax, nphmax, ibric, lmin, info, npolhmax, nppmax)
Definition polyhedr.F:31