OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
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!|| rlink1 ../engine/source/constraints/general/rlink/rlink1.F
25!||--- called by ------------------------------------------------------
26!|| rlink10 ../engine/source/constraints/general/rlink/rlink10.F
27!|| rlink11 ../engine/source/constraints/general/rlink/rlink10.F
28!||--- calls -----------------------------------------------------
29!|| sum_6_float ../engine/source/system/parit.F
30!||====================================================================
31 SUBROUTINE rlink1(MS,IN ,A ,AR ,NSN ,
32 . IC,ICR,NOD,WEIGHT,FRL6 ,
33 . IFLAG )
34C-----------------------------------------------
35C I m p l i c i t T y p e s
36C-----------------------------------------------
37#include "implicit_f.inc"
38C-----------------------------------------------
39C C o m m o n B l o c k s
40C-----------------------------------------------
41#include "com01_c.inc"
42C-----------------------------------------------
43C D u m m y A r g u m e n t s
44C-----------------------------------------------
45 INTEGER NSN, IC, ICR, IFLAG
46 INTEGER NOD(*),WEIGHT(*)
47C REAL
48 my_real
49 . ms(*), in(*), a(3,*), ar(3,*)
50 DOUBLE PRECISION FRL6(15,6)
51C-----------------------------------------------
52C L o c a l V a r i a b l e s
53C-----------------------------------------------
54 INTEGER I, N, K
55C REAL
56 my_real
57 . mass, iner, ax, ay, az,
58 . f1(nsn), f2(nsn), f3(nsn), f4(nsn)
59C-----------------------------------------------
60 IF(iflag == 1)THEN
61
62C Init Parith/ON
63 DO k = 1, 6
64 frl6(1,k) = zero
65 frl6(2,k) = zero
66 frl6(3,k) = zero
67 frl6(4,k) = zero
68 frl6(5,k) = zero
69 frl6(6,k) = zero
70 frl6(7,k) = zero
71 frl6(8,k) = zero
72 frl6(9,k) = zero
73 frl6(10,k) = zero
74 frl6(11,k) = zero
75 frl6(12,k) = zero
76 frl6(13,k) = zero
77 frl6(14,k) = zero
78 frl6(15,k) = zero
79 END DO
80
81 IF(ic==0)GOTO 150
82C
83 DO i=1,nsn
84 n = nod(i)
85 IF(weight(n)==1) THEN
86 f1(i)=ms(n)
87 f2(i)=ms(n)*a(1,n)
88 f3(i)=ms(n)*a(2,n)
89 f4(i)=ms(n)*a(3,n)
90 ELSE
91 f1(i)=zero
92 f2(i)=zero
93 f3(i)=zero
94 f4(i)=zero
95 ENDIF
96 ENDDO
97C
98C Traitement Parith/ON avant echange
99C
100 CALL sum_6_float(1 ,nsn ,f1, frl6(1,1), 15)
101 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1), 15)
102 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1), 15)
103 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1), 15)
104
105 150 IF(icr==0.OR.iroddl==0)RETURN
106C
107 DO i=1,nsn
108 n = nod(i)
109 IF(weight(n)==1) THEN
110 f1(i)=in(n)
111 f2(i)=in(n)*ar(1,n)
112 f3(i)=in(n)*ar(2,n)
113 f4(i)=in(n)*ar(3,n)
114 ELSE
115 f1(i)=zero
116 f2(i)=zero
117 f3(i)=zero
118 f4(i)=zero
119 ENDIF
120 ENDDO
121C
122C Traitement Parith/ON avant echange
123C
124 CALL sum_6_float(1 ,nsn ,f1, frl6(5,1), 15)
125 CALL sum_6_float(1 ,nsn ,f2, frl6(6,1), 15)
126 CALL sum_6_float(1 ,nsn ,f3, frl6(7,1), 15)
127 CALL sum_6_float(1 ,nsn ,f4, frl6(8,1), 15)
128
129C
130 ELSEIF(iflag == 2)THEN
131C
132 IF(ic==0)GOTO 250
133C
134 mass = frl6(1,1)+frl6(1,2)+frl6(1,3)+
135 + frl6(1,4)+frl6(1,5)+frl6(1,6)
136 ax = frl6(2,1)+frl6(2,2)+frl6(2,3)+
137 + frl6(2,4)+frl6(2,5)+frl6(2,6)
138 ay = frl6(3,1)+frl6(3,2)+frl6(3,3)+
139 + frl6(3,4)+frl6(3,5)+frl6(3,6)
140 az = frl6(4,1)+frl6(4,2)+frl6(4,3)+
141 + frl6(4,4)+frl6(4,5)+frl6(4,6)
142C
143 IF(mass==zero)GOTO 250
144 ax=ax/mass
145 ay=ay/mass
146 az=az/mass
147C
148 IF(ic==1.OR.ic==3.OR.ic==5.OR.ic==7)THEN
149 DO 110 i=1,nsn
150 n = nod(i)
151 a(3,n) =az
152 110 CONTINUE
153 ENDIF
154 IF(ic==2.OR.ic==3.OR.ic==6.OR.ic==7)THEN
155 DO 120 i=1,nsn
156 n = nod(i)
157 a(2,n) =ay
158 120 CONTINUE
159 ENDIF
160 IF(ic==4.OR.ic==5.OR.ic==6.OR.ic==7)THEN
161 DO 130 i=1,nsn
162 n = nod(i)
163 a(1,n) =ax
164 130 CONTINUE
165 ENDIF
166C
167 250 IF(icr==0.OR.iroddl==0)RETURN
168C
169 iner = frl6(5,1)+frl6(5,2)+frl6(5,3)+
170 + frl6(5,4)+frl6(5,5)+frl6(5,6)
171 ax = frl6(6,1)+frl6(6,2)+frl6(6,3)+
172 + frl6(6,4)+frl6(6,5)+frl6(6,6)
173 ay = frl6(7,1)+frl6(7,2)+frl6(7,3)+
174 + frl6(7,4)+frl6(7,5)+frl6(7,6)
175 az = frl6(8,1)+frl6(8,2)+frl6(8,3)+
176 + frl6(8,4)+frl6(8,5)+frl6(8,6)
177C
178 IF(iner==zero)RETURN
179C
180 ax=ax/iner
181 ay=ay/iner
182 az=az/iner
183C
184 IF(icr==1.OR.icr==3.OR.icr==5.OR.icr==7)THEN
185 DO 210 i=1,nsn
186 n = nod(i)
187 ar(3,n) =az
188 210 CONTINUE
189 ENDIF
190 IF(icr==2.OR.icr==3.OR.icr==6.OR.icr==7)THEN
191 DO 220 i=1,nsn
192 n = nod(i)
193 ar(2,n) =ay
194 220 CONTINUE
195 ENDIF
196 IF(icr==4.OR.icr==5.OR.icr==6.OR.icr==7)THEN
197 DO 230 i=1,nsn
198 n = nod(i)
199 ar(1,n) =ax
200 230 CONTINUE
201 ENDIF
202 END IF
203C
204 RETURN
205 END
my_real
#define my_real
Definition cppsort.cpp:32
sum_6_float
subroutine sum_6_float(jft, jlt, f, f6, n)
Definition parit.F:64
rlink1
subroutine rlink1(ms, in, a, ar, nsn, ic, icr, nod, weight, frl6, iflag)
Definition rlink1.F:34