OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ipartm1.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!|| create_ipartm1 ../starter/source/model/sets/ipartm1.F
25!||--- calls -----------------------------------------------------
26!||====================================================================
27 SUBROUTINE create_ipartm1 (NPART,IPART,IPARTM1 )
28C-----------------------------------------------
29C I m p l i c i t T y p e s
30C-----------------------------------------------
31#include "implicit_f.inc"
32C-----------------------------------------------
33C C o m m o n B l o c k s
34C-----------------------------------------------
35#include "scr17_c.inc"
36C-----------------------------------------------
37C D u m m y A r g u m e n t s
38C-----------------------------------------------
39 INTEGER, INTENT(IN) :: NPART
40 INTEGER, INTENT(IN), DIMENSION(LIPART1,NPART) :: IPART
41 INTEGER, INTENT(INOUT),DIMENSION(NPART,2) :: IPARTM1
42C-----------------------------------------------
43C L o c a l V a r i a b l e s
44C-----------------------------------------------
45 INTEGER I
46 INTEGER, DIMENSION(:),ALLOCATABLE :: IPARTSORT
47 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX_SORT
48 INTEGER, DIMENSION(70000) :: IWORK
49C-----------------------------------------------
50 ALLOCATE(ipartsort(npart))
51 ALLOCATE(index_sort(2*npart))
52
53 DO i=1,npart
54 ipartsort(i)=ipart(4,i)
55 index_sort(i)=i
56 ENDDO
57 CALL my_orders(0,iwork,ipartsort,index_sort,npart,1)
58
59 DO i=1,npart
60 ipartm1(i,1)=ipartsort(index_sort(i))
61 ipartm1(i,2)=index_sort(i)
62 ENDDO
63
64 END
65!||====================================================================
66!|| part_usrtos ../starter/source/model/sets/ipartm1.F
67!||====================================================================
68 INTEGER FUNCTION part_usrtos(IU,IPARTM1,NPART)
69C IDENTIQUE A USR2SYS, SANS GENERER D'ERREUR
70C FONCTION DONNE N0 SYSTEME DU NOEUD USER IU
71C-----------------------------------------------
72C I m p l i c i t T y p e s
73C-----------------------------------------------
74#include "implicit_f.inc"
75C-----------------------------------------------
76C D u m m y A r g u m e n t s
77C-----------------------------------------------
78 INTEGER iu
79 INTEGER npart
80 INTEGER ipartm1(npart,2)
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 INTEGER jinf, jsup, j,i
85 jinf=1
86 jsup=npart
87 j=max(1,npart/2)
88 10 IF(jsup<=jinf.AND.(iu-ipartm1(j,1))/=0) THEN
89C
90 part_usrtos=0
91 RETURN
92 ENDIF
93 IF((iu-ipartm1(j,1))==0)THEN
94C >CAS IU=TABM FIN DE LA RECHERCHE
95 part_usrtos=j
96 RETURN
97 ELSE IF (iu-ipartm1(j,1)<0) THEN
98C >CAS IU<TABM
99 jsup=j-1
100 ELSE
101C >CAS IU>TABM
102 jinf=j+1
103 ENDIF
104 j=(jsup+jinf)/2
105 GO TO 10
106 END
107C
108C-----------------------------------------------
109!||====================================================================
110!|| set_usrtos ../starter/source/model/sets/ipartm1.F
111!||--- called by ------------------------------------------------------
112!|| create_elt_list ../starter/source/model/sets/create_element_clause.F
113!|| create_node_list ../starter/source/model/sets/create_node_clause.F
114!|| create_nodens_clause ../starter/source/model/sets/create_nodens_clause.F90
115!|| create_part_list ../starter/source/model/sets/create_part_clause.F
116!|| create_rbody_list ../starter/source/model/sets/create_rbody_clause.F
117!|| create_seg_clause ../starter/source/model/sets/create_seg_clause.F
118!|| create_set_list ../starter/source/model/sets/create_set_clause.F
119!|| create_setcol_list ../starter/source/model/sets/create_setcol_clause.F
120!|| create_subm_list ../starter/source/model/sets/create_subm_clause.F
121!|| create_subs_list ../starter/source/model/sets/create_subs_clause.F
122!|| hm_read_inistate_d00 ../starter/source/elements/initia/hm_read_inistate_d00.F
123!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
124!|| hm_tagpart2 ../starter/source/groups/hm_tagpart2.F
125!|| lectur ../starter/source/starter/lectur.f
126!||====================================================================
127 INTEGER FUNCTION set_usrtos(IU,IPARTM1,NPART)
128C-----------------------------------------------
129C ROUTINE DESCRIPTION :
130C ===================
131C Dichotomy Over sorted array to obtain Local id from
132C Global ID
133C-----------------------------------------------
134C DUMMY ARGUMENTS DESCRIPTION:
135C ===================
136C
137C NAME DESCRIPTION
138C
139C UI, INTEGER : User ID
140C MAP(SZ,2) : UID,LOCAL ID Map
141C SZ : Size of Option
142C Returns : indice in ipartm1 to get nearest local ID
143C-----------------------------------------------
144C I m p l i c i t T y p e s
145C-----------------------------------------------
146#include "implicit_f.inc"
147C-----------------------------------------------
148C D u m m y A r g u m e n t s
149C-----------------------------------------------
150 INTEGER iu
151 INTEGER npart
152 INTEGER ipartm1(npart,2)
153C-----------------------------------------------
154C L o c a l V a r i a b l e s
155C-----------------------------------------------
156 INTEGER jinf, jsup, j,i
157 jinf=1
158 jsup=npart
159 j=max(1,npart/2)
160 10 IF(j == 0)THEN
161C
162 set_usrtos=0
163 RETURN
164 ELSEIF(jsup<=jinf.AND.(iu-ipartm1(j,1))/=0) THEN
165C
166 set_usrtos=0
167 RETURN
168 ENDIF
169 IF((iu-ipartm1(j,1))==0)THEN
170C >CAS IU=TABM FIN DE LA RECHERCHE
171 set_usrtos=j
172 RETURN
173 ELSE IF (iu-ipartm1(j,1)<0) THEN
174C >CAS IU<TABM
175 jsup=j-1
176 ELSE
177C >CAS IU>TABM
178 jinf=j+1
179 ENDIF
180 j=(jsup+jinf)/2
181 GO TO 10
182 END
183C
184!||====================================================================
185!|| set_usrtos_nearest ../starter/source/model/sets/ipartm1.F
186!||--- called by ------------------------------------------------------
187!|| create_elt_list_g ../starter/source/model/sets/create_element_clause.F
188!|| create_node_list_g ../starter/source/model/sets/create_node_clause.F
189!|| create_part_list_g ../starter/source/model/sets/create_part_clause.F
190!|| create_rbody_list_g ../starter/source/model/sets/create_rbody_clause.F
191!|| create_set_list_g ../starter/source/model/sets/create_set_clause.F
192!|| create_setcol_list_g ../starter/source/model/sets/create_setcol_clause.F
193!|| create_subm_list_g ../starter/source/model/sets/create_subm_clause.F
194!|| create_subs_list_g ../starter/source/model/sets/create_subs_clause.F
195!||====================================================================
196 INTEGER FUNCTION set_usrtos_nearest(UI,MAP,SZ,UPLOW)
197C-----------------------------------------------
198C ROUTINE DESCRIPTION :
199C ===================
200C Dichotomy Over sorted array to obtain Local id from
201C Global ID
202C-----------------------------------------------
203C DUMMY ARGUMENTS DESCRIPTION:
204C ===================
205C
206C NAME DESCRIPTION
207C
208C UI, INTEGER : User ID
209C MAP(SZ,2) : UID,LOCAL ID Map
210C SZ : Size of Option
211C UPLOW : 1 UP (take a majorant), 2 LOW (take a minorant)
212C Returns : indice in ipartm1 to get nearest local ID
213C
214C-----------------------------------------------
215C I m p l i c i t T y p e s
216C-----------------------------------------------
217#include "implicit_f.inc"
218C-----------------------------------------------
219C D u m m y A r g u m e n t s
220C-----------------------------------------------
221 INTEGER ui
222 INTEGER sz, uplow
223 INTEGER map(sz,2)
224C-----------------------------------------------
225C L o c a l V a r i a b l e s
226C-----------------------------------------------
227 INTEGER jinf, jsup, j,i
228 jinf=1
229 jsup=sz
230
231 IF ( ui >= map(sz,1) ) THEN
232 set_usrtos_nearest = sz
233 RETURN
234 ENDIF
235
236 IF ( ui <= map(1,1) ) THEN
237 set_usrtos_nearest = 1
238 RETURN
239 ENDIF
240
241 j=max(1,sz/2)
242
243 10 IF(jsup<=jinf.AND.(ui-map(j,1))/=0) THEN
244C
245 set_usrtos_nearest=0
246 IF (uplow == 1) THEN
247
248 DO WHILE (map(jinf,1) < ui) ! FIRST Entity higher then UI
249 jinf=jinf+1
250 ENDDO
251 set_usrtos_nearest=jinf
252
253 ELSEIF (uplow == 2) THEN
254
255 DO WHILE (map(jsup,1) > ui) ! FIRST Entity lower then UI
256 jsup=jsup-1
257 ENDDO
258 set_usrtos_nearest=jsup
259
260 ENDIF
261 RETURN
262 ENDIF
263 IF((ui-map(j,1))==0)THEN
264C >CAS IU=TABM FIN DE LA RECHERCHE
265 set_usrtos_nearest=j
266 RETURN
267 ELSE IF (ui-map(j,1)<0) THEN
268C >CAS IU<TABM
269 jsup=j-1
270 ELSE
271C >CAS IU>TABM
272 jinf=j+1
273 ENDIF
274 j=(jsup+jinf)/2
275 GO TO 10
276 END
277C
278
279!||====================================================================
280!|| print_ipartm1 ../starter/source/model/sets/ipartm1.F
281!||====================================================================
282 SUBROUTINE print_ipartm1(NPART,IPARTM1 )
283C-----------------------------------------------
284C I m p l i c i t T y p e s
285C-----------------------------------------------
286#include "implicit_f.inc"
287C-----------------------------------------------
288C D u m m y A r g u m e n t s
289C-----------------------------------------------
290 INTEGER NPART,I
291 INTEGER IPARTM1(NPART,2)
292 DO i=1,npart
293 print*,i,'IPART=',ipartm1(i,1),'--',ipartm1(i,2)
294 ENDDO
295 END
296
part_usrtos
integer function part_usrtos(iu, ipartm1, npart)
Definition ipartm1.F:69
set_usrtos_nearest
integer function set_usrtos_nearest(ui, map, sz, uplow)
Definition ipartm1.F:197
print_ipartm1
subroutine print_ipartm1(npart, ipartm1)
Definition ipartm1.F:283
set_usrtos
integer function set_usrtos(iu, ipartm1, npart)
Definition ipartm1.F:128
create_ipartm1
subroutine create_ipartm1(npart, ipart, ipartm1)
Definition ipartm1.F:28
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
lectur
subroutine lectur(multi_fvm, lsubmodel, is_dyna, detonators, ebcs_tab, seatbelt_converted_elements, nb_seatbelt_shells, nb_dyna_include, user_windows, output, mat_elem, names_and_titles, defaults, glob_therm, pblast, sensor_user_struct)
Definition lectur.F:533
starter
program starter
Definition starter.F:39