OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
table_mat_vinterp_mod Module Reference

Functions/Subroutines

subroutine table_mat_vinterp (table, dimx, nel, ipos, xx, yy, dydx)
subroutine table_mat_vinterp (table, dimx, nel, ipos, xx, yy, dydx, opt_extrapolate)

Function/Subroutine Documentation

◆ table_mat_vinterp() [1/2]

subroutine table_mat_vinterp_mod::table_mat_vinterp ( type(table_4d_), intent(in) table,
integer, intent(in) dimx,
integer, intent(in) nel,
integer, dimension(dimx,table%ndim), intent(inout) ipos,
intent(in) xx,
intent(inout) yy,
intent(inout) dydx )

Definition at line 45 of file table_mat_vinterp.F.

46C-----------------------------------------------
47 USE table4d_mod
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 TYPE(TABLE_4D_) ,INTENT(IN) :: TABLE
56 INTEGER ,INTENT(IN) :: DIMX
57 INTEGER ,INTENT(IN) :: NEL
58 my_real, DIMENSION(DIMX,TABLE%NDIM),INTENT(IN) :: xx
59 INTEGER, DIMENSION(DIMX,TABLE%NDIM),INTENT(INOUT) :: IPOS
60 my_real, DIMENSION(NEL) ,INTENT(INOUT) :: yy
61 my_real, DIMENSION(NEL) ,INTENT(INOUT) :: dydx
62C-----------------------------------------------
63C L o c a l V a r i a b l e s
64C-----------------------------------------------
65 LOGICAL, DIMENSION(NEL) :: NEED_TO_COMPUTE
66 INTEGER I,J,K,M,N,I1,I2,J1,J2,K1,K2,L1,L2,NDIM
67 INTEGER :: MINDX_1,MINDX_2
68 INTEGER :: NINDX_1,NINDX_2
69 INTEGER, DIMENSION(NEL) :: INDX_1,INDX_2
70 INTEGER, DIMENSION(4) :: LDIM
71 my_real :: dx,dy,alpha,alphai,beta,betai,gamma,gammai,delta,deltai
72 my_real, DIMENSION(NEL,4) :: fac
73c=======================================================================
74 ndim = table%NDIM
75C-----
76 DO k=1,ndim
77 ldim(k) = SIZE(table%X(k)%VALUES)
78 END DO
79c
80 DO k=1,ndim
81 ipos(1:nel,k) = max(ipos(1:nel,k),1)
82 nindx_1 = 0
83 mindx_1 = 0
84 nindx_2 = 0
85 mindx_2 = ldim(k) + 1
86#include "vectorize.inc"
87 DO i=1,nel
88 m = ipos(i,k)
89 dx = table%X(k)%VALUES(m) - xx(i,k)
90 IF (dx >= zero)THEN
91 nindx_1 = nindx_1 + 1
92 indx_1(nindx_1) = i
93 mindx_1 = max(mindx_1,m)
94 ELSE
95 nindx_2 = nindx_2 + 1
96 indx_2(nindx_2) = i
97 mindx_2 = min(mindx_2,m)
98 ENDIF
99 ENDDO
100
101 need_to_compute(1:nindx_1) = .true.
102 DO n = mindx_1,1,-1
103#include "vectorize.inc"
104 DO j=1,nindx_1
105 IF(need_to_compute(j)) THEN
106 i = indx_1(j)
107 m = ipos(i,k)
108 dx = table%X(k)%VALUES(n) - xx(i,k)
109 IF (dx < zero .OR. n <= 1) THEN
110 ipos(i,k)=max(n,1)
111 need_to_compute(j) = .false.
112 ENDIF
113 ENDIF
114 ENDDO
115 ENDDO
116c
117 need_to_compute(1:nindx_2) = .true.
118c
119 DO n=mindx_2,ldim(k)
120#include "vectorize.inc"
121 DO j=1,nindx_2
122 IF (need_to_compute(j)) THEN
123 i = indx_2(j)
124 m = ipos(i,k)
125 dx = table%X(k)%VALUES(n) - xx(i,k)
126 IF (dx >= zero .OR. n == ldim(k)) THEN
127 ipos(i,k) = n-1
128 need_to_compute(j) = .false.
129 ENDIF
130 ENDIF
131 ENDDO
132 ENDDO
133
134 ENDDO ! K=1,NDIM
135c
136 DO k=1,ndim
137#include "vectorize.inc"
138 DO i=1,nel
139 n = ipos(i,k)
140 fac(i,k) = (table%X(k)%VALUES(n+1) - xx(i,k))
141 . / (table%X(k)%VALUES(n+1) - table%X(k)%VALUES(n))
142 END DO
143 END DO
144c----------------------------------------------
145 SELECT CASE(ndim)
146
147 CASE(4)
148C
149#include "vectorize.inc"
150 DO i=1,nel
151 i1 = ipos(i,1)
152 i2 = i1 + 1
153 j1 = ipos(i,2)
154 j2 = j1 + 1
155 k1 = ipos(i,3)
156 k2 = k1 + 1
157 l1 = ipos(i,4)
158 l2 = k1 + 1
159 alpha = fac(i,1)
160 beta = fac(i,2)
161 gamma = fac(i,3)
162 delta = fac(i,4)
163 alphai = one - alpha
164 betai = one - beta
165 gammai = one - gamma
166 deltai = one - delta
167c
168 yy(i) =
169 . delta* (gamma*(beta * (alpha * table%Y4D(i1,j1,k1,l1)
170 . + alphai * table%Y4D(i2,j1,k1,l1))
171 . + betai* (alpha * table%Y4D(i1,j2,k1,l1)
172 . + alphai * table%Y4D(i2,j2,k1,l1)) )
173
174 . +gammai*( beta* (alpha * table%Y4D(i1,j1,k2,l1)
175 . + alphai * table%Y4D(i2,j1,k2,l1))
176 . + betai* (alpha * table%Y4D(i1,j2,k2,l1)
177 . + alphai * table%Y4D(i2,j2,k2,l1))))
178 . +deltai*(gamma *( beta* (alpha * table%Y4D(i1,j1,k1,l1)
179 . +alphai * table%Y4D(i2,j1,k1,l1))
180 . + betai* (alpha * table%Y4D(i1,j2,k1,l1)
181 . + alphai * table%Y4D(i2,j2,k1,l1)))
182 . +gammai*(beta * (alpha * table%Y4D(i1,j1,k2,l1)
183 . + alphai * table%Y4D(i2,j1,k2,l1))
184 . + betai* (alpha * table%Y4D(i1,j2,k2,l1)
185 . + alphai * table%Y4D(i2,j2,k2,l1))))
186c
187 dy = delta * (gamma *(beta *(table%Y4D(i2,j1,k1,l1)-table%Y4D(i1,j1,k1,l1))
188 . + betai*(table%Y4D(i2,j2,k1,l1)-table%Y4D(i1,j2,k1,l1)))
189 . + gammai *(beta *(table%Y4D(i2,j1,k2,l1)-table%Y4D(i1,j1,k2,l1))
190 . + betai*(table%Y4D(i2,j2,k2,l1)-table%Y4D(i1,j2,k2,l1))))
191 . + deltai * (gamma *(beta *(table%Y4D(i2,j1,k1,l1)-table%Y4D(i1,j1,k1,l1))
192 . + betai*(table%Y4D(i2,j2,k1,l1)-table%Y4D(i1,j2,k1,l1)))
193 . + gammai *(beta *(table%Y4D(i2,j1,k2,l1)-table%Y4D(i1,j1,k2,l1))
194 . + betai*(table%Y4D(i2,j2,k2,l1)-table%Y4D(i1,j2,k2,l1))))
195 .
196 .
197 dx = table%X(1)%VALUES(i2) - table%X(1)%VALUES(i1)
198 dydx(i) = dy / dx
199 END DO
200C-----
201 CASE(3)
202C
203#include "vectorize.inc"
204 DO i=1,nel
205 i1 = ipos(i,1)
206 i2 = i1 + 1
207 j1 = ipos(i,2)
208 j2 = j1 + 1
209 k1 = ipos(i,3)
210 k2 = k1 + 1
211 alpha = fac(i,1)
212 beta = fac(i,2)
213 gamma = fac(i,3)
214 alphai = one - alpha
215 betai = one - beta
216 gammai = one - gamma
217C
218 yy(i)=(gamma * (beta* (alpha*table%Y3D(i1,j1,k1) + alphai*table%Y3D(i2,j1,k1))
219 . + betai* (alpha*table%Y3D(i1,j2,k1) + alphai*table%Y3D(i2,j2,k1)) )
220 . + gammai * (beta* (alpha*table%Y3D(i1,j1,k2) + alphai*table%Y3D(i2,j1,k2))
221 . + betai* (alpha*table%Y3D(i1,j2,k2) + alphai*table%Y3D(i2,j2,k2))))
222c
223 dy = gamma * ( beta*(table%Y3D(i2,j1,k1) - table%Y3D(i1,j1,k1))
224 . + betai*(table%Y3D(i2,j2,k1) - table%Y3D(i1,j2,k1)))
225 . + gammai * ( beta*(table%Y3D(i2,j1,k2) - table%Y3D(i1,j1,k2))
226 . + betai*(table%Y3D(i2,j2,k2) - table%Y3D(i1,j2,k2)))
227 dx = table%X(1)%VALUES(i2) - table%X(1)%VALUES(i1)
228 .
229 dydx(i) = dy / dx
230 END DO
231C-----
232 CASE(2)
233C
234#include "vectorize.inc"
235 DO i=1,nel
236 i1 = ipos(i,1)
237 i2 = i1 + 1
238 j1 = ipos(i,2)
239 j2 = j1 + 1
240 alpha = fac(i,1)
241 beta = fac(i,2)
242 alphai = one - alpha
243 betai = one - beta
244c
245 yy(i) = (beta * (alpha*table%Y2D(i1,j1) + alphai*table%Y2D(i2,j1))
246 . + betai * (alpha*table%Y2D(i1,j2) + alphai*table%Y2D(i2,j2)) )
247c
248 dydx(i) = (beta *(table%Y2D(i2,j1) - table%Y2D(i1,j1))
249 . + betai *(table%Y2D(i2,j2) - table%Y2D(i1,j2)))
250 . / (table%X(1)%VALUES(i2)-table%X(1)%VALUES(i1))
251 END DO
252C-----
253 CASE(1)
254c
255#include "vectorize.inc"
256 DO i=1,nel
257 i1 = ipos(i,1)
258 i2 = i1 + 1
259 alpha = fac(i,1)
260 alphai = one - alpha
261c
262 yy(i) = alpha*table%Y1D(i1) + alphai*table%Y1D(i2)
263 dydx(i) = (table%Y1D(i2) - table%Y1D(i1))
264 . / (table%X(1)%VALUES(i2) - table%X(1)%VALUES(i1))
265 END DO
266C-----
267 END SELECT
268c-----------
269 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
alpha
#define alpha
Definition eval.h:35
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
table4d_mod
Definition table4d_mod.F:54

◆ table_mat_vinterp() [2/2]

subroutine table_mat_vinterp_mod::table_mat_vinterp ( type(table_4d_), intent(in) table,
integer, intent(in), value dimx,
integer, intent(in) nel,
integer, dimension(dimx,table%ndim), intent(inout) ipos,
intent(in) xx,
intent(inout) yy,
intent(inout) dydx,
logical, intent(in), optional opt_extrapolate )

Definition at line 90 of file table_mat_vinterp.F.

91C-----------------------------------------------
92C D e s c r i p t i o n
93C-----------------------------------------------
94C This subroutine is proceeding to table interpolation.
95C example with case dim=1 (table <=> function)
96C nel is number interpolatation
97C ipos is index backup to prevent from starting the loop from 1 to npt during each cycle (input/output)
98C XX(nel) are abscissa on which the interpolation is required (input)
99C YY(nel) are the interpolated value (output)
100C DYDX(nel) is the slope (output)
101C-----------------------------------------------
102C M o d u l e s
103C-----------------------------------------------
104 USE table4d_mod
105 USE message_mod
106C-----------------------------------------------
107C I m p l i c i t T y p e s
108C-----------------------------------------------
109#include "implicit_f.inc"
110C-----------------------------------------------
111C D u m m y A r g u m e n t s
112C-----------------------------------------------
113 TYPE(TABLE_4D_) ,INTENT(IN) :: TABLE
114 INTEGER, VALUE ,INTENT(IN) :: DIMX
115 INTEGER ,INTENT(IN) :: NEL
116 my_real, DIMENSION(DIMX,TABLE%NDIM),INTENT(IN) :: xx
117 INTEGER, DIMENSION(DIMX,TABLE%NDIM),INTENT(INOUT) :: IPOS
118 my_real, DIMENSION(DIMX) ,INTENT(INOUT) :: yy
119 my_real, DIMENSION(DIMX) ,INTENT(INOUT) :: dydx
120 LOGICAL, OPTIONAL, INTENT(IN) :: OPT_EXTRAPOLATE
121C-----------------------------------------------
122C L o c a l V a r i a b l e s
123C-----------------------------------------------
124 LOGICAL :: NEED_TO_COMPUTE
125 INTEGER I,J,K,M,N,I1,I2,J1,J2,K1,K2,L1,L2,NDIM
126 INTEGER :: NINDX_1,NINDX_2
127 INTEGER, DIMENSION(NEL) :: INDX_1,INDX_2
128 INTEGER, DIMENSION(4) :: LDIM
129 my_real :: dx,dy,alpha,alphai,beta,betai,gamma,gammai,delta,deltai
130 my_real, DIMENSION(NEL,4) :: fac
131 LOGICAL DO_EXTRAPOLATION
132C-----------------------------------------------
133C Source Lines
134C-----------------------------------------------
135 do_extrapolation = .true.
136 IF(PRESENT(opt_extrapolate)) THEN
137 do_extrapolation = opt_extrapolate
138 ENDIF
139
140 ndim = table%NDIM
141 IF (SIZE(xx,2) < ndim ) THEN
142 CALL ancmsg(msgid=36,anmode=aninfo,c1='TABLE INTERPOLATION')
143 CALL arret(2)
144 END IF
145
146 DO k=1,ndim
147 ldim(k) = SIZE(table%X(k)%VALUES)
148 END DO
149
150 DO k=1,ndim
151 ipos(1:nel,k) = max(ipos(1:nel,k),1)
152 nindx_1 = 0
153 nindx_2 = 0
154#include "vectorize.inc"
155 DO i=1,nel
156 m = ipos(i,k)
157 dx = table%X(k)%VALUES(m) - xx(i,k)
158 IF (dx >= zero)THEN
159 nindx_1 = nindx_1 + 1
160 indx_1(nindx_1) = i
161 ELSE
162 nindx_2 = nindx_2 + 1
163 indx_2(nindx_2) = i
164 ENDIF
165 ENDDO
166
167 DO j=1,nindx_1
168 i = indx_1(j)
169 m = ipos(i,k)
170 need_to_compute = .true.
171 DO WHILE (need_to_compute )
172 dx = table%X(k)%VALUES(m) - xx(i,k)
173 IF (dx < zero .OR. m <= 1 ) THEN
174 ipos(i,k) = max(m,1)
175 need_to_compute = .false.
176 ELSE
177 m=m-1
178 ENDIF
179 ENDDO
180 ENDDO
181
182 DO j=1,nindx_2
183 i = indx_2(j)
184 m = ipos(i,k)
185 need_to_compute = .true.
186 DO WHILE (need_to_compute )
187 dx = table%X(k)%VALUES(m) - xx(i,k)
188 IF (dx >= zero .OR. m == ldim(k)) THEN
189 ipos(i,k) = m-1
190 need_to_compute = .false.
191 ELSE
192 m=m+1
193 ENDIF
194 ENDDO
195 ENDDO
196 ENDDO ! K=1,NDIM
197
198 DO k=1,ndim
199#include "vectorize.inc"
200 DO i=1,nel
201 n = ipos(i,k)
202 fac(i,k) = (table%X(k)%VALUES(n+1) - xx(i,k)) / (table%X(k)%VALUES(n+1) - table%X(k)%VALUES(n))
203 END DO
204 END DO
205
206 IF(.NOT. do_extrapolation)THEN
207 DO k=1,ndim
208#include "vectorize.inc"
209 DO i=1,nel
210 n = ipos(i,k)
211 fac(i,k) = min(one,max(fac(i,k),zero))
212 END DO
213 END DO
214 ENDIF
215c----------------------------------------------
216
217 SELECT CASE(ndim)
218
219 CASE(4)
220#include "vectorize.inc"
221 DO i=1,nel
222 i1 = ipos(i,1)
223 i2 = i1 + 1
224 j1 = ipos(i,2)
225 j2 = j1 + 1
226 k1 = ipos(i,3)
227 k2 = k1 + 1
228 l1 = ipos(i,4)
229 l2 = l1 + 1
230 alpha = fac(i,1)
231 beta = fac(i,2)
232 gamma = fac(i,3)
233 delta = fac(i,4)
234 alphai = one - alpha
235 betai = one - beta
236 gammai = one - gamma
237 deltai = one - delta
238 yy(i) =
239 . delta* (gamma*(beta * (alpha * table%Y4D(i1,j1,k1,l1)
240 . + alphai * table%Y4D(i2,j1,k1,l1))
241 . + betai* (alpha * table%Y4D(i1,j2,k1,l1)
242 . + alphai * table%Y4D(i2,j2,k1,l1)) )
243 . +gammai*( beta* (alpha * table%Y4D(i1,j1,k2,l1)
244 . + alphai * table%Y4D(i2,j1,k2,l1))
245 . + betai* (alpha * table%Y4D(i1,j2,k2,l1)
246 . + alphai * table%Y4D(i2,j2,k2,l1))))
247
248 . + deltai*(gamma *(beta * (alpha * table%Y4D(i1,j1,k1,l2)
249 . + alphai * table%Y4D(i2,j1,k1,l2))
250 . + betai* (alpha * table%Y4D(i1,j2,k1,l2)
251 . + alphai * table%Y4D(i2,j2,k1,l2)))
252 . +gammai* (beta* (alpha * table%Y4D(i1,j1,k2,l2)
253 . + alphai * table%Y4D(i2,j1,k2,l2))
254 . + betai* (alpha * table%Y4D(i1,j2,k2,l2)
255 . + alphai * table%Y4D(i2,j2,k2,l2))))
256!
257 dy = delta * (gamma *(beta *(table%Y4D(i2,j1,k1,l1)-table%Y4D(i1,j1,k1,l1))
258 . + betai*(table%Y4D(i2,j2,k1,l1)-table%Y4D(i1,j2,k1,l1)))
259 . + gammai *(beta *(table%Y4D(i2,j1,k2,l1)-table%Y4D(i1,j1,k2,l1))
260 . + betai*(table%Y4D(i2,j2,k2,l1)-table%Y4D(i1,j2,k2,l1))))
261 . + deltai * (gamma *(beta *(table%Y4D(i2,j1,k1,l2)-table%Y4D(i1,j1,k1,l2))
262 . + betai*(table%Y4D(i2,j2,k1,l2)-table%Y4D(i1,j2,k1,l2)))
263 . + gammai *(beta *(table%Y4D(i2,j1,k2,l2)-table%Y4D(i1,j1,k2,l2))
264 . + betai*(table%Y4D(i2,j2,k2,l2)-table%Y4D(i1,j2,k2,l2))))
265 dx = table%X(1)%VALUES(i2) - table%X(1)%VALUES(i1)
266 dydx(i) = dy / dx
267 END DO
268C-----
269 CASE(3)
270#include "vectorize.inc"
271 DO i=1,nel
272 i1 = ipos(i,1)
273 i2 = i1 + 1
274 j1 = ipos(i,2)
275 j2 = j1 + 1
276 k1 = ipos(i,3)
277 k2 = k1 + 1
278 alpha = fac(i,1)
279 beta = fac(i,2)
280 gamma = fac(i,3)
281 alphai = one - alpha
282 betai = one - beta
283 gammai = one - gamma
284 yy(i)=(gamma * (beta * (alpha*table%Y3D(i1,j1,k1) + alphai*table%Y3D(i2,j1,k1))
285 . + betai* (alpha*table%Y3D(i1,j2,k1) + alphai*table%Y3D(i2,j2,k1)) )
286 . + gammai * (beta * (alpha*table%Y3D(i1,j1,k2) + alphai*table%Y3D(i2,j1,k2))
287 . + betai* (alpha*table%Y3D(i1,j2,k2) + alphai*table%Y3D(i2,j2,k2))))
288
289 dy = gamma * ( beta*(table%Y3D(i2,j1,k1) - table%Y3D(i1,j1,k1))
290 . + betai*(table%Y3D(i2,j2,k1) - table%Y3D(i1,j2,k1)))
291 . + gammai * ( beta*(table%Y3D(i2,j1,k2) - table%Y3D(i1,j1,k2))
292 . + betai*(table%Y3D(i2,j2,k2) - table%Y3D(i1,j2,k2)))
293 dx = table%X(1)%VALUES(i2) - table%X(1)%VALUES(i1)
294 .
295 dydx(i) = dy / dx
296 END DO
297
298 CASE(2)
299#include "vectorize.inc"
300 DO i=1,nel
301 i1 = ipos(i,1)
302 i2 = i1 + 1
303 j1 = ipos(i,2)
304 j2 = j1 + 1
305 alpha = fac(i,1)
306 beta = fac(i,2)
307 alphai = one - alpha
308 betai = one - beta
309 yy(i) = (beta * (alpha*table%Y2D(i1,j1) + alphai*table%Y2D(i2,j1))
310 . + betai * (alpha*table%Y2D(i1,j2) + alphai*table%Y2D(i2,j2)) )
311 dydx(i) = (beta *(table%Y2D(i2,j1) - table%Y2D(i1,j1))
312 . + betai *(table%Y2D(i2,j2) - table%Y2D(i1,j2)))
313 . / (table%X(1)%VALUES(i2)-table%X(1)%VALUES(i1))
314 END DO
315
316 CASE(1)
317#include "vectorize.inc"
318 DO i=1,nel
319 i1 = ipos(i,1)
320 i2 = i1 + 1
321 alpha = fac(i,1)
322 alphai = one - alpha
323 yy(i) = alpha*table%Y1D(i1) + alphai*table%Y1D(i2)
324 dydx(i) = (table%Y1D(i2) - table%Y1D(i1)) / (table%X(1)%VALUES(i2) - table%X(1)%VALUES(i1))
325 END DO
326
327 END SELECT
328c-----------
329 RETURN
message_mod
Definition message_mod.F:1257
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
arret
subroutine arret(nn)
Definition arret.F:86