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