ttable.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
module m_table
  implicit none
  integer, parameter, private :: kreal = kind(0.0d0)
 
  !
  ! The length of the keys
  !
  integer, parameter :: dict_key_length = 128
  integer, parameter :: maxindex = 20
  integer, parameter :: maxnval = 10000
 
  !
  ! The data that will be stored with each key
  type ttable
    integer                     :: ndepends
    integer                     :: tbcol, tbrow
    integer                     :: tbindex(maxindex)
    real(kind=kreal), pointer   :: tbval(:,:)=>null()
  end type ttable
 
  !
  ! The "null" value for these data
  !
  type(ttable), parameter :: dict_null = ttable( 0,0,0, 0,null() )
 
  interface assignment(=)
    module procedure tablecopy
  end interface
 
  interface operator(==)
    module procedure tablecompare
  end interface
 
contains
 
  subroutine init_table( table, ndp, col, row, tbval )
    type( ttable ), intent(inout)   :: table
    integer, intent(in)             :: ndp, col, row
    real(kind=kreal), intent(in)    :: tbval(col,row)
    integer :: i,j
    real(kind=kreal) :: tbindexval(maxnval)
    if( associated( table%tbval ) ) deallocate( table%tbval )
    table%tbcol = col
    table%tbrow = row
    table%ndepends = ndp
    allocate( table%tbval( col, row ) )
    do i=1, col
      do j=1, row
        table%tbval(i,j) = tbval(i,j)
      enddo
    enddo
 
    do i=1,ndp
      table%tbindex(i) =1
      tbindexval(1) = table%tbval(table%tbcol-i+1, 1)
      ! print *, 0, i, table%tbindex(i), tbindexval(1)
 
      do j=2, table%tbrow
        if( any( tbindexval(1:table%tbindex(i))==table%tbval(table%tbcol-i+1, j) ) ) cycle
        table%tbindex(i) = table%tbindex(i)+1
        tbindexval(table%tbindex(i)) = table%tbval(table%tbcol-i+1, j)
        !     print *, 1, i, table%tbindex(i), tbindexval(table%tbindex(i))
      enddo
    enddo
 
    j=1
    do i=1,ndp
      j=j*table%tbindex(i)
    enddo
    if( j/= row) stop "Error in table definition!"
    !  print *, j,row, table%tbindex(1:ndp); pause
  end subroutine
 
  subroutine finalize_table( table )
    type( ttable ), intent(inout) :: table
    if( associated( table%tbval ) ) deallocate( table%tbval )
  end subroutine
 
  subroutine print_table( table, fname )
    type( ttable ), intent(in) :: table
    integer, intent(in)        :: fname
    integer :: i,j
    write(fname,*) table%ndepends, table%tbcol, table%tbrow
    do i=1,table%tbrow
      write(fname,*) i,(table%tbval(j,i),j=1,table%tbcol)
    enddo
  end subroutine
 
  logical function tablecompare( lhs, rhs )
    type(ttable), intent(in) :: lhs
    type(ttable), intent(in) :: rhs
    integer :: i,j
    tablecompare = .false.
    if( lhs%ndepends /= rhs%ndepends ) return
    if( lhs%tbcol /= rhs%tbcol ) return
    if( lhs%tbrow /= rhs%tbrow ) return
    do i=1, rhs%ndepends
      if( lhs%tbindex(i) /= rhs%tbindex(i) ) return
    enddo
    do i=1, rhs%tbcol
      do j=1, rhs%tbrow
        if( lhs%tbval(i,j) /= rhs%tbval(i,j) ) return
      enddo
    enddo
    tablecompare = .true.
  end function
 
  subroutine tablecopy( lhs, rhs )
    type(ttable), intent(out) :: lhs
    type(ttable), intent(in)  :: rhs
 
    lhs%ndepends = rhs%ndepends
    lhs%tbcol = rhs%tbcol
    lhs%tbrow = rhs%tbrow
    lhs%tbindex(:) = rhs%tbindex(:)
    if( associated( lhs%tbval ) ) deallocate( lhs%tbval )
    if( rhs%tbcol<=0 .or. rhs%tbrow<=0 ) return
    allocate( lhs%tbval( lhs%tbcol, lhs%tbrow ) )
    lhs%tbval(:,:) = rhs%tbval(:,:)
  end subroutine
 
end module m_table
 
!======================================================================!
!
!
!======================================================================!
 
module table_dicts
  use m_table, dict_data => ttable
  implicit none
  integer, parameter, private :: kreal = kind(0.0d0)
 
  private :: gettablegrad, gettabledata
 
  include "dictionary.f90"
 
 
  subroutine fetch_table( key, dict, dicval, ierr )
    character(len=*), intent(in)   :: key
    type(dict_struct), pointer     :: dict
    logical, intent(out)           :: ierr
    type(dict_data), pointer       :: dicval
 
    dicval => dict_get_key( dict, key )
    ierr = .false.
    if( .not. associated(dicval) ) then
      ierr=.true.;  return
    endif
 
  end subroutine
 
 
  integer function fetch_tablerow( key, dict )
    character(len=*), intent(in)   :: key
    type(dict_struct), pointer     :: dict
    type(dict_data), pointer       :: dicval
 
    dicval => dict_get_key( dict, key )
    fetch_tablerow = -1
    if( .not. associated(dicval) ) return
    fetch_tablerow = dicval%tbrow
    ! call finalize_table( dicval )
  end function
 
  subroutine fetch_tablegrad( key, a, dict, outa, ierr )
    character(len=*), intent(in)   :: key
    real(kind=kreal), intent(in)   :: a(:)    
    type(dict_struct), pointer     :: dict
    real(kind=kreal), intent(out)  :: outa    
    logical, intent(out)           :: ierr
 
    type(dict_data), pointer       :: dicval
    integer          :: na, dd, crow, cindex
    dicval => dict_get_key( dict, key )
    ierr = .false.
    if( .not. associated(dicval) ) then
      ierr=.true.;  return
    endif
 
    cindex = 1;  crow=1
    dd = dicval%tbrow
    na = 1
    if( size(a) > dicval%ndepends ) then   ! in case no dependent definition
      na = size(a) - dicval%ndepends+1
    endif
 
    call gettablegrad( a(na:), cindex, dicval, dd, crow, outa )
    ! call finalize_table( dicval )
 
  end subroutine
 
  recursive subroutine gettablegrad( a, cindex, table, dd, crow, outa )
    real(kind=kreal), intent(in)   :: a(:)
    integer, intent(inout)         :: cindex
    type(dict_data)                :: table
    integer, intent(inout)         :: dd, crow
    real(kind=kreal), intent(out)  :: outa
 
    integer          :: i, ccol, ddd
    real(kind=kreal) :: val1, val2, lambda
 
    ddd = dd / table%tbindex(cindex)
    ccol = table%tbcol-cindex+1
 
    if( ddd==1 ) then
      if( a(cindex)<table%tbval(2, crow) ) then
        outa = 0.d0
      elseif( a(cindex)>=table%tbval(2, crow+dd-1) ) then
        outa = 0.d0
      else
        do i=crow, crow+dd-2
          if( a(cindex)>=table%tbval(2, i) .and. a(cindex)<table%tbval(2, i+1) ) then
            outa = (table%tbval(1, i+1)-table%tbval(1, i))/(table%tbval(2, i+1)-table%tbval(2, i))
            exit
          endif
        enddo
      endif
    else
      if( a(cindex)<=table%tbval(ccol, crow) ) then
        cindex = cindex+1
        dd = ddd
        call gettablegrad( a, cindex, table, dd, crow, outa )
      elseif( a(cindex)>=table%tbval(ccol, crow+dd-1) ) then
        crow = crow+dd-ddd
        cindex = cindex+1
        dd = ddd
        call gettablegrad( a, cindex, table, dd, crow, outa )
      else
        do i=crow, crow+dd-2, ddd
          if( a(cindex)==table%tbval(ccol, i) ) then
            crow = i
            cindex = cindex+1
            dd = ddd
            call gettablegrad( a, cindex, table, dd, crow, outa )
            exit
          elseif( a(cindex)==table%tbval(ccol, i+ddd) ) then
            crow = i+ddd
            cindex = cindex+1
            dd = ddd
            call gettablegrad( a, cindex, table, dd, crow, outa )
            exit
          elseif( a(cindex)>table%tbval(ccol, i) .and. a(cindex)<table%tbval(ccol, i+ddd) ) then
            crow=i
            cindex = cindex+1
            dd = ddd
            call gettablegrad( a, cindex, table, dd, crow, val1 )
            crow = i+ddd
            call gettablegrad( a, cindex, table, dd, crow, val2 )
            lambda = (a(cindex-1)-table%tbval(ccol, i))/(table%tbval(ccol, crow)-table%tbval(ccol, i))
            outa = (1.d0-lambda)*val1+ lambda* val2
            exit
          endif
        enddo
      endif
    endif
 
  end subroutine
 
  subroutine fetch_tabledata( key, dict, outa, ierr, a )
    character(len=*), intent(in)   :: key
    type(dict_struct), pointer     :: dict
    real(kind=kreal), intent(out)  :: outa(:) 
    logical, intent(out)           :: ierr
    real(kind=kreal), intent(in), optional   :: a(:)    
 
    type(dict_data), pointer       :: dicval
    integer          :: nval, na, dd, crow, cindex
 
    dicval => dict_get_key( dict, key )
    ierr = .false.
    if( .not. associated(dicval) ) then
      ierr=.true.;  return
    endif
    !  call print_table( dicval, 6 )
 
    nval = dicval%tbcol-dicval%ndepends
    if( nval /= size(outa) ) then
      ierr=.true.;  return
    endif
    if( dicval%tbrow==1 ) then
      outa(:) =dicval%tbval(1:nval, 1); return
    endif
    if( .not. present(a) ) then
      outa(:) =dicval%tbval(1:nval, 1); return
    endif
 
    cindex = 1;  crow=1
    dd = dicval%tbrow
    na = 1
    if( size(a) > dicval%ndepends ) then   ! in case no dependent definition
      na = size(a) - dicval%ndepends+1
    endif
    !  if( size(a) < dicval%ndepends ) then   ! in case take no consider of dependent definition
    !    na = dicval%ndepends- size(a)+1
    !    cindex = na
    !  endif
    call gettabledata( a(na:), cindex, dicval, dd, crow, outa )
    !  call finalize_table( dicval )
 
  end subroutine
 
  recursive subroutine gettabledata( a, cindex, table, dd, crow, outa )
    real(kind=kreal), intent(in)   :: a(:)
    integer, intent(inout)         :: cindex
    type(dict_data)                :: table
    integer, intent(inout)         :: dd, crow
    real(kind=kreal), intent(out)  :: outa(:)
 
    integer          :: i, ccol, ddd, nval
    real(kind=kreal) :: lambda, val1(maxindex), val2(maxindex)
 
    ddd = dd / table%tbindex(cindex)
    ccol = table%tbcol-cindex+1
    nval = size(outa)
 
    if( ddd==1 ) then
      if( a(cindex)<table%tbval(ccol, crow) ) then
        outa(:) = table%tbval(1:ccol-1, crow)
      elseif( a(cindex)>=table%tbval(ccol, crow+dd-1) ) then
        outa(:) = table%tbval(1:ccol-1, crow+dd-1)
      else
        do i=crow, crow+dd-2
          if( a(cindex)>=table%tbval(ccol, i) .and. a(cindex)<table%tbval(ccol, i+1) ) then
            lambda = (a(cindex)-table%tbval(ccol, i))/(table%tbval(ccol, i+1)-table%tbval(ccol, i))
            outa(:) = (1.d0-lambda)*table%tbval(1:ccol-1, i)+ lambda* table%tbval(1:ccol-1, i+1)
            exit
          endif
        enddo
      endif
    else
      if( a(cindex)<=table%tbval(ccol, crow) ) then
        cindex = cindex+1
        dd = ddd
        call gettabledata( a, cindex, table, dd, crow, outa )
      elseif( a(cindex)>=table%tbval(ccol, crow+dd-1) ) then
        crow = crow+dd-ddd
        cindex = cindex+1
        dd = ddd
        call gettabledata( a, cindex, table, dd, crow, outa )
      else
        do i=crow, crow+dd-2, ddd
          if( a(cindex)==table%tbval(ccol, i) ) then
            crow = i
            cindex = cindex+1
            dd = ddd
            call gettabledata( a, cindex, table, dd, crow, outa )
            exit
          elseif( a(cindex)==table%tbval(ccol, i+ddd) ) then
            crow = i+ddd
            cindex = cindex+1
            dd = ddd
            call gettabledata( a, cindex, table, dd, crow, outa )
            exit
          elseif( a(cindex)>table%tbval(ccol, i) .and. a(cindex)<table%tbval(ccol, i+ddd) ) then
            crow=i
            cindex = cindex+1
            dd = ddd
            call gettabledata( a, cindex, table, dd, crow, val1(1:nval) )
            crow = i+ddd
            call gettabledata( a, cindex, table, dd, crow, val2(1:nval) )
            lambda = (a(cindex-1)-table%tbval(ccol, i))/(table%tbval(ccol, crow)-table%tbval(ccol, i))
            outa(:) = (1.d0-lambda)*val1(1:nval)+ lambda* val2(1:nval)
            exit
          endif
        enddo
      endif
    endif
 
  end subroutine
 
 
  subroutine print_tabledata( dict, fname )
    type(dict_struct), pointer     :: dict
    integer, intent(in)            :: fname
 
    type(linked_list), pointer  :: current
    integer :: i
    do i = 1,size(dict%table)
      if ( associated( dict%table(i)%list ) ) then
        current => dict%table(i)%list
        do while ( associated(current) )
          if( trim(current%data%key) /= 'INIT' ) then
            write( fname, * ) trim(current%data%key)
            call print_table( current%data%value, fname )
          endif
          current => current%next
        enddo
      endif
    enddo
  end subroutine
 
end module table_dicts