OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sysfus.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!|| usr2sys ../starter/source/system/sysfus.F
25!||--- called by ------------------------------------------------------
26!|| fsdcod ../starter/source/system/fsdcod.F
27!|| hm_lecgrn ../starter/source/groups/hm_lecgrn.F
28!|| hm_prelce16s ../starter/source/elements/reader/hm_read_solid.F
29!|| hm_prelecgrns ../starter/source/groups/hm_prelecgrns.F
30!|| hm_read_admas ../starter/source/tools/admas/hm_read_admas.F
31!|| hm_read_ale_link ../starter/source/constraints/ale/hm_read_ale_link_vel.F
32!|| hm_read_alebcs ../starter/source/constraints/ale/hm_read_alebcs.F
33!|| hm_read_bcs ../starter/source/constraints/general/bcs/hm_read_bcs.F
34!|| hm_read_beam ../starter/source/elements/reader/hm_read_beam.F
35!|| hm_read_convec ../starter/source/loads/thermic/hm_read_convec.F
36!|| hm_read_cyljoint ../starter/source/constraints/general/cyl_joint/hm_read_cyljoint.F
37!|| hm_read_eig ../starter/source/general_controls/computation/hm_read_eig.f
38!|| hm_read_eref ../starter/source/loads/reference_state/eref/hm_read_eref.F
39!|| hm_read_frm ../starter/source/tools/skew/hm_read_frm.f
40!|| hm_read_fxb1 ../starter/source/constraints/fxbody/hm_read_fxb.F
41!|| hm_read_gauge ../starter/source/output/gauge/hm_read_gauge.F
42!|| hm_read_gjoint ../starter/source/constraints/general/gjoint/hm_read_gjoint.F
43!|| hm_read_grav ../starter/source/loads/general/grav/hm_read_grav.F
44!|| hm_read_impflux ../starter/source/constraints/thermic/hm_read_impflux.F
45!|| hm_read_inicrack ../starter/source/initial_conditions/inicrack/hm_read_inicrack.f
46!|| hm_read_inimap1d ../starter/source/initial_conditions/inimap/hm_read_inimap1d.F
47!|| hm_read_inimap2d ../starter/source/initial_conditions/inimap/hm_read_inimap2d.F
48!|| hm_read_initemp ../starter/source/initial_conditions/thermic/hm_read_initemp.F
49!|| hm_read_inivel ../starter/source/initial_conditions/general/inivel/hm_read_inivel.F
50!|| hm_read_inject1 ../starter/source/properties/injector/hm_read_inject1.F
51!|| hm_read_inject2 ../starter/source/properties/injector/hm_read_inject2.F
52!|| hm_read_inter_lagdt_type07 ../starter/source/interfaces/int07/hm_read_inter_lagdt_type07.F
53!|| hm_read_inter_type12 ../starter/source/interfaces/int12/hm_read_inter_type12.F
54!|| hm_read_interfaces ../starter/source/interfaces/reader/hm_read_interfaces.F
55!|| hm_read_lines ../starter/source/groups/hm_read_lines.f
56!|| hm_read_link ../starter/source/constraints/rigidlink/hm_read_rlink.F
57!|| hm_read_merge ../starter/source/constraints/general/merge/hm_read_merge.F
58!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
59!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
60!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
61!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
62!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
63!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
64!|| hm_read_mpc ../starter/source/constraints/general/mpc/hm_read_mpc.F
65!|| hm_read_nbcs ../starter/source/constraints/general/bcs/hm_read_nbcs.f
66!|| hm_read_pblast ../starter/source/loads/pblast/hm_read_pblast.F
67!|| hm_read_pload ../starter/source/loads/general/pload/hm_read_pload.F
68!|| hm_read_prop15 ../starter/source/properties/solid/hm_read_prop15.F
69!|| hm_read_properties ../starter/source/properties/hm_read_properties.F
70!|| hm_read_quad ../starter/source/elements/reader/hm_read_quad.F
71!|| hm_read_radiation ../starter/source/loads/thermic/hm_read_radiation.F
72!|| hm_read_rbe2 ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
73!|| hm_read_rbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
74!|| hm_read_rbody ../starter/source/constraints/general/rbody/hm_read_rbody.f
75!|| hm_read_rbody_lagmul ../starter/source/constraints/general/rbody/hm_read_rbody_lagmul.F
76!|| hm_read_retractor ../starter/source/tools/seatbelts/hm_read_retractor.f
77!|| hm_read_rivet ../starter/source/elements/reader/hm_read_rivet.F
78!|| hm_read_rwall_cyl ../starter/source/constraints/general/rwall/hm_read_rwall_cyl.F
79!|| hm_read_rwall_lagmul ../starter/source/constraints/general/rwall/hm_read_rwall_lagmul.F
80!|| hm_read_rwall_paral ../starter/source/constraints/general/rwall/hm_read_rwall_paral.F
81!|| hm_read_rwall_plane ../starter/source/constraints/general/rwall/hm_read_rwall_plane.F
82!|| hm_read_rwall_spher ../starter/source/constraints/general/rwall/hm_read_rwall_spher.F
83!|| hm_read_rwall_therm ../starter/source/constraints/general/rwall/hm_read_rwall_therm.F
84!|| hm_read_sensors ../starter/source/tools/sensor/hm_read_sensors.F
85!|| hm_read_sh3n ../starter/source/elements/reader/hm_read_sh3n.F
86!|| hm_read_shell ../starter/source/elements/reader/hm_read_shell.F
87!|| hm_read_skw ../starter/source/tools/skew/hm_read_skw.F
88!|| hm_read_slipring ../starter/source/tools/seatbelts/hm_read_slipring.F
89!|| hm_read_solid ../starter/source/elements/reader/hm_read_solid.F
90!|| hm_read_sphcel ../starter/source/elements/reader/hm_read_sphcel.F
91!|| hm_read_sphio ../starter/source/loads/sph/hm_read_sphio.F
92!|| hm_read_spring ../starter/source/elements/reader/hm_read_spring.F
93!|| hm_read_surf ../starter/source/groups/hm_read_surf.f
94!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
95!|| hm_read_thgrou ../starter/source/output/th/hm_read_thgrou.F
96!|| hm_read_thgrsurf ../starter/source/output/th/hm_read_thgrsurf.f
97!|| hm_read_tria ../starter/source/elements/reader/hm_read_tria.F
98!|| hm_read_truss ../starter/source/elements/reader/hm_read_truss.F
99!|| hm_read_xref ../starter/source/loads/reference_state/xref/hm_read_xref.F
100!|| hm_setfxrbyon ../starter/source/constraints/fxbody/hm_setfxrbyon.F
101!|| hm_submodgrn ../starter/source/groups/hm_submodgr.F
102!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
103!|| i24surf_pxfem ../starter/source/interfaces/inter3d1/inintr2.F
104!|| ini_fxbody ../starter/source/constraints/fxbody/ini_fxbody.F
105!|| init_monvol ../starter/source/airbag/init_monvol.F
106!|| inslin ../starter/source/interfaces/interf1/inslin.F
107!|| insurf ../starter/source/interfaces/interf1/insurf.F
108!|| insurfigeo ../starter/source/interfaces/interf1/insurfigeo.F
109!|| lce16q3 ../starter/source/elements/solid_2d/quad/lce16q.F
110!|| lce16s3 ../starter/source/elements/reader/hm_read_solid.F
111!|| lec_inimap2d_file ../starter/source/initial_conditions/inimap/lec_inimap2d_file.F
112!|| lecacc ../starter/source/tools/accele/lecacc.F
113!|| lecig3d ../starter/source/elements/ige3d/lecig3d.F
114!|| lecrefsta ../starter/source/loads/reference_state/refsta/lecrefsta.F
115!|| lecsec42 ../starter/source/tools/sect/hm_read_sect.F
116!|| lecsec4bolt ../starter/source/tools/sect/lecsec4bolt.F
117!|| lecstack_ply ../starter/source/properties/composite_options/stack/lecstack_ply.F
118!|| lecstamp ../starter/source/interfaces/interf1/lecstamp.F
119!|| nbadigemesh ../starter/source/elements/ige3d/nbadigemesh.F
120!|| nbadmesh ../starter/source/model/remesh/nbadmesh.F
121!|| prelecsec ../starter/source/tools/sect/prelecsec.F
122!|| prelecsec4bolt ../starter/source/tools/sect/prelecsec4bolt.F
123!|| preread_rbody_set ../starter/source/model/sets/preread_rbody_set.F
124!|| printbcs ../starter/source/constraints/general/bcs/printbcs.F
125!|| r2r_domdec ../starter/source/coupling/rad2rad/r2r_domdec.F
126!|| r2r_monvol ../starter/source/coupling/rad2rad/r2r_prelec.F
127!|| r2r_prelec ../starter/source/coupling/rad2rad/r2r_prelec.F
128!|| read_box_cyl ../starter/source/model/box/read_box_cyl.F
129!|| read_box_rect ../starter/source/model/box/read_box_rect.F
130!|| read_box_spher ../starter/source/model/box/read_box_spher.F
131!|| read_dfs_detcord ../starter/source/initial_conditions/detonation/read_dfs_detcord.F
132!|| read_dfs_detline ../starter/source/initial_conditions/detonation/read_dfs_detline.F
133!|| read_dfs_detplan ../starter/source/initial_conditions/detonation/read_dfs_detplan.F
134!|| read_dfs_detpoint ../starter/source/initial_conditions/detonation/read_dfs_detpoint.F
135!|| read_dfs_wave_shaper ../starter/source/initial_conditions/detonation/read_dfs_wave_shaper.F
136!|| read_impdisp_fgeo ../starter/source/constraints/general/impvel/read_impdisp_fgeo.F
137!|| read_impvel ../starter/source/constraints/general/impvel/read_impvel.F
138!|| read_impvel_fgeo ../starter/source/constraints/general/impvel/read_impvel_fgeo.F
139!|| read_impvel_lagmul ../starter/source/constraints/general/impvel/read_impvel_lagmul.F
140!|| read_pch_file ../starter/source/constraints/fxbody/read_pch_file.F
141!|| read_sensor_disp ../starter/source/tools/sensor/read_sensor_disp.F
142!|| read_sensor_dist_surf ../starter/source/tools/sensor/read_sensor_dist_surf.F
143!|| read_sensor_user ../starter/source/tools/sensor/read_sensor_user.F
144!|| read_sensor_vel ../starter/source/tools/sensor/read_sensor_vel.F
145!|| read_sensor_work ../starter/source/tools/sensor/read_sensor_work.F
146!|| sensor_user_convert_local_id ../starter/source/tools/sensor/sensor_user_convert_local_id.F
147!|| set_user_window_nodes ../starter/source/user_interface/user_windows_tools.F
148!|| setrb2on ../starter/source/constraints/general/rbe2/hm_read_rbe2.F
149!|| thprin ../starter/source/output/th/thprin.F
150!|| thprin_sub ../starter/source/output/th/thprin.F
151!|| uelt_spmd_additional_node ../starter/source/user_interface/uaccess.F
152!|| w_itabm1 ../starter/source/restart/ddsplit/w_itabm1.F
153!||--- calls -----------------------------------------------------
154!|| ancmsg ../starter/source/output/message/message.F
155!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.F
156!||--- uses -----------------------------------------------------
157!|| message_mod ../starter/share/message_module/message_mod.F
158!||====================================================================
159 INTEGER FUNCTION usr2sys(IU,ITABM1,MESS,ID)
160 USE message_mod
161C FONCTION DONNE N0 SYSTEME DU NOEUD USER IU
162C-----------------------------------------------
163C I m p l i c i t T y p e s
164C-----------------------------------------------
165#include "implicit_f.inc"
166C-----------------------------------------------
167C D u m m y A r g u m e n t s
168C-----------------------------------------------
169 INTEGER iu,id
170 CHARACTER mess*40
171 INTEGER itabm1(*)
172 LOGICAL :: has_search_failed
173C-----------------------------------------------
174C E x t e r n a l F u n c t i o n s
175C-----------------------------------------------
176 INTEGER r2r_sys
177C-----------------------------------------------
178C C o m m o n B l o c k s
179C-----------------------------------------------
180#include "hash_id.inc"
181#include "com04_c.inc"
182#include "r2r_c.inc"
183C-----------------------------------------------
184C L o c a l V a r i a b l e s
185C-----------------------------------------------
186 INTEGER jinf, jsup, j, nn
187
188 j = -1
189 CALL c_hash_find(h_node,iu,j)
190 usr2sys = j
191
192 IF(nsubdom > 0 .OR. usr2sys < 0 .OR. itabm1(max(1,j)) /= iu) THEN
193 jinf=1
194 jsup=numnod
195 j=max(1,numnod/2)
196 has_search_failed=.false.
197 10 IF(j == 0)THEN
198 has_search_failed = .true.
199 ELSE
200 IF(jsup <= jinf .AND. (iu-itabm1(j)) /= 0) has_search_failed=.true.
201 ENDIF
202 IF(has_search_failed) THEN
203 IF ((nsubdom>0).AND.(flg_split==1)) THEN
204C----- -------Multidomaines -> On check dans la liste des noeuds suprimes-----
205 nn=r2r_sys(iu,itabm1,mess)
206 IF (nn==0) THEN
207 CALL ancmsg(msgid=895,
208 . msgtype=msgerror,
209 . anmode=anstop,
210 . i1=iu)
211 ENDIF
212C----- ------------------------------------------------------
213 ELSE
214 CALL ancmsg(msgid=78,
215 . msgtype=msgerror,
216 . anmode=aninfo,
217 . c1=mess,
218 . i1=id,
219 . i2=iu)
220 usr2sys=0
221 ENDIF
222 RETURN
223 ENDIF
224 IF((iu-itabm1(j))==0)THEN
225C >CAS IU=TABM FIN DE LA RECHERCHE
226 usr2sys=itabm1(j+numnod)
227 RETURN
228 ELSE IF (iu-itabm1(j)<0) THEN
229C >CAS IU<TABM
230 jsup=j-1
231 ELSE
232C >CAS IU>TABM
233 jinf=j+1
234 ENDIF
235 j=(jsup+jinf)/2
236 GO TO 10
237 ENDIF
238 END
239C
240!||====================================================================
241!|| usrtos ../starter/source/system/sysfus.F
242!||--- called by ------------------------------------------------------
243!|| hm_read_initemp ../starter/source/initial_conditions/thermic/hm_read_initemp.f
244!|| hm_read_node ../starter/source/elements/reader/hm_read_node.F
245!|| inivel ../starter/source/initial_conditions/general/inivel/inivel.F
246!|| lecsubmod ../starter/source/model/submodel/lecsubmod.F
247!|| lectrans ../starter/source/model/transformation/lectrans.F
248!|| lectranssub ../starter/source/model/submodel/lectranssub.F
249!|| merge ../starter/source/model/submodel/merge.F
250!|| merge_bucket_search ../starter/source/elements/nodes/merge_bucket_search.F
251!|| merge_cnod_cnod ../starter/source/model/submodel/merge_cnod_cnod.F
252!|| merge_node ../starter/source/elements/nodes/merge_node.F
253!||====================================================================
254 INTEGER FUNCTION usrtos(IU,ITABM1)
255C IDENTIQUE A USR2SYS, SANS GENERER D'ERREUR
256C FONCTION DONNE N0 SYSTEME DU NOEUD USER IU
257C-----------------------------------------------
258C I m p l i c i t T y p e s
259C-----------------------------------------------
260#include "implicit_f.inc"
261C-----------------------------------------------
262C D u m m y A r g u m e n t s
263C-----------------------------------------------
264 INTEGER iu
265 INTEGER itabm1(*)
266C-----------------------------------------------
267C C o m m o n B l o c k s
268C-----------------------------------------------
269#include "com04_c.inc"
270C-----------------------------------------------
271C L o c a l V a r i a b l e s
272C-----------------------------------------------
273 INTEGER jinf, jsup, j
274 ! Out of bounds at startup - no need to iterate
275 IF(iu < itabm1(1) .OR. iu > itabm1(numnod) ) THEN
276 usrtos=0
277 RETURN
278 ENDIF
279
280 jinf=1
281 jsup=numnod
282 j=max(1,numnod/2)
283 10 IF(j < 1 .OR. j>numnod)THEN ! out of bounds
284 usrtos=0
285 RETURN
286 ENDIF
287 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN ! not found
288 usrtos=0
289 RETURN
290 ENDIF
291 IF((iu-itabm1(j))==0)THEN
292C >CAS IU=TABM FIN DE LA RECHERCHE
293 usrtos=itabm1(j+numnod)
294 RETURN
295 ELSE IF (iu-itabm1(j)<0) THEN
296C >CAS IU<TABM
297 jsup=j-1
298 ELSE
299C >CAS IU>TABM
300 jinf=j+1
301 ENDIF
302 j=(jsup+jinf)/2
303 GO TO 10
304 END
305C
306!||====================================================================
307!|| itabm1_search ../starter/source/system/sysfus.F
308!||====================================================================
309 INTEGER FUNCTION itabm1_search(IU,ITABM1)
310C-----------------------------------------------
311C ROUTINE DESCRIPTION :
312C ===================
313C ITABM1_SEARCH : Return INDEX in ITABM1 for a given User ID
314C Permits to have : * entry in ITABM1
315C Internal NOD_ID with (ITABM1(ENTRY+NUMNOD)
316C * -1 if node was no found
317C-----------------------------------------------
318C DUMMY ARGUMENTS DESCRIPTION:
319C ===================
320C
321C NAME DESCRIPTION
322C
323C IU (INPUT) Node User ID
324C ITABM1(2*NUMNOD) (INPUT) Array for UserID -> Internal NodID Mapping
325C============================================================================
326C-----------------------------------------------
327C I m p l i c i t T y p e s
328C-----------------------------------------------
329#include "implicit_f.inc"
330C-----------------------------------------------
331C D u m m y A r g u m e n t s
332C-----------------------------------------------
333 INTEGER, INTENT(IN) :: iu
334 INTEGER, INTENT(IN) :: itabm1(2*numnod)
335C-----------------------------------------------
336C C o m m o n B l o c k s
337C-----------------------------------------------
338#include "com04_c.inc"
339C-----------------------------------------------
340C L o c a l V a r i a b l e s
341C-----------------------------------------------
342 INTEGER jinf, jsup, j
343 jinf=1
344 jsup=numnod
345 j=max(1,numnod/2)
346 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
347 itabm1_search=-1
348 RETURN
349 ENDIF
350 IF((iu-itabm1(j))==0)THEN
351C >CAS IU=TABM FIN DE LA RECHERCHE
352 itabm1_search=j
353 RETURN
354 ELSE IF (iu-itabm1(j)<0) THEN
355C >CAS IU<TABM
356 jsup=j-1
357 ELSE
358C >CAS IU>TABM
359 jinf=j+1
360 ENDIF
361 j=(jsup+jinf)/2
362 GO TO 10
363 END
364!||====================================================================
365!|| usr2sys2 ../starter/source/system/sysfus.F
366!||--- called by ------------------------------------------------------
367!||--- calls -----------------------------------------------------
368!|| ancmsg ../starter/source/output/message/message.F
369!|| r2r_sys ../starter/source/coupling/rad2rad/routines_r2r.F
370!||--- uses -----------------------------------------------------
371!|| message_mod ../starter/share/message_module/message_mod.F
372!||====================================================================
373 INTEGER FUNCTION usr2sys2(IU,ITABM1,MESS,JINDEX,ID)
374C-----------------------------------------------
375C M o d u l e s
376C-----------------------------------------------
377 USE message_mod
378C-----------------------------------------------
379C D e s c r i p t i o n
380C-----------------------------------------------
381C SAME AS USR2SYS, SENDING INDEX JINDEX CORRESPONDING TO
382C INTERNAL IDENTIFIER OF USER NODE IDENTIFIER IU
383C-----------------------------------------------
384C I m p l i c i t T y p e s
385C-----------------------------------------------
386#include "implicit_f.inc"
387C-----------------------------------------------
388C D u m m y A r g u m e n t s
389C-----------------------------------------------
390 INTEGER iu, jindex
391 CHARACTER mess*40
392 INTEGER itabm1(*)
393 INTEGER,INTENT(IN) :: id
394C-----------------------------------------------
395C E x t e r n a l F u n c t i o n s
396C-----------------------------------------------
397 INTEGER r2r_sys
398C-----------------------------------------------
399C C o m m o n B l o c k s
400C-----------------------------------------------
401#include "com04_c.inc"
402#include "r2r_c.inc"
403C-----------------------------------------------
404C L o c a l V a r i a b l e s
405C-----------------------------------------------
406 INTEGER jinf, jsup, j, nn
407 jindex=0
408 jinf=1
409 jsup=numnod
410 j=max(1,numnod/2)
411 10 IF(jsup<=jinf.AND.(iu-itabm1(j))/=0) THEN
412 IF (nsubdom>0) THEN
413C------------Multidomaines -> checking in list of deleted nodes-----
414 nn=r2r_sys(iu,itabm1,mess)
415 IF (nn==0) THEN
416 CALL ancmsg(msgid=895,
417 . msgtype=msgerror,
418 . anmode=anstop,
419 . i1=iu)
420 ENDIF
421C-----------------------------------------------------------
422 ELSE
423 CALL ancmsg(msgid=78,
424 . msgtype=msgerror,
425 . anmode=aninfo,
426 . c1=mess,
427 . i1=id,
428 . i2=iu)
429 usr2sys2=0
430 ENDIF
431 RETURN
432 ENDIF
433 IF((iu-itabm1(j))==0)THEN
434C >CASE IU=TABM : ENDING THE SEARCH ALGORITHM
435 jindex=j
436 usr2sys2=itabm1(j+numnod)
437 RETURN
438 ELSE IF (iu-itabm1(j)<0) THEN
439C >CASE IU<TABM
440 jsup=j-1
441 ELSE
442C >CASE IU>TABM
443 jinf=j+1
444 ENDIF
445 j=(jsup+jinf)/2
446 GO TO 10
447 END
448C
449!||====================================================================
450!|| ulist2s ../starter/source/system/sysfus.F
451!||--- called by ------------------------------------------------------
452!|| hm_lecgrn ../starter/source/groups/hm_lecgrn.F
453!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
454!|| hm_read_thgrou ../starter/source/output/th/hm_read_thgrou.F
455!|| hm_read_thgrsurf ../starter/source/output/th/hm_read_thgrsurf.F
456!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
457!|| thprin ../starter/source/output/th/thprin.F
458!|| thprin_sub ../starter/source/output/th/thprin.F
459!||--- calls -----------------------------------------------------
460!|| ancmsg ../starter/source/output/message/message.F
461!||--- uses -----------------------------------------------------
462!|| message_mod ../starter/share/message_module/message_mod.F
463!||====================================================================
464 INTEGER FUNCTION ulist2s(LIST,NLIST,ITABM1,MESS,INDEX,ID)
465C-----------------------------------------------
466C M o d u l e s
467C-----------------------------------------------
468 USE message_mod
469C-----------------------------------------------
470C D e s c r i p t i o n
471C-----------------------------------------------
472C Function is sending back Internal node identifiers from a list of user node identifiers
473C-----------------------------------------------
474C I m p l i c i t T y p e s
475C-----------------------------------------------
476#include "implicit_f.inc"
477C-----------------------------------------------
478C D u m m y A r g u m e n t s
479C-----------------------------------------------
480 INTEGER list(*),nlist,id
481 CHARACTER mess*40
482 INTEGER itabm1(*),index(*)
483C ITABM1(1:NUMNOD) NO USER TRIE
484C ITABM1(1+NUMNOD:2*NUMNOD) INDEX NUMBER
485C ITABM1(NUMNOD+J) INTERNAL NODE IDENTIFIER IN ITABM1(J)
486C-----------------------------------------------
487C C o m m o n B l o c k s
488C-----------------------------------------------
489#include "com04_c.inc"
490C-----------------------------------------------
491C L o c a l V a r i a b l e s
492C-----------------------------------------------
493 INTEGER i, j,nnod,nold,k, iwork(70000)
494C-----------------------------------------------
495C E x t e r n a l F u n c t i o n s
496C-----------------------------------------------
497 INTEGER usr2sys2
498C-----------------------
499C SORT (ASCENDING ORDER)
500C-----------------------
501 CALL my_orders(0,iwork,list,index,nlist,1)
502 DO i=1,nlist
503 index(nlist+i) = list(index(i))
504 ENDDO
505 k=1
506 nold = index(nlist+1)
507 DO i=1,nlist
508 IF(nold/=index(nlist+i))k=k+1
509 list(k) = index(nlist+i)
510 nold = index(nlist+i)
511 ENDDO
512 nnod=k
513C-----------------------
514C SEARCH NODES FROM LIST() IN ITABM1()
515C ALGO < NLIST+NUMNOD
516C-----------------------
517C I=1
518C J=1
519C USR2SYS2 is sending back J, index in ITABM1 array such as LIST(1)=ITABM1(J)
520C cursor is then directly positioned on the correct address in ITABM1
521 list(1)=usr2sys2(list(1),itabm1,mess,j,id)
522 IF(j==0)THEN
523 ! in case of error, node does not exist
524 ulist2s=0
525 ELSE
526C
527 DO i=2,nnod
528 DO WHILE(list(i)>itabm1(j).AND.j<numnod)
529 j=j+1
530 ENDDO
531 IF(list(i)==itabm1(j))THEN
532 list(i)=itabm1(numnod+j)
533 ELSE
534 CALL ancmsg(msgid=78,
535 . msgtype=msgerror,
536 . anmode=aninfo,
537 . c1=mess,
538 . i1=id,
539 . i2=list(i))
540 ulist2s=i-1
541 RETURN
542 ENDIF
543 ENDDO
544C
545 ulist2s=nnod
546
547 ENDIF
548
549 RETURN
550 END
551C
552!||====================================================================
553!|| udouble ../starter/source/system/sysfus.F
554!||--- called by ------------------------------------------------------
555!|| hm_read_cyljoint ../starter/source/constraints/general/cyl_joint/hm_read_cyljoint.F
556!|| hm_read_drape ../starter/source/properties/composite_options/drape/hm_read_drape.F
557!|| hm_read_frm ../starter/source/tools/skew/hm_read_frm.F
558!|| hm_read_fxb1 ../starter/source/constraints/fxbody/hm_read_fxb.f
559!|| hm_read_impacc ../starter/source/constraints/general/impvel/hm_read_impacc.F
560!|| hm_read_impvel ../starter/source/constraints/general/impvel/hm_read_impvel.f
561!|| hm_read_initemp ../starter/source/initial_conditions/thermic/hm_read_initemp.F
562!|| hm_read_inivel ../starter/source/initial_conditions/general/inivel/hm_read_inivel.f
563!|| hm_read_intsub ../starter/source/output/subinterface/hm_read_intsub.F
564!|| hm_read_link ../starter/source/constraints/rigidlink/hm_read_rlink.F
565!|| hm_read_part ../starter/source/model/assembling/hm_read_part.F
566!|| hm_read_perturb ../starter/source/general_controls/computation/hm_read_perturb.F
567!|| hm_read_prelecdrape ../starter/source/properties/composite_options/drape/hm_read_drape.F
568!|| hm_read_rbody ../starter/source/constraints/general/rbody/hm_read_rbody.F
569!|| hm_read_retractor ../starter/source/tools/seatbelts/hm_read_retractor.F
570!|| hm_read_sensors ../starter/source/tools/sensor/hm_read_sensors.F
571!|| hm_read_skw ../starter/source/tools/skew/hm_read_skw.F
572!|| hm_read_slipring ../starter/source/tools/seatbelts/hm_read_slipring.F
573!|| hm_read_solid ../starter/source/elements/reader/hm_read_solid.F
574!|| hm_read_sphcel ../starter/source/elements/reader/hm_read_sphcel.F
575!|| hm_read_sphio ../starter/source/loads/sph/hm_read_sphio.F
576!|| hm_read_table2 ../starter/source/tools/curve/hm_read_table.F
577!|| hm_read_thgrne ../starter/source/output/th/hm_read_thgrne.F
578!|| hm_read_thgrou ../starter/source/output/th/hm_read_thgrou.F
579!|| hm_read_thpart ../starter/source/output/thpart/hm_read_thpart.F
580!|| hm_read_xelem ../starter/source/elements/reader/hm_read_xelem.F
581!|| lecig3d ../starter/source/elements/ige3d/lecig3d.F
582!|| lecsec42 ../starter/source/tools/sect/hm_read_sect.f
583!|| lecsec4bolt ../starter/source/tools/sect/lecsec4bolt.F
584!|| read_rwall ../starter/source/constraints/general/rwall/read_rwall.F
585!||--- calls -----------------------------------------------------
586!|| udoubl2 ../starter/source/system/sysfus.F
587!||====================================================================
588 SUBROUTINE udouble(LIST,ILIST,NLIST,MESS,IR,RLIST)
589C TEST LES N0 DOUBLES
590C-----------------------------------------------
591C I m p l i c i t T y p e s
592C-----------------------------------------------
593#include "implicit_f.inc"
594C-----------------------------------------------
595C D u m m y A r g u m e n t s
596C-----------------------------------------------
597C remonte la declaration des entiers pour la compile sur Compaq
598 INTEGER ILIST,NLIST,LIST(ILIST,NLIST),IR
599 my_real
600 . rlist(ilist,nlist)
601 CHARACTER MESS*40
602C-----------------------------------------------
603C C o m m o n B l o c k s
604C-----------------------------------------------
605C ALLOC FREE
606C-----------------------------------------------
607#if CPP_comp == f90
608 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
609#else
610 pointer(iindex,index(1))
611 INTEGER INDEX
612#endif
613C-----------------------------------------------
614C L o c a l V a r i a b l e s
615C-----------------------------------------------
616 INTEGER I
617 IF (nlist>=2)THEN
618#if CPP_comp == f90
619 ALLOCATE(index(3*nlist))
620#else
621 CALL my_alloc(iindex,3*nlist,0)
622#endif
623 CALL udoubl2(index,nlist,mess,list,ilist,ir,rlist)
624#if CPP_comp == f90
625 DEALLOCATE(index)
626#else
627 CALL my_free(iindex)
628#endif
629 ENDIF
630C
631 RETURN
632 END
633
634!||====================================================================
635!|| udoublex ../starter/source/system/sysfus.F
636!||--- calls -----------------------------------------------------
637!||====================================================================
638 SUBROUTINE udoublex(NLIST,ILIST,IXX,KXX)
639C TEST LES N0 DOUBLES
640C-----------------------------------------------
641C I m p l i c i t T y p e s
642C-----------------------------------------------
643#include "implicit_f.inc"
644C-----------------------------------------------
645C D u m m y A r g u m e n t s
646C-----------------------------------------------
647C remonte la declaration des entiers pour la compile sur Compaq
648 INTEGER ILIST,NLIST,IXX(*),N,KXX(ILIST,*),
649 . IAD,nnod
650
651C-----------------------------------------------
652C C o m m o n B l o c k s
653C-----------------------------------------------
654C ALLOC FREE
655C-----------------------------------------------
656#if CPP_comp == f90
657 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
658#else
659 pointer(iindex,index(1))
660 INTEGER INDEX
661#endif
662C-----------------------------------------------
663C L o c a l V a r i a b l e s
664C-----------------------------------------------
665 INTEGER I
666 IF (nlist>=2)THEN
667#if CPP_comp == f90
668 ALLOCATE(index(3*nlist))
669#else
670 CALL my_alloc(iindex,3*nlist,0)
671#endif
672 DO n=1,nlist
673 iad=kxx(4,n)
674 print*,'UBOUBLE X - MULTIBRIN NUM :',n
675 nnod = kxx(3,n)
676 do i=1,nnod
677 print*,'IXX:', ixx(iad+i-1)
678 enddo
679 enddo
680#if CPP_comp == f90
681 DEALLOCATE(index)
682#else
683 CALL my_free(iindex)
684#endif
685 ENDIF
686C
687 RETURN
688 END
689
690!||====================================================================
691!|| udoubl2 ../starter/source/system/sysfus.F
692!||--- called by ------------------------------------------------------
693!|| udouble ../starter/source/system/sysfus.F
694!||--- calls -----------------------------------------------------
695!|| ancmsg ../starter/source/output/message/message.F
696!||--- uses -----------------------------------------------------
697!|| message_mod ../starter/share/message_module/message_mod.F
698!||====================================================================
699 SUBROUTINE udoubl2(INDEX,NLIST,MESS,LIST,ILIST,IR,RLIST)
700 USE message_mod
701C TEST LES N0 DOUBLES
702C-----------------------------------------------
703C I m p l i c i t T y p e s
704C-----------------------------------------------
705#include "implicit_f.inc"
706C-----------------------------------------------
707C D u m m y A r g u m e n t s
708C-----------------------------------------------
709 INTEGER NLIST,ILIST,IR
710 CHARACTER MESS*40
711 INTEGER INDEX(NLIST,3),LIST(ILIST,NLIST)
712 my_real
713 . rlist(ilist,nlist)
714C-----------------------------------------------
715C L o c a l V a r i a b l e s
716C-----------------------------------------------
717 INTEGER I, J,NNOD,NOLD,K,ID,IDM,
718 . IWORK(70000)
719C-----------------------
720C TRI DE LIST EN ORDRE CROISSANT
721C-----------------------
722 IF(ir==1)THEN
723 DO i=1,nlist
724 index(i,3)=nint(rlist(1,i))
725 ENDDO
726 ELSE
727 DO i=1,nlist
728 index(i,3)=list(1,i)
729 ENDDO
730 ENDIF
731C
732 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
733 id=index(index(1,1),3)
734 DO i=2,nlist
735 idm=id
736 id=index(index(i,1),3)
737 IF(id==idm .AND. id/=0)THEN
738 CALL ancmsg(msgid=79,
739 . msgtype=msgerror,
740 . anmode=aninfo,
741 . c1=mess,
742 . i1=id)
743 ENDIF
744 ENDDO
745C-----------------------
746 RETURN
747 END
748C
749!||====================================================================
750!|| newdbl ../starter/source/system/sysfus.F
751!||--- called by ------------------------------------------------------
752!|| hm_read_fxb1 ../starter/source/constraints/fxbody/hm_read_fxb.F
753!|| hm_read_rbody ../starter/source/constraints/general/rbody/hm_read_rbody.F
754!||--- calls -----------------------------------------------------
755!|| newdbl2 ../starter/source/system/sysfus.F
756!||====================================================================
757 SUBROUTINE newdbl(LIST,ILIST,NLIST,TAB,ERRID,STATUS,NOM_OPT)
758C TEST LES N0 DOUBLES SUR DES LISTES D'ID de noeuds ou elt ou ...
759C-----------------------------------------------
760C I m p l i c i t T y p e s
761C-----------------------------------------------
762#include "implicit_f.inc"
763C-----------------------------------------------
764C D u m m y A r g u m e n t s
765C-----------------------------------------------
766#include "scr17_c.inc"
767 INTEGER TAB(*)
768 INTEGER ILIST,NLIST,LIST(ILIST,NLIST),ERRID,STATUS
769 INTEGER NOM_OPT(LNOPT1,*)
770C-----------------------------------------------
771C C o m m o n B l o c k s
772C-----------------------------------------------
773#include "scr03_c.inc"
774C-----------------------------------------------
775C ALLOC FREE
776C-----------------------------------------------
777#if CPP_comp == f90
778 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
779#else
780 pointer(iindex,index(1))
781 INTEGER INDEX
782#endif
783 IF (invers>=40.AND.nlist>=2)THEN
784#if CPP_comp == f90
785 ALLOCATE(index(3*nlist))
786#else
787 CALL my_alloc(iindex,3*nlist,0)
788#endif
789 CALL newdbl2(index,nlist,list,ilist,tab,errid,status,nom_opt)
790#if CPP_comp == f90
791 DEALLOCATE(index)
792#else
793 CALL my_free(iindex)
794#endif
795 ENDIF
796C
797 RETURN
798 END
799!||====================================================================
800!|| newdbl2 ../starter/source/system/sysfus.F
801!||--- called by ------------------------------------------------------
802!|| newdbl ../starter/source/system/sysfus.F
803!||--- calls -----------------------------------------------------
804!|| ancmsg ../starter/source/output/message/message.F
805!|| fretitl2 ../starter/source/starter/freform.F
806!||--- uses -----------------------------------------------------
807!|| message_mod ../starter/share/message_module/message_mod.F
808!||====================================================================
809 SUBROUTINE newdbl2(INDEX,NLIST,LIST,ILIST,TAB,ERRID,STATUS,
810 . NOM_OPT)
811 USE message_mod
812 USE names_and_titles_mod , ONLY : nchartitle
813C TEST LES N0 DOUBLES
814C-----------------------------------------------
815C I m p l i c i t T y p e s
816C-----------------------------------------------
817#include "implicit_f.inc"
818C-----------------------------------------------
819C D u m m y A r g u m e n t s
820C-----------------------------------------------
821#include "scr17_c.inc"
822 INTEGER NLIST,ILIST,ERRID,STATUS
823 INTEGER TAB(*), INDEX(NLIST,3),LIST(ILIST,NLIST)
824 INTEGER NOM_OPT(LNOPT1,*)
825C-----------------------------------------------
826C L o c a l V a r i a b l e s
827C-----------------------------------------------
828 INTEGER I, ID,IDM, IWORK(70000),ID1
829 CHARACTER(LEN=NCHARTITLE)::TITR
830C-----------------------
831C TRI DE LIST EN ORDRE CROISSANT
832C-----------------------
833 DO i=1,nlist
834 index(i,3)=list(1,i)
835 ENDDO
836C
837 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
838 id=index(index(1,1),3)
839 DO i=2,nlist
840 idm=id
841 id=index(index(i,1),3)
842 IF(id==idm)THEN
843 IF (status < 0) THEN
844C CAS D ONE WARNING STATUS Negatif
845 status = -1*status
846 CALL ancmsg(msgid=errid,
847 . msgtype=msgwarning,
848 . anmode=status,i1=tab(id))
849 status = -1*status
850 ELSE
851C CAS D UNE ERREUR STATUS Positif
852 id1=nom_opt(1,i)
853 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
854 CALL ancmsg(msgid=errid,
855 . msgtype=msgerror,
856 . anmode=status,i1=id1,c1=titr,i2=tab(id))
857 ENDIF
858 ENDIF
859 ENDDO
860C-----------------------
861 RETURN
862 END
863C
864!||====================================================================
865!|| vdouble ../starter/source/system/sysfus.F
866!||--- called by ------------------------------------------------------
867!|| hm_read_beam ../starter/source/elements/reader/hm_read_beam.F
868!|| hm_read_gauge ../starter/source/output/gauge/hm_read_gauge.F
869!|| hm_read_mat ../starter/source/materials/mat/hm_read_mat.F90
870!|| hm_read_properties ../starter/source/properties/hm_read_properties.F
871!|| hm_read_quad ../starter/source/elements/reader/hm_read_quad.F
872!|| hm_read_rivet ../starter/source/elements/reader/hm_read_rivet.F
873!|| hm_read_sh3n ../starter/source/elements/reader/hm_read_sh3n.F
874!|| hm_read_shell ../starter/source/elements/reader/hm_read_shell.f
875!|| hm_read_spring ../starter/source/elements/reader/hm_read_spring.F
876!|| hm_read_tria ../starter/source/elements/reader/hm_read_tria.F
877!|| hm_read_truss ../starter/source/elements/reader/hm_read_truss.F
878!|| lecacc ../starter/source/tools/accele/lecacc.F
879!|| lecstack_ply ../starter/source/properties/composite_options/stack/lecstack_ply.F
880!||--- calls -----------------------------------------------------
881!|| vdoubl2 ../starter/source/system/sysfus.F
882!||====================================================================
883 SUBROUTINE vdouble(LIST,ILIST,NLIST,MESS,IR,RLIST)
884C TEST LES N0 DOUBLES , TOUS FORMATS, ERREUR
885C-----------------------------------------------
886C I m p l i c i t T y p e s
887C-----------------------------------------------
888#include "implicit_f.inc"
889C-----------------------------------------------
890C D u m m y A r g u m e n t s
891C-----------------------------------------------
892 INTEGER ILIST,NLIST,LIST(ILIST,NLIST),IR
893 my_real
894 . rlist(ilist,nlist)
895 CHARACTER MESS*40
896C-----------------------------------------------
897C ALLOC FREE
898C-----------------------------------------------
899#if CPP_comp == f90
900 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
901#else
902 pointer(iindex,index(1))
903 INTEGER INDEX
904#endif
905C-----------------------------------------------
906C L o c a l V a r i a b l e s
907C-----------------------------------------------
908 INTEGER I
909#if CPP_comp == f90
910 ALLOCATE(index(3*nlist))
911#else
912 CALL my_alloc(iindex,3*nlist,0)
913#endif
914 CALL vdoubl2(index,nlist,mess,list,ilist,ir,rlist)
915#if CPP_comp == f90
916 DEALLOCATE(index)
917#else
918 CALL my_free(iindex)
919#endif
920C
921 RETURN
922 END
923!||====================================================================
924!|| vdoubl2 ../starter/source/system/sysfus.F
925!||--- called by ------------------------------------------------------
926!|| vdouble ../starter/source/system/sysfus.f
927!||--- calls -----------------------------------------------------
928!|| ancmsg ../starter/source/output/message/message.F
929!||--- uses -----------------------------------------------------
930!|| message_mod ../starter/share/message_module/message_mod.F
931!||====================================================================
932 SUBROUTINE vdoubl2(INDEX,NLIST,MESS,LIST,ILIST,IR,RLIST)
933 USE message_mod
934C TEST LES N0 DOUBLES , TOUS FORMATS, ERREUR
935C-----------------------------------------------
936C I m p l i c i t T y p e s
937C-----------------------------------------------
938#include "implicit_f.inc"
939C-----------------------------------------------
940C D u m m y A r g u m e n t s
941C-----------------------------------------------
942 INTEGER NLIST,ILIST,IR
943 CHARACTER MESS*40
944 INTEGER INDEX(NLIST,3),LIST(ILIST,NLIST)
945 my_real
946 . rlist(ilist,nlist)
947C-----------------------------------------------
948C L o c a l V a r i a b l e s
949C-----------------------------------------------
950 INTEGER I, J,NNOD,NOLD,K,ID,IDM,
951 . iwork(70000)
952C-----------------------
953C TRI DE LIST EN ORDRE CROISSANT
954C-----------------------
955 IF(ir==1)THEN
956 DO i=1,nlist
957 index(i,3)=nint(rlist(1,i))
958 ENDDO
959 ELSE
960 DO i=1,nlist
961 index(i,3)=list(1,i)
962 ENDDO
963 ENDIF
964C
965 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
966 id=index(index(1,1),3)
967 DO i=2,nlist
968 idm=id
969 id=index(index(i,1),3)
970 IF(id==idm .AND. id/=0)THEN
971 CALL ancmsg(msgid=79,
972 . msgtype=msgerror,
973 . anmode=aninfo,
974 . c1=mess,
975 . i1=id)
976 ENDIF
977 ENDDO
978C-----------------------
979 RETURN
980 END
981!||====================================================================
982!|| udouble_wo_title ../starter/source/system/sysfus.F
983!||--- called by ------------------------------------------------------
984!|| hm_read_unit ../starter/source/general_controls/computation/hm_read_unit.F
985!||--- calls -----------------------------------------------------
986!|| udoubl2_wo_title ../starter/source/system/sysfus.F
987!||====================================================================
988 SUBROUTINE udouble_wo_title(LIST,ILIST,NLIST,MESS,IR,RLIST)
989C TEST LES N0 DOUBLES
990C-----------------------------------------------
991C I m p l i c i t T y p e s
992C-----------------------------------------------
993#include "implicit_f.inc"
994C-----------------------------------------------
995C D u m m y A r g u m e n t s
996C-----------------------------------------------
997C remonte la declaration des entiers pour la compile sur Compaq
998 INTEGER ILIST,NLIST,LIST(ILIST,NLIST),IR
999 my_real
1000 . rlist(ilist,nlist)
1001 CHARACTER MESS*40
1002C-----------------------------------------------
1003C C o m m o n B l o c k s
1004C-----------------------------------------------
1005C ALLOC FREE
1006C-----------------------------------------------
1007#if CPP_comp == f90
1008 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
1009#else
1010 pointer(iindex,index(1))
1011 INTEGER INDEX
1012#endif
1013C-----------------------------------------------
1014C L o c a l V a r i a b l e s
1015C-----------------------------------------------
1016 INTEGER I
1017 IF (nlist>=2)THEN
1018#if CPP_comp == f90
1019 ALLOCATE(index(3*nlist))
1020#else
1021 CALL my_alloc(iindex,3*nlist,0)
1022#endif
1023 CALL udoubl2_wo_title(index,nlist,mess,list,ilist,ir,rlist)
1024#if CPP_comp == f90
1025 DEALLOCATE(index)
1026#else
1027 CALL my_free(iindex)
1028#endif
1029 ENDIF
1030C
1031 RETURN
1032 END
1033!||====================================================================
1034!|| udoubl2_wo_title ../starter/source/system/sysfus.F
1035!||--- called by ------------------------------------------------------
1036!|| udouble_wo_title ../starter/source/system/sysfus.F
1037!||--- calls -----------------------------------------------------
1038!|| ancmsg ../starter/source/output/message/message.F
1039!||--- uses -----------------------------------------------------
1040!|| message_mod ../starter/share/message_module/message_mod.F
1041!||====================================================================
1042 SUBROUTINE udoubl2_wo_title(INDEX,NLIST,MESS,LIST,ILIST,IR,RLIST)
1043 USE message_mod
1044C TEST LES N0 DOUBLES
1045C-----------------------------------------------
1046C I m p l i c i t T y p e s
1047C-----------------------------------------------
1048#include "implicit_f.inc"
1049C-----------------------------------------------
1050C D u m m y A r g u m e n t s
1051C-----------------------------------------------
1052 INTEGER NLIST,ILIST,IR
1053 CHARACTER MESS*40
1054 INTEGER INDEX(NLIST,3),LIST(ILIST,NLIST)
1055 my_real
1056 . rlist(ilist,nlist)
1057C-----------------------------------------------
1058C L o c a l V a r i a b l e s
1059C-----------------------------------------------
1060 INTEGER I, J,NNOD,NOLD,K,ID,IDM,IDS,
1061 . iwork(70000)
1062C-----------------------
1063C TRI DE LIST EN ORDRE CROISSANT
1064C-----------------------
1065 IF(ir==1)THEN
1066 DO i=1,nlist
1067 index(i,3)=nint(rlist(1,i))
1068 ENDDO
1069 ELSE
1070 DO i=1,nlist
1071 index(i,3)=list(1,i)
1072 ENDDO
1073 ENDIF
1074C
1075 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
1076 id=index(index(1,1),3)
1077 DO i=2,nlist
1078 idm=id
1079 id=index(index(i,1),3)
1080 IF(id==idm)THEN
1081 ids=list(1,i)
1082 CALL ancmsg(msgid=1108,
1083 . msgtype=msgerror,
1084 . anmode=aninfo,
1085 . c1=mess,
1086 . i1=id)
1087 ENDIF
1088 ENDDO
1089C-----------------------
1090 RETURN
1091 END
1092!||====================================================================
1093!|| udouble3 ../starter/source/system/sysfus.F
1094!||--- called by ------------------------------------------------------
1095!|| hm_read_drape ../starter/source/properties/composite_options/drape/hm_read_drape.F
1096!||--- calls -----------------------------------------------------
1097!|| udoubl3 ../starter/source/system/sysfus.F
1098!||====================================================================
1099 SUBROUTINE udouble3(LIST,ILIST,NLIST,MESS,MESS2,IR,RLIST)
1100C TEST LES N0 DOUBLES
1101C-----------------------------------------------
1102C I m p l i c i t T y p e s
1103C-----------------------------------------------
1104#include "implicit_f.inc"
1105C-----------------------------------------------
1106C D u m m y A r g u m e n t s
1107C-----------------------------------------------
1108C remonte la declaration des entiers pour la compile sur Compaq
1109 INTEGER ILIST,NLIST,LIST(ILIST,NLIST),IR
1110 my_real
1111 . rlist(ilist,nlist)
1112 CHARACTER MESS*40,MESS2*40
1113C-----------------------------------------------
1114C C o m m o n B l o c k s
1115C-----------------------------------------------
1116C ALLOC FREE
1117C-----------------------------------------------
1118#if CPP_comp == f90
1119 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
1120#else
1121 pointer(iindex,index(1))
1122 INTEGER INDEX
1123#endif
1124C-----------------------------------------------
1125C L o c a l V a r i a b l e s
1126C-----------------------------------------------
1127 INTEGER I
1128 IF (nlist>=2)THEN
1129#if CPP_comp == f90
1130 ALLOCATE(index(3*nlist))
1131#else
1132 CALL my_alloc(iindex,3*nlist,0)
1133#endif
1134 CALL udoubl3(index,nlist,mess,mess2,list,ilist,ir,rlist)
1135#if CPP_comp == f90
1136 DEALLOCATE(index)
1137#else
1138 CALL my_free(iindex)
1139#endif
1140 ENDIF
1141C
1142 RETURN
1143 END
1144!||====================================================================
1145!|| udoubl3 ../starter/source/system/sysfus.F
1146!||--- called by ------------------------------------------------------
1147!|| udouble3 ../starter/source/system/sysfus.F
1148!||--- calls -----------------------------------------------------
1149!|| ancmsg ../starter/source/output/message/message.F
1150!||--- uses -----------------------------------------------------
1151!|| message_mod ../starter/share/message_module/message_mod.F
1152!||====================================================================
1153 SUBROUTINE udoubl3(INDEX,NLIST,MESS,MESS2,LIST,ILIST,IR,RLIST)
1154 USE message_mod
1155C TEST LES N0 DOUBLES
1156C-----------------------------------------------
1157C I m p l i c i t T y p e s
1158C-----------------------------------------------
1159#include "implicit_f.inc"
1160C-----------------------------------------------
1161C D u m m y A r g u m e n t s
1162C-----------------------------------------------
1163 INTEGER NLIST,ILIST,IR
1164 CHARACTER MESS*40,MESS2*40
1165 INTEGER INDEX(NLIST,3),LIST(ILIST,NLIST)
1166 my_real
1167 . rlist(ilist,nlist)
1168C-----------------------------------------------
1169C L o c a l V a r i a b l e s
1170C-----------------------------------------------
1171 INTEGER I, J,NNOD,NOLD,K,ID,IDM,IDS,
1172 . iwork(70000)
1173C-----------------------
1174C TRI DE LIST EN ORDRE CROISSANT
1175C-----------------------
1176 IF(ir==1)THEN
1177 DO i=1,nlist
1178 index(i,3)=nint(rlist(1,i))
1179 ENDDO
1180 ELSE
1181 DO i=1,nlist
1182 index(i,3)=list(1,i)
1183 ENDDO
1184 ENDIF
1185C
1186 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
1187 id=index(index(1,1),3)
1188 DO i=2,nlist
1189 idm=id
1190 id=index(index(i,1),3)
1191 IF(id==idm)THEN
1192 ids=list(2,i)
1193 CALL ancmsg(msgid=1154,
1194 . msgtype=msgerror,
1195 . anmode=aninfo,
1196 . c1=mess,
1197 . i1=ids,
1198 . c2=mess2,
1199 . i2=id)
1200 ENDIF
1201 ENDDO
1202C-----------------------
1203 RETURN
1204 END
1205!||====================================================================
1206!|| udouble_igr ../starter/source/system/sysfus.F
1207!||--- called by ------------------------------------------------------
1208!|| hm_lecgre ../starter/source/groups/hm_lecgre.F
1209!|| hm_lecgrn ../starter/source/groups/hm_lecgrn.F
1210!|| hm_read_box ../starter/source/model/box/hm_read_box.F
1211!|| hm_read_grpart ../starter/source/groups/hm_read_grpart.F
1212!|| hm_read_inicrack ../starter/source/initial_conditions/inicrack/hm_read_inicrack.F
1213!|| hm_read_lines ../starter/source/groups/hm_read_lines.F
1214!|| hm_read_subset ../starter/source/model/assembling/hm_read_subset.F
1215!|| hm_read_surf ../starter/source/groups/hm_read_surf.F
1216!||--- calls -----------------------------------------------------
1217!|| udoubl2_igr ../starter/source/system/sysfus.F
1218!||====================================================================
1219 SUBROUTINE udouble_igr(LIST,NLIST,MESS,IR,RLIST)
1220C TEST LES N0 DOUBLES
1221C-----------------------------------------------
1222C I m p l i c i t T y p e s
1223C-----------------------------------------------
1224#include "implicit_f.inc"
1225C-----------------------------------------------
1226C D u m m y A r g u m e n t s
1227C-----------------------------------------------
1228C remonte la declaration des entiers pour la compile sur Compaq
1229 INTEGER NLIST,LIST(NLIST),IR
1230 my_real
1231 . rlist(nlist)
1232 CHARACTER MESS*40
1233C-----------------------------------------------
1234C C o m m o n B l o c k s
1235C-----------------------------------------------
1236C ALLOC FREE
1237C-----------------------------------------------
1238#if CPP_comp == f90
1239 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
1240#else
1241 pointer(iindex,index(1))
1242 INTEGER INDEX
1243#endif
1244C-----------------------------------------------
1245C L o c a l V a r i a b l e s
1246C-----------------------------------------------
1247 INTEGER I
1248 IF (nlist>=2)THEN
1249#if CPP_comp == f90
1250 ALLOCATE(index(3*nlist))
1251#else
1252 CALL my_alloc(iindex,3*nlist,0)
1253#endif
1254 CALL udoubl2_igr(index,nlist,mess,list,ir,rlist)
1255#if CPP_comp == f90
1256 DEALLOCATE(index)
1257#else
1258 CALL my_free(iindex)
1259#endif
1260 ENDIF
1261C
1262 RETURN
1263 END
1264!||====================================================================
1265!|| udouble_set ../starter/source/system/sysfus.F
1266!||--- calls -----------------------------------------------------
1267!|| udoubl2_set ../starter/source/system/sysfus.F
1268!||====================================================================
1269 SUBROUTINE udouble_set(LIST,NLIST,MESS,IR,RLIST)
1270C TEST LES N0 DOUBLES
1271C-----------------------------------------------
1272C I m p l i c i t T y p e s
1273C-----------------------------------------------
1274#include "implicit_f.inc"
1275C-----------------------------------------------
1276C D u m m y A r g u m e n t s
1277C-----------------------------------------------
1278C remonte la declaration des entiers pour la compile sur Compaq
1279 INTEGER NLIST,LIST(NLIST),IR
1280 my_real
1281 . rlist(nlist)
1282 CHARACTER MESS*40
1283C-----------------------------------------------
1284C C o m m o n B l o c k s
1285C-----------------------------------------------
1286C ALLOC FREE
1287C-----------------------------------------------
1288#if CPP_comp == f90
1289 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
1290#else
1291 pointer(iindex,index(1))
1292 INTEGER INDEX
1293#endif
1294C-----------------------------------------------
1295C L o c a l V a r i a b l e s
1296C-----------------------------------------------
1297 INTEGER I
1298 IF (nlist>=2)THEN
1299#if CPP_comp == f90
1300 ALLOCATE(index(3*nlist))
1301#else
1302 CALL my_alloc(iindex,3*nlist,0)
1303#endif
1304 CALL udoubl2_set(index,nlist,mess,list,ir,rlist)
1305#if CPP_comp == f90
1306 DEALLOCATE(index)
1307#else
1308 CALL my_free(iindex)
1309#endif
1310 ENDIF
1311C
1312 RETURN
1313 END
1314!||====================================================================
1315!|| udoubl2_igr ../starter/source/system/sysfus.F
1316!||--- called by ------------------------------------------------------
1317!|| udouble_igr ../starter/source/system/sysfus.F
1318!||--- calls -----------------------------------------------------
1319!|| ancmsg ../starter/source/output/message/message.F
1320!||--- uses -----------------------------------------------------
1321!|| message_mod ../starter/share/message_module/message_mod.F
1322!||====================================================================
1323 SUBROUTINE udoubl2_igr(INDEX,NLIST,MESS,LIST,IR,RLIST)
1324 USE message_mod
1325C TEST LES N0 DOUBLES
1326C-----------------------------------------------
1327C I m p l i c i t T y p e s
1328C-----------------------------------------------
1329#include "implicit_f.inc"
1330C-----------------------------------------------
1331C D u m m y A r g u m e n t s
1332C-----------------------------------------------
1333 INTEGER NLIST,IR
1334 CHARACTER MESS*40
1335 INTEGER INDEX(NLIST,3),LIST(NLIST)
1336 my_real
1337 . rlist(nlist)
1338C-----------------------------------------------
1339C L o c a l V a r i a b l e s
1340C-----------------------------------------------
1341 INTEGER I, J,NNOD,NOLD,K,ID,IDM,
1342 . iwork(70000)
1343C-----------------------
1344C TRI DE LIST EN ORDRE CROISSANT
1345C-----------------------
1346 IF(ir==1)THEN
1347 DO i=1,nlist
1348 index(i,3)=nint(rlist(i))
1349 ENDDO
1350 ELSE
1351 DO i=1,nlist
1352 index(i,3)=list(i)
1353 ENDDO
1354 ENDIF
1355C
1356 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
1357 id=index(index(1,1),3)
1358 DO i=2,nlist
1359 idm=id
1360 id=index(index(i,1),3)
1361 IF(id==idm .AND. id/=0)THEN
1362 CALL ancmsg(msgid=79,
1363 . msgtype=msgerror,
1364 . anmode=aninfo,
1365 . c1=mess,
1366 . i1=id)
1367 ENDIF
1368 ENDDO
1369C-----------------------
1370 RETURN
1371 END
1372!||====================================================================
1373!|| udoubl2_set ../starter/source/system/sysfus.F
1374!||--- called by ------------------------------------------------------
1375!|| udouble_set ../starter/source/system/sysfus.F
1376!||--- calls -----------------------------------------------------
1377!|| ancmsg ../starter/source/output/message/message.F
1378!||--- uses -----------------------------------------------------
1379!|| message_mod ../starter/share/message_module/message_mod.F
1380!||====================================================================
1381 SUBROUTINE udoubl2_set(INDEX,NLIST,MESS,LIST,IR,RLIST)
1382 USE message_mod
1383C TEST LES N0 DOUBLES
1384C-----------------------------------------------
1385C I m p l i c i t T y p e s
1386C-----------------------------------------------
1387#include "implicit_f.inc"
1388C-----------------------------------------------
1389C D u m m y A r g u m e n t s
1390C-----------------------------------------------
1391 INTEGER NLIST,IR
1392 CHARACTER MESS*40
1393 INTEGER INDEX(NLIST,3),LIST(NLIST)
1394 my_real
1395 . rlist(nlist)
1396C-----------------------------------------------
1397C L o c a l V a r i a b l e s
1398C-----------------------------------------------
1399 INTEGER I, J,NNOD,NOLD,K,ID,IDM,
1400 . iwork(70000)
1401C-----------------------
1402C TRI DE LIST EN ORDRE CROISSANT
1403C-----------------------
1404 IF(ir==1)THEN
1405 DO i=1,nlist
1406 index(i,3)=nint(rlist(i))
1407 ENDDO
1408 ELSE
1409 DO i=1,nlist
1410 index(i,3)=list(i)
1411 ENDDO
1412 ENDIF
1413C
1414 CALL my_orders(0,iwork,index(1,3),index,nlist,1)
1415 id=index(index(1,1),3)
1416 DO i=2,nlist
1417 idm=id
1418 id=index(index(i,1),3)
1419 IF(id==idm)THEN
1420 CALL ancmsg(msgid=1814,
1421 . msgtype=msgerror,
1422 . anmode=aninfo,
1423 . c1=mess,
1424 . i1=id)
1425 ENDIF
1426 ENDDO
1427C-----------------------
1428 RETURN
1429 END
c_hash_find
void c_hash_find(int *map, int *key, int *val)
Definition c_hash_table.cpp:129
my_real
#define my_real
Definition cppsort.cpp:32
hm_read_eig
subroutine hm_read_eig(eigipm, eigibuf, eigrpm, igrnod, itabm1, unitab, lsubmodel)
Definition hm_read_eig.F:156
hm_read_frm
subroutine hm_read_frm(iskn, x, itab, itabm1, xframe, lsubmodel, rtrans, nom_opt, unitab)
Definition hm_read_frm.F:50
hm_read_fxb1
subroutine hm_read_fxb1(nom_opt, fxbnod, fxbipm, fxb_matrix, fxb_matrix_add, nmanim, itab, itabm1, fxbfile_tab, lsubmodel)
Definition hm_read_fxb.F:47
hm_read_impvel
subroutine hm_read_impvel(fbfvel, ibfvel, ikine, ikine1lag, itab, itabm1, igrnod, x0, ixr, ipart, ipartr, iskn, nom_opt, nimpdisp, nimpvel, unitab, lsubmodel)
Definition hm_read_impvel.F:45
hm_read_inicrack
subroutine hm_read_inicrack(itabm1, inicrack, unitab, lsubmodel)
Definition hm_read_inicrack.F:41
hm_read_initemp
subroutine hm_read_initemp(temp, nintemp, itherm_fe, itab, itabm1, igrnod, initids, unitab, lsubmodel)
Definition hm_read_initemp.F:45
hm_read_inivel
subroutine hm_read_inivel(v, w, itab, itabm1, vr, igrnod, igrbric, iskn, skew, inivids, x, unitab, lsubmodel, rtrans, xframe, iframe, vflow, wflow, kxsp, multi_fvm, fvm_inivel, igrquad, igrsh3n, rby_msn, rby_iniaxis, sensors, ninivelt, inivel_t)
Definition hm_read_inivel.F:53
hm_read_lines
subroutine hm_read_lines(itab, itabm1, isubmod, igrslin, igrsurf, x, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ipart, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, iparttg, nsegs, flag, skew, iskn, unitab, ibox, rtrans, lsubmodel, ipartx, kxx, ixx, iadboxmax, subset, igrtruss, igrbeam, igrspring, nsets, map_tables)
Definition hm_read_lines.F:63
hm_read_nbcs
subroutine hm_read_nbcs(icode, iskew, itab, itabm1, ikine, igrnod, ibcslag, lag_ncf, lag_nkf, lag_nhf, ikine1lag, iskn, nom_opt, lsubmodel)
Definition hm_read_nbcs.F:45
hm_read_rbody
subroutine hm_read_rbody(rby, npby, lpby, itab, itabm1, igrnod, igrsurf, ibfv, igrv, ibgr, sensors, imerge, unitab, iskn, nom_opt, numsl, knod2els, knod2elc, knod2eltg, knod2el1d, knod2elq, itagnd, icdns10, lsubmodel, icfield, lcfield)
Definition hm_read_rbody.F:56
hm_read_retractor
subroutine hm_read_retractor(lsubmodel, itabm1, ixr, itab, unitab, x, func_id, nom_opt, alea, ipm)
Definition hm_read_retractor.F:47
lecsec42
subroutine lecsec42(ixs, ixq, ixc, ixt, ixp, ixr, ixtg, x0, itab, itabm1, igrnod, secbuf, ipari, ixs10, ixs20, ixs16, unitab, iskn, xframe, isolnod, nom_sect, rtrans, lsubmodel, nom_opt, igrbric, igrquad, igrsh4n, igrtruss, igrbeam, igrspring, igrsh3n, seatbelt_shell_to_spring, nb_seatbelt_shells)
Definition hm_read_sect.F:67
hm_read_shell
subroutine hm_read_shell(ixc, itab, itabm1, ipart, ipartc, thk, ipm, igeo, unitab, itag, angle, lsubmodel)
Definition hm_read_shell.F:42
hm_read_surf
subroutine hm_read_surf(itab, itabm1, igrsurf, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ipart, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, iparttg, x, mfi, iskn, skew, bufsf, knod2els, nod2els, sh4tree, sh3tree, isubmod, flag, unitab, ibox, ixs10, ixs16, ixs20, rtrans, lsubmodel, knod2elc, nod2elc, knod2eltg, nod2eltg, kxig3d, ixig3d, ipartig3d, knot, igeo, wige, knod2elig3d, nod2elig3d, v, nige, rige, xige, vige, iadtabige, decaligeo, iadboxmax, knod2elq, nod2elq, subset, igrbric, igrsh4n, igrsh3n, knotlocpc, knotlocel, nsets, map_tables)
Definition hm_read_surf.F:76
hm_read_thgrsurf
subroutine hm_read_thgrsurf(ityp, key, iad, ifi, ithgrp, ithbuf, nv, vare, num, varg, nvg, ivarg, nsne, nv0, ithvar, flagabf, nvarabf, igrsurf, igs, lsubmodel)
Definition hm_read_thgrsurf.F:52
inivel
subroutine inivel(v, vr, svr, itabm1)
Definition inivel.F:35
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
r2r_sys
integer function r2r_sys(iu, itabm1, mess)
Definition routines_r2r.F:67
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
usrtos
integer function usrtos(iu, itabm1)
Definition sysfus.F:255
newdbl2
subroutine newdbl2(index, nlist, list, ilist, tab, errid, status, nom_opt)
Definition sysfus.F:811
ulist2s
integer function ulist2s(list, nlist, itabm1, mess, index, id)
Definition sysfus.F:465
usr2sys2
integer function usr2sys2(iu, itabm1, mess, jindex, id)
Definition sysfus.F:374
newdbl
subroutine newdbl(list, ilist, nlist, tab, errid, status, nom_opt)
Definition sysfus.F:758
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
udouble_set
subroutine udouble_set(list, nlist, mess, ir, rlist)
Definition sysfus.F:1270
itabm1_search
integer function itabm1_search(iu, itabm1)
Definition sysfus.F:310
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589
vdouble
subroutine vdouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:884
udouble3
subroutine udouble3(list, ilist, nlist, mess, mess2, ir, rlist)
Definition sysfus.F:1100
udoublex
subroutine udoublex(nlist, ilist, ixx, kxx)
Definition sysfus.F:639
udoubl3
subroutine udoubl3(index, nlist, mess, mess2, list, ilist, ir, rlist)
Definition sysfus.F:1154
udouble_wo_title
subroutine udouble_wo_title(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:989
udouble_igr
subroutine udouble_igr(list, nlist, mess, ir, rlist)
Definition sysfus.F:1220
udoubl2_igr
subroutine udoubl2_igr(index, nlist, mess, list, ir, rlist)
Definition sysfus.F:1324
udoubl2
subroutine udoubl2(index, nlist, mess, list, ilist, ir, rlist)
Definition sysfus.F:700
udoubl2_set
subroutine udoubl2_set(index, nlist, mess, list, ir, rlist)
Definition sysfus.F:1382
vdoubl2
subroutine vdoubl2(index, nlist, mess, list, ilist, ir, rlist)
Definition sysfus.F:933
udoubl2_wo_title
subroutine udoubl2_wo_title(index, nlist, mess, list, ilist, ir, rlist)
Definition sysfus.F:1043
starter
program starter
Definition starter.F:39