module mod_initgrid
  use mpi_f08
  use mod_param     , only:pi
  use mod_types
  implicit none
  private
  public initgrid,distribute_grid,bound_grid,save_grid
  contains
  subroutine initgrid(lo,hi,gt,gr,lmin,lmax,drc_g,drf_g,rc_g,rf_g)
    !
    ! initializes a non-uniform grid
    !
    ! NEEDS TO BE PROBABLY SLIGHTLY ADAPTED IN CASE IT IS IN THE MIDDLE OF A BLOCK
    !
    implicit none
    integer, parameter :: CLUSTER_TWO_END              = 0, &
                          CLUSTER_ONE_END              = 1, &
                          CLUSTER_MIDDLE               = 2, &
                          CLUSTER_ONE_END_R            = 3, &
                          CLUSTER_GEOMETRIC_ONE_END    = 4, &
                          CLUSTER_GEOMETRIC_ONE_END_R  = 5, &
                          CLUSTER_GEOMETRIC_TWO_ENDS   = 6, &
                          CLUSTER_GEOMETRIC_MIDDLE     = 7
    integer         , intent(in )                  :: lo,hi,gt
    real(rp)        , intent(in )                  :: gr,lmin,lmax
    real(rp)        , intent(out), dimension(lo-1:) :: drc_g,drf_g,rc_g,rf_g
    real(rp) :: r0
    integer :: q,n
    procedure (), pointer :: gridpoint => null()
    select case(gt)
    case(CLUSTER_TWO_END)
      gridpoint => gridpoint_cluster_two_end
    case(CLUSTER_ONE_END)
      gridpoint => gridpoint_cluster_one_end
    case(CLUSTER_MIDDLE)
      gridpoint => gridpoint_cluster_middle
    case(CLUSTER_ONE_END_R)
      gridpoint => gridpoint_cluster_one_end_r
    case(CLUSTER_GEOMETRIC_ONE_END)
     gridpoint => gridpoint_cluster_geometric_one_end
    CASE(CLUSTER_GEOMETRIC_ONE_END_R)
     gridpoint => gridpoint_cluster_geometric_one_end_r
    CASE(CLUSTER_GEOMETRIC_TWO_ENDS)
     gridpoint => gridpoint_cluster_geometric_two_ends
    CASE(CLUSTER_GEOMETRIC_MIDDLE)
     gridpoint => gridpoint_cluster_geometric_middle
    case default
      gridpoint => gridpoint_cluster_two_end
    end select
    !
    ! step 1) determine coordinates of cell faces rf
    !
    do q=lo,hi
      n  = hi-lo+1
      r0 = (q-lo+1-0._rp)/(1._rp*n)
      call gridpoint(gr,r0,rf_g(q))
      rf_g(q) = lmin + rf_g(q)*(lmax-lmin)
    end do
    rf_g(lo-1) = lmin
    !
    ! step 2) determine grid spacing between faces drf
    !
    do q=lo,hi
      drf_g(q) = rf_g(q)-rf_g(q-1)
    end do
    drf_g(lo-1) = drf_g(lo)
    drf_g(hi+1) = drf_g(hi)
    !
    ! step 3) determine grid spacing between centers drc
    !
    do q=lo-1,hi
      drc_g(q) = .5_rp*(drf_g(q)+drf_g(q+1))
    end do
    drc_g(hi+1) = drc_g(hi)
    !
    ! step 4) compute coordinates of cell centers rc and faces rf
    !
    rc_g(lo-1)    = lmin - drc_g(lo-1)/2._rp
    rf_g(lo-1)    = lmin
    do q=lo,hi+1
      rc_g(q) = rc_g(q-1) + drc_g(q-1)
      rf_g(q) = rf_g(q-1) + drf_g(q  )
    end do
    !
  end subroutine initgrid
  subroutine distribute_grid(lo_g,lo,hi,grid_g,grid)
    implicit none
    integer , intent(in )                     :: lo_g,lo,hi
    real(rp), intent(in ), dimension(lo_g-1:) :: grid_g
    real(rp), intent(out), dimension(lo  -1:) :: grid
    grid(lo-1:hi+1) = grid_g(lo-1:hi+1)
  end subroutine distribute_grid
  subroutine bound_grid(lo_g,hi_g,lo,hi,nb,is_periodic,lo_min,hi_max,grid_f,grid_c)
    implicit none
    integer , intent(in   )                   :: lo_g,hi_g,lo,hi
    integer , intent(in   ), dimension(0:1)   :: nb
    logical , intent(in   )                   :: is_periodic
    integer , intent(in   )                   :: lo_min,hi_max
    real(rp), intent(inout), dimension(lo-1:) :: grid_f,grid_c
    integer                                   :: shift
    type(MPI_REQUEST), dimension(4)           :: requests
    integer                                   :: nrequests
    nrequests = 0
    shift = 0
    if(lo == lo_g) then
      if(is_periodic.and.lo == lo_min) shift = hi_max-lo_min + 1
      call MPI_ISEND(grid_f(lo  ),1,MPI_REAL_RP,nb(0),lo_g+shift, &
                     MPI_COMM_WORLD,requests(nrequests+1))
      call MPI_IRECV(grid_f(lo-1),1,MPI_REAL_RP,nb(0),lo_g-1    , &
                     MPI_COMM_WORLD,requests(nrequests+2))
      nrequests = nrequests + 2
    end if
    shift = 0
    if(hi == hi_g) then
      if(is_periodic.and.hi == hi_max) shift = hi_max-lo_min + 1
      call MPI_ISEND(grid_f(hi  ),1,MPI_REAL_RP,nb(1),hi_g-shift, &
                     MPI_COMM_WORLD,requests(nrequests+1))
      call MPI_IRECV(grid_f(hi+1),1,MPI_REAL_RP,nb(1),hi_g+1    , &
                     MPI_COMM_WORLD,requests(nrequests+2))
      nrequests = nrequests + 2
    end if
    call MPI_WAITALL(nrequests,requests,MPI_STATUSES_IGNORE)
    if(lo == lo_g) grid_c(lo-1) = (grid_f(lo  )+grid_f(lo-1))/2._rp
    if(hi == hi_g) grid_c(hi  ) = (grid_f(hi+1)+grid_f(hi  ))/2._rp
    if(hi == hi_g) grid_c(hi+1) = grid_c(hi) ! not needed
  end subroutine bound_grid
  subroutine save_grid(fname,lo_g,hi_g,rf_g,rc_g,drf_g,drc_g)
    implicit none
    character(len=*), intent(in) :: fname
    integer         , intent(in) :: lo_g,hi_g
    real(rp)        , intent(in), dimension(lo_g-1:) :: rf_g,rc_g,drf_g,drc_g
    integer :: iunit,q,reclen
    inquire(iolength=reclen) rf_g(lo_g:hi_g),rc_g(lo_g:hi_g),drf_g(lo_g:hi_g),drc_g(lo_g:hi_g)
    open(newunit=iunit,file=trim(fname)//'.bin',status='replace',access='direct',recl=reclen)
    write(iunit,rec=1) rf_g(lo_g:hi_g),rc_g(lo_g:hi_g),drf_g(lo_g:hi_g),drc_g(lo_g:hi_g)
    close(iunit)
    open(newunit=iunit,status='replace',file=trim(fname)//'.out')
    do q=lo_g-1,hi_g+1
      write(iunit,'(5E15.7)') 0._rp,rf_g(q),rc_g(q),drf_g(q),drc_g(q)
    end do
    close(iunit)
  end subroutine save_grid
  !
  ! grid stretching functions
  ! see e.g., Fluid Flow Phenomena -- A Numerical Toolkit, by P. Orlandi
  !           Pirozzoli et al. JFM 788, 614–639 (commented)
  !
  subroutine gridpoint_cluster_two_end(alpha,r0,r)
    !
    ! clustered at the two sides
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      r = 0.5_rp*(1._rp+tanh((r0-0.5_rp)*alpha)/tanh(alpha/2._rp))
      !r = 0.5_rp*(1._rp+erf( (r0-0.5_rp)*alpha)/erf( alpha/2._rp))
    else
      r = r0
    end if
  end subroutine gridpoint_cluster_two_end
  subroutine gridpoint_cluster_one_end(alpha,r0,r)
    !
    ! clustered at the lower side
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      r = 1.0_rp*(1._rp+tanh((r0-1.0_rp)*alpha)/tanh(alpha/1._rp))
      !r = 1.0_rp*(1._rp+erf( (r0-1.0_rp)*alpha)/erf( alpha/1._rp))
    else
      r = r0
    end if
  end subroutine gridpoint_cluster_one_end
  subroutine gridpoint_cluster_one_end_r(alpha,r0,r)
    !
    ! clustered at the lower side
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      r = 1._rp-1.0_rp*(1._rp+tanh((1._rp-r0-1.0_rp)*alpha)/tanh(alpha/1._rp))
      !r = 1._rp-1.0_rp*(1._rp+erf( (1._rp-r0-1.0_rp)*alpha)/erf( alpha/1._rp))
    else
      r = r0
    end if
  end subroutine gridpoint_cluster_one_end_r
  subroutine gridpoint_cluster_middle(alpha,r0,r)
    !
    ! clustered in the middle
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      if(     r0 <= 0.5_rp) then
        r = 0.5_rp*(1._rp-1._rp+tanh(2._rp*alpha*(r0-0._rp))/tanh(alpha))
        !r = 0.5_rp*(1._rp-1._rp+erf( 2._rp*alpha*(r0-0._rp))/erf( alpha))
      else if(r0 >  0.5_rp) then
        r = 0.5_rp*(1._rp+1._rp+tanh(2._rp*alpha*(r0-1._rp))/tanh(alpha))
        !r = 0.5_rp*(1._rp+1._rp+erf( 2._rp*alpha*(r0-1._rp))/erf( alpha))
      end if
    else
      r = r0
    end if
  end subroutine gridpoint_cluster_middle
  subroutine gridpoint_cluster_geometric_one_end(alpha,r0,r)
    !
    ! geometric progression
    !
    implicit none
    !real(rp), parameter   :: power = 1._rp/2._rp
    !real(rp), parameter   :: power = 1._rp/1._rp
    real(rp), parameter   :: power = 1._rp/3._rp
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(    r0 == 1.0_rp) then
      r = r0
    else
      r = r0*((1._rp-r0**(alpha))/(1._rp-r0)/alpha)**power
    end if
  end subroutine gridpoint_cluster_geometric_one_end
  subroutine gridpoint_cluster_geometric_one_end_r(alpha,r0,r)
    !
    ! reversed geometric progression
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    call gridpoint_cluster_geometric_one_end(alpha,1._rp-r0,r)
    r = 1._rp-r
  end subroutine gridpoint_cluster_geometric_one_end_r
  subroutine gridpoint_cluster_geometric_two_ends(alpha,r0,r)
    !
    ! geometric progression towards each end
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(r0 <= 0.5) then
      call gridpoint_cluster_geometric_one_end(alpha/2._rp,2._rp*r0        ,r)
      r = r/2._rp
    else
      call gridpoint_cluster_geometric_one_end(alpha/2._rp,2._rp*(1._rp-r0),r)
      r = 1._rp-r/2._rp
    end if
  end subroutine gridpoint_cluster_geometric_two_ends
  subroutine gridpoint_cluster_geometric_middle(alpha,r0,r)
    !
    ! geometric progression towards each end
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(r0 <= 0.5) then
      call gridpoint_cluster_geometric_one_end(alpha/2._rp,(.5_rp-r0)*2._rp,r)
      r = (1._rp-r)/2._rp
    else
      call gridpoint_cluster_geometric_one_end(alpha/2._rp,(r0-.5_rp)*2._rp,r)
      r = (1._rp+r)/2._rp
    end if
  end subroutine gridpoint_cluster_geometric_middle
end module mod_initgrid


: FORTH CREATE S" FORTH" type DOES> ;
: UFLOAD S" UFLOAD" type DOES> ;
: FNEGATE S" FNEGATE" type DOES> ;
: F/ S" F/" type DOES> ;
: F* S" F*" type DOES> ;
: F+ S" F+" type DOES> ;
: F- S" F-" type DOES> ;
: LOAD S" LOAD" type DOES> ;
: BVERIFY S" BVERIFY" type DOES> ;
: VERIFY S" VERIFY" type DOES> ;
: BLOAD S" BLOAD" type DOES> ;
: BSAVE S" BSAVE" type DOES> ;
: SAVE S" SAVE" type DOES> ;
: LIST S" LIST" type DOES> ;
: EDIT S" EDIT" type DOES> ;
: FORGET S" FORGET" type DOES> ;
: REDEFINE S" REDEFINE" type DOES> ;
: EXIT S" EXIT" type DOES> ;
: ." S" .''" type DOES> ;
: ( S" (" type DOES> ;
: [ S" [" type DOES> ;
: +LOOP S" +LOOP" type DOES> ;
: LOOP S" LOOP" type DOES> ;
: DO S" DO" type DOES> ;
: UNTIL S" UNTIL" type DOES> ;
: REPEAT S" REPEAT" type DOES> ;
: BEGIN S" BEGIN" type DOES> ;
: THEN S" THEN" type DOES> ;
: ELSE S" ELSE" type DOES> ;
: WHILE S" WHILE" type DOES> ;
: IF S" IF" type DOES> ;
: ] S" ]" type DOES> ;
: LEAVE S" LEAVE" type DOES> ;
: J S" J" type DOES> ;
: I' S" I'" type DOES> ;
: I S" I" type DOES> ;
: DEFINITIONS S" DEFINITIONS" type DOES> ;
: VOCABULARY S" VOCABULARY" type DOES> ;
: IMMEDIATE S" IMMEDIATE" type DOES> ;
: RUNS> S" RUNS>" type DOES> ;
: DOES> S" DOES>" type DOES> ;
: COMPILER S" COMPILER" type DOES> ;
: CALL S" CALL" type DOES> ;
: DEFINER S" DEFINER" type DOES> ;
: ASCII S" ASCII" type DOES> ;
: LITERAL S" LITERAL" type DOES> ;
: CONSTANT S" CONSTANT" type DOES> ;
: VARIABLE S" VARIABLE" type DOES> ;
: ALLOT S" ALLOT" type DOES> ;
: C, S" C," type DOES> ;
: , S" ," type DOES> ;
: CREATE S" CREATE" type DOES> ;
\ :
: DECIMAL S" DECIMAL" type DOES> ;
: MIN S" MIN" type DOES> ;
: MAX S" MAX" type DOES> ;
: XOR S" XOR" type DOES> ;
: AND S" AND" type DOES> ;
: OR S" OR" type DOES> ;
: 2- S" 2-" type DOES> ;
: 1- S" 1-" type DOES> ;
: 2+ S" 2+" type DOES> ;
: 1+ S" 1+" type DOES> ;
: D+ S" D+" type DOES> ;
: - S" -" type DOES> ;
: + S" +" type DOES> ;
: DNEGATE S" DNEGATE" type DOES> ;
: NEGATE S" NEGATE" type DOES> ;
: U/MOD S" U/MOD" type DOES> ;
: */ S" */" type DOES> ;
: * S" *" type DOES> ;
: MOD S" MOD" type DOES> ;
: / S" /" type DOES> ;
: */MOD S" */MOD" type DOES> ;
: /MOD S" /MOD" type DOES> ;
: U* S" U*" type DOES> ;
: D< S" D<" type DOES> ;
: U< S" U<" type DOES> ;
: < S" <" type DOES> ;
: > S" >" type DOES> ;
: = S" =" type DOES> ;
: 0> S" 0>" type DOES> ;
: 0< S" 0<" type DOES> ;
: 0= S" 0=" type DOES> ;
: ABS S" ABS" type DOES> ;
: OUT S" OUT" type DOES> ;
: IN S" IN" type DOES> ;
: INKEY S" INKEY" type DOES> ;
: BEEP S" BEEP" type DOES> ;
: PLOT S" PLOT" type DOES> ;
: AT S" AT" type DOES> ;
: F. S" F." type DOES> ;
: EMIT S" EMIT" type DOES> ;
: CR S" CR" type DOES> ;
: SPACES S" SPACES" type DOES> ;
: SPACE S" SPACE" type DOES> ;
: HOLD S" HOLD" type DOES> ;
: CLS S" CLS" type DOES> ;
: # S" #" type DOES> ;
: #S S" #S" type DOES> ;
: U. S" U." type DOES> ;
: . S" ." type DOES> ;
: SIGN S" SIGN" type DOES> ;
: #> S" #>" type DOES> ;
: <# S" <#" type DOES> ;
: TYPE S" TYPE" type DOES> ;
: ROLL S" ROLL" type DOES> ;
: PICK S" PICK" type DOES> ;
: OVER S" OVER" type DOES> ;
: ROT S" ROT" type DOES> ;
: ?DUP S" ?DUP" type DOES> ;
: R> S" R>" type DOES> ;
: >R S" >R" type DOES> ;
: ! S" !" type DOES> ;
: @ S" @" type DOES> ;
: C! S" C!" type DOES> ;
: C@ S" C@" type DOES> ;
: SWAP S" SWAP" type DOES> ;
: DROP S" DROP" type DOES> ;
: DUP S" DUP" type DOES> ;
: SLOW S" SLOW" type DOES> ;
: FAST S" FAST" type DOES> ;
: INVIS S" INVIS" type DOES> ;
: VIS S" VIS" type DOES> ;
: CONVERT S" CONVERT" type DOES> ;
: NUMBER S" NUMBER" type DOES> ;
: EXECUTE S" EXECUTE" type DOES> ;
: FIND S" FIND" type DOES> ;
: VLIST S" VLIST" type DOES> ;
: WORD S" WORD" type DOES> ;
: RETYPE S" RETYPE" type DOES> ;
: QUERY S" QUERY" type DOES> ;
: LINE S" LINE" type DOES> ;
: PAD S" PAD" type DOES> ;
: BASE S" BASE" type DOES> ;
: CURRENT S" CURRENT" type DOES> ;
: CONTEXT S" CONTEXT" type DOES> ;
: HERE S" HERE" type DOES> ;
: ABORT S" ABORT" type DOES> ;
: QUIT S" QUIT" type DOES> ;


!=============================================================================!
        subroutine csolve2bc( n, nsys, nblk, mat, rhs, bc, mult, fact )
!=============================================================================!
!
!  Solves a block tridiagonal system of equations without pivoting.
!  Vectorized over the second index.
!
!  This routine has been modified to allow for high-order wall boundary
!  conditions.
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  WARNING: This routine works for nblk = 5 only!
!
!  input:
!    nsys       : number of systems to vectorize over
!    n          : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!
!  inout:
!    mat        : the block tridiagonal matrix to be solved
!    rhs        : the right hand side
!    bc         : the bc array
!=============================================================================!
        implicit none

        integer, intent(in) :: n, nblk, nsys
        complex, intent(inout) :: mat(n,nsys,nblk,nblk*3), rhs(n,nsys,nblk)
        complex, intent(inout) :: bc(nsys,nblk,nblk,14)
        complex, intent(inout) :: mult(nsys), fact(nsys)

!.... useful constants

        real, parameter :: zero = 0.0, one = 1.0

!.... local variables

        integer :: nc, nr, i, j, l, m, p, q, s, r, t, iv
!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!

!.... first 3 rows are special due to boundary conditions

        i = 1

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
            end do

            do iv = 1, nsys
              mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
              mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
              mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
              mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
              mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

              bc(iv,l,1,1) = bc(iv,l,1,1) + mult(iv) * bc(iv,nc,1,1)
              bc(iv,l,2,1) = bc(iv,l,2,1) + mult(iv) * bc(iv,nc,2,1)
              bc(iv,l,3,1) = bc(iv,l,3,1) + mult(iv) * bc(iv,nc,3,1)
              bc(iv,l,4,1) = bc(iv,l,4,1) + mult(iv) * bc(iv,nc,4,1)
              bc(iv,l,5,1) = bc(iv,l,5,1) + mult(iv) * bc(iv,nc,5,1)

              bc(iv,l,1,2) = bc(iv,l,1,2) + mult(iv) * bc(iv,nc,1,2)
              bc(iv,l,2,2) = bc(iv,l,2,2) + mult(iv) * bc(iv,nc,2,2)
              bc(iv,l,3,2) = bc(iv,l,3,2) + mult(iv) * bc(iv,nc,3,2)
              bc(iv,l,4,2) = bc(iv,l,4,2) + mult(iv) * bc(iv,nc,4,2)
              bc(iv,l,5,2) = bc(iv,l,5,2) + mult(iv) * bc(iv,nc,5,2)

              bc(iv,l,1,3) = bc(iv,l,1,3) + mult(iv) * bc(iv,nc,1,3)
              bc(iv,l,2,3) = bc(iv,l,2,3) + mult(iv) * bc(iv,nc,2,3)
              bc(iv,l,3,3) = bc(iv,l,3,3) + mult(iv) * bc(iv,nc,3,3)
              bc(iv,l,4,3) = bc(iv,l,4,3) + mult(iv) * bc(iv,nc,4,3)
              bc(iv,l,5,3) = bc(iv,l,5,3) + mult(iv) * bc(iv,nc,5,3)

              rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
            end do

          end do

        end do  ! end of loop on nc

!.... for all columns

        p = i + 1
        r = i + 2

        do nc = 1, nblk

          j = nc + nblk
          fact(:) = one / mat(i,:,nc,j)

          do m = 1, nblk

!.... second row

            mult(:) = -mat(p,:,m,nc) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
            end do

            do iv = 1, nsys
              mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
              mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
              mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
              mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
              mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

              mat(p,iv,m,11) = mat(p,iv,m,11) + mult(iv) * bc(iv,nc,1,1)
              mat(p,iv,m,12) = mat(p,iv,m,12) + mult(iv) * bc(iv,nc,2,1)
              mat(p,iv,m,13) = mat(p,iv,m,13) + mult(iv) * bc(iv,nc,3,1)
              mat(p,iv,m,14) = mat(p,iv,m,14) + mult(iv) * bc(iv,nc,4,1)
              mat(p,iv,m,15) = mat(p,iv,m,15) + mult(iv) * bc(iv,nc,5,1)

              bc(iv,m,1,4)  = bc(iv,m,1,4)  + mult(iv) * bc(iv,nc,1,2)
              bc(iv,m,2,4)  = bc(iv,m,2,4)  + mult(iv) * bc(iv,nc,2,2)
              bc(iv,m,3,4)  = bc(iv,m,3,4)  + mult(iv) * bc(iv,nc,3,2)
              bc(iv,m,4,4)  = bc(iv,m,4,4)  + mult(iv) * bc(iv,nc,4,2)
              bc(iv,m,5,4)  = bc(iv,m,5,4)  + mult(iv) * bc(iv,nc,5,2)

              bc(iv,m,1,5)  = bc(iv,m,1,5)  + mult(iv) * bc(iv,nc,1,3)
              bc(iv,m,2,5)  = bc(iv,m,2,5)  + mult(iv) * bc(iv,nc,2,3)
              bc(iv,m,3,5)  = bc(iv,m,3,5)  + mult(iv) * bc(iv,nc,3,3)
              bc(iv,m,4,5)  = bc(iv,m,4,5)  + mult(iv) * bc(iv,nc,4,3)
              bc(iv,m,5,5)  = bc(iv,m,5,5)  + mult(iv) * bc(iv,nc,5,3)

              rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
            end do

!.... third row

            mult(:) = -bc(:,m,nc,7) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              bc(:,m,q,7) = bc(:,m,q,7) + mult(:) * mat(i,:,nc,l)
            end do

            do iv = 1, nsys
              mat(r,iv,m, 1) = mat(r,iv,m, 1) + mult(iv) * mat(i,iv,nc,11)
              mat(r,iv,m, 2) = mat(r,iv,m, 2) + mult(iv) * mat(i,iv,nc,12)
              mat(r,iv,m, 3) = mat(r,iv,m, 3) + mult(iv) * mat(i,iv,nc,13)
              mat(r,iv,m, 4) = mat(r,iv,m, 4) + mult(iv) * mat(i,iv,nc,14)
              mat(r,iv,m, 5) = mat(r,iv,m, 5) + mult(iv) * mat(i,iv,nc,15)

              mat(r,iv,m, 6) = mat(r,iv,m, 6) + mult(iv) * bc(iv,nc,1,1)
              mat(r,iv,m, 7) = mat(r,iv,m, 7) + mult(iv) * bc(iv,nc,2,1)
              mat(r,iv,m, 8) = mat(r,iv,m, 8) + mult(iv) * bc(iv,nc,3,1)
              mat(r,iv,m, 9) = mat(r,iv,m, 9) + mult(iv) * bc(iv,nc,4,1)
              mat(r,iv,m,10) = mat(r,iv,m,10) + mult(iv) * bc(iv,nc,5,1)

              mat(r,iv,m,11) = mat(r,iv,m,11) + mult(iv) * bc(iv,nc,1,2)
              mat(r,iv,m,12) = mat(r,iv,m,12) + mult(iv) * bc(iv,nc,2,2)
              mat(r,iv,m,13) = mat(r,iv,m,13) + mult(iv) * bc(iv,nc,3,2)
              mat(r,iv,m,14) = mat(r,iv,m,14) + mult(iv) * bc(iv,nc,4,2)
              mat(r,iv,m,15) = mat(r,iv,m,15) + mult(iv) * bc(iv,nc,5,2)

              bc(iv,m,1,6)  = bc(iv,m,1,6)  + mult(iv) * bc(iv,nc,1,3)
              bc(iv,m,2,6)  = bc(iv,m,2,6)  + mult(iv) * bc(iv,nc,2,3)
              bc(iv,m,3,6)  = bc(iv,m,3,6)  + mult(iv) * bc(iv,nc,3,3)
              bc(iv,m,4,6)  = bc(iv,m,4,6)  + mult(iv) * bc(iv,nc,4,3)
              bc(iv,m,5,6)  = bc(iv,m,5,6)  + mult(iv) * bc(iv,nc,5,3)

              rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... second special row

        i = 2

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
            end do

            do iv = 1, nsys
              mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
              mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
              mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
              mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
              mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

              bc(iv,l,1,4) = bc(iv,l,1,4) + mult(iv) * bc(iv,nc,1,4)
              bc(iv,l,2,4) = bc(iv,l,2,4) + mult(iv) * bc(iv,nc,2,4)
              bc(iv,l,3,4) = bc(iv,l,3,4) + mult(iv) * bc(iv,nc,3,4)
              bc(iv,l,4,4) = bc(iv,l,4,4) + mult(iv) * bc(iv,nc,4,4)
              bc(iv,l,5,4) = bc(iv,l,5,4) + mult(iv) * bc(iv,nc,5,4)

              bc(iv,l,1,5) = bc(iv,l,1,5) + mult(iv) * bc(iv,nc,1,5)
              bc(iv,l,2,5) = bc(iv,l,2,5) + mult(iv) * bc(iv,nc,2,5)
              bc(iv,l,3,5) = bc(iv,l,3,5) + mult(iv) * bc(iv,nc,3,5)
              bc(iv,l,4,5) = bc(iv,l,4,5) + mult(iv) * bc(iv,nc,4,5)
              bc(iv,l,5,5) = bc(iv,l,5,5) + mult(iv) * bc(iv,nc,5,5)

              rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

          p  = i + 1

          j = nc + nblk
          fact(:) = one / mat(i,:,nc,j)

          do m = 1, nblk
            mult(:) = -mat(p,:,m,nc) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
            end do

            do iv = 1, nsys
              mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
              mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
              mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
              mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
              mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

              mat(p,iv,m,11) = mat(p,iv,m,11) + mult(iv) * bc(iv,nc,1,4)
              mat(p,iv,m,12) = mat(p,iv,m,12) + mult(iv) * bc(iv,nc,2,4)
              mat(p,iv,m,13) = mat(p,iv,m,13) + mult(iv) * bc(iv,nc,3,4)
              mat(p,iv,m,14) = mat(p,iv,m,14) + mult(iv) * bc(iv,nc,4,4)
              mat(p,iv,m,15) = mat(p,iv,m,15) + mult(iv) * bc(iv,nc,5,4)

              bc(iv,m,1,6)  = bc(iv,m,1,6)  + mult(iv) * bc(iv,nc,1,5)
              bc(iv,m,2,6)  = bc(iv,m,2,6)  + mult(iv) * bc(iv,nc,2,5)
              bc(iv,m,3,6)  = bc(iv,m,3,6)  + mult(iv) * bc(iv,nc,3,5)
              bc(iv,m,4,6)  = bc(iv,m,4,6)  + mult(iv) * bc(iv,nc,4,5)
              bc(iv,m,5,6)  = bc(iv,m,5,6)  + mult(iv) * bc(iv,nc,5,5)

              rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... the third and final special row

        i = 3

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
            end do

            do iv = 1, nsys
              mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
              mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
              mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
              mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
              mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

              bc(iv,l,1,6) = bc(iv,l,1,6) + mult(iv) * bc(iv,nc,1,6)
              bc(iv,l,2,6) = bc(iv,l,2,6) + mult(iv) * bc(iv,nc,2,6)
              bc(iv,l,3,6) = bc(iv,l,3,6) + mult(iv) * bc(iv,nc,3,6)
              bc(iv,l,4,6) = bc(iv,l,4,6) + mult(iv) * bc(iv,nc,4,6)
              bc(iv,l,5,6) = bc(iv,l,5,6) + mult(iv) * bc(iv,nc,5,6)

              rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

          p  = i + 1

          j = nc + nblk
          fact(:) = one / mat(i,:,nc,j)

          do m = 1, nblk
            mult(:) = -mat(p,:,m,nc) * fact(:)

            do q = nc + 1, nblk
              l = q + nblk
              mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
            end do

            do iv = 1, nsys
              mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
              mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
              mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
              mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
              mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

              mat(p,iv,m,11) = mat(p,iv,m,11) + mult(iv) * bc(iv,nc,1,6)
              mat(p,iv,m,12) = mat(p,iv,m,12) + mult(iv) * bc(iv,nc,2,6)
              mat(p,iv,m,13) = mat(p,iv,m,13) + mult(iv) * bc(iv,nc,3,6)
              mat(p,iv,m,14) = mat(p,iv,m,14) + mult(iv) * bc(iv,nc,4,6)
              mat(p,iv,m,15) = mat(p,iv,m,15) + mult(iv) * bc(iv,nc,5,6)

              rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
            end do
          end do

        end do  ! end of loop on nc

!.... the rest of the matrix is a standard tridiagonal up to the other boundary

        do i = 4, n - 5

!.... do the first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do

              do iv = 1, nsys
                mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
                mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
                mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
                mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
                mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p  = i + 1

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
                mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
                mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
                mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
                mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

        end do          ! end of loop on i

!.... do the FIFTH to the last row

        i = n - 4

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do

              do iv = 1, nsys
                mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
                mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
                mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
                mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
                mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1
          r = i + 2
          s = i + 3
          t = i + 4

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
                mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
                mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
                mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
                mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

!.... eliminate the boundary conditions: bc(8)

              mult(:) = -bc(:,m,nc,8) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,8) = bc(:,m,q,8) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(r,iv,m, 1) = mat(r,iv,m, 1) + mult(iv) * mat(i,iv,nc,11)
                mat(r,iv,m, 2) = mat(r,iv,m, 2) + mult(iv) * mat(i,iv,nc,12)
                mat(r,iv,m, 3) = mat(r,iv,m, 3) + mult(iv) * mat(i,iv,nc,13)
                mat(r,iv,m, 4) = mat(r,iv,m, 4) + mult(iv) * mat(i,iv,nc,14)
                mat(r,iv,m, 5) = mat(r,iv,m, 5) + mult(iv) * mat(i,iv,nc,15)

                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

!.... eliminate the boundary conditions: bc(10)

              mult(:) = -bc(:,m,nc,10) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,10) = bc(:,m,q,10) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                bc(iv,m, 1,11) = bc(iv,m, 1,11) + mult(iv) * mat(i,iv,nc,11)
                bc(iv,m, 2,11) = bc(iv,m, 2,11) + mult(iv) * mat(i,iv,nc,12)
                bc(iv,m, 3,11) = bc(iv,m, 3,11) + mult(iv) * mat(i,iv,nc,13)
                bc(iv,m, 4,11) = bc(iv,m, 4,11) + mult(iv) * mat(i,iv,nc,14)
                bc(iv,m, 5,11) = bc(iv,m, 5,11) + mult(iv) * mat(i,iv,nc,15)

                rhs(s,iv,m) = rhs(s,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

!.... eliminate the boundary conditions: bc(12)

              mult(:) = -bc(:,m,nc,12) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,12) = bc(:,m,q,12) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                bc(iv,m, 1,13) = bc(iv,m, 1,13) + mult(iv) * mat(i,iv,nc,11)
                bc(iv,m, 2,13) = bc(iv,m, 2,13) + mult(iv) * mat(i,iv,nc,12)
                bc(iv,m, 3,13) = bc(iv,m, 3,13) + mult(iv) * mat(i,iv,nc,13)
                bc(iv,m, 4,13) = bc(iv,m, 4,13) + mult(iv) * mat(i,iv,nc,14)
                bc(iv,m, 5,13) = bc(iv,m, 5,13) + mult(iv) * mat(i,iv,nc,15)

                rhs(t,iv,m) = rhs(t,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

            end do

          end do        ! end of loop on nc

!.... do the FOURTH to the last row

        i = n - 3

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do

              do iv = 1, nsys
                mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
                mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
                mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
                mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
                mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1
          r = i + 2
          s = i + 3

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
                mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
                mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
                mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
                mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

!.... eliminate the boundary conditions: bc(11)

              mult(:) = -bc(:,m,nc,11) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,11) = bc(:,m,q,11) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(r,iv,m, 1) = mat(r,iv,m, 1) + mult(iv) * mat(i,iv,nc,11)
                mat(r,iv,m, 2) = mat(r,iv,m, 2) + mult(iv) * mat(i,iv,nc,12)
                mat(r,iv,m, 3) = mat(r,iv,m, 3) + mult(iv) * mat(i,iv,nc,13)
                mat(r,iv,m, 4) = mat(r,iv,m, 4) + mult(iv) * mat(i,iv,nc,14)
                mat(r,iv,m, 5) = mat(r,iv,m, 5) + mult(iv) * mat(i,iv,nc,15)

                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

!.... eliminate the boundary conditions: bc(13)

              mult(:) = -bc(:,m,nc,13) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,13) = bc(:,m,q,13) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                bc(iv,m, 1,14) = bc(iv,m, 1,14) + mult(iv) * mat(i,iv,nc,11)
                bc(iv,m, 2,14) = bc(iv,m, 2,14) + mult(iv) * mat(i,iv,nc,12)
                bc(iv,m, 3,14) = bc(iv,m, 3,14) + mult(iv) * mat(i,iv,nc,13)
                bc(iv,m, 4,14) = bc(iv,m, 4,14) + mult(iv) * mat(i,iv,nc,14)
                bc(iv,m, 5,14) = bc(iv,m, 5,14) + mult(iv) * mat(i,iv,nc,15)

                rhs(s,iv,m) = rhs(s,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the THIRD to the last row

        i = n - 2

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do

              do iv = 1, nsys
                mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
                mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
                mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
                mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
                mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

                bc(iv,l, 1,9) = bc(iv,l, 1,9) + mult(iv) * bc(iv,nc,1,9)
                bc(iv,l, 2,9) = bc(iv,l, 2,9) + mult(iv) * bc(iv,nc,2,9)
                bc(iv,l, 3,9) = bc(iv,l, 3,9) + mult(iv) * bc(iv,nc,3,9)
                bc(iv,l, 4,9) = bc(iv,l, 4,9) + mult(iv) * bc(iv,nc,4,9)
                bc(iv,l, 5,9) = bc(iv,l, 5,9) + mult(iv) * bc(iv,nc,5,9)

                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1
          r = i + 2

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
                mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
                mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
                mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
                mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

                mat(p,iv,m,11) = mat(p,iv,m,11) + mult(iv) * bc(iv,nc,1,9)
                mat(p,iv,m,12) = mat(p,iv,m,12) + mult(iv) * bc(iv,nc,2,9)
                mat(p,iv,m,13) = mat(p,iv,m,13) + mult(iv) * bc(iv,nc,3,9)
                mat(p,iv,m,14) = mat(p,iv,m,14) + mult(iv) * bc(iv,nc,4,9)
                mat(p,iv,m,15) = mat(p,iv,m,15) + mult(iv) * bc(iv,nc,5,9)

                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do

!.... eliminate the boundary condition:  bc(14)

              mult(:) = -bc(:,m,nc,14) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                bc(:,m,q,14) = bc(:,m,q,14) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(r,iv,m, 1) = mat(r,iv,m, 1) + mult(iv) * mat(i,iv,nc,11)
                mat(r,iv,m, 2) = mat(r,iv,m, 2) + mult(iv) * mat(i,iv,nc,12)
                mat(r,iv,m, 3) = mat(r,iv,m, 3) + mult(iv) * mat(i,iv,nc,13)
                mat(r,iv,m, 4) = mat(r,iv,m, 4) + mult(iv) * mat(i,iv,nc,14)
                mat(r,iv,m, 5) = mat(r,iv,m, 5) + mult(iv) * mat(i,iv,nc,15)

                mat(r,iv,m, 6) = mat(r,iv,m, 6) + mult(iv) * bc(iv,nc,1,9)
                mat(r,iv,m, 7) = mat(r,iv,m, 7) + mult(iv) * bc(iv,nc,2,9)
                mat(r,iv,m, 8) = mat(r,iv,m, 8) + mult(iv) * bc(iv,nc,3,9)
                mat(r,iv,m, 9) = mat(r,iv,m, 9) + mult(iv) * bc(iv,nc,4,9)
                mat(r,iv,m,10) = mat(r,iv,m,10) + mult(iv) * bc(iv,nc,5,9)

                rhs(r,iv,m) = rhs(r,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the SECOND to the last row (which is normal tridiagonal)

        i = n - 1

!.... first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 2
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do

              do iv = 1, nsys
                mat(i,iv,l,11) = mat(i,iv,l,11) + mult(iv) * mat(i,iv,nc,11)
                mat(i,iv,l,12) = mat(i,iv,l,12) + mult(iv) * mat(i,iv,nc,12)
                mat(i,iv,l,13) = mat(i,iv,l,13) + mult(iv) * mat(i,iv,nc,13)
                mat(i,iv,l,14) = mat(i,iv,l,14) + mult(iv) * mat(i,iv,nc,14)
                mat(i,iv,l,15) = mat(i,iv,l,15) + mult(iv) * mat(i,iv,nc,15)

                rhs(i,iv,l) = rhs(i,iv,l) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          p = i + 1

          do nc = 1, nblk

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do

              do iv = 1, nsys
                mat(p,iv,m, 6) = mat(p,iv,m, 6) + mult(iv) * mat(i,iv,nc,11)
                mat(p,iv,m, 7) = mat(p,iv,m, 7) + mult(iv) * mat(i,iv,nc,12)
                mat(p,iv,m, 8) = mat(p,iv,m, 8) + mult(iv) * mat(i,iv,nc,13)
                mat(p,iv,m, 9) = mat(p,iv,m, 9) + mult(iv) * mat(i,iv,nc,14)
                mat(p,iv,m,10) = mat(p,iv,m,10) + mult(iv) * mat(i,iv,nc,15)

                rhs(p,iv,m) = rhs(p,iv,m) + mult(iv) * rhs(i,iv,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
            end do
            rhs(i,:,l) = rhs(i,:,l) + mult(:) * rhs(i,:,nc)
          end do

        end do  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the LAST row first

        i = n

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do
          rhs(i,:,m) = rhs(i,:,m) / mat(i,:,m,j)
        end do

!.... do the SECOND to the last row (normal row)

        i = n - 1
        p = i + 1

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do

          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,1) * mat(i,iv,m,11)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,2) * mat(i,iv,m,12)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,3) * mat(i,iv,m,13)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,4) * mat(i,iv,m,14)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,5) * mat(i,iv,m,15)

            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,j)
          end do
        end do

!.... do the THIRD to the last row

        i = n - 2
        p = i + 1
        r = i + 2

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do

          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,1) * mat(i,iv,m,11)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,2) * mat(i,iv,m,12)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,3) * mat(i,iv,m,13)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,4) * mat(i,iv,m,14)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,5) * mat(i,iv,m,15)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,1) * bc(iv,m,1,9)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,2) * bc(iv,m,2,9)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,3) * bc(iv,m,3,9)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,4) * bc(iv,m,4,9)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,5) * bc(iv,m,5,9)

            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,j)
          end do

        end do

!.... now do the rest of the rows in reverse order upto the boundary

        do i = n - 3, 4, -1

          p = i + 1

          do m = nblk, 1, -1
            j = m + nblk
            do q = m+1, nblk
              l = q + nblk
              rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
            end do

            do iv = 1, nsys
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,1) * mat(i,iv,m,11)
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,2) * mat(i,iv,m,12)
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,3) * mat(i,iv,m,13)
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,4) * mat(i,iv,m,14)
              rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,5) * mat(i,iv,m,15)

              rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,j)
            end do
          end do

        end do

!.... now do the boundary rows

        i = 3

        p = i + 1
        r = i + 2

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do

          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,1) * mat(i,iv,m,11)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,2) * mat(i,iv,m,12)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,3) * mat(i,iv,m,13)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,4) * mat(i,iv,m,14)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,5) * mat(i,iv,m,15)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,1) * bc(iv,m,1,6)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,2) * bc(iv,m,2,6)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,3) * bc(iv,m,3,6)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,4) * bc(iv,m,4,6)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,5) * bc(iv,m,5,6)

            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,j)
          end do
        end do

        i = 2

        p = i + 1
        r = i + 2
        s = i + 3

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do

          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,1) * mat(i,iv,m,11)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,2) * mat(i,iv,m,12)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,3) * mat(i,iv,m,13)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,4) * mat(i,iv,m,14)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,5) * mat(i,iv,m,15)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,1) * bc(iv,m,1,4)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,2) * bc(iv,m,2,4)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,3) * bc(iv,m,3,4)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,4) * bc(iv,m,4,4)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,5) * bc(iv,m,5,4)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,1) * bc(iv,m,1,5)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,2) * bc(iv,m,2,5)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,3) * bc(iv,m,3,5)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,4) * bc(iv,m,4,5)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,5) * bc(iv,m,5,5)

            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,j)
          end do
        end do

        i = 1

        p = i + 1
        r = i + 2
        s = i + 3
        t = i + 4

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do

          do iv = 1, nsys
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,1) * mat(i,iv,m,11)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,2) * mat(i,iv,m,12)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,3) * mat(i,iv,m,13)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,4) * mat(i,iv,m,14)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(p,iv,5) * mat(i,iv,m,15)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,1) * bc(iv,m,1,1)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,2) * bc(iv,m,2,1)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,3) * bc(iv,m,3,1)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,4) * bc(iv,m,4,1)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(r,iv,5) * bc(iv,m,5,1)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,1) * bc(iv,m,1,2)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,2) * bc(iv,m,2,2)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,3) * bc(iv,m,3,2)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,4) * bc(iv,m,4,2)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(s,iv,5) * bc(iv,m,5,2)

            rhs(i,iv,m) = rhs(i,iv,m) - rhs(t,iv,1) * bc(iv,m,1,3)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(t,iv,2) * bc(iv,m,2,3)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(t,iv,3) * bc(iv,m,3,3)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(t,iv,4) * bc(iv,m,4,3)
            rhs(i,iv,m) = rhs(i,iv,m) - rhs(t,iv,5) * bc(iv,m,5,3)

            rhs(i,iv,m) = rhs(i,iv,m) / mat(i,iv,m,j)
          end do
        end do
!=============================================================================!
        return
        end


*=======================================================================
*
* WCSLIB 4.24 - an implementation of the FITS WCS standard.
* Copyright (C) 1995-2014, Mark Calabretta
*
* This file is part of WCSLIB.
*
* WCSLIB is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* WCSLIB is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with WCSLIB.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning WCSLIB to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: ttab2.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================

      PROGRAM TTAB2
*-----------------------------------------------------------------------
*
* TTAB2 tests the -TAB routines using PGPLOT for graphical display.  It
* demonstrates the nature of linear interpolation in 2 dimensions by
* contouring the interior a single 2 x 2 interpolation element as the
* values in each corner change.
*
*-----------------------------------------------------------------------

*     Set up a 2 x 2 lookup table.
      INTEGER   K1, K2, M
      PARAMETER (M = 2, K1 = 2, K2 = 2)

      INTEGER   K(2), MAP(2)
      DOUBLE PRECISION CRVAL(2)
      DATA K     /K1, K2/
      DATA MAP   /0, 1/
      DATA CRVAL /0D0, 0D0/

*     Number of subdivisions on each side of the interpolation element.
      INTEGER   NP
      REAL      SCL
      PARAMETER (NP = 128)
      PARAMETER (SCL = 2.0/(NP-1))

      INTEGER   I, IM, IK, J, L, L1, L2, L3, LSTEP, STAT(NP*NP), STATUS
      REAL      ARRAY(NP,NP), CLEV(-10:20), LTM(6), V0, V1, W
      DOUBLE PRECISION X(M,NP,NP), WORLD(M,NP,NP)
      CHARACTER TEXT*80

*     On some systems, such as Sun Sparc, the struct MUST be aligned
*     on a double precision boundary, done here using an equivalence.
*     Failure to do this may result in mysterious "bus errors".
      INCLUDE 'tab.inc'
      INTEGER   TAB(TABLEN)
      DOUBLE PRECISION DUMMY
      EQUIVALENCE (TAB,DUMMY)
*-----------------------------------------------------------------------

      WRITE (*, 10)
 10   FORMAT (
     :   'Testing WCSLIB coordinate lookup table routines (ttab2.f)',/,
     :   '---------------------------------------------------------')

*     PGPLOT initialization.
      CALL PGBEG (0, '/xwindow', 1, 1)
      CALL PGVSTD ()
      CALL PGSCH (0.7)

*     The viewport is slightly oversized.
      CALL PGWNAD (-0.65, 1.65, -0.65, 1.65)

      DO 20 L = -10, 20
        CLEV(L) = 0.2*L
 20   CONTINUE

      LTM(1) = -SCL*(1.0 + (NP-1)/4.0)
      LTM(2) =  SCL
      LTM(3) =  0.0
      LTM(4) = -SCL*(1.0 + (NP-1)/4.0)
      LTM(5) =  0.0
      LTM(6) =  SCL

*     Set up the lookup table.
      STATUS = TABPUT (TAB, TAB_FLAG, -1, 0, 0)
      STATUS = TABINI(M, K, TAB)
      IF (STATUS.NE.0) THEN
        WRITE (*, 30) STATUS
 30     FORMAT ('TABINI ERROR',I2,'.')
        GO TO 999
      END IF

      STATUS = TABPUT (TAB, TAB_M, M, 0, 0)
      DO 50 IM = 1, M
        STATUS = TABPUT (TAB, TAB_K,     K(IM),     IM, 0)
        STATUS = TABPUT (TAB, TAB_MAP,   MAP(IM),   IM, 0)
        STATUS = TABPUT (TAB, TAB_CRVAL, CRVAL(IM), IM, 0)

        DO 40 IK = 1, K(IM)
          STATUS = TABPUT (TAB, TAB_INDEX, DBLE(IK-1), IM, IK)
 40     CONTINUE
 50   CONTINUE

*     Subdivide the interpolation element.
      DO 70 I = 1, NP
        DO 60 J = 1, NP
          X(1,J,I) = (J-1)*(K1-1.0)*SCL - 0.5 - CRVAL(1)
          X(2,J,I) = (I-1)*(K2-1.0)*SCL - 0.5 - CRVAL(2)
 60     CONTINUE
 70   CONTINUE

*     The first coordinate element is static.
      STATUS = TABPUT (TAB, TAB_COORD, 0D0, 1, 0)
      STATUS = TABPUT (TAB, TAB_COORD, 0D0, 3, 0)
      STATUS = TABPUT (TAB, TAB_COORD, 0D0, 5, 0)
      STATUS = TABPUT (TAB, TAB_COORD, 0D0, 7, 0)

*     (k1,k2) = (1,1).
      STATUS = TABPUT (TAB, TAB_COORD, 0D0, 2, 0)

*     The second coordinate element varies in three of the corners.
      DO 170 L3 = 0, 100, 20
*       (k1,k2) = (2,2).
        STATUS = TABPUT (TAB, TAB_COORD, 0.01D0*L3, 8, 0)

        DO 160 L2 = 0, 100, 20
*         (k1,k2) = (1,2).
          STATUS = TABPUT (TAB, TAB_COORD, 0.01D0*L2, 6, 0)

          CALL PGPAGE ()
          DO 150 L1 = 0, 100, 2
*           (k1,k2) = (2,1).
            STATUS = TABPUT (TAB, TAB_COORD, 0.01D0*L1, 4, 0)

*           Compute coordinates within the interpolation element.
            STATUS = TABX2S (TAB, NP*NP, 2, X, WORLD, STAT)
            IF (STATUS.NE.0) THEN
              WRITE (*, 80) STATUS
 80           FORMAT ('TABX2S ERROR',I2,'.')
            END IF

*           Start a new plot.
            CALL PGBBUF ()
            CALL PGERAS ()
            CALL PGSCI (1)
            CALL PGSLW (3)
            CALL PGBOX ('BCNST', 0.0, 0, 'BCNSTV', 0.0, 0)
            CALL PGMTXT ('T', 0.7, 0.5, 0.5, '-TAB coordinates:  ' //
     :                   'linear interpolation / extrapolation in 2-D')

*           Draw the boundary of the interpolation element in red.
            CALL PGSCI (2)
            CALL PGMOVE (-0.5,  0.0)
            CALL PGDRAW ( 1.5,  0.0)

            CALL PGMOVE ( 1.0, -0.5)
            CALL PGDRAW ( 1.0,  1.5)

            CALL PGMOVE ( 1.5,  1.0)
            CALL PGDRAW (-0.5,  1.0)

            CALL PGMOVE ( 0.0,  1.5)
            CALL PGDRAW ( 0.0, -0.5)

*           Label the value of the coordinate element in each corner.
            WRITE (TEXT, '(F3.1)') 0.0
            CALL PGTEXT (-0.09, -0.05, TEXT)
            WRITE (TEXT, '(F4.2)') 0.01*L1
            CALL PGTEXT ( 1.02, -0.05, TEXT)
            WRITE (TEXT, '(F3.1)') 0.01*L2
            CALL PGTEXT (-0.13,  1.02, TEXT)
            WRITE (TEXT, '(F3.1)') 0.01*L3
            CALL PGTEXT ( 1.02,  1.02, TEXT)

            CALL PGSCI (1)

*           Contour labelling: bottom.
            V0 = REAL(WORLD(2,1,1))
            V1 = REAL(WORLD(2,NP,1))
            IF (V0.NE.V1) THEN
              IF (ABS(INT((V1-V0)/0.2)).LT.10) THEN
                LSTEP = 20
              ELSE
                LSTEP = 40
              END IF

              DO 90 L = -200, 300, LSTEP
                W = -0.5 + 2.0*(L*0.01 - V0)/(V1 - V0)
                IF (W.LT.-0.5 .OR. W.GT.1.5) GO TO 90

                WRITE (TEXT, '(F4.1)') L*0.01
                CALL PGPTXT (W+0.04, -0.56, 0.0, 1.0, TEXT)
 90           CONTINUE
            END IF

*           Contour labelling: left.
            V0 = REAL(WORLD(2,1,1))
            V1 = REAL(WORLD(2,1,NP))
            IF (V0.NE.V1) THEN
              IF (ABS(INT((V1-V0)/0.2)).LT.10) THEN
                LSTEP = 20
              ELSE
                LSTEP = 40
              END IF

              DO 100 L = -200, 300, LSTEP
                W = -0.5 + 2.0*(L*0.01 - V0)/(V1 - V0)
                IF (W.LT.-0.5 .OR. W.GT.1.5) GO TO 100

                WRITE (TEXT, '(F4.1)') L*0.01
                CALL PGPTXT (-0.52, W-0.02, 0.0, 1.0, TEXT)
 100          CONTINUE
            END IF

*           Contour labelling: right.
            V0 = REAL(WORLD(2,NP,1))
            V1 = REAL(WORLD(2,NP,NP))
            IF (V0.NE.V1) THEN
              IF (ABS(INT((V1-V0)/0.2)).LT.10) THEN
                LSTEP = 20
              ELSE
                LSTEP = 40
              END IF

              DO 110 L = -200, 300, LSTEP
                W = -0.5 + 2.0*(L*0.01 - V0)/(V1 - V0)
                IF (W.LT.-0.5 .OR. W.GT.1.5) GO TO 110

                WRITE (TEXT, '(F3.1)') L*0.01
                CALL PGPTXT (1.52, W-0.02, 0.0, 0.0, TEXT)
 110          CONTINUE
            END IF

*           Contour labelling: top.
            V0 = REAL(WORLD(2,1,NP))
            V1 = REAL(WORLD(2,NP,NP))
            IF (V0.NE.V1) THEN
              IF (ABS(INT((V1-V0)/0.2)).LT.10) THEN
                LSTEP = 20
              ELSE
                LSTEP = 40
              END IF

              DO 120 L = -200, 300, LSTEP
                W = -0.5 + 2.0*(L*0.01 - V0)/(V1 - V0)
                IF (W.LT.-0.5 .OR. W.GT.1.5) GO TO 120

                WRITE (TEXT, '(F3.1)') L*0.01
                CALL PGPTXT (W+0.04, 1.52, 0.0, 1.0, TEXT)
 120          CONTINUE
            END IF

*           Draw contours for the second coordinate element.
            DO 140 I = 1, NP
              DO 130 J = 1, NP
                ARRAY(J,I) = REAL(WORLD(2,J,I))
 130          CONTINUE
 140        CONTINUE

            CALL PGSLW (2)

            CALL PGSCI (4)
            CALL PGCONT (ARRAY, NP, NP, 1, NP, 1, NP, CLEV(-10), 10,
     :                   LTM)

            CALL PGSCI (7)
            CALL PGCONT (ARRAY, NP, NP, 1, NP, 1, NP, CLEV(0), 1, LTM)

            CALL PGSCI (5)
            CALL PGCONT (ARRAY, NP, NP, 1, NP, 1, NP, CLEV(1), 20, LTM)

            CALL PGEBUF ()
 150      CONTINUE
 160    CONTINUE
 170  CONTINUE

      CALL PGEND ()

 999  STATUS = TABFREE (TAB)

      END


SUBROUTINE DetermineCurvilinearTransform2D(CompGrid,alpha,beta,gamma,GhostGridX,GhostGridY,GhostGridZ)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: alpha, beta, gamma, kappa, GhostGridX, GhostGridY, GhostGridZ, Nxg, Nyg, i1, i2
REAL(KIND=long) , DIMENSION(:,:), POINTER :: xe, xn, ye, yn, J, J3, xee, xen, xnn, yee, yen, ynn, &
												 nx, ny, ex, ey, exx, nxx, eyy, nyy, tmp2
Nxg = CompGrid%Nx + 2*GhostGridX
Nyg = CompGrid%Ny + 2*GhostGridY

! Allocate arrays
ALLOCATE(xe(Nxg,Nyg) , xn(Nxg,Nyg) , ye(Nxg,Nyg) , yn(Nxg,Nyg) )
ALLOCATE(J(Nxg,Nyg)  , J3(Nxg,Nyg) , xee(Nxg,Nyg), xen(Nxg,Nyg))
ALLOCATE(xnn(Nxg,Nyg), yee(Nxg,Nyg), yen(Nxg,Nyg), ynn(Nxg,Nyg))
ALLOCATE(exx(Nxg,Nyg), nxx(Nxg,Nyg), eyy(Nxg,Nyg), nyy(Nxg,Nyg))
ALLOCATE(ex(Nxg,Nyg) , ey(Nxg,Nyg) , nx(Nxg,Nyg) , ny(Nxg,Nyg) )
ALLOCATE(tmp2(Nxg,Nyg)                                         )

! Initialize
xe  = one;  xn  = zero; ye  = zero; yn  = one  ! note that two of these are initially set to one (this is convenient for 1D setup)
J   = zero; J3  = zero; xee = zero; xen = zero
xnn = zero; yee = zero; yen = zero; ynn = zero
exx = zero; nxx = zero; eyy = zero; nyy = zero
ex  = zero; ey  = zero; nx  = zero; ny  = zero
tmp2= zero

kappa = alpha
IF (alpha/=beta) THEN
	! FIXME: just picking the largest of alpha and beta here... perhaps check that they are equal in 3D
	kappa = MAX(alpha,beta)
END IF
!ALLOCATE(CompGrid%CurvilinearStuff%DiffStencils%StencilG(2*alpha+1,2*alpha+1,2))
!CALL DetermineGenericStencilsUniform(CompGrid%CurvilinearStuff%DiffStencils%StencilG,kappa)
CALL DetermineGenericStencils(CompGrid%CurvilinearStuff%DiffStencils,kappa)

! First derivatives
IF (CompGrid%Nx>1) THEN
  CALL DiffXuniform2D(CompGrid%x(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),1,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,alpha)
!  CALL DiffXuniform2D(CompGrid%x,&
!     tmp2,1,CompGrid%CurvilinearStuff%DiffStencils%StencilG,&
!     CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,alpha)
!  xe = tmp2
! GD: to prevent from J=zero on boundary...
  xe(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  	tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  IF (CompGrid%Ny>1) THEN
	CALL DiffYuniform2D(CompGrid%x(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),1,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,beta)
!	CALL DiffYuniform2D(CompGrid%x,&
!	  tmp2,1,CompGrid%CurvilinearStuff%DiffStencils%StencilG,&
!	  CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,beta)
!	xn = tmp2
! GD: to prevent from J=zero on boundary...
  xn(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  	tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  END IF
END IF
IF (CompGrid%Ny>1) THEN
	CALL DiffYuniform2D(CompGrid%y(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),1,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,beta)
!   CALL DiffYuniform2D(CompGrid%y,&
 !    tmp2,1,CompGrid%CurvilinearStuff%DiffStencils%StencilG,&
  !   CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,beta)
   !yn = tmp2
   ! GD: to prevent from J=zero on boundary...
   yn(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  		tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
   IF (CompGrid%Nx>1) THEN
     CALL DiffXuniform2D(CompGrid%y(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
       tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),1,&
       CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,alpha)
!	  CALL DiffXuniform2D(CompGrid%y,&
!		tmp2,1,CompGrid%CurvilinearStuff%DiffStencils%StencilG,&
!		CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY,alpha)
	  !ye = tmp2
      ! GD: to prevent from J=zero on boundary...
  	  ye(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  		tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
   END IF
END IF

! second derivatives
IF (CompGrid%Nx>1) THEN
  CALL DiffXuniform2D(CompGrid%x(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),2,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,alpha)
  !xee = tmp2
  ! GD: to prevent from assigning non-correct value... tmp2 not evaluated on boundary (not necessary since ghost points not used?!)
  xee(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  	tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  IF (CompGrid%Ny>1) THEN
	CALL DiffYuniform2D(CompGrid%x(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),2,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,beta)
    !xnn = tmp2
    ! GD: to prevent from assigning non-correct value... tmp2 not evaluated on boundary (not necessary since ghost points not used?!)
  	xnn(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  		tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  END IF
END IF
IF (CompGrid%Ny>1) THEN
  CALL DiffYuniform2D(CompGrid%y(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),2,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,beta)
  !ynn = tmp2
  ! GD: to prevent from assigning non-correct value... tmp2 not evaluated on boundary (not necessary since ghost points not used?!)
  ynn(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  	tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  IF (CompGrid%Nx>1) THEN
	  CALL DiffXuniform2D(CompGrid%y(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
       tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),2,&
       CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,alpha)
     !yee = tmp2
     ! GD: to prevent from assigning non-correct value... tmp2 not evaluated on boundary (not necessary since ghost points not used?!)
  	yee(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  		tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  END IF
END IF

! cross derivatives
!! FIXME: choice has been made with order of differentiation for cross-products here:
IF (CompGrid%Nx>1 .AND. CompGrid%Ny>1) THEN
!  CALL DiffYuniform2D(xe(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
!     tmp2,1,CompGrid%CurvilinearStuff%DiffStencils%StencilG,&
!     CompGrid%Nx,CompGrid%Ny,beta)
!  xen = tmp2
!  CALL DiffYuniform2D(ye(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
!     tmp2,1,CompGrid%CurvilinearStuff%DiffStencils%StencilG,&
!     CompGrid%Nx,CompGrid%Ny,beta)
!  yen = tmp2
! GD: error on indexes of tmp2
! GD: construct tmp2 on (Nx,Ny) points or (Nx+2*GhostGridX,Ny+2*GhostGridY)? 1st option after...
  CALL DiffYuniform2D(xe(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),1,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,beta)
  !xen = tmp2
  ! GD: to prevent from assigning non-correct value... tmp2 not evaluated on boundary (not necessary since ghost points not used?!)
  xen(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  	tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
  CALL DiffYuniform2D(ye(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),&
     tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY),1,&
     CompGrid%CurvilinearStuff%DiffStencils%StencilG,CompGrid%Nx,CompGrid%Ny,beta)
  !yen = tmp2
  ! GD: to prevent from assigning non-correct value... tmp2 not evaluated on boundary (not necessary since ghost points not used?!)
  yen(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)= &
  	tmp2(1+GhostGridX:CompGrid%Nx+GhostGridX,1+GhostGridY:CompGrid%Ny+GhostGridY)
END IF

J   = xe*yn-ye*xn ! 2D operator

nx  = -ye/J ! d\eta dx
ny  =  xe/J ! d\eta dy
ex  =  yn/J ! d\xi dx
ey  = -xn/J ! d\xi dy

J3  = J**3
exx = one/J3*(-xee*yn**3+two*xen*yn**2*ye-xnn*yn*ye**2+xn*ynn*ye**2-two*xn*yn*ye*yen+xn*yn**2*yee)
nxx = one/J3*(xee*yn**2*ye-two*xen*yn*ye**2-xe*ynn*ye**2+xnn*ye**3+two*xe*yn*ye*yen-xe*yn**2*yee)
eyy = one/J3*(-xnn*xe**2*yn+xn*(two*xe*xen*yn-xn*xee*yn+xe**2*ynn-two*xn*xe*yen+xn**2*yee))
nyy = one/J3*(-xe**3*ynn+xn**2*xee*ye+xe**2*(xnn*ye+two*xn*yen)-xn*xe*(two*xen*ye+xn*yee))
! not needed - but kept here for potential future need
!exy = one/J3*(xe*(-xen*yn**2+xnn*yn*ye-xn*ynn*ye+xn*yn*yen)+xn*(xee*yn**2-xen*yn*ye+xn*ye*yen-xn*yn*yee))
!nxy = one/J3*(xn*ye*(-xee*yn+xen*ye)+xe**2*(ynn*ye-yn*yen)+xe*(xen*yn*ye-xnn*ye**2-xn*ye*yen+xn*yn*yee))

CompGrid%CurvilinearStuff%xe  => xe
CompGrid%CurvilinearStuff%xn  => xn
CompGrid%CurvilinearStuff%xen => xen
CompGrid%CurvilinearStuff%xee => xee
CompGrid%CurvilinearStuff%xnn => xnn
CompGrid%CurvilinearStuff%ye  => ye
CompGrid%CurvilinearStuff%yn  => yn
CompGrid%CurvilinearStuff%yen => yen
CompGrid%CurvilinearStuff%yee => yee
CompGrid%CurvilinearStuff%ynn => ynn
CompGrid%CurvilinearStuff%J   => J
CompGrid%CurvilinearStuff%J3  => J3
CompGrid%CurvilinearStuff%ex  => ex
CompGrid%CurvilinearStuff%ey  => ey
CompGrid%CurvilinearStuff%nx  => nx
CompGrid%CurvilinearStuff%ny  => ny
CompGrid%CurvilinearStuff%exx => exx
CompGrid%CurvilinearStuff%nxx => nxx
CompGrid%CurvilinearStuff%eyy => eyy
CompGrid%CurvilinearStuff%nyy => nyy

END SUBROUTINE DetermineCurvilinearTransform2D