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 44 of file table_mat_vinterp.F.

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

◆ 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 79 of file table_mat_vinterp.F.

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