OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fr_rlink1.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!|| fr_rlink1 ../engine/source/mpi/kinematic_conditions/fr_rlink1.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../engine/source/input/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| spmd_glob_isum9 ../engine/source/mpi/interfaces/spmd_th.F
30!|| spmd_ibcast ../engine/source/mpi/generic/spmd_ibcast.F
31!|| sysfus2 ../engine/source/system/sysfus.F
32!||--- uses -----------------------------------------------------
33!|| message_mod ../engine/share/message_module/message_mod.F
34!||====================================================================
35 SUBROUTINE fr_rlink1(NOD,ITABM1,FR_RL,NSN)
36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE message_mod
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com01_c.inc"
48#include "com04_c.inc"
49#include "warn_c.inc"
50#include "task_c.inc"
51C-----------------------------------------------
52C D u m m y A r g u m e n t s
53C-----------------------------------------------
54 INTEGER NSN, NOD(*),ITABM1(*), FR_RL(*)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER I, NSN_L, P, PMAIN, IMAX,
59 . NODTMP(NSN),NODU(NSN)
60C-----------------------------------------------
61C E x t e r n a l F u n c t i o n s
62C-----------------------------------------------
63 INTEGER SYSFUS2
64C-----------------------------------------------
65C S o u r c e L i n e s
66C-----------------------------------------------
67C
68C Search for internal node number
69C
70 DO i=1,nsn
71 nodu(i) = nod(i)
72C Sysfus2 returns 0 if node not found
73 nodtmp(i) = sysfus2(nod(i),itabm1,numnod)
74 END DO
75C Department number of local nodes (ie number of nodes n <> 0
76 nsn_l=0
77 DO i=1,nsn
78 IF(nodtmp(i)/=0) THEN
79 nsn_l = nsn_l+1
80 nod(nsn_l) = nodtmp(i)
81 END IF
82 END DO
83 fr_rl(ispmd+1)=nsn_l
84C save total number of nodes
85 fr_rl(nspmd+1)=nsn
86C Verification of ID User with Global Comm
87 IF(nspmd > 1) CALL spmd_glob_isum9(nodtmp,nsn)
88 IF(ispmd==0) THEN
89 DO i = 1, nsn
90 IF(nodtmp(i)==0) THEN
91 CALL ancmsg(msgid=186,anmode=aninfo_blind,
92 . i1=nodu(i),c1='RIGID LINK')
93 ierr=ierr+1
94 END IF
95 END DO
96 ENDIF
97C Assignment of the number of local node
98 nsn = nsn_l
99C EXCHANGE VALUE FR_RL
100 IF(nspmd > 1) THEN
101 DO p = 1, nspmd
102 CALL spmd_ibcast(fr_rl(p),fr_rl(p),1,1,it_spmd(p),0)
103 ENDDO
104 END IF
105C Dettermination of the pmain
106 imax = 0
107 pmain = 1
108 DO p = 1, nspmd
109 IF(fr_rl(p)>imax)THEN
110 pmain = p
111 imax = fr_rl(p)
112 END IF
113 END DO
114 fr_rl(nspmd+2) = pmain
115C
116 RETURN
117 END
118C
119!||====================================================================
120!|| fr_rlale ../engine/source/mpi/kinematic_conditions/fr_rlink1.F
121!||--- called by ------------------------------------------------------
122!|| lectur ../engine/source/input/lectur.F
123!||--- calls -----------------------------------------------------
124!|| ancmsg ../engine/source/output/message/message.F
125!|| spmd_glob_isum9 ../engine/source/mpi/interfaces/spmd_th.f
126!|| sysfus2 ../engine/source/system/sysfus.F
127!||--- uses -----------------------------------------------------
128!|| message_mod ../engine/share/message_module/message_mod.F
129!||====================================================================
130 SUBROUTINE fr_rlale(M1,M2,NOD,ITABM1,ITAG)
131C-----------------------------------------------
132C M o d u l e s
133C-----------------------------------------------
134 USE message_mod
135C-----------------------------------------------
136C I m p l i c i t T y p e s
137C-----------------------------------------------
138#include "implicit_f.inc"
139C-----------------------------------------------
140C C o m m o n B l o c k s
141C-----------------------------------------------
142#include "com01_c.inc"
143#include "com04_c.inc"
144#include "warn_c.inc"
145#include "task_c.inc"
146C-----------------------------------------------
147C D u m m y A r g u m e n t s
148C-----------------------------------------------
149 INTEGER M1, M2, NOD(*),ITABM1(*),ITAG
150C-----------------------------------------------
151C L o c a l V a r i a b l e s
152C-----------------------------------------------
153 INTEGER I,NSN,
154 . NODTMP(ABS(ITAG)+2),NODU(ABS(ITAG)+2)
155C-----------------------------------------------
156C E x t e r n a l F u n c t i o n s
157C-----------------------------------------------
158 INTEGER SYSFUS2
159C-----------------------------------------------
160C D e s c r i p t i o n
161C-----------------------------------------------
162C NOD(1:NSN) is the array containing user ids from
163C /VEL/ALE card (ale links) if the node is present on
164C local domain then it is replaced by its internal id
165C otherwise its sign is changed.
166C / internal_id, if present in local domain
167C OUTPUT: NOD(id) = -
168C \ -user id, otherwise
169C-----------------------------------------------
170C S o u r c e L i n e s
171C-----------------------------------------------
172C
173C Search for internal node numbers
174C
175 IF(itag>0)THEN !ALE LINK DEFINED BY A NODE LIST
176 nsn=itag
177 nodu(nsn+1)=m1
178 nodu(nsn+2)=m2
179 nodtmp(nsn+1) = sysfus2(m1,itabm1,numnod)
180 nodtmp(nsn+2) = sysfus2(m2,itabm1,numnod)
181 DO i=1,nsn
182 nodu(i) = nod(i)
183 ! SYSFUS2 returns 0 if node not found, local id otherwise
184 nodtmp(i) = sysfus2(nod(i),itabm1,numnod)
185 END DO
186 !Department number of local nodes (ie number of nodes n <> 0)
187 DO i=1,nsn
188 IF(nodtmp(i)/=0) THEN
189 nod(i) = nodtmp(i)
190 ELSE
191 nod(i) = -nodu(i)
192 END IF
193 END DO
194 ! If nodes not present then tag en - for m1 and m2
195 IF(nodtmp(nsn+1)==0)THEN
196 m1=-m1
197 ELSE
198 m1=nodtmp(nsn+1)
199 END IF
200 IF(nodtmp(nsn+2)==0)THEN
201 m2=-m2
202 ELSE
203 m2=nodtmp(nsn+2)
204 END IF
205 ! Verification of ID User with Global Comm
206 IF(nspmd > 1) CALL spmd_glob_isum9(nodtmp,nsn+2)
207 IF(ispmd==0) THEN
208 !stop if main nodes not found
209 DO i = nsn+1, nsn+2
210 IF(nodtmp(i)==0) THEN
211 CALL ancmsg(msgid=186,anmode=aninfo_blind,
212 . i1=nodu(i),c1='ALE LINK')
213 ierr=ierr+1
214 RETURN
215 END IF
216 END DO
217 !stop if a SECONDARY node is not found
218 DO i = 1, nsn
219 IF(nodtmp(i)==0) THEN
220 CALL ancmsg(msgid=186,anmode=aninfo_blind,
221 . i1=nodu(i),c1='ALE LINK')
222 ierr=ierr+1
223 RETURN
224 END IF
225 END DO
226 ENDIF
227
228 ELSE ! ALE LINK DEFINED FROM A GRNOD
229 nsn=0
230 nodu(nsn+1)=m1
231 nodu(nsn+2)=m2
232 nodtmp(nsn+1) = sysfus2(m1,itabm1,numnod)
233 nodtmp(nsn+2) = sysfus2(m2,itabm1,numnod)
234 ! If nodes not present then tag en - for m1 and m2
235 IF(nodtmp(nsn+1)==0)THEN
236 m1=-m1
237 ELSE
238 m1=nodtmp(nsn+1)
239 END IF
240 IF(nodtmp(nsn+2)==0)THEN
241 m2=-m2
242 ELSE
243 m2=nodtmp(nsn+2)
244 END IF
245 ! Verification of ID User with Global Comm
246 IF(nspmd > 1) CALL spmd_glob_isum9(nodtmp,nsn+2)
247 IF(ispmd==0) THEN
248 !stop if main nodes not found
249 DO i = nsn+1, nsn+2
250 IF(nodtmp(i)==0) THEN
251 CALL ancmsg(msgid=186,anmode=aninfo_blind,
252 . i1=nodu(i),c1='ALE LINK')
253 ierr=ierr+1
254 RETURN
255 END IF
256 END DO
257 ENDIF
258
259 !CHECK EXISTENS OF GRNOD_ID
260
261 ENDIF !(ITAG>0)
262
263 RETURN
264 END
265
fr_rlink1
subroutine fr_rlink1(nod, itabm1, fr_rl, nsn)
Definition fr_rlink1.F:36
fr_rlale
subroutine fr_rlale(m1, m2, nod, itabm1, itag)
Definition fr_rlink1.F:131
message_mod
Definition message_mod.F:1257
spmd_ibcast
subroutine spmd_ibcast(tabi, tabr, n1, n2, from, add)
Definition spmd_ibcast.F:57
spmd_glob_isum9
subroutine spmd_glob_isum9(v, len)
Definition spmd_th.F:520
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