OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
table_tools.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "com01_c.inc"
#include "vectorize.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine table_zero (table)
subroutine table_wresti (table, leni)
subroutine table_wrestr (table, lenr)
subroutine table_interp (table, xx, yy)
subroutine table_vinterp (table, dimx, nel, ipos, xx, yy, dydx1)

Function/Subroutine Documentation

◆ table_interp()

subroutine table_interp ( type(ttable) table,
dimension(:) xx,
yy )

Definition at line 158 of file table_tools.F.

159C-----------------------------------------------
160 USE table_mod
161C-----------------------------------------------
162C I m p l i c i t T y p e s
163C-----------------------------------------------
164#include "implicit_f.inc"
165C-----------------------------------------------
166C C o m m o n B l o c k s
167C-----------------------------------------------
168#include "units_c.inc"
169C-----------------------------------------------
170C D u m m y A r g u m e n t s
171C-----------------------------------------------
172 TYPE(TTABLE) TABLE
173 my_real,
174 . DIMENSION(:) :: xx
175 my_real
176 . yy
177C-----------------------------------------------
178C L o c a l V a r i a b l e s
179C-----------------------------------------------
180 TYPE(TTABLE_XY), POINTER :: TY
181 INTEGER NDIM, K, NXK(4), I, IPOS(4), IB(2,2,2,2),
182 . IP,IN,IM,IL,P,N,M,L,N1,N12,N123
183 my_real
184 . dx1,dx2,r(4),unr(4)
185C-----------------------------------------------
186 ndim=table%NDIM
187 IF( SIZE(xx) < ndim )THEN
188 WRITE(iout,*) ' ** INTERNAL ERROR - TABLE INTERPOLATION'
189 WRITE(istdo,*)' ** INTERNAL ERROR - TABLE INTERPOLATION'
190 CALL arret(2)
191 END IF
192C-----
193 DO k=1,ndim
194
195 nxk(k)=SIZE(table%X(k)%VALUES)
196 DO i=2,nxk(k)
197 dx2 = table%X(k)%VALUES(i) - xx(k)
198 IF(dx2>=zero.OR.i==nxk(k))THEN
199 ipos(k)=i-1
200 r(k) =(table%X(k)%VALUES(i)-xx(k))/
201 . (table%X(k)%VALUES(i)-table%X(k)%VALUES(i-1))
202 EXIT
203 ENDIF
204 END DO
205
206 END DO
207C-----
208 ty=>table%Y
209 SELECT CASE(ndim)
210
211 CASE(4)
212
213 n1 =nxk(1)
214 n12 =nxk(1)*nxk(2)
215 n123=n12 *nxk(3)
216 DO p=0,1
217 ip=n123*(ipos(4)-1+p)
218 DO n=0,1
219 in=n12*(ipos(3)-1+n)
220 DO m=0,1
221 im=n1*(ipos(2)-1+m)
222 DO l=0,1
223 il=ipos(1)+l
224 ib(l+1,m+1,n+1,p+1)=ip+in+im+il
225 END DO
226 END DO
227 END DO
228 END DO
229C
230 DO k=1,4
231 unr(k)=one-r(k)
232 END DO
233C
234 yy= r(4)*( r(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
235 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
236 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
237 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
238 . +unr(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,2,1))
239 . +unr(1)*ty%VALUES(ib(2,1,2,1)))
240 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,2,1))
241 . +unr(1)*ty%VALUES(ib(2,2,2,1)))))
242 . +unr(4)*( r(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,1,2))
243 . +unr(1)*ty%VALUES(ib(2,1,1,2)))
244 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,2))
245 . +unr(1)*ty%VALUES(ib(2,2,1,2))))
246 . +unr(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,2,2))
247 . +unr(1)*ty%VALUES(ib(2,1,2,2)))
248 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,2,2))
249 . +unr(1)*ty%VALUES(ib(2,2,2,2)))))
250C-----
251 CASE(3)
252
253 n1 =nxk(1)
254 n12 =nxk(1)*nxk(2)
255 DO n=0,1
256 in=n12*(ipos(3)-1+n)
257 DO m=0,1
258 im=n1*(ipos(2)-1+m)
259 DO l=0,1
260 il=ipos(1)+l
261 ib(l+1,m+1,n+1,1)=in+im+il
262 END DO
263 END DO
264 END DO
265C
266 DO k=1,3
267 unr(k)=one-r(k)
268 END DO
269C
270 yy=r(3) *( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
271 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
272 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
273 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
274 . +unr(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,2,1))
275 . +unr(1)*ty%VALUES(ib(2,1,2,1)))
276 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,2,1))
277 . +unr(1)*ty%VALUES(ib(2,2,2,1))))
278C-----
279 CASE(2)
280
281 n1 =nxk(1)
282 DO m=0,1
283 im=n1*(ipos(2)-1+m)
284 DO l=0,1
285 il=ipos(1)+l
286 ib(l+1,m+1,1,1)=im+il
287 END DO
288 END DO
289C
290 DO k=1,2
291 unr(k)=one-r(k)
292 END DO
293C
294 yy=( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
295 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
296 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
297 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
298
299C-----
300 CASE(1)
301
302 DO k=1,2
303 unr(k)=one-r(k)
304 END DO
305C
306 yy=r(1)*ty%VALUES(ipos(1))
307 . +unr(1)*ty%VALUES(ipos(1)+1)
308
309C-----
310 END SELECT
311
312 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
table_mod
Definition table_mod.F:112
arret
subroutine arret(nn)
Definition arret.F:87

◆ table_vinterp()

subroutine table_vinterp ( type(ttable) table,
integer, intent(in), value dimx,
integer, intent(in) nel,
integer, dimension(dimx,table%ndim) ipos,
dimension(dimx,table%ndim) xx,
dimension(nel) yy,
dimension(nel) dydx1 )

Definition at line 323 of file table_tools.F.

324C-----------------------------------------------
325 USE table_mod
326C-----------------------------------------------
327C I m p l i c i t T y p e s
328C-----------------------------------------------
329#include "implicit_f.inc"
330C-----------------------------------------------
331C C o m m o n B l o c k s
332C-----------------------------------------------
333#include "com01_c.inc"
334#include "units_c.inc"
335C-----------------------------------------------
336C D u m m y A r g u m e n t s
337C-----------------------------------------------
338 TYPE(TTABLE) :: TABLE
339 INTEGER ,INTENT(IN) :: NEL
340 INTEGER ,VALUE ,INTENT(IN) :: DIMX
341 INTEGER ,DIMENSION(DIMX,TABLE%NDIM) :: IPOS
342 my_real ,DIMENSION(DIMX,TABLE%NDIM) :: xx
343 my_real ,DIMENSION(NEL) :: yy, dydx1
344C-----------------------------------------------
345C L o c a l V a r i a b l e s
346C-----------------------------------------------
347 LOGICAL, DIMENSION(NEL) :: NEED_TO_COMPUTE
348 INTEGER NDIM, K, NXK(4), I, IB(NEL,2,2,2,2),
349 . IP,IN,IM,IL,P,N,M,L,N1,N12,N123
350 my_real :: dx2,r(nel,4),unr(nel,4),dx2_0(nel)
351 INTEGER :: J
352 INTEGER :: NINDX_1,M_INDX1,NINDX_2,M_INDX2
353 INTEGER, DIMENSION(NEL) :: INDX_1,INDX_2
354C-----------------------------------------------
355 r(1:nel,1:4) = zero
356 ndim=table%NDIM
357 IF (SIZE(xx,2) < table%NDIM) THEN
358 WRITE(iout,*) ' ** INTERNAL ERROR - TABLE INTERPOLATION'
359 WRITE(istdo,*)' ** INTERNAL ERROR - TABLE INTERPOLATION'
360 CALL arret(2)
361 END IF
362C-----
363 DO k=1,ndim
364 nxk(k)=SIZE(table%X(k)%VALUES)
365 ENDDO
366
367 DO k=1,ndim
368 ipos(1:nel,k)=max(ipos(1:nel,k),1)
369 nindx_1 = 0
370 m_indx1 = 0
371 nindx_2 = 0
372 m_indx2 = nxk(k) + 1
373#include "vectorize.inc"
374 DO i=1,nel
375 m = ipos(i,k)
376 dx2_0(i) = table%X(k)%VALUES(m) - xx(i,k)
377 IF(dx2_0(i) >= zero)THEN
378 nindx_1 = nindx_1 + 1
379 indx_1(nindx_1) = i
380 m_indx1 = max(m_indx1,m)
381 ELSE
382 nindx_2 = nindx_2 + 1
383 indx_2(nindx_2) = i
384 m_indx2 = min(m_indx2,m)
385 ENDIF
386 ENDDO
387
388 need_to_compute(1:nindx_1) = .true.
389 DO n=m_indx1,1,-1
390#include "vectorize.inc"
391 DO j=1,nindx_1
392 IF(need_to_compute(j)) THEN
393 i = indx_1(j)
394 m = ipos(i,k)
395 dx2 = table%X(k)%VALUES(n) - xx(i,k)
396 IF(dx2<zero.OR.n <=1)THEN
397 ipos(i,k)=max(n,1) !N
398 need_to_compute(j) = .false.
399 ENDIF
400 ENDIF
401 ENDDO
402 ENDDO
403 need_to_compute(1:nindx_2) = .true.
404 DO n=m_indx2,nxk(k)
405#include "vectorize.inc"
406 DO j=1,nindx_2
407 IF(need_to_compute(j)) THEN
408 i = indx_2(j)
409 m = ipos(i,k)
410 dx2 = table%X(k)%VALUES(n) - xx(i,k)
411 IF(dx2>=zero.OR.n==nxk(k))THEN
412 ipos(i,k)=n-1
413 need_to_compute(j) = .false.
414 ENDIF
415 ENDIF
416 ENDDO
417 ENDDO
418 ENDDO
419
420 DO k=1,ndim
421#include "vectorize.inc"
422 DO i=1,nel
423 n = ipos(i,k)
424 r(i,k) =(table%X(k)%VALUES(n+1)-xx(i,k))/
425 . (table%X(k)%VALUES(n+1)-table%X(k)%VALUES(n))
426 END DO
427 END DO
428C-----
429 SELECT CASE(ndim)
430
431 CASE(4)
432C
433 n1 =nxk(1)
434 n12 =nxk(1)*nxk(2)
435 n123=n12 *nxk(3)
436 DO i=1,nel
437 DO p=0,1
438 ip=n123*(ipos(i,4)-1+p)
439 DO n=0,1
440 in=n12*(ipos(i,3)-1+n)
441 DO m=0,1
442 im=n1*(ipos(i,2)-1+m)
443 DO l=0,1
444 il=ipos(i,1)+l
445 ib(i,l+1,m+1,n+1,p+1)=ip+in+im+il
446 END DO
447 END DO
448 END DO
449 END DO
450 END DO
451C
452 unr(1:nel,1:4)=one-r(1:nel,1:4)
453#include "vectorize.inc"
454 DO i=1,nel
455C
456 yy(i)=
457 . r(i,4)*(r(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
458 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
459 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
460 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
461 . +unr(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,2,1))
462 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,2,1)))
463 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,2,1))
464 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,2,1)))))
465 . +unr(i,4)*(r(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
466 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
467 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
468 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
469 . +unr(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,2,1))
470 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,2,1)))
471 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,2,1))
472 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,2,1)))))
473C
474 dydx1(i)=
475 . (r(i,4)*(r(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
476 . -table%Y%VALUES(ib(i,1,1,1,1)))
477 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
478 . -table%Y%VALUES(ib(i,1,2,1,1))))
479 . +unr(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,2,1))
480 . -table%Y%VALUES(ib(i,1,1,2,1)))
481 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,2,1))
482 . -table%Y%VALUES(ib(i,1,2,2,1)))))
483 . +unr(i,4)*(r(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
484 . -table%Y%VALUES(ib(i,1,1,1,1)))
485 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
486 . -table%Y%VALUES(ib(i,1,2,1,1))))
487 . +unr(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,2,1))
488 . -table%Y%VALUES(ib(i,1,1,2,1)))
489 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,2,1))
490 . -table%Y%VALUES(ib(i,1,2,2,1))))))/
491 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
492
493 END DO
494C-----
495 CASE(3)
496C
497 n1 =nxk(1)
498 n12 =nxk(1)*nxk(2)
499 DO i=1,nel
500 DO n=0,1
501 in=n12*(ipos(i,3)-1+n)
502 DO m=0,1
503 im=n1*(ipos(i,2)-1+m)
504 DO l=0,1
505 il=ipos(i,1)+l
506 ib(i,l+1,m+1,n+1,1)=in+im+il
507 END DO
508 END DO
509 END DO
510 END DO
511C
512 unr(1:nel,1:3)=one-r(1:nel,1:3)
513#include "vectorize.inc"
514 DO i=1,nel
515C
516 yy(i)=
517 . (r(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
518 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
519 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
520 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
521 . +unr(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,2,1))
522 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,2,1)))
523 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,2,1))
524 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,2,1)))))
525C
526 dydx1(i)=
527 . (r(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
528 . -table%Y%VALUES(ib(i,1,1,1,1)))
529 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
530 . -table%Y%VALUES(ib(i,1,2,1,1))))
531 . +unr(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,2,1))
532 . -table%Y%VALUES(ib(i,1,1,2,1)))
533 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,2,1))
534 . -table%Y%VALUES(ib(i,1,2,2,1)))))/
535 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
536C
537 END DO
538C-----
539 CASE(2)
540C
541 n1 =nxk(1)
542 DO i=1,nel
543 DO m=0,1
544 im=n1*(ipos(i,2)-1+m)
545 DO l=0,1
546 il=ipos(i,1)+l
547 ib(i,l+1,m+1,1,1)=im+il
548 END DO
549 END DO
550 END DO
551C
552 unr(1:nel,1:2)=one-r(1:nel,1:2)
553#include "vectorize.inc"
554 DO i=1,nel
555C
556 yy(i)=
557 . (r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
558 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
559 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
560 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
561 dydx1(i)=
562 . (r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
563 . -table%Y%VALUES(ib(i,1,1,1,1)))
564 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
565 . -table%Y%VALUES(ib(i,1,2,1,1))))/
566 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
567 END DO
568C-----
569 CASE(1)
570
571 unr(1:nel,1:1)=one-r(1:nel,1:1)
572#include "vectorize.inc"
573 DO i=1,nel
574C
575 yy(i)= r(i,1)*table%Y%VALUES(ipos(i,1))
576 . +unr(i,1)*table%Y%VALUES(ipos(i,1)+1)
577 dydx1(i)=(table%Y%VALUES(ipos(i,1)+1)-table%Y%VALUES(ipos(i,1)))/
578 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
579 END DO
580C-----
581 END SELECT
582C-----
583 RETURN
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ table_wresti()

subroutine table_wresti ( type(ttable), dimension(*) table,
integer leni )

Definition at line 66 of file table_tools.F.

67C-----------------------------------------------
68 USE table_mod
69C-----------------------------------------------
70C I m p l i c i t T y p e s
71C-----------------------------------------------
72#include "implicit_f.inc"
73C-----------------------------------------------
74C C o m m o n B l o c k s
75C-----------------------------------------------
76#include "com04_c.inc"
77C-----------------------------------------------
78C D u m m y A r g u m e n t s
79C-----------------------------------------------
80 INTEGER LENI
81 TYPE(TTABLE) TABLE(*)
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER LEN, N, K
86C--------------------------------------
87 leni=0
88 DO n=1,ntable
89 len =1
90 CALL write_i_c(table(n)%NOTABLE,len)
91 leni = leni + len
92 len =1
93 CALL write_i_c(table(n)%NDIM,len)
94 leni = leni + len
95 DO k=1,table(n)%NDIM
96 len =1
97 CALL write_i_c( SIZE(table(n)%X(k)%VALUES) , len)
98 leni = leni + len
99 END DO
100 len =1
101 CALL write_i_c(SIZE(table(n)%Y%VALUES),len)
102 leni = leni + len
103 END DO
104 RETURN
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645

◆ table_wrestr()

subroutine table_wrestr ( type(ttable), dimension(*) table,
integer lenr )

Definition at line 114 of file table_tools.F.

115C-----------------------------------------------
116 USE table_mod
117C-----------------------------------------------
118C I m p l i c i t T y p e s
119C-----------------------------------------------
120#include "implicit_f.inc"
121C-----------------------------------------------
122C C o m m o n B l o c k s
123C-----------------------------------------------
124#include "com04_c.inc"
125C-----------------------------------------------
126C D u m m y A r g u m e n t s
127C-----------------------------------------------
128 INTEGER LENR
129 TYPE(TTABLE) TABLE(*)
130C-----------------------------------------------
131C L o c a l V a r i a b l e s
132C-----------------------------------------------
133 INTEGER LEN, N, K
134C--------------------------------------
135 lenr=0
136 DO n=1,ntable
137 DO k=1,table(n)%NDIM
138 len =SIZE( table(n)%X(k)%VALUES)
139 CALL write_db(table(n)%X(k)%VALUES,len)
140 lenr=lenr+len
141 END DO
142 len =SIZE( table(n)%Y%VALUES)
143 CALL write_db(table(n)%Y%VALUES,len)
144 lenr=lenr+len
145 END DO
146c-----------
147 RETURN
write_db
subroutine write_db(a, n)
Definition write_db.F:140

◆ table_zero()

subroutine table_zero ( type(ttable), dimension(*) table)

Definition at line 30 of file table_tools.F.

31C-----------------------------------------------
32 USE table_mod
33C-----------------------------------------------
34C I m p l i c i t T y p e s
35C-----------------------------------------------
36#include "implicit_f.inc"
37C-----------------------------------------------
38C C o m m o n B l o c k s
39C-----------------------------------------------
40#include "com04_c.inc"
41C-----------------------------------------------
42C D u m m y A r g u m e n t s
43C-----------------------------------------------
44 TYPE(TTABLE) TABLE(*)
45C-----------------------------------------------
46C L o c a l V a r i a b l e s
47C-----------------------------------------------
48 INTEGER LEN, N
49C--------------------------------------
50 DO n=1,ntable
51 table(n)%NOTABLE = 0
52 table(n)%NDIM = 0
53 NULLIFY(table(n)%X)
54 NULLIFY(table(n)%Y)
55 END DO
56 RETURN