OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
valpr.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/.
23C
24!||====================================================================
25!|| valpr ../engine/source/constraints/general/rbody/valpr.F
26!||--- called by ------------------------------------------------------
27!|| inepri ../engine/source/constraints/general/rbody/inepri.F
28!||====================================================================
29 SUBROUTINE valpr (A,R,N,MV)
30C-----------------------------------------------
31C I m p l i c i t T y p e s
32C-----------------------------------------------
33#include "implicit_f.inc"
34C-----------------------------------------------
35C D u m m y A r g u m e n t s
36C-----------------------------------------------
37 INTEGER N, MV
38 my_real a(*), r(*)
39C-----------------------------------------------
40C L o c a l V a r i a b l e s
41C-----------------------------------------------
42 INTEGER IQ, J, I, IJ, IA, IND, L, M, MQ, LQ, LM, LL, MM, ILQ, IMQ, IM, IL, ILR, IMR, JQ, K
43 my_real range, anorm, anrmx, thr, x, y, sinx, sinx2, cosx, cosx2, sincs
44C-----------------------------------------------
45C S o u r c e L i n e s
46C-----------------------------------------------
47 range = 1.0e-7
48
49 IF (mv-1 /= 0)THEN
50 iq = -n
51 DO j = 1,n
52 iq = iq+n
53 DO i = 1,n
54 ij = iq+i
55 r(ij) = zero
56 IF (i-j /= 0)cycle
57 r(ij) = one
58 ENDDO
59 ENDDO
60 ENDIF
61 anorm = zero
62
63 DO i = 1,n
64 DO j = 1,n
65 IF (i-j == 0)cycle
66 ia = i+(j*j-j)/2
67 anorm = anorm+a(ia)*a(ia)
68 ENDDO
69 ENDDO
70
71 IF (anorm > zero)THEN
72
73 anorm = 1.414*sqrt(anorm)
74 anrmx = anorm*range/float(n)
75 ind = 0
76 thr = anorm
77
78 thr = thr/float(n)
79 l = 1
80 m = l+1
81 mq = (m*m-m)/2
82
83 DO
84 lq = (l*l-l)/2
85 lm = l+mq
86 IF (abs(a(lm))-thr >= zero)THEN
87 ind = 1
88 ll = l+lq
89 mm = m+mq
90 x = half*(a(ll)-a(mm))
91 y = -a(lm)/sqrt(a(lm)*a(lm)+x*x)
92 IF (x < zero) THEN
93 y = -y
94 ELSEIF(x == zero)THEN
95 y = -one
96 ENDIF
97 sinx = y/sqrt(two*(one+(sqrt(one-y*y))))
98 sinx2 = sinx*sinx
99 cosx = sqrt(one - sinx2)
100 cosx2 = cosx*cosx
101 sincs = sinx*cosx
102 ilq = n*(l-1)
103 imq = n*(m-1)
104 DO i = 1,n
105 iq = (i*i-i)/2
106 IF(i-l /= 0) THEN
107 IF(i-m < 0)THEN
108 im = i+mq
109 ELSEIF(i-m > 0)THEN
110 im = m+iq
111 ENDIF
112 IF(i-m /= 0)THEN
113 IF(i-l < 0)THEN
114 il = i+lq
115 ELSE
116 il = l+iq
117 ENDIF
118 x = a(il)*cosx-a(im)*sinx
119 a(im) = a(il)*sinx+a(im)*cosx
120 a(il) = x
121 ENDIF
122 ENDIF
123 IF (mv-1 /= 0)THEN
124 ilr = ilq+i
125 imr = imq+i
126 x = r(ilr)*cosx-r(imr)*sinx
127 r(imr) = r(ilr)*sinx+r(imr)*cosx
128 r(ilr) = x
129 ENDIF
130 ENDDO
131 x = two*a(lm)*sincs
132 y = a(ll)*cosx2+a(mm)*sinx2-x
133 x = a(ll)*sinx2+a(mm)*cosx2+x
134 a(lm) = (a(ll)-a(mm))*sincs+a(lm)*(cosx2-sinx2)
135 a(ll) = y
136 a(mm) = x
137 ENDIF
138 IF(m-n /= 0)THEN
139 m = m+1
140 mq = (m*m-m)/2
141 cycle
142 ELSE
143 IF (l-(n-1) /= 0)THEN
144 l = l+1
145 m = l+1
146 mq = (m*m-m)/2
147 cycle
148 ELSE
149 IF (ind-1 == 0)THEN
150 ind = 0
151 l = 1
152 m = l+1
153 mq = (m*m-m)/2
154 cycle
155 ELSE
156 IF (thr-anrmx > 0) THEN
157 thr = thr/float(n)
158 l = 1
159 m = l+1
160 mq = (m*m-m)/2
161 cycle
162 ELSE
163 EXIT
164 ENDIF
165 ENDIF
166 ENDIF
167 ENDIF
168 END DO ! WHILE
169 ENDIF !(ANORM > ZERO)
170
171 iq = -n
172C
173 DO i = 1,n
174 iq = iq+n
175 ll = i+(i*i-i)/2
176 jq = n*(i-2)
177 DO j = i,n
178 jq = jq+n
179 mm = j+(j*j-j)/2
180 IF (a(ll) >= a(mm)) cycle
181 x = a(ll)
182 a(ll) = a(mm)
183 a(mm) = x
184 IF (mv == 1) cycle
185 DO k = 1,n
186 ilr = iq+k
187 imr = jq+k
188 x = r(ilr)
189 r(ilr) = r(imr)
190 r(imr) = x
191 ENDDO
192 ENDDO
193 ENDDO
194
195 anorm=sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3))
196 r(1)=r(1)/anorm
197 r(2)=r(2)/anorm
198 r(3)=r(3)/anorm
199 anorm=sqrt(r(4)*r(4)+r(5)*r(5)+r(6)*r(6))
200 r(4)=r(4)/anorm
201 r(5)=r(5)/anorm
202 r(6)=r(6)/anorm
203 r(7)=r(2)*r(6)-r(3)*r(5)
204 r(8)=r(3)*r(4)-r(1)*r(6)
205 r(9)=r(1)*r(5)-r(2)*r(4)
206 anorm=sqrt(r(7)*r(7)+r(8)*r(8)+r(9)*r(9))
207 r(7)=r(7)/anorm
208 r(8)=r(8)/anorm
209 r(9)=r(9)/anorm
210
211 RETURN
212 END
my_real
#define my_real
Definition cppsort.cpp:32
valpr
subroutine valpr(a, r, n, mv)
Definition valpr.F:30