OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
bcs2.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "vectorize.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine bcs2 (a, b, j, k)
subroutine bcs2v (nindx, indx, iskew, icodt, a, b)

Function/Subroutine Documentation

◆ bcs2()

subroutine bcs2 ( dimension(3), intent(inout) a,
dimension(lskew), intent(inout) b,
integer, intent(inout) j,
integer, intent(inout) k )

Definition at line 31 of file bcs2.F.

32C-----------------------------------------------
33C I m p l i c i t T y p e s
34C-----------------------------------------------
35#include "implicit_f.inc"
36#include "param_c.inc"
37C-----------------------------------------------
38C D u m m y A r g u m e n t s
39C-----------------------------------------------
40 INTEGER,INTENT(INOUT) :: J, K
41 my_real,INTENT(INOUT) :: a(3), b(lskew)
42C-----------------------------------------------
43C L o c a l V a r i a b l e s
44C-----------------------------------------------
45 my_real :: aa
46C-----------------------------------------------
47C P r e - C o n i d i t i o n s
48C-----------------------------------------------
49 IF(k==0) RETURN
50C-----------------------------------------------
51C S o u r c e L i n e s
52C-----------------------------------------------
53 IF(j==1) THEN
54 !=====REPERE GLOBAL
55 SELECT CASE (k)
56 CASE(1)
57 a(3)=zero
58 CASE(2)
59 a(2)=zero
60 CASE(3)
61 a(2)=zero
62 a(3)=zero
63 CASE(4)
64 a(1)=zero
65 CASE(5)
66 a(1)=zero
67 a(3)=zero
68 CASE(6)
69 a(1)=zero
70 a(2)=zero
71 CASE(7)
72 a(1)=zero
73 a(2)=zero
74 a(3)=zero
75 CASE DEFAULT !same as CASE(1)
76 a(3)=zero
77 END SELECT
78 ELSE
79 !=====REPERE OBLIQUE
80 SELECT CASE (k)
81 CASE(1)
82 aa =b(7)*a(1)+b(8)*a(2)+b(9)*a(3)
83 a(1)=a(1)-b(7)*aa
84 a(2)=a(2)-b(8)*aa
85 a(3)=a(3)-b(9)*aa
86 CASE(2)
87 aa =b(4)*a(1)+b(5)*a(2)+b(6)*a(3)
88 a(1)=a(1)-b(4)*aa
89 a(2)=a(2)-b(5)*aa
90 a(3)=a(3)-b(6)*aa
91 CASE(3)
92 aa =b(7)*a(1)+b(8)*a(2)+b(9)*a(3)
93 a(1)=a(1)-b(7)*aa
94 a(2)=a(2)-b(8)*aa
95 a(3)=a(3)-b(9)*aa
96 aa =b(4)*a(1)+b(5)*a(2)+b(6)*a(3)
97 a(1)=a(1)-b(4)*aa
98 a(2)=a(2)-b(5)*aa
99 a(3)=a(3)-b(6)*aa
100 CASE(4)
101 aa =b(1)*a(1)+b(2)*a(2)+b(3)*a(3)
102 a(1)=a(1)-b(1)*aa
103 a(2)=a(2)-b(2)*aa
104 a(3)=a(3)-b(3)*aa
105 CASE(5)
106 aa =b(7)*a(1)+b(8)*a(2)+b(9)*a(3)
107 a(1)=a(1)-b(7)*aa
108 a(2)=a(2)-b(8)*aa
109 a(3)=a(3)-b(9)*aa
110 aa =b(1)*a(1)+b(2)*a(2)+b(3)*a(3)
111 a(1)=a(1)-b(1)*aa
112 a(2)=a(2)-b(2)*aa
113 a(3)=a(3)-b(3)*aa
114 CASE(6)
115 aa =b(1)*a(1)+b(2)*a(2)+b(3)*a(3)
116 a(1)=a(1)-b(1)*aa
117 a(2)=a(2)-b(2)*aa
118 a(3)=a(3)-b(3)*aa
119 aa =b(4)*a(1)+b(5)*a(2)+b(6)*a(3)
120 a(1)=a(1)-b(4)*aa
121 a(2)=a(2)-b(5)*aa
122 a(3)=a(3)-b(6)*aa
123 CASE(7)
124 a(1)=zero
125 a(2)=zero
126 a(3)=zero
127 CASE DEFAULT !same as CASE(1)
128 aa =b(7)*a(1)+b(8)*a(2)+b(9)*a(3)
129 a(1)=a(1)-b(7)*aa
130 a(2)=a(2)-b(8)*aa
131 a(3)=a(3)-b(9)*aa
132 END SELECT
133 END IF
134C-----------------------------------------------
135 RETURN
my_real
#define my_real
Definition cppsort.cpp:32

◆ bcs2v()

subroutine bcs2v ( integer, intent(inout) nindx,
integer, dimension(*), intent(inout) indx,
integer, dimension(*), intent(inout) iskew,
integer, dimension(*), intent(inout) icodt,
dimension(3,*), intent(inout) a,
dimension(lskew,*), intent(inout) b )

Definition at line 145 of file bcs2.F.

146C-----------------------------------------------
147C I m p l i c i t T y p e s
148C-----------------------------------------------
149#include "implicit_f.inc"
150#include "param_c.inc"
151C-----------------------------------------------
152C D u m m y A r g u m e n t s
153C-----------------------------------------------
154 INTEGER,INTENT(INOUT) :: NINDX, INDX(*),ISKEW(*),ICODT(*)
155 my_real, INTENT(INOUT) :: a(3,*), b(lskew,*)
156C-----------------------------------------------
157C L o c a l V a r i a b l e s
158C-----------------------------------------------
159 INTEGER :: K, N, ISK, LCOD
160 my_real :: aa
161C-----------------------------------------------
162C S o u r c e L i n e s
163C-----------------------------------------------
164#include "vectorize.inc"
165 DO k = 1, nindx
166 n = indx(k)
167 isk = iskew(n)
168 lcod = icodt(n)
169 IF(isk==1) THEN
170 !=====REPERE GLOBAL
171 SELECT CASE (lcod)
172 CASE(1)
173 a(3,n)=zero
174 CASE(2)
175 a(2,n)=zero
176 CASE(3)
177 a(2,n)=zero
178 a(3,n)=zero
179 CASE(4)
180 a(1,n)=zero
181 CASE(5)
182 a(1,n)=zero
183 a(3,n)=zero
184 CASE(6)
185 a(1,n)=zero
186 a(2,n)=zero
187 CASE(7)
188 a(1,n)=zero
189 a(2,n)=zero
190 a(3,n)=zero
191 END SELECT
192 ELSE
193 !=====REPERE OBLIQUE
194 SELECT CASE (lcod)
195 CASE(1)
196 aa =b(7,isk)*a(1,n)+b(8,isk)*a(2,n)+b(9,isk)*a(3,n)
197 a(1,n)=a(1,n)-b(7,isk)*aa
198 a(2,n)=a(2,n)-b(8,isk)*aa
199 a(3,n)=a(3,n)-b(9,isk)*aa
200 CASE(2)
201 aa =b(4,isk)*a(1,n)+b(5,isk)*a(2,n)+b(6,isk)*a(3,n)
202 a(1,n)=a(1,n)-b(4,isk)*aa
203 a(2,n)=a(2,n)-b(5,isk)*aa
204 a(3,n)=a(3,n)-b(6,isk)*aa
205 CASE(3)
206 aa =b(7,isk)*a(1,n)+b(8,isk)*a(2,n)+b(9,isk)*a(3,n)
207 a(1,n)=a(1,n)-b(7,isk)*aa
208 a(2,n)=a(2,n)-b(8,isk)*aa
209 a(3,n)=a(3,n)-b(9,isk)*aa
210 aa =b(4,isk)*a(1,n)+b(5,isk)*a(2,n)+b(6,isk)*a(3,n)
211 a(1,n)=a(1,n)-b(4,isk)*aa
212 a(2,n)=a(2,n)-b(5,isk)*aa
213 a(3,n)=a(3,n)-b(6,isk)*aa
214 CASE(4)
215 aa =b(1,isk)*a(1,n)+b(2,isk)*a(2,n)+b(3,isk)*a(3,n)
216 a(1,n)=a(1,n)-b(1,isk)*aa
217 a(2,n)=a(2,n)-b(2,isk)*aa
218 a(3,n)=a(3,n)-b(3,isk)*aa
219 CASE(5)
220 aa =b(7,isk)*a(1,n)+b(8,isk)*a(2,n)+b(9,isk)*a(3,n)
221 a(1,n)=a(1,n)-b(7,isk)*aa
222 a(2,n)=a(2,n)-b(8,isk)*aa
223 a(3,n)=a(3,n)-b(9,isk)*aa
224 aa =b(1,isk)*a(1,n)+b(2,isk)*a(2,n)+b(3,isk)*a(3,n)
225 a(1,n)=a(1,n)-b(1,isk)*aa
226 a(2,n)=a(2,n)-b(2,isk)*aa
227 a(3,n)=a(3,n)-b(3,isk)*aa
228 CASE(6)
229 aa =b(1,isk)*a(1,n)+b(2,isk)*a(2,n)+b(3,isk)*a(3,n)
230 a(1,n)=a(1,n)-b(1,isk)*aa
231 a(2,n)=a(2,n)-b(2,isk)*aa
232 a(3,n)=a(3,n)-b(3,isk)*aa
233 aa =b(4,isk)*a(1,n)+b(5,isk)*a(2,n)+b(6,isk)*a(3,n)
234 a(1,n)=a(1,n)-b(4,isk)*aa
235 a(2,n)=a(2,n)-b(5,isk)*aa
236 a(3,n)=a(3,n)-b(6,isk)*aa
237 CASE(7)
238 a(1,n)=zero
239 a(2,n)=zero
240 a(3,n)=zero
241 END SELECT
242 ENDIF
243 ENDDO
244C-----------------------------------------------
245 RETURN