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), IP,IN,IM,IL,P,N,M,L,N1,N12,N123
182 my_real :: dx2,r(4),unr(4)
183C-----------------------------------------------
184 ndim=table%NDIM
185 IF( SIZE(xx) < ndim )THEN
186 WRITE(iout,*) ' ** INTERNAL ERROR - TABLE INTERPOLATION'
187 WRITE(istdo,*)' ** INTERNAL ERROR - TABLE INTERPOLATION'
188 CALL arret(2)
189 END IF
190C-----
191 DO k=1,ndim
192
193 nxk(k)=SIZE(table%X(k)%VALUES)
194 DO i=2,nxk(k)
195 dx2 = table%X(k)%VALUES(i) - xx(k)
196 IF(dx2>=zero.OR.i==nxk(k))THEN
197 ipos(k)=i-1
198 r(k) =(table%X(k)%VALUES(i)-xx(k))/
199 . (table%X(k)%VALUES(i)-table%X(k)%VALUES(i-1))
200 EXIT
201 ENDIF
202 END DO
203
204 END DO
205C-----
206 ty=>table%Y
207 SELECT CASE(ndim)
208
209 CASE(4)
210
211 n1 =nxk(1)
212 n12 =nxk(1)*nxk(2)
213 n123=n12 *nxk(3)
214 DO p=0,1
215 ip=n123*(ipos(4)-1+p)
216 DO n=0,1
217 in=n12*(ipos(3)-1+n)
218 DO m=0,1
219 im=n1*(ipos(2)-1+m)
220 DO l=0,1
221 il=ipos(1)+l
222 ib(l+1,m+1,n+1,p+1)=ip+in+im+il
223 END DO
224 END DO
225 END DO
226 END DO
227C
228 DO k=1,4
229 unr(k)=one-r(k)
230 END DO
231C
232 yy= r(4)*( r(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
233 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
234 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
235 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
236 . +unr(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,2,1))
237 . +unr(1)*ty%VALUES(ib(2,1,2,1)))
238 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,2,1))
239 . +unr(1)*ty%VALUES(ib(2,2,2,1)))))
240 . +unr(4)*( r(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,1,2))
241 . +unr(1)*ty%VALUES(ib(2,1,1,2)))
242 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,2))
243 . +unr(1)*ty%VALUES(ib(2,2,1,2))))
244 . +unr(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,2,2))
245 . +unr(1)*ty%VALUES(ib(2,1,2,2)))
246 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,2,2))
247 . +unr(1)*ty%VALUES(ib(2,2,2,2)))))
248C-----
249 CASE(3)
250
251 n1 =nxk(1)
252 n12 =nxk(1)*nxk(2)
253 DO n=0,1
254 in=n12*(ipos(3)-1+n)
255 DO m=0,1
256 im=n1*(ipos(2)-1+m)
257 DO l=0,1
258 il=ipos(1)+l
259 ib(l+1,m+1,n+1,1)=in+im+il
260 END DO
261 END DO
262 END DO
263C
264 DO k=1,3
265 unr(k)=one-r(k)
266 END DO
267C
268 yy=r(3) *( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
269 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
270 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
271 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
272 . +unr(3)*( r(2)*( r(1)*ty%VALUES(ib(1,1,2,1))
273 . +unr(1)*ty%VALUES(ib(2,1,2,1)))
274 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,2,1))
275 . +unr(1)*ty%VALUES(ib(2,2,2,1))))
276C-----
277 CASE(2)
278
279 n1 =nxk(1)
280 DO m=0,1
281 im=n1*(ipos(2)-1+m)
282 DO l=0,1
283 il=ipos(1)+l
284 ib(l+1,m+1,1,1)=im+il
285 END DO
286 END DO
287C
288 DO k=1,2
289 unr(k)=one-r(k)
290 END DO
291C
292 yy=( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
293 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
294 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
295 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
296
297C-----
298 CASE(1)
299
300 DO k=1,2
301 unr(k)=one-r(k)
302 END DO
303C
304 yy=r(1)*ty%VALUES(ipos(1))
305 . +unr(1)*ty%VALUES(ipos(1)+1)
306
307C-----
308 END SELECT
309
310 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
table_mod
Definition table_mod.F:113
arret
subroutine arret(nn)
Definition arret.F:86

◆ 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 321 of file table_tools.F.

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

◆ 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 :: 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