OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
set_poin_ump.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!|| set_poin_ump ../starter/source/system/set_poin_ump.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| loi_fluid ../starter/source/fluid/loi_fluid.F
29!||====================================================================
30 SUBROUTINE set_poin_ump(IPART,IPM,TAB_UMP,POIN_UMP,TAILLE)
31C-----------------------------------------------
32C I m p l i c i t T y p e s
33C-----------------------------------------------
34#include "implicit_f.inc"
35C-----------------------------------------------
36C C o m m o n B l o c k s
37C-----------------------------------------------
38#include "scr17_c.inc"
39#include "com04_c.inc"
40#include "param_c.inc"
41C-----------------------------------------------
42 LOGICAL LOI_FLUID
43 EXTERNAL loi_fluid
44C-----------------------------------------------
45C D u m m y A r g u m e n t s
46C-----------------------------------------------
47 INTEGER IPART(LIPART1,*),IPM(NPROPMI,*),
48 . POIN_UMP(NUMMAT),TAB_UMP(5,NPART),TAILLE
49C-----------------------------------------------
50C L o c a l V a r i a b l e s
51C-----------------------------------------------
52 INTEGER RES,MARQUEUR,MARQUEUR2,TAB_LOCAL(NPART),TAB_LOCAL2(NUMMAT),
53 . K1,K2,I,J,ILAW, IMID
54
55C=======================================================================
56
57! ---------------------------------
58! Timer Mat/Prop
59 IF(npart>0) THEN
60 DO i=1,npart
61 ilaw=0
62 imid=ipart(1,i)
63 IF(imid > 0) ilaw = ipm(2,imid)
64 tab_ump(1,i) = ipart(5,i)
65 tab_ump(2,i) = ipart(6,i)
66 tab_ump(3,i) = ipart(1,i)
67 tab_ump(4,i) = ipart(2,i)
68 tab_ump(5,i) = ilaw
69 tab_local(i) = 0
70 ENDDO
71
72 taille = npart
73 IF(npart>1) THEN
74 DO i=2,npart
75 DO j=1,i-1
76 IF( (tab_local(j) == 0 ) .AND.
77 . (tab_ump(3,i)==tab_ump(3,j)).AND.
78 . (tab_ump(4,i)==tab_ump(4,j))) THEN
79 tab_local(j) = -1
80 taille = taille - 1
81 ENDIF
82 ENDDO
83 ENDDO
84 ENDIF
85 IF(taille<npart) THEN
86 marqueur2 = 0
87 DO i=1,npart
88 IF(tab_local(i)==0) THEN
89 marqueur2 = marqueur2 + 1
90 tab_ump(1,marqueur2) = tab_ump(1,i)
91 tab_ump(2,marqueur2) = tab_ump(2,i)
92 tab_ump(3,marqueur2) = tab_ump(3,i)
93 tab_ump(4,marqueur2) = tab_ump(4,i)
94 tab_ump(5,marqueur2) = tab_ump(5,i)
95 ENDIF
96 ENDDO
97 DO i= taille+1,npart
98 tab_ump(1,i) = 0
99 tab_ump(2,i) = 0
100 tab_ump(3,i) = 0
101 tab_ump(4,i) = 0
102 tab_ump(5,i) = 0
103 ENDDO
104 ENDIF
105
106
107 i = taille
108 IF(taille>1) THEN
109 marqueur = 0
110 IF(nummat>1) THEN
111 DO WHILE ((marqueur==0).AND.(i>0))
112 marqueur=1
113 DO j=1,i-1
114 IF(tab_ump(1,j) > tab_ump(1,j+1)) THEN
115 marqueur = tab_ump(1,j)
116 tab_ump(1,j) = tab_ump(1,j+1)
117 tab_ump(1,j+1) = marqueur
118 marqueur = tab_ump(2,j)
119 tab_ump(2,j) = tab_ump(2,j+1)
120 tab_ump(2,j+1) = marqueur
121 marqueur = tab_ump(3,j)
122 tab_ump(3,j) = tab_ump(3,j+1)
123 tab_ump(3,j+1) = marqueur
124 marqueur = tab_ump(4,j)
125 tab_ump(4,j) = tab_ump(4,j+1)
126 tab_ump(4,j+1) = marqueur
127 marqueur = tab_ump(5,j)
128 tab_ump(5,j) = tab_ump(5,j+1)
129 tab_ump(5,j+1) = marqueur
130 marqueur=0
131 ENDIF
132 ENDDO
133 i=i-1
134 ENDDO
135 j = 1
136 marqueur = 1
137 poin_ump = 0
138 poin_ump(tab_ump(3,1)) = 1
139 tab_local2 = 0
140 tab_local2(1) = 1
141 DO i=2,taille
142 IF(tab_ump(3,i-1)/=tab_ump(3,i)) THEN
143 marqueur = marqueur + 1
144 poin_ump(tab_ump(3,i)) = i
145 tab_local2(marqueur) = i
146 ENDIF
147 ENDDO
148 ELSE
149 poin_ump(1) = 1
150 ENDIF
151
152 IF(marqueur>1) THEN
153 k1=tab_local2(1)
154 DO i=2,marqueur
155 marqueur2 = 0
156 k2 = tab_local2(i)-1
157
158 DO WHILE ((marqueur2==0).AND.(k2>k1).AND.
159 . (k2*k1>0))
160 marqueur2=1
161 DO j=k1,k2-1
162 IF(tab_ump(2,j) > tab_ump(2,j+1)) THEN
163 marqueur2 = tab_ump(2,j)
164 tab_ump(2,j) = tab_ump(2,j+1)
165 tab_ump(2,j+1) = marqueur2
166 marqueur2 = tab_ump(4,j)
167 tab_ump(4,j) = tab_ump(4,j+1)
168 tab_ump(4,j+1) = marqueur2
169 marqueur2=0
170 ENDIF
171 ENDDO
172 k2=k2-1
173 ENDDO
174 k1=tab_local2(i)
175 ENDDO
176 ELSEIF(marqueur==1) THEN
177 marqueur2 = 0
178 i=taille
179 DO WHILE ((marqueur2==0).AND.(i>0))
180 marqueur2=1
181 DO j=1,i-1
182 IF(tab_ump(2,j) > tab_ump(2,j+1)) THEN
183 marqueur2 = tab_ump(2,j)
184 tab_ump(2,j) = tab_ump(2,j+1)
185 tab_ump(2,j+1) = marqueur2
186 marqueur2 = tab_ump(4,j)
187 tab_ump(4,j) = tab_ump(4,j+1)
188 tab_ump(4,j+1) = marqueur2
189 marqueur2=0
190 ENDIF
191 ENDDO
192 i=i-1
193 ENDDO
194 ENDIF
195 ELSE
196 poin_ump(1:nummat) = 0
197 IF(tab_ump(3,1) > 0) poin_ump(tab_ump(3,1)) = 1
198 ENDIF
199 ENDIF
200C
201 END
set_poin_ump
subroutine set_poin_ump(ipart, ipm, tab_ump, poin_ump, taille)
Definition set_poin_ump.F:31