OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
table_tools.F File Reference
#include "implicit_f.inc"
#include "com04_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_rresti (table)
subroutine table_rrestr (table)
subroutine table_interp (table, xx, yy)
subroutine table_interp_dydx (table, xx, xxdim, yy, dydx)
subroutine table_vinterp (table, dimx, nel, ipos, xx, yy, dydx1)
subroutine table_interp_law76 (table, ipos2, xx, r2, dydx, yy)

Function/Subroutine Documentation

◆ table_interp()

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

Definition at line 273 of file table_tools.F.

274C-----------------------------------------------
275 USE table_mod
276 USE message_mod
277C-----------------------------------------------
278C I m p l i c i t T y p e s
279C-----------------------------------------------
280#include "implicit_f.inc"
281C-----------------------------------------------
282C D u m m y A r g u m e n t s
283C-----------------------------------------------
284 TYPE(TTABLE) :: TABLE
285 my_real ,DIMENSION(:) :: xx
286 my_real :: yy
287C-----------------------------------------------
288C L o c a l V a r i a b l e s
289C-----------------------------------------------
290 TYPE(TTABLE_XY), POINTER :: TY
291 INTEGER NDIM, I,K,IP,IN,IM,IL,P,N,M,L,N1,N12,N123
292 INTEGER NXK(4),IPOS(4)
293 INTEGER IB(2,2,2,2)
294 my_real
295 . dx1,dx2,r(4),unr(4)
296C-----------------------------------------------
297 ndim=table%NDIM
298 IF( SIZE(xx) < ndim )THEN
299 CALL ancmsg(msgid=36,anmode=aninfo,
300 . c1='TABLE INTERPOLATION')
301 CALL arret(2)
302 END IF
303C-----
304 ipos(1:ndim)= 1
305 r(1:ndim) = one
306c
307 DO k=1,ndim
308 nxk(k) = SIZE(table%X(k)%VALUES)
309 DO i=2,nxk(k)
310 dx2 = table%X(k)%VALUES(i) - xx(k)
311 IF (dx2>=zero .OR. i==nxk(k)) THEN
312 ipos(k)=i-1
313 r(k) =(table%X(k)%VALUES(i)-xx(k))/
314 . (table%X(k)%VALUES(i)-table%X(k)%VALUES(i-1))
315 EXIT
316 ENDIF
317 END DO
318
319 unr(k) = one - r(k)
320
321 END DO
322C-----
323 ty=>table%Y
324 SELECT CASE(ndim)
325
326 CASE(4)
327
328 n1 =nxk(1)
329 n12 =nxk(1)*nxk(2)
330 n123=n12 *nxk(3)
331 DO p=0,1
332 ip=n123*(ipos(4)-1+p)
333 DO n=0,1
334 in=n12*(ipos(3)-1+n)
335 DO m=0,1
336 im=n1*(ipos(2)-1+m)
337 DO l=0,1
338 il=ipos(1)+l
339 ib(l+1,m+1,n+1,p+1)=ip+in+im+il
340 END DO
341 END DO
342 END DO
343 END DO
344C
345 yy = r(4) * (r(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
346 . + unr(2) * (r(1)*ty%VALUES(ib(1,2,1,1)) + unr(1)*ty%VALUES(ib(2,2,1,1))))
347 . +unr(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,2,1)) + unr(1)*ty%VALUES(ib(2,1,2,1)))
348 . + unr(2) * (r(1)*ty%VALUES(ib(1,2,2,1)) + unr(1)*ty%VALUES(ib(2,2,2,1)))))
349 . +unr(4) *(r(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,1,2)) + unr(1)*ty%VALUES(ib(2,1,1,2)))
350 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,1,2)) + unr(1)*ty%VALUES(ib(2,2,1,2))))
351 . +unr(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,2,2)) + unr(1)*ty%VALUES(ib(2,1,2,2)))
352 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,2,2)) + unr(1)*ty%VALUES(ib(2,2,2,2)))))
353C-----
354 CASE(3)
355
356 n1 = nxk(1)
357 n12 = nxk(1)*nxk(2)
358 DO n=0,1
359 in = n12*(ipos(3)-1+n)
360 DO m=0,1
361 im = n1*(ipos(2)-1+m)
362 DO l=0,1
363 il = ipos(1)+l
364 ib(l+1,m+1,n+1,1) = in+im+il
365 END DO
366 END DO
367 END DO
368c
369 IF (r(2) == one) THEN ! case when second variable has only one value
370 yy = r(3) * (r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
371 . + unr(3) * (r(1)*ty%VALUES(ib(1,1,2,1)) + unr(1)*ty%VALUES(ib(2,1,2,1)))
372 ELSE
373C
374 yy = r(3) *(r(2) * (r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
375 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,1,1)) + unr(1)*ty%VALUES(ib(2,2,1,1))))
376 . + unr(3) *(r(2) * (r(1)*ty%VALUES(ib(1,1,2,1)) + unr(1)*ty%VALUES(ib(2,1,2,1)))
377 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,2,1)) + unr(1)*ty%VALUES(ib(2,2,2,1))))
378 END IF
379C-----
380 CASE(2)
381
382 n1 =nxk(1)
383 DO m=0,1
384 im=n1*(ipos(2)-1+m)
385 DO l=0,1
386 il=ipos(1)+l
387 ib(l+1,m+1,1,1)=im+il
388 END DO
389 END DO
390C
391 yy = (r(2)*(r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
392 . +unr(2)*(r(1)*ty%VALUES(ib(1,2,1,1)) + unr(1)*ty%VALUES(ib(2,2,1,1))))
393
394C-----
395 CASE(1)
396
397C
398 yy = r(1) * ty%VALUES(ipos(1)) + unr(1) * ty%VALUES(ipos(1)+1)
399
400C-----
401 END SELECT
402
403 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
message_mod
Definition message_mod.F:1249
table_mod
Definition table_mod.F:112
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

◆ table_interp_dydx()

subroutine table_interp_dydx ( type(ttable) table,
dimension(xxdim) xx,
integer xxdim,
intent(out) yy,
intent(out) dydx )

Definition at line 418 of file table_tools.F.

419C-----------------------------------------------
420 USE table_mod
421 USE message_mod
422C-----------------------------------------------
423C I m p l i c i t T y p e s
424C-----------------------------------------------
425#include "implicit_f.inc"
426C-----------------------------------------------
427C D u m m y A r g u m e n t s
428C-----------------------------------------------
429 INTEGER XXDIM
430 TYPE(TTABLE) TABLE
431 my_real, INTENT(IN),DIMENSION(XXDIM) :: xx
432 my_real, INTENT(OUT) :: yy,dydx
433C-----------------------------------------------
434C L o c a l V a r i a b l e s
435C-----------------------------------------------
436 TYPE(TTABLE_XY), POINTER :: TY
437 INTEGER NDIM, I,K,IP,IN,IM,IL,P,N,M,L,N1,N12,N123
438 INTEGER NXK(4),IPOS(4)
439 INTEGER IB(2,2,2,2)
440 my_real
441 . dx1,dx2,r(4),unr(4)
442C-----------------------------------------------
443 ndim=table%NDIM
444 IF( xxdim < ndim )THEN
445 CALL ancmsg(msgid=36,anmode=aninfo,
446 . c1='TABLE INTERPOLATION')
447 CALL arret(2)
448 END IF
449C-----
450 ipos(1:ndim)= 1
451 r(1:ndim) = one
452c
453 DO k=1,ndim
454 nxk(k) = SIZE(table%X(k)%VALUES)
455 DO i=2,nxk(k)
456 dx2 = table%X(k)%VALUES(i) - xx(k)
457 IF (dx2>=zero .OR. i==nxk(k)) THEN
458 ipos(k)=i-1
459 r(k) =(table%X(k)%VALUES(i)-xx(k))/
460 . (table%X(k)%VALUES(i)-table%X(k)%VALUES(i-1))
461 EXIT
462 ENDIF
463 END DO
464
465 unr(k) = one - r(k)
466
467 END DO
468C-----
469 ty=>table%Y
470 SELECT CASE(ndim)
471
472 CASE(4)
473
474 n1 =nxk(1)
475 n12 =nxk(1)*nxk(2)
476 n123=n12 *nxk(3)
477 DO p=0,1
478 ip=n123*(ipos(4)-1+p)
479 DO n=0,1
480 in=n12*(ipos(3)-1+n)
481 DO m=0,1
482 im=n1*(ipos(2)-1+m)
483 DO l=0,1
484 il=ipos(1)+l
485 ib(l+1,m+1,n+1,p+1)=ip+in+im+il
486 END DO
487 END DO
488 END DO
489 END DO
490C
491 yy = r(4) * (r(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
492 . + unr(2) * (r(1)*ty%VALUES(ib(1,2,1,1)) + unr(1)*ty%VALUES(ib(2,2,1,1))))
493 . +unr(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,2,1)) + unr(1)*ty%VALUES(ib(2,1,2,1)))
494 . + unr(2) * (r(1)*ty%VALUES(ib(1,2,2,1)) + unr(1)*ty%VALUES(ib(2,2,2,1)))))
495 . +unr(4) *(r(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,1,2)) + unr(1)*ty%VALUES(ib(2,1,1,2)))
496 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,1,2)) + unr(1)*ty%VALUES(ib(2,2,1,2))))
497 . +unr(3)*(r(2) * (r(1)*ty%VALUES(ib(1,1,2,2)) + unr(1)*ty%VALUES(ib(2,1,2,2)))
498 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,2,2)) + unr(1)*ty%VALUES(ib(2,2,2,2)))))
499C-----
500 dydx =
501 . (r(4) * (r(3) * (r(2) * ( ty%VALUES(ib(2,1,1,1)) - ty%VALUES(ib(1,1,1,1)))
502 . +unr(2) * ( ty%VALUES(ib(2,2,1,1)) - ty%VALUES(ib(1,2,1,1))))
503 . + unr(3) * (r(2) * ( ty%VALUES(ib(2,1,2,1)) - ty%VALUES(ib(1,1,2,1)))
504 . + unr(2) * ( ty%VALUES(ib(2,2,2,1)) - ty%VALUES(ib(1,2,2,1)))))
505 . + unr(4) * (r(3) * (r(2) * ( ty%VALUES(ib(2,1,1,1)) - ty%VALUES(ib(1,1,1,1)))
506 . + unr(2) * ( ty%VALUES(ib(2,2,1,1)) - ty%VALUES(ib(1,2,1,1))))
507 . + unr(3) * (r(2) * ( ty%VALUES(ib(2,1,2,1)) - ty%VALUES(ib(1,1,2,1)))
508 . + unr(2) * ( ty%VALUES(ib(2,2,2,1)) - ty%VALUES(ib(1,2,2,1))))))/
509 . (table%X(1)%VALUES(ipos(1)+1)-table%X(1)%VALUES(ipos(1)))
510
511
512C-----
513 CASE(3)
514
515 n1 = nxk(1)
516 n12 = nxk(1)*nxk(2)
517 DO n=0,1
518 in = n12*(ipos(3)-1+n)
519 DO m=0,1
520 im = n1*(ipos(2)-1+m)
521 DO l=0,1
522 il = ipos(1)+l
523 ib(l+1,m+1,n+1,1) = in+im+il
524 END DO
525 END DO
526 END DO
527c
528 IF (r(2) == one) THEN ! case when second variable has only one value
529 yy = r(3) * (r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
530 . + unr(3) * (r(1)*ty%VALUES(ib(1,1,2,1)) + unr(1)*ty%VALUES(ib(2,1,2,1)))
531 ELSE
532C
533 yy = r(3) *(r(2) * (r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
534 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,1,1)) + unr(1)*ty%VALUES(ib(2,2,1,1))))
535 . + unr(3) *(r(2) * (r(1)*ty%VALUES(ib(1,1,2,1)) + unr(1)*ty%VALUES(ib(2,1,2,1)))
536 . +unr(2) * (r(1)*ty%VALUES(ib(1,2,2,1)) + unr(1)*ty%VALUES(ib(2,2,2,1))))
537 END IF
538
539 dydx =
540 . (r(3) * (r(2) * ( ty%VALUES(ib(2,1,1,1)) - ty%VALUES(ib(1,1,1,1)))
541 . + unr(2) * ( ty%VALUES(ib(2,2,1,1)) - ty%VALUES(ib(1,2,1,1))))
542 . + unr(3) * (r(2) * ( ty%VALUES(ib(2,1,2,1)) - ty%VALUES(ib(1,1,2,1)))
543 . +unr(2) * ( ty%VALUES(ib(2,2,2,1)) - ty%VALUES(ib(1,2,2,1)))))/
544 . (table%X(1)%VALUES(ipos(1)+1)-table%X(1)%VALUES(ipos(1)))
545C-----
546 CASE(2)
547
548 n1 =nxk(1)
549 DO m=0,1
550 im=n1*(ipos(2)-1+m)
551 DO l=0,1
552 il=ipos(1)+l
553 ib(l+1,m+1,1,1)=im+il
554 END DO
555 END DO
556C
557 yy = (r(2)*(r(1)*ty%VALUES(ib(1,1,1,1)) + unr(1)*ty%VALUES(ib(2,1,1,1)))
558 . +unr(2)*(r(1)*ty%VALUES(ib(1,2,1,1)) + unr(1)*ty%VALUES(ib(2,2,1,1))))
559
560 dydx =
561 . (r(2) * ( ty%VALUES(ib(2,1,1,1)) - ty%VALUES(ib(1,1,1,1)))
562 . + unr(2) * ( ty%VALUES(ib(2,2,1,1)) - ty%VALUES(ib(1,2,1,1))))/
563 . (table%X(1)%VALUES(ipos(1)+1)-table%X(1)%VALUES(ipos(1)))
564
565C-----
566 CASE(1)
567
568C
569 yy = r(1) * ty%VALUES(ipos(1)) + unr(1) * ty%VALUES(ipos(1)+1)
570
571 dydx = (ty%VALUES(ipos(1)+1)-ty%VALUES(ipos(1)))/
572 . (table%X(1)%VALUES(ipos(1)+1)-table%X(1)%VALUES(ipos(1)))
573
574C-----
575 END SELECT
576
577 RETURN

◆ table_interp_law76()

subroutine table_interp_law76 ( type(ttable) table,
integer ipos2,
dimension(:) xx,
r2,
dydx,
yy )

Definition at line 889 of file table_tools.F.

890C-----------------------------------------------
891 USE table_mod
892 USE message_mod
893C-----------------------------------------------
894C I m p l i c i t T y p e s
895C-----------------------------------------------
896#include "implicit_f.inc"
897C-----------------------------------------------
898C D u m m y A r g u m e n t s
899C-----------------------------------------------
900 TYPE(TTABLE) TABLE
901 my_real,
902 . DIMENSION(:) :: xx
903 my_real
904 . yy, r2,dydx
905 INTEGER IPOS2
906C-----------------------------------------------
907C L o c a l V a r i a b l e s
908C-----------------------------------------------
909 TYPE(TTABLE_XY), POINTER :: TY
910 INTEGER NDIM, K, NXK, I, IPOS, IB(2,2,2,2),
911 . IP,IN,IM,IL,P,N,M,L,N1,N12,N123
912 my_real
913 . dx1,dx,r(2),unr(2)
914C-----------------------------------------------
915 r(1:2) = huge(r(1))
916 ndim=table%NDIM
917 IF( SIZE(xx) < ndim )THEN
918 CALL ancmsg(msgid=36,anmode=aninfo,
919 . c1='TABLE INTERPOLATION')
920 CALL arret(2)
921 END IF
922 ipos = 1
923C-----
924 r(2)= r2
925 k=1
926 nxk=SIZE(table%X(1)%VALUES)
927 DO i=2,nxk
928 dx = table%X(1)%VALUES(i) - xx(1)
929 IF(dx >= zero.OR.i == nxk)THEN
930 ipos=i-1
931 r(1) =(table%X(1)%VALUES(i)-xx(1))/
932 . (table%X(1)%VALUES(i)-table%X(1)%VALUES(i-1))
933 EXIT
934 ENDIF
935 END DO
936C-----
937 ty=>table%Y
938 SELECT CASE(ndim)
939C-----
940 CASE(2)
941
942 n1 =nxk
943 DO m=0,1
944 im=n1*(ipos2-1+m)
945 DO l=0,1
946 il=ipos+l
947 ib(l+1,m+1,1,1)=im+il
948 END DO
949 END DO
950C
951 DO k=1,2
952 unr(k)=one-r(k)
953 END DO
954C
955 yy=( r(2)*( r(1)*ty%VALUES(ib(1,1,1,1))
956 . +unr(1)*ty%VALUES(ib(2,1,1,1)))
957 . +unr(2)*( r(1)*ty%VALUES(ib(1,2,1,1))
958 . +unr(1)*ty%VALUES(ib(2,2,1,1))))
959 dydx=
960 . (r(2)*( ty%VALUES(ib(2,1,1,1))
961 . -ty%VALUES(ib(1,1,1,1)))
962 . +unr(2)*( ty%VALUES(ib(2,2,1,1))
963 . -ty%VALUES(ib(1,2,1,1))))
964 . /(table%X(1)%VALUES(ipos+1)-table%X(1)%VALUES(ipos))
965
966C-----
967 CASE(1)
968
969 DO k=1,2
970 unr(k)=one-r(k)
971 END DO
972C
973 yy=r(1)*ty%VALUES(ipos)
974 . +unr(1)*ty%VALUES(ipos+1)
975 dydx=(ty%VALUES(ipos+1)-ty%VALUES(ipos))
976 . /(table%X(1)%VALUES(ipos+1)-table%X(1)%VALUES(ipos))
977
978C-----
979 END SELECT
980 RETURN

◆ table_rresti()

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

Definition at line 162 of file table_tools.F.

163C-----------------------------------------------
164 USE table_mod
165 USE message_mod
166C-----------------------------------------------
167C I m p l i c i t T y p e s
168C-----------------------------------------------
169#include "implicit_f.inc"
170C-----------------------------------------------
171C A n a l y s e M o d u l e
172C-----------------------------------------------
173C C o m m o n B l o c k s
174C-----------------------------------------------
175#include "com04_c.inc"
176C-----------------------------------------------
177C D u m m y A r g u m e n t s
178C-----------------------------------------------
179 TYPE(TTABLE) TABLE(*)
180C-----------------------------------------------
181C L o c a l V a r i a b l e s
182C-----------------------------------------------
183 INTEGER LEN, N, K, NXK, NY, STAT, NDIM
184C--------------------------------------
185 DO n=1,ntable
186 len =1
187 CALL read_i_c(table(n)%NOTABLE,len)
188 len =1
189 CALL read_i_c(ndim,len)
190 table(n)%NDIM=ndim
191
192 ALLOCATE(table(n)%X(ndim),stat=stat)
193 IF(stat/=0) GOTO 1000
194
195 DO k=1,table(n)%NDIM
196 len =1
197 CALL read_i_c(nxk,len)
198 ALLOCATE(table(n)%X(k)%VALUES(nxk),stat=stat)
199 IF(stat/=0) GOTO 1000
200 END DO
201 len =1
202 CALL read_i_c(ny,len)
203
204 ALLOCATE(table(n)%Y,stat=stat)
205 IF(stat/=0) GOTO 1000
206
207 ALLOCATE(table(n)%Y%VALUES(ny),stat=stat)
208 IF(stat/=0) GOTO 1000
209 END DO
210 RETURN
211C--------------------------------------
212 1000 CONTINUE
213 CALL ancmsg(msgid=20,anmode=aninfo)
214 CALL arret(2)
215C--------------------------------------
read_i_c
void read_i_c(int *w, int *len)
Definition write_routtines.c:805

◆ table_rrestr()

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

Definition at line 226 of file table_tools.F.

227C-----------------------------------------------
228 USE table_mod
229C-----------------------------------------------
230C I m p l i c i t T y p e s
231C-----------------------------------------------
232#include "implicit_f.inc"
233C-----------------------------------------------
234C C o m m o n B l o c k s
235C-----------------------------------------------
236#include "com04_c.inc"
237C-----------------------------------------------
238C D u m m y A r g u m e n t s
239C-----------------------------------------------
240 TYPE(TTABLE) TABLE(*)
241C-----------------------------------------------
242C L o c a l V a r i a b l e s
243C-----------------------------------------------
244 INTEGER LEN, N, K, STAT, i
245C--------------------------------------
246 DO n=1,ntable
247 DO k=1,table(n)%NDIM
248 len = SIZE( table(n)%X(k)%VALUES )
249 CALL read_db(table(n)%X(k)%VALUES,len)
250 END DO
251 len = SIZE( table(n)%Y%VALUES )
252 CALL read_db(table(n)%Y%VALUES,len)
253 END DO
254 RETURN
read_db
subroutine read_db(a, n)
Definition read_db.F:88

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

621C-----------------------------------------------
622 USE table_mod
623 USE message_mod
624C-----------------------------------------------
625C I m p l i c i t T y p e s
626C-----------------------------------------------
627#include "implicit_f.inc"
628C-----------------------------------------------
629C D u m m y A r g u m e n t s
630C-----------------------------------------------
631 TYPE(TTABLE) TABLE
632 INTEGER ,INTENT(IN) :: NEL
633 INTEGER ,VALUE ,INTENT(IN) :: DIMX
634 INTEGER ,DIMENSION(DIMX,TABLE%NDIM) :: IPOS
635 my_real ,DIMENSION(DIMX,TABLE%NDIM) :: xx
636 my_real ,DIMENSION(NEL) :: yy, dydx1
637C-----------------------------------------------
638C L o c a l V a r i a b l e s
639C-----------------------------------------------
640 LOGICAL, DIMENSION(NEL) :: NEED_TO_COMPUTE
641 INTEGER NDIM, K, NXK(4), I, IB(NEL,2,2,2,2),
642 . IP,IN,IM,IL,P,N,M,L,N1,N12,N123
643 my_real :: dx2,r(nel,4),unr(nel,4),dx2_0(nel)
644 INTEGER :: J
645 INTEGER :: NINDX_1,M_INDX1,NINDX_2,M_INDX2
646 INTEGER, DIMENSION(NEL) :: INDX_1,INDX_2
647C-----------------------------------------------
648 r(1:nel,1:4) = zero
649 ndim=table%NDIM
650 IF( SIZE(xx,2) < table%NDIM )THEN
651 CALL ancmsg(msgid=36,anmode=aninfo,
652 . c1='TABLE INTERPOLATION')
653 CALL arret(2)
654 END IF
655C-----
656 DO k=1,ndim
657 nxk(k)=SIZE(table%X(k)%VALUES)
658 ENDDO
659
660 DO k=1,ndim
661 ipos(1:nel,k)=max(ipos(1:nel,k),1)
662 nindx_1 = 0
663 m_indx1 = 0
664 nindx_2 = 0
665 m_indx2 = nxk(k) + 1
666#include "vectorize.inc"
667 DO i=1,nel
668 m = ipos(i,k)
669 dx2_0(i) = table%X(k)%VALUES(m) - xx(i,k)
670 IF(dx2_0(i) >= zero)THEN
671 nindx_1 = nindx_1 + 1
672 indx_1(nindx_1) = i
673 m_indx1 = max(m_indx1,m)
674 ELSE
675 nindx_2 = nindx_2 + 1
676 indx_2(nindx_2) = i
677 m_indx2 = min(m_indx2,m)
678 ENDIF
679 ENDDO
680
681 need_to_compute(1:nindx_1) = .true.
682 DO n=m_indx1,1,-1
683#include "vectorize.inc"
684 DO j=1,nindx_1
685 IF(need_to_compute(j)) THEN
686 i = indx_1(j)
687 m = ipos(i,k)
688 dx2 = table%X(k)%VALUES(n) - xx(i,k)
689 IF(dx2<zero.OR.n <=1)THEN
690 ipos(i,k)=max(n,1) !N
691 need_to_compute(j) = .false.
692 ENDIF
693 ENDIF
694 ENDDO
695 ENDDO
696 need_to_compute(1:nindx_2) = .true.
697 DO n=m_indx2,nxk(k)
698#include "vectorize.inc"
699 DO j=1,nindx_2
700 IF(need_to_compute(j)) THEN
701 i = indx_2(j)
702 m = ipos(i,k)
703 dx2 = table%X(k)%VALUES(n) - xx(i,k)
704 IF(dx2>=zero.OR.n==nxk(k))THEN
705 ipos(i,k)=n-1
706 need_to_compute(j) = .false.
707 ENDIF
708 ENDIF
709 ENDDO
710 ENDDO
711 ENDDO
712
713 DO k=1,ndim
714#include "vectorize.inc"
715 DO i=1,nel
716 n = ipos(i,k)
717 r(i,k) =(table%X(k)%VALUES(n+1)-xx(i,k))/
718 . (table%X(k)%VALUES(n+1)-table%X(k)%VALUES(n))
719 END DO
720 END DO
721C-----
722 SELECT CASE(ndim)
723
724 CASE(4)
725C
726 n1 =nxk(1)
727 n12 =nxk(1)*nxk(2)
728 n123=n12 *nxk(3)
729 DO i=1,nel
730 DO p=0,1
731 ip=n123*(ipos(i,4)-1+p)
732 DO n=0,1
733 in=n12*(ipos(i,3)-1+n)
734 DO m=0,1
735 im=n1*(ipos(i,2)-1+m)
736 DO l=0,1
737 il=ipos(i,1)+l
738 ib(i,l+1,m+1,n+1,p+1)=ip+in+im+il
739 END DO
740 END DO
741 END DO
742 END DO
743 END DO
744C
745 unr(1:nel,1:4)=one-r(1:nel,1:4)
746#include "vectorize.inc"
747 DO i=1,nel
748C
749 yy(i)=
750 . r(i,4)*(r(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
751 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
752 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
753 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
754 . +unr(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,2,1))
755 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,2,1)))
756 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,2,1))
757 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,2,1)))))
758 . +unr(i,4)*(r(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
759 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
760 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
761 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
762 . +unr(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,2,1))
763 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,2,1)))
764 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,2,1))
765 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,2,1)))))
766C
767 dydx1(i)=
768 . (r(i,4)*(r(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
769 . -table%Y%VALUES(ib(i,1,1,1,1)))
770 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
771 . -table%Y%VALUES(ib(i,1,2,1,1))))
772 . +unr(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,2,1))
773 . -table%Y%VALUES(ib(i,1,1,2,1)))
774 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,2,1))
775 . -table%Y%VALUES(ib(i,1,2,2,1)))))
776 . +unr(i,4)*(r(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
777 . -table%Y%VALUES(ib(i,1,1,1,1)))
778 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
779 . -table%Y%VALUES(ib(i,1,2,1,1))))
780 . +unr(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,2,1))
781 . -table%Y%VALUES(ib(i,1,1,2,1)))
782 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,2,1))
783 . -table%Y%VALUES(ib(i,1,2,2,1))))))/
784 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
785
786 END DO
787C-----
788 CASE(3)
789C
790 n1 =nxk(1)
791 n12 =nxk(1)*nxk(2)
792 DO i=1,nel
793 DO n=0,1
794 in=n12*(ipos(i,3)-1+n)
795 DO m=0,1
796 im=n1*(ipos(i,2)-1+m)
797 DO l=0,1
798 il=ipos(i,1)+l
799 ib(i,l+1,m+1,n+1,1)=in+im+il
800 END DO
801 END DO
802 END DO
803 END DO
804C
805 unr(1:nel,1:3)=one-r(1:nel,1:3)
806#include "vectorize.inc"
807 DO i=1,nel
808C
809 yy(i)=
810 . (r(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
811 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
812 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
813 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
814 . +unr(i,3)*(r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,2,1))
815 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,2,1)))
816 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,2,1))
817 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,2,1)))))
818C
819 dydx1(i)=
820 . (r(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
821 . -table%Y%VALUES(ib(i,1,1,1,1)))
822 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
823 . -table%Y%VALUES(ib(i,1,2,1,1))))
824 . +unr(i,3)*(r(i,2)*( table%Y%VALUES(ib(i,2,1,2,1))
825 . -table%Y%VALUES(ib(i,1,1,2,1)))
826 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,2,1))
827 . -table%Y%VALUES(ib(i,1,2,2,1)))))/
828 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
829C
830 END DO
831C-----
832 CASE(2)
833C
834 n1 =nxk(1)
835 DO i=1,nel
836 DO m=0,1
837 im=n1*(ipos(i,2)-1+m)
838 DO l=0,1
839 il=ipos(i,1)+l
840 ib(i,l+1,m+1,1,1)=im+il
841 END DO
842 END DO
843 END DO
844C
845 unr(1:nel,1:2)=one-r(1:nel,1:2)
846#include "vectorize.inc"
847 DO i=1,nel
848C
849 yy(i)=
850 . (r(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,1,1,1))
851 . +unr(i,1)*table%Y%VALUES(ib(i,2,1,1,1)))
852 . +unr(i,2)*(r(i,1)*table%Y%VALUES(ib(i,1,2,1,1))
853 . +unr(i,1)*table%Y%VALUES(ib(i,2,2,1,1))))
854 dydx1(i)=
855 . (r(i,2)*( table%Y%VALUES(ib(i,2,1,1,1))
856 . -table%Y%VALUES(ib(i,1,1,1,1)))
857 . +unr(i,2)*( table%Y%VALUES(ib(i,2,2,1,1))
858 . -table%Y%VALUES(ib(i,1,2,1,1))))/
859 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
860 END DO
861C-----
862 CASE(1)
863
864 unr(1:nel,1:1)=one-r(1:nel,1:1)
865#include "vectorize.inc"
866 DO i=1,nel
867C
868 yy(i)= r(i,1)*table%Y%VALUES(ipos(i,1))
869 . +unr(i,1)*table%Y%VALUES(ipos(i,1)+1)
870 dydx1(i)=(table%Y%VALUES(ipos(i,1)+1)-table%Y%VALUES(ipos(i,1)))/
871 . (table%X(1)%VALUES(ipos(i,1)+1)-table%X(1)%VALUES(ipos(i,1)))
872 END DO
873C-----
874 END SELECT
875 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 67 of file table_tools.F.

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

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