/tools/flat_table_2D.f90
https://bitbucket.org/NeilMiller/h5tbuilder · Fortran Modern · 401 lines · 304 code · 71 blank · 26 comment · 36 complexity · 5e568400da773267598c783436bd8bea MD5 · raw file
- module table_2D_mod
- use flat_interpolator_mod
- implicit none
-
- integer, private, parameter :: NDIM = 2
- type :: table_2D
-
- private
- character(LEN=80) :: name
- logical :: initialized = .false.
- integer :: nderiv
- integer :: nmax1
- integer :: nmax2
- integer, dimension(NDIM) :: nx
- logical, dimension(NDIM) :: log_spc
- real(8), dimension(NDIM) :: x0
- real(8), dimension(NDIM) :: xmax
- real(8), dimension(NDIM) :: dx
- logical, dimension(NDIM) :: zero = .false. ! Allows for zero point on logarithmic grids
- ! If true, the first position in the table
- ! along a dimension corresponds to zero and
- ! the second point has the value x0 (instead
- ! of the first)
- real(8), dimension(:,:), allocatable :: tab
- real(8), dimension(:,:), allocatable :: xx
- type(flat_interpolator) :: interpol
-
- contains
- procedure :: init => init_table_2D
- procedure :: get_xmin => get_xmin_table_2D
- procedure :: get_xmax => get_xmax_table_2D
- procedure :: load_slab_der => load_slab_der_table_2D
- procedure :: load_slab_pos => load_slab_pos_table_2D
- procedure :: interp => interp_table_2D
-
- end type table_2D
-
- private :: init_table_2D
- private :: get_xmin_table_2D
- private :: get_xmax_table_2D
- private :: load_slab_der_table_2D
- private :: load_slab_pos_table_2D
- private :: interp_table_2D
- private :: table_position
- contains
- function get_xmin_table_2D(this,id) result(xmin)
- real(8) :: xmin
- class(table_2D), intent(in) :: this
- integer, intent(in) :: id
- if (id<=NDIM.and.id>0) then
- xmin = this%x0(id)
- else
- xmin = this%x0(NDIM)
- endif
- return
- end function get_xmin_table_2D
- function get_xmax_table_2D(this,id) result(xmax)
- real(8) :: xmax
- class(table_2D), intent(in) :: this
- integer, intent(in) :: id
- if (id<=NDIM.and.id>0) then
- xmax = this%xmax(id)
- else
- xmax = this%xmax(NDIM)
- endif
- return
- end function get_xmax_table_2D
-
- subroutine init_table_2D(this,nx,nderiv,x0,dx,log_spc,tab,zero)
-
- class(table_2D), intent(out) :: this
- integer, dimension(NDIM), intent(in) :: nx
- integer, dimension(NDIM), intent(in) :: nderiv
- real(8), dimension(NDIM), intent(in) :: x0,dx
- logical, dimension(NDIM), intent(in), optional :: log_spc
- logical, dimension(NDIM), intent(in), optional :: zero
- real(8), dimension(:,:,0:,0:), intent(in), optional :: tab
- integer :: ierr,i,j,i1,i2,i3,i4
-
- ! Set the array properties
- this%nx = nx
- this%x0 = x0
- this%dx = dx
- this%nderiv = MINVAL(nderiv(1:NDIM))
- if (present(zero).and.present(log_spc)) then
- do i=1,NDIM
- this%zero(i) = zero(i) .and. log_spc(i)
- this%log_spc(i) = log_spc(i)
- enddo
- elseif (present(log_spc)) then
- this%log_spc = log_spc
- this%zero = .false.
- else
- this%zero = .false.
- this%log_spc = .false.
- this%xmax = x0 + dx*(nx-1.d0)
- endif
-
- ! Build tables of point values
- ! This is done only to prevent numerous
- ! recalculations of 10.d0**x for
- ! logarithmic tables (i.e. a hash is used
- ! to find the table positions, not a table search).
- if (allocated(this%xx)) deallocate(this%xx)
- print *,1
- allocate(this%xx(MAXVAL(this%nx),NDIM))
- print *,2
- do i=1,NDIM
- if (this%log_spc(i).and.this%zero(i)) then
- this%xx(1,i) = 0.d0
- do j=2,this%nx(i)
- this%xx(j,i) = this%x0(i)*10.d0**(REAL(j-2)*this%dx(i))
- enddo
- elseif (this%log_spc(i)) then
- do j=1,this%nx(i)
- this%xx(j,i) = this%x0(i)*10.d0**(REAL(j-1)*this%dx(i))
- enddo
- else
- do j=1,this%nx(i)
- this%xx(j,i) = this%x0(i) + REAL(j-1)*this%dx(i)
- enddo
- endif
- enddo
- ! Set the flat array sizes
- this%nmax1 = (this%nderiv+1)**NDIM-1
- this%nmax2 = 1
- do i=1,NDIM
- this%nmax2 = this%nx(i)*this%nmax2
- enddo
- this%nmax2 = this%nmax2-1
-
- ! Allocate the table
- if (allocated(this%tab)) deallocate(this%tab)
- allocate(this%tab(0:this%nmax1,0:this%nmax2))
-
- this%initialized = .true.
-
- ! Load table if present
- if (present(tab)) then
- do i1=0,this%nderiv
- do i2=0,this%nderiv
- ierr = this%load_slab_der(tab(:,:,i1,i2),(/i1,i2/))
- if (ierr .ne. 0) print *, 'Table load error ',ierr
- enddo
- enddo
- endif
- return
-
- end subroutine
- function load_slab_der_table_2D(this,dat,ideriv) result(ierr)
-
- integer :: ierr
-
- class(table_2D), intent(inout) :: this
- real(8), dimension(:,:), intent(in) :: dat
- integer, dimension(:), intent(in) :: ideriv
-
- integer :: i,id,ii,i1,i2,i3,i4
- ierr = 0
- ! Can't load an uninitialized table
- if (.not.this%initialized) then
- ierr = -1
- return
- endif
-
- ! Check that the array is large enough
- if (SIZE(dat)<this%nmax2+1) then
- ierr = i
- return
- endif
- ! Check derivative position specification
- if (SIZE(ideriv)<NDIM) then
- ierr = -2
- return
- endif
- do i=1,NDIM
- if (ideriv(i)<0 .or. ideriv(i)>this%nderiv) then
- ierr = -i-2
- return
- endif
- enddo
-
- ! Put it in the table
- id = 0
- do i=NDIM,1,-1
- id = (this%nderiv+1)*id + ideriv(i)
- enddo
- do i1=0,this%nx(1)-1
- do i2=0,this%nx(2)-1
- ii = this%nx(1)*i2 + i1
- this%tab(id,ii) = dat(i1+1,i2+1)
- enddo
- enddo
- return
-
- end function load_slab_der_table_2D
- function load_slab_pos_table_2D(this,dat,ipos) result(ierr)
-
- integer :: ierr
-
- class(table_2D), intent(inout) :: this
- real(8), dimension(:,:), intent(in) :: dat
- integer, dimension(:), intent(in) :: ipos
-
- integer :: i,id,ii,i1,i2,i3,i4
- ierr = 0
- ! Can't load an uninitialized table
- if (.not.this%initialized) then
- ierr = -1
- return
- endif
-
- ! Check that the array is large enough
- if (SIZE(dat)<this%nmax1+1) then
- ierr = i
- return
- endif
- ! Check derivative position specification
- if (SIZE(ipos)<NDIM) then
- ierr = -2
- return
- endif
- do i=1,NDIM
- if (ipos(i)<1 .or. ipos(i)>this%nx(i)) then
- ierr = -i-2
- return
- endif
- enddo
-
- ! Put it in the table
- ii = 0
- do i=NDIM,1,-1
- ii = this%nx(i)*id + ipos(i) - 1
- enddo
- do i1=0,this%nderiv
- do i2=0,this%nderiv
- id = (this%nderiv+1)*i2 + i1
- this%tab(id,ii) = dat(i1+1,i2+1)
- enddo
- enddo
- return
-
- end function load_slab_pos_table_2D
-
- function interp_table_2D(this,x,der,order) result(f)
-
- real(8) :: f
-
- class(table_2D) :: this
- real(8) :: x(NDIM),dd(NDIM),delta(NDIM)
- integer :: idx(NDIM)
- integer, optional :: der(NDIM)
- integer, optional :: order
- integer :: ierr,ipos(0:2**NDIM-1)
- integer :: ii,i1,i2,i3,i4
- if (present(order)) then
- print *,'Not allowing you to choose the order for now'
- endif
-
- if (this%nderiv==0) then
- ierr = this%interpol%set_order('linear')
- elseif (this%nderiv==1) then
- ierr = this%interpol%set_order('cubic')
- else
- ierr = this%interpol%set_order('quintic')
- endif
-
- call table_position(this,x,dd,idx,delta)
- ! write(*,*) "luketbl: dd = ", dd
- ! write(*,*) "luketbl: delta = ", delta
- do i1=0,1
- do i2=0,1
- ii = 2*i2 + i1
- ipos(ii) = this%nx(1)*(idx(2)-1 + i2) &
- + (idx(1)-1 + i1)
- enddo
- enddo
- if (present(der)) then
- f = this%interpol%f2D(dd,delta,this%tab(:,ipos),der,this%nderiv+1)
- else
- f = this%interpol%f2D(dd,delta,this%tab(:,ipos),(/0,0/),this%nderiv+1)
- endif
-
- return
- end function interp_table_2D
- subroutine table_position(this,x,dd,idx,delta)
-
- class(table_2D), intent(in) :: this
- real(8), dimension(NDIM), intent(in) :: x
- real(8), dimension(NDIM), intent(out) :: dd
- real(8), dimension(NDIM), intent(out), optional :: delta
- integer, dimension(NDIM), intent(out) :: idx
-
- real(8), dimension(NDIM) :: xt
- integer :: i
- real(8) :: xl,xh,x0
- integer, save :: nprint = 0
- ! Transform logarithmic dimensions
- do i=1,NDIM
- if (this%log_spc(i)) then
- xt(i) = log10(x(i))
- else
- xt(i) = x(i)
- endif
- enddo
-
- ! Hash into table
- do i=1,NDIM
- if (this%log_spc(i)) then
- x0 = log10(this%x0(i))
- else
- x0 = this%x0(i)
- endif
- if (xt(i)<x0) then
- idx(i) = 1
- if (this%log_spc(i) .and. this%zero(i)) then
- continue
- elseif (this%log_spc(i)) then
- if (nprint<20) write(6,'(a,i2,a,2es12.3)')'Value ',i,' off bottom of table.',10.d0**xt(i),10.d0**x0
- else
- if (nprint<20) write(6,'(a,i2,a,2es12.3)')'Value ',i,' off bottom of table.',xt(i),x0
- endif
- nprint = nprint + 1
- elseif (xt(i)==(x0 + (this%nx(i)-1)*this%dx(i))) then
- idx(i) = this%nx(i)-1
- elseif (xt(i)>(x0 + (this%nx(i)-1)*this%dx(i))) then
- idx(i) = this%nx(i)-1
- if (nprint<20) write(6,'(a,i2,a,2f5.1,i3)')'Value ',i,' off top of table.',xt(i),this%dx(i),this%nx(i)
- nprint = nprint + 1
- elseif (xt(i).ne.xt(i)) then
- idx(i) = 1
- if (nprint<20) write(6,'(a,i2,a,es12.3)')'Value ',i,' is NaN.',xt(i)
- nprint = nprint + 1
- else
- idx(i) = INT(FLOOR((xt(i)-x0)/this%dx(i))) + 1
- endif
- enddo
-
- ! Calculate fractional distances
- do i=1,NDIM
- if (idx(i)==1 .and. this%log_spc(i) .and. this%zero(i)) then
- dd(i) = x(i)/this%x0(i)
- if (present(delta)) delta(i) = this%x0(i)
- elseif (this%log_spc(i) .and. this%zero(i)) then
- idx(i) = idx(i) + 1 ! Set to the correct grid position
- xl = this%xx(idx(i),i)
- xh = this%xx(idx(i)+1,i)
- dd(i) = (x(i)-xl)/(xh-xl)
- if (present(delta)) delta(i) = xh-xl
- elseif (this%log_spc(i)) then
- xl = this%xx(idx(i),i)
- xh = this%xx(idx(i)+1,i)
- dd(i) = (x(i)-xl)/(xh-xl)
- if (present(delta)) delta(i) = xh-xl
- else
- dd(i) = (x(i)-(idx(i)-1)*this%dx(i) - this%x0(i))/this%dx(i)
- if (present(delta)) delta(i) = this%dx(i)
- endif
- if (dd(i).ne.dd(i)) dd(i) = 0.d0
- dd(i) = min(dd(i),1.0)
- dd(i) = max(dd(i),0.0)
- enddo
-
- return
-
- end subroutine table_position
- end module table_2D_mod