      subroutine r8akherm3(x,nx,y,ny,z,nz,fherm,nf2,nf3,
     >   ilinx,iliny,ilinz,ier)
C
C  create a data set for Hermite interpolation, based on Akima's method
C  [Hiroshi Akima, Communications of the ACM, Jan 1974, Vol. 17 No. 1]
C
C  3d routine
C
C  input:
C
C  nf2.get.nx and nf3.ge.ny  expected!
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER iliny,ilinz,ier,ilinx
!============
      integer nx,ny,nz,nf2,nf3          ! array dimensions
      REAL*8 x(nx)                        ! x coordinate array
      REAL*8 y(ny)                        ! y coordinate array
      REAL*8 z(nz)                        ! z coordinate array
      REAL*8 fherm(0:7,nf2,nf3,nz)        ! data/Hermite array
C
C  fherm(0,i,j,k) = function value f at x(i),y(j),z(k)  **on input**
C
C  fherm(1,i,j,k) = derivative df/dx at x(i),y(j),z(k)  **on output**
C  fherm(2,i,j,k) = derivative df/dy at x(i),y(j),z(k)  **on output**
C  fherm(3,i,j,k) = derivative df/dz at x(i),y(j),z(k)  **on output**
C  fherm(4,i,j,k) = derivative d2f/dxdy at x(i),y(j),z(k)  **on output**
C  fherm(5,i,j,k) = derivative d2f/dxdz at x(i),y(j),z(k)  **on output**
C  fherm(6,i,j,k) = derivative d2f/dydz at x(i),y(j),z(k)  **on output**
C  fherm(7,i,j,k) = derivative d3f/dxdydz at x(i),y(j),z(k)  **on output**
C
C  additional outputs:
C
C    ilinx = 1  if x is evenly spaced (approximately)
C    iliny = 1  if y is evenly spaced (approximately)
C    ilinz = 1  if z is evenly spaced (approximately)
C
C    ier = 0 if there are no errors
C
C  note possible errors:  x y or z NOT strict ascending
C  nf2.lt.nx   .or.   nf3.lt.ny
C
C  a default boundary condition is used, based on divided differences
C  in the edge region.  For more control of BC, use akherm3p...
C
      call r8akherm3p(x,nx,y,ny,z,nz,fherm,nf2,nf3,
     >   ilinx,iliny,ilinz,0,0,0,ier)
C
      return
      end
C----------------------------
      subroutine r8akherm3p(x,nx,y,ny,z,nz,fherm,nf2,nf3,
     >   ilinx,iliny,ilinz,ipx,ipy,ipz,ier)
C
C  create a data set for Hermite interpolation, based on Akima's method
C  [Hiroshi Akima, Communications of the ACM, Jan 1974, Vol. 17 No. 1]
C
C  3d routine --
C  with independently settable boundary condition options:
C     ipx|ipy|ipz  =0  -- default, boundary conditions from divided diffs
C     ipx|ipy|ipz  =1  -- periodic boundary condition
C     ipx|ipy|ipz  =2  -- user supplied df/dx|df/dy|df/dz
C
C  input:
C
C  nf2.get.nx and nf3.ge.ny  expected!
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER iliny,ilinz,ier,ilinx,ierx,iery,ierz,ierbc,iz,iy,ix
      INTEGER icx,incx,ix1,icy,incy,iy1,icz,incz,iz1,izm2,izm1
      INTEGER izmm2,izmm1,izp2,izp1,izpp2,izpp1,iym2,iym1,iymm2
      INTEGER iymm1,iyp2,iyp1,iypp2,iypp1,ixm2,ixm1,ixmm2,ixmm1
      INTEGER iflagx,ixp2,ixp1,ixpp2,ixpp1,iflagy,iflagz,k
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 cxp,cxm,cxpp,cxmm,cxtrap0,cxtrapn,cyp,cym,cypp,cymm
      REAL*8 cytrap0,cytrapn,czp,czm,czpp,czmm,cztrap0,cztrapn
      REAL*8 zansr,cxm2,cxp2,cym2,cyp2,fzp,fzm
!============
      integer nx,ny,nz,nf2,nf3          ! array dimensions
      REAL*8 x(nx)                        ! x coordinate array
      REAL*8 y(ny)                        ! y coordinate array
      REAL*8 z(nz)                        ! z coordinate array
      REAL*8 fherm(0:7,nf2,nf3,nz)        ! data/Hermite array
C
      integer ipx                       ! =0: dflt; =1: periodic df/dx
      integer ipy                       ! =0: dflt; =1: periodic df/dy
      integer ipz                       ! =0: dflt; =1: periodic df/dz
C
C  if ipx=2:  fherm(1,1,1:ny,1:nz) & fherm(1,nx,1:ny,1:nz) = INPUT df/dx BCs
C  if ipy=2:  fherm(2,1:nx,1,1:nz) & fherm(2,1:nx,ny,1:nz) = INPUT df/dy BCs
C  if ipz=2:  fherm(3,1:nx,1:ny,1) & fherm(3,1:nx,1:ny,nz) = INPUT df/dz BCs
C
C  for the rest of the grid points...
C
C  fherm(0,i,j,k) = function value f at x(i),y(j),z(k)  **on input**
C
C  fherm(1,i,j,k) = derivative df/dx at x(i),y(j),z(k)  **on output**
C  fherm(2,i,j,k) = derivative df/dy at x(i),y(j),z(k)  **on output**
C  fherm(3,i,j,k) = derivative df/dz at x(i),y(j),z(k)  **on output**
C  fherm(4,i,j,k) = derivative d2f/dxdy at x(i),y(j),z(k)  **on output**
C  fherm(5,i,j,k) = derivative d2f/dxdz at x(i),y(j),z(k)  **on output**
C  fherm(6,i,j,k) = derivative d2f/dydz at x(i),y(j),z(k)  **on output**
C  fherm(7,i,j,k) = derivative d3f/dxdydz at x(i),y(j),z(k)  **on output**
C
C  additional outputs:
C
C    ilinx = 1  if x is evenly spaced (approximately)
C    iliny = 1  if y is evenly spaced (approximately)
C    ilinz = 1  if z is evenly spaced (approximately)
C
C---------------------
C  local...
C
      REAL*8 wx(2),wy(2),wz(2),exy(2,2),exz(2,2),eyz(2,2),fxyz(2,2,2)
C
      REAL*8, dimension(:,:,:), allocatable ::  ftmp
c
      REAL*8 xx(0:nx+1)
      REAL*8 yy(0:ny+1)
      REAL*8 zz(0:nz+1)
C
C----------------------------
C
C  error check
C
      ier=0
c
      call r8splinck(x,nx,ilinx,1.0E-3_r8,ierx)
      if(ierx.ne.0) ier=ier+1
c
      if(ierx.ne.0) then
         write(6,'('' ?akherm3:  x axis not strict ascending'')')
      endif
c
      call r8splinck(y,ny,iliny,1.0E-3_r8,iery)
      if(iery.ne.0) ier=ier+1
c
      if(iery.ne.0) then
         write(6,'('' ?akherm3:  y axis not strict ascending'')')
      endif
c
      call r8splinck(z,nz,ilinz,1.0E-3_r8,ierz)
      if(ierz.ne.0) ier=ier+1
c
      if(ierz.ne.0) then
         write(6,'('' ?akherm3:  z axis not strict ascending'')')
      endif
c
      if(nf2.lt.nx) then
         ier=ier+1
         write(6,*) '?akherm3:  fherm (x) array dimension too small.'
      endif
c
      if(nf3.lt.ny) then
         ier=ier+1
         write(6,*) '?akherm3:  fherm (y) array dimension too small.'
      endif
C
      ierbc=0
      call ibc_ck(ipx,'akherm3','X Bdy Cond',0,2,ierbc)
      ier=ier+ierbc
C
      ierbc=0
      call ibc_ck(ipy,'akherm3','Y Bdy Cond',0,2,ierbc)
      ier=ier+ierbc
C
      ierbc=0
      call ibc_ck(ipz,'akherm3','Z Bdy Cond',0,2,ierbc)
      ier=ier+ierbc
C
      if(ier.ne.0) return
C
C  error check OK
C
C---------------------------------------
C
C  get a  temporary array for f -- will extend out by 1 zone in
C  each direction so that numerical derivative evaluation can be
C  done without a lot of special case logic near the edges...
C
      allocate(ftmp(0:nx+1,0:ny+1,0:nz+1))
C
      do iz=1,nz
         do iy=1,ny
            do ix=1,nx
               ftmp(ix,iy,iz)=fherm(0,ix,iy,iz)
            enddo
         enddo
      enddo
C
C  also create expanded axes grids...
C
      xx(1:nx)=x
      yy(1:ny)=y
      zz(1:nz)=z
c
      xx(0)=2*x(1)-x(2)
      xx(nx+1)=2*x(nx)-x(nx-1)
      yy(0)=2*y(1)-y(2)
      yy(ny+1)=2*y(ny)-y(ny-1)
      zz(0)=2*z(1)-z(2)
      zz(nz+1)=2*z(nz)-z(nz-1)
C
C---------------------------------------
C
C  handle boundary conditions and create rows of extrapolated points
C  in ftmp.  first do ftmp(0,1:ny), ftmp(nx+1,1:ny),
C                then ftmp(1:nx,0), ftmp(1:nx,ny+1),
c                then ... fill in the corners
c
c  also, for ipx.le.1 fill in the bdy fherm(1,*) values;
c        for ipy.le.1 fill in the bdy fherm(2,*) values
c
c  x bc's
c
      do iz=1,nz
         do iy=1,ny
c
            cxp=(ftmp(2,iy,iz)-ftmp(1,iy,iz))/(xx(2)-xx(1))
            cxm=(ftmp(nx,iy,iz)-ftmp(nx-1,iy,iz))/(xx(nx)-xx(nx-1))
c
            if(ipx.eq.1) then
c
c  periodic BC
c
               if(nx.gt.2) then
                  cxpp=(ftmp(3,iy,iz)-ftmp(2,iy,iz))/(xx(3)-xx(2))
                  cxmm=(ftmp(nx-1,iy,iz)-ftmp(nx-2,iy,iz))/
     >                 (xx(nx-1)-xx(nx-2))
c
                  call r8akherm0(cxmm,cxm,cxp,cxpp,wx,fherm(1,1,iy,iz))
                  fherm(1,nx,iy,iz)=fherm(1,1,iy,iz)
c
               else
                  fherm(1,1,iy,iz)=cxp  ! =cxm, nx=2
                  fherm(1,nx,iy,iz)=fherm(1,1,iy,iz)
               endif
c
               cxtrap0=cxm
               cxtrapn=cxp
c
            else if(ipx.eq.0) then
C
C  default BC -- standard numeric extrapolation
C
               if(nx.gt.2) then
                  cxpp=(ftmp(3,iy,iz)-ftmp(2,iy,iz))/(xx(3)-xx(2))
                  fherm(1,1,iy,iz)=1.5_r8*cxp-0.5_r8*cxpp
C
                  cxmm=(ftmp(nx-1,iy,iz)-ftmp(nx-2,iy,iz))/
     >                 (xx(nx-1)-xx(nx-2))
                  fherm(1,nx,iy,iz)=1.5_r8*cxm-0.5_r8*cxmm
c
               else
                  fherm(1,1,iy,iz)=cxp  ! =cxm, nx=2
                  fherm(1,nx,iy,iz)=fherm(1,1,iy,iz)
               endif
C
C  extrapolate to slope to ghost points just past bdy...
C
               cxtrap0=2.0_r8*fherm(1,1,iy,iz)-cxp
               cxtrapn=2.0_r8*fherm(1,nx,iy,iz)-cxm
C
            else
C
C  BC supplied by user.  Also use this for extrapolation...
C
               cxtrap0=2.0_r8*fherm(1,1,iy,iz)-cxp
               cxtrapn=2.0_r8*fherm(1,nx,iy,iz)-cxm
C
            endif
C
            ftmp(0,iy,iz)=ftmp(1,iy,iz)-cxtrap0*(xx(1)-xx(0))
            ftmp(nx+1,iy,iz)=ftmp(nx,iy,iz)+cxtrapn*(xx(nx+1)-xx(nx))
C
         enddo
      enddo
c
c  y bc's
c
      do iz=1,nz
         do ix=1,nx
c
            cyp=(ftmp(ix,2,iz)-ftmp(ix,1,iz))/(yy(2)-yy(1))
            cym=(ftmp(ix,ny,iz)-ftmp(ix,ny-1,iz))/(yy(ny)-yy(ny-1))
c
            if(ipy.eq.1) then
c
c  periodic BC
c
               if(ny.gt.2) then
                  cypp=(ftmp(ix,3,iz)-ftmp(ix,2,iz))/(yy(3)-yy(2))
                  cymm=(ftmp(ix,ny-1,iz)-ftmp(ix,ny-2,iz))/
     >                 (yy(ny-1)-yy(ny-2))
c
                  call r8akherm0(cymm,cym,cyp,cypp,wy,fherm(2,ix,1,iz))
                  fherm(2,ix,ny,iz)=fherm(2,ix,1,iz)
c
               else
                  fherm(2,ix,1,iz) = cyp  ! =cym, ny=2
                  fherm(2,ix,ny,iz)=fherm(2,ix,1,iz)
               endif
               cytrap0=cym
               cytrapn=cyp
c
            else if(ipy.eq.0) then
C
C  default BC -- standard numeric extrapolation
C
               if(ny.gt.2) then
                  cypp=(ftmp(ix,3,iz)-ftmp(ix,2,iz))/(yy(3)-yy(2))
                  fherm(2,ix,1,iz)=1.5_r8*cyp-0.5_r8*cypp
C
                  cymm=(ftmp(ix,ny-1,iz)-ftmp(ix,ny-2,iz))/
     >                 (yy(ny-1)-yy(ny-2))
                  fherm(2,ix,ny,iz)=1.5_r8*cym-0.5_r8*cymm
c
               else
                  fherm(2,ix,1,iz) = cyp  ! =cym, ny=2
                  fherm(2,ix,ny,iz)=fherm(2,ix,1,iz)
               endif
C
C  extrapolate to slope to ghost points just past bdy...
C
               cytrap0=2.0_r8*fherm(2,ix,1,iz)-cyp
               cytrapn=2.0_r8*fherm(2,ix,ny,iz)-cym
C
            else
C
C  BC supplied by user.  Also use this for extrapolation...
C
               cytrap0=2.0_r8*fherm(2,ix,1,iz)-cyp
               cytrapn=2.0_r8*fherm(2,ix,ny,iz)-cym
C
            endif
C
            ftmp(ix,0,iz)=ftmp(ix,1,iz)-cytrap0*(yy(1)-yy(0))
            ftmp(ix,ny+1,iz)=ftmp(ix,ny,iz)+cytrapn*(yy(ny+1)-yy(ny))
C
         enddo
      enddo
c
c  z bc's
c
      do iy=1,ny
         do ix=1,nx
c
            czp=(ftmp(ix,iy,2)-ftmp(ix,iy,1))/(zz(2)-zz(1))
            czm=(ftmp(ix,iy,nz)-ftmp(ix,iy,nz-1))/(zz(nz)-zz(nz-1))
c
            if(ipy.eq.1) then
c
c  periodic BC
c
               if(nz.gt.2) then
                  czpp=(ftmp(ix,iy,3)-ftmp(ix,iy,2))/(zz(3)-zz(2))
                  czmm=(ftmp(ix,iy,nz-1)-ftmp(ix,iy,nz-2))/
     >                 (zz(nz-1)-zz(nz-2))
c
                  call r8akherm0(czmm,czm,czp,czpp,wz,fherm(3,ix,iy,1))
                  fherm(3,ix,iy,nz)=fherm(3,ix,iy,1)
c
               else
                  fherm(3,ix,iy,1) = czp
                  fherm(3,ix,iy,nz)=fherm(3,ix,iy,1)
               endif
c
               cztrap0=czm
               cztrapn=czp
c
            else if(ipy.eq.0) then
C
C  default BC -- standard numeric extrapolation
C
               if(nz.gt.2) then
                  czpp=(ftmp(ix,iy,3)-ftmp(ix,iy,2))/(zz(3)-zz(2))
                  fherm(3,ix,iy,1)=1.5_r8*czp-0.5_r8*czpp
C
                  czmm=(ftmp(ix,iy,nz-1)-ftmp(ix,iy,nz-2))/
     >                 (zz(nz-1)-zz(nz-2))
                  fherm(3,ix,iy,nz)=1.5_r8*czm-0.5_r8*czmm
c
               else
                  fherm(3,ix,iy,1) = czp
                  fherm(3,ix,iy,nz)=fherm(3,ix,iy,1)
               endif
C
C  extrapolate to slope to ghost points just past bdy...
C
               cztrap0=2.0_r8*fherm(3,ix,iy,1)-czp
               cztrapn=2.0_r8*fherm(3,ix,iy,nz)-czm
C
            else
C
C  BC supplied by user.  Also use this for extrapolation...
C
               cztrap0=2.0_r8*fherm(3,ix,iy,1)-czp
               cztrapn=2.0_r8*fherm(3,ix,iy,nz)-czm
C
            endif
C
            ftmp(ix,iy,0)=ftmp(ix,iy,1)-cztrap0*(zz(1)-zz(0))
            ftmp(ix,iy,nz+1)=ftmp(ix,iy,nz)+cztrapn*(zz(nz+1)-zz(nz))
C
         enddo
      enddo
c
c  and for the edges...
c
      do iz=1,nz
         do ix=0,1
            icx=ix*(nx+1)
            incx=1-2*ix
            ix1=icx+incx
            do iy=0,1
               icy=iy*(ny+1)
               incy=1-2*iy
               iy1=icy+incy
C
               ftmp(icx,icy,iz)=ftmp(icx,iy1,iz)+ftmp(ix1,icy,iz)-
     >              ftmp(ix1,iy1,iz)
C
            enddo
         enddo
      enddo
c
      do iy=1,ny
         do iz=0,1
            icz=iz*(nz+1)
            incz=1-2*iz
            iz1=icz+incz
            do ix=0,1
               icx=ix*(nx+1)
               incx=1-2*ix
               ix1=icx+incx
C
               ftmp(icx,iy,icz)=ftmp(icx,iy,iz1)+ftmp(ix1,iy,icz)-
     >              ftmp(ix1,iy,iz1)
C
            enddo
         enddo
      enddo
c
      do ix=1,nx
         do iy=0,1
            icy=iy*(ny+1)
            incy=1-2*iy
            iy1=icy+incy
            do iz=0,1
               icz=iz*(nz+1)
               incz=1-2*iz
               iz1=icz+incz
C
               ftmp(ix,icy,icz)=ftmp(ix,icy,iz1)+ftmp(ix,iy1,icz)-
     >              ftmp(ix,iy1,iz1)
C
            enddo
         enddo
      enddo
c
c  and the corners...
c
      do iz=0,1
         icz=iz*(nz+1)
         incz=1-2*iz
         iz1=icz+incz
         do iy=0,1
            icy=iy*(ny+1)
            incy=1-2*iy
            iy1=icy+incy
            do ix=0,1
               icx=ix*(nx+1)
               incx=1-2*ix
               ix1=icx+incx
C
               ftmp(icx,icy,icz)=(
     >              2*(ftmp(icx,icy,iz1)+ftmp(icx,iy1,icz)+
     >              ftmp(ix1,icy,icz)) -
     >              (ftmp(icx,iy1,iz1)+ftmp(ix1,icy,iz1)+
     >              ftmp(ix1,iy1,icz)))/3
C
            enddo
         enddo
      enddo
c
c-----------------------------------------------------
c  boundary done; now fill in the interior
c
c
      do iz=1,nz
         izm2=iz
         izm1=izm2-1
c
         izmm2=iz-1
         izmm1=izmm2-1
c
         izp2=iz+1
         izp1=izp2-1
c
         izpp2=iz+2
         izpp1=izpp2-1
c
         do iy=1,ny
            iym2=iy
            iym1=iym2-1
c
            iymm2=iy-1
            iymm1=iymm2-1
c
            iyp2=iy+1
            iyp1=iyp2-1
c
            iypp2=iy+2
            iypp1=iypp2-1
c
            do ix=1,nx
c
c  x div. diffs in vicinity
c
               ixm2=ix
               ixm1=ixm2-1
c
               ixmm2=ix-1
               ixmm1=ixmm2-1
c
               iflagx=0
               cxm=(ftmp(ixm2,iy,iz)-ftmp(ixm1,iy,iz))/
     >            (xx(ixm2)-xx(ixm1))
               if(ix.gt.1) then
                  cxmm=(ftmp(ixmm2,iy,iz)-ftmp(ixmm1,iy,iz))/
     >               (xx(ixmm2)-xx(ixmm1))
               else
                  if(ipx.eq.1) then
                     cxmm=(ftmp(nx-1,iy,iz)-ftmp(nx-2,iy,iz))/
     >                  (xx(nx-1)-xx(nx-2))
                  else
                     iflagx=1
                  endif
               endif
c
               ixp2=ix+1
               ixp1=ixp2-1
c
               ixpp2=ix+2
               ixpp1=ixpp2-1
c
               cxp=(ftmp(ixp2,iy,iz)-ftmp(ixp1,iy,iz))/
     >            (xx(ixp2)-xx(ixp1))
               if(ix.lt.nx) then
                  cxpp=(ftmp(ixpp2,iy,iz)-ftmp(ixpp1,iy,iz))/
     >               (xx(ixpp2)-xx(ixpp1))
               else
                  if(ipx.eq.1) then
                     cxpp=(ftmp(3,iy,iz)-ftmp(2,iy,iz))/
     >                  (xx(3)-xx(2))
                  else
                     cxpp=cxp+(cxm-cxmm)
                  endif
               endif
c
               if(iflagx.eq.1) then
                  cxmm=cxm+(cxp-cxpp)
               endif
c
c  Akima weightings + df/dx for interior pts
c
               call r8akherm0(cxmm,cxm,cxp,cxpp,wx,zansr)
               if((ix.gt.1).and.(ix.lt.nx)) fherm(1,ix,iy,iz)=zansr
c
c  y div. diffs in vicinity
c
               iflagy=0
               cym=(ftmp(ix,iym2,iz)-ftmp(ix,iym1,iz))/
     >            (yy(iym2)-yy(iym1))
               if(iy.gt.1) then
                  cymm=(ftmp(ix,iymm2,iz)-ftmp(ix,iymm1,iz))/
     >               (yy(iymm2)-yy(iymm1))
               else
                  if(ipy.eq.1) then
                     cymm=(ftmp(ix,ny-1,iz)-ftmp(ix,ny-2,iz))/
     >                  (yy(ny-1)-yy(ny-2))
                  else
                     iflagy=1
                  endif
               endif
c
               cyp=(ftmp(ix,iyp2,iz)-ftmp(ix,iyp1,iz))/
     >            (yy(iyp2)-yy(iyp1))
               if(iy.lt.ny) then
                  cypp=(ftmp(ix,iypp2,iz)-ftmp(ix,iypp1,iz))/
     >               (yy(iypp2)-yy(iypp1))
               else
                  if(ipy.eq.1) then
                     cypp=(ftmp(ix,3,iz)-ftmp(ix,2,iz))/(yy(3)-yy(2))
                  else
                     cypp=cyp+(cym-cymm)
                  endif
               endif
c
               if(iflagy.eq.1) then
                  cymm=cym+(cyp-cypp)
               endif
c
c  Akima weightings + df/dy for interior pts
c
               call r8akherm0(cymm,cym,cyp,cypp,wy,zansr)
               if((iy.gt.1).and.(iy.lt.ny)) fherm(2,ix,iy,iz)=zansr
c
c  z div. diffs in vicinity
c
               iflagz=0
               czm=(ftmp(ix,iy,izm2)-ftmp(ix,iy,izm1))/
     >            (zz(izm2)-zz(izm1))
               if(iz.gt.1) then
                  czmm=(ftmp(ix,iy,izmm2)-ftmp(ix,iy,izmm1))/
     >               (zz(izmm2)-zz(izmm1))
               else
                  if(ipz.eq.1) then
                     czmm=(ftmp(ix,iy,nz-1)-ftmp(ix,iy,nz-2))/
     >                  (zz(nz-1)-zz(nz-2))
                  else
                     iflagz=1
                  endif
               endif
c
               czp=(ftmp(ix,iy,izp2)-ftmp(ix,iy,izp1))/
     >            (zz(izp2)-zz(izp1))
               if(iz.lt.nz) then
                  czpp=(ftmp(ix,iy,izpp2)-ftmp(ix,iy,izpp1))/
     >               (zz(izpp2)-zz(izpp1))
               else
                  if(ipz.eq.1) then
                     czpp=(ftmp(ix,iy,3)-ftmp(ix,iy,2))/(zz(3)-zz(2))
                  else
                     czpp=czp+(czm-czmm)
                  endif
               endif
c
               if(iflagz.eq.1) then
                  czmm=czm+(czp-czpp)
               endif
c
c  Akima weightings + df/dy for interior pts
c
               call r8akherm0(czmm,czm,czp,czpp,wz,zansr)
               if((iz.gt.1).and.(iz.lt.nz)) fherm(3,ix,iy,iz)=zansr
c
c  cross derivatives (2nd order divided differences)
c
               cxm2=(ftmp(ixm2,iym1,iz)-ftmp(ixm1,iym1,iz))/
     >            (xx(ixm2)-xx(ixm1))
               exy(1,1)=(cxm-cxm2)/(yy(iym2)-yy(iym1))
c
               cxm2=(ftmp(ixm2,iyp2,iz)-ftmp(ixm1,iyp2,iz))/
     >            (xx(ixm2)-xx(ixm1))
               exy(1,2)=(cxm2-cxm)/(yy(iyp2)-yy(iyp1))
c
               cxp2=(ftmp(ixp2,iym1,iz)-ftmp(ixp1,iym1,iz))/
     >            (xx(ixp2)-xx(ixp1))
               exy(2,1)=(cxp-cxp2)/(yy(iym2)-yy(iym1))
c
               cxp2=(ftmp(ixp2,iyp2,iz)-ftmp(ixp1,iyp2,iz))/
     >            (xx(ixp2)-xx(ixp1))
               exy(2,2)=(cxp2-cxp)/(yy(iyp2)-yy(iyp1))
c
c---------
c
               cxm2=(ftmp(ixm2,iy,izm1)-ftmp(ixm1,iy,izm1))/
     >            (xx(ixm2)-xx(ixm1))
               exz(1,1)=(cxm-cxm2)/(zz(izm2)-zz(izm1))
c
               cxm2=(ftmp(ixm2,iy,izp2)-ftmp(ixm1,iy,izp2))/
     >            (xx(ixm2)-xx(ixm1))
               exz(1,2)=(cxm2-cxm)/(zz(izp2)-zz(izp1))
c
               cxp2=(ftmp(ixp2,iy,izm1)-ftmp(ixp1,iy,izm1))/
     >            (xx(ixp2)-xx(ixp1))
               exz(2,1)=(cxp-cxp2)/(zz(izm2)-zz(izm1))
c
               cxp2=(ftmp(ixp2,iy,izp2)-ftmp(ixp1,iy,izp2))/
     >            (xx(ixp2)-xx(ixp1))
               exz(2,2)=(cxp2-cxp)/(zz(izp2)-zz(izp1))
c
c---------
c
               cym2=(ftmp(ix,iym2,izm1)-ftmp(ix,iym1,izm1))/
     >            (yy(iym2)-yy(iym1))
               eyz(1,1)=(cym-cym2)/(zz(izm2)-zz(izm1))
c
               cym2=(ftmp(ix,iym2,izp2)-ftmp(ix,iym1,izp2))/
     >            (yy(iym2)-yy(iym1))
               eyz(1,2)=(cym2-cym)/(zz(izp2)-zz(izp1))
c
               cyp2=(ftmp(ix,iyp2,izm1)-ftmp(ix,iyp1,izm1))/
     >            (yy(iyp2)-yy(iyp1))
               eyz(2,1)=(cyp-cyp2)/(zz(izm2)-zz(izm1))
c
               cyp2=(ftmp(ix,iyp2,izp2)-ftmp(ix,iyp1,izp2))/
     >            (yy(iyp2)-yy(iyp1))
               eyz(2,2)=(cyp2-cyp)/(zz(izp2)-zz(izp1))
c
c  dxdydz 3rd order cross deriv.
c
               k=1
c
               fzp=(ftmp(ixm2,iym2,izm2)-ftmp(ixm2,iym1,izm2)-
     >            ftmp(ixm1,iym2,izm2)+ftmp(ixm1,iym1,izm2))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iym2)-yy(iym1)))
               fzm=(ftmp(ixm2,iym2,izm1)-ftmp(ixm2,iym1,izm1)-
     >            ftmp(ixm1,iym2,izm1)+ftmp(ixm1,iym1,izm1))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iym2)-yy(iym1)))
               fxyz(1,1,k)=(fzp-fzm)/(zz(izm2)-zz(izm1))
c
               fzp=(ftmp(ixm2,iyp2,izm2)-ftmp(ixm2,iyp1,izm2)-
     >            ftmp(ixm1,iyp2,izm2)+ftmp(ixm1,iyp1,izm2))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iyp2)-yy(iyp1)))
               fzm=(ftmp(ixm2,iyp2,izm1)-ftmp(ixm2,iyp1,izm1)-
     >            ftmp(ixm1,iyp2,izm1)+ftmp(ixm1,iyp1,izm1))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iyp2)-yy(iyp1)))
               fxyz(1,2,k)=(fzp-fzm)/(zz(izm2)-zz(izm1))
c
               fzp=(ftmp(ixp2,iym2,izm2)-ftmp(ixp2,iym1,izm2)-
     >            ftmp(ixp1,iym2,izm2)+ftmp(ixp1,iym1,izm2))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iym2)-yy(iym1)))
               fzm=(ftmp(ixp2,iym2,izm1)-ftmp(ixp2,iym1,izm1)-
     >            ftmp(ixp1,iym2,izm1)+ftmp(ixp1,iym1,izm1))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iym2)-yy(iym1)))
               fxyz(2,1,k)=(fzp-fzm)/(zz(izm2)-zz(izm1))
c
               fzp=(ftmp(ixp2,iyp2,izm2)-ftmp(ixp2,iyp1,izm2)-
     >            ftmp(ixp1,iyp2,izm2)+ftmp(ixp1,iyp1,izm2))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iyp2)-yy(iyp1)))
               fzm=(ftmp(ixp2,iyp2,izm1)-ftmp(ixp2,iyp1,izm1)-
     >            ftmp(ixp1,iyp2,izm1)+ftmp(ixp1,iyp1,izm1))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iyp2)-yy(iyp1)))
               fxyz(2,2,k)=(fzp-fzm)/(zz(izm2)-zz(izm1))
c
               k=2
c
               fzp=(ftmp(ixm2,iym2,izp2)-ftmp(ixm2,iym1,izp2)-
     >            ftmp(ixm1,iym2,izp2)+ftmp(ixm1,iym1,izp2))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iym2)-yy(iym1)))
               fzm=(ftmp(ixm2,iym2,izp1)-ftmp(ixm2,iym1,izp1)-
     >            ftmp(ixm1,iym2,izp1)+ftmp(ixm1,iym1,izp1))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iym2)-yy(iym1)))
               fxyz(1,1,k)=(fzp-fzm)/(zz(izp2)-zz(izp1))
c
               fzp=(ftmp(ixm2,iyp2,izp2)-ftmp(ixm2,iyp1,izp2)-
     >            ftmp(ixm1,iyp2,izp2)+ftmp(ixm1,iyp1,izp2))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iyp2)-yy(iyp1)))
               fzm=(ftmp(ixm2,iyp2,izp1)-ftmp(ixm2,iyp1,izp1)-
     >            ftmp(ixm1,iyp2,izp1)+ftmp(ixm1,iyp1,izp1))/
     >            ((xx(ixm2)-xx(ixm1))*(yy(iyp2)-yy(iyp1)))
               fxyz(1,2,k)=(fzp-fzm)/(zz(izp2)-zz(izp1))
c
               fzp=(ftmp(ixp2,iym2,izp2)-ftmp(ixp2,iym1,izp2)-
     >            ftmp(ixp1,iym2,izp2)+ftmp(ixp1,iym1,izp2))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iym2)-yy(iym1)))
               fzm=(ftmp(ixp2,iym2,izp1)-ftmp(ixp2,iym1,izp1)-
     >            ftmp(ixp1,iym2,izp1)+ftmp(ixp1,iym1,izp1))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iym2)-yy(iym1)))
               fxyz(2,1,k)=(fzp-fzm)/(zz(izp2)-zz(izp1))
c
               fzp=(ftmp(ixp2,iyp2,izp2)-ftmp(ixp2,iyp1,izp2)-
     >            ftmp(ixp1,iyp2,izp2)+ftmp(ixp1,iyp1,izp2))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iyp2)-yy(iyp1)))
               fzm=(ftmp(ixp2,iyp2,izp1)-ftmp(ixp2,iyp1,izp1)-
     >            ftmp(ixp1,iyp2,izp1)+ftmp(ixp1,iyp1,izp1))/
     >            ((xx(ixp2)-xx(ixp1))*(yy(iyp2)-yy(iyp1)))
               fxyz(2,2,k)=(fzp-fzm)/(zz(izp2)-zz(izp1))
c
c  the values
c
               fherm(4,ix,iy,iz)=
     >            (wx(1)*(wy(1)*exy(1,1)+wy(2)*exy(1,2))+
     >             wx(2)*(wy(1)*exy(2,1)+wy(2)*exy(2,2)))/
     >             ((wx(1)+wx(2))*(wy(1)+wy(2)))
c
               fherm(5,ix,iy,iz)=
     >            (wx(1)*(wz(1)*exz(1,1)+wz(2)*exz(1,2))+
     >             wx(2)*(wz(1)*exz(2,1)+wz(2)*exz(2,2)))/
     >             ((wx(1)+wx(2))*(wz(1)+wz(2)))
c
               fherm(6,ix,iy,iz)=
     >            (wy(1)*(wz(1)*eyz(1,1)+wz(2)*eyz(1,2))+
     >             wy(2)*(wz(1)*eyz(2,1)+wz(2)*eyz(2,2)))/
     >             ((wy(1)+wy(2))*(wz(1)+wz(2)))
c
               fherm(7,ix,iy,iz)=(wz(1)*
     >            (wx(1)*(wy(1)*fxyz(1,1,1)+wy(2)*fxyz(1,2,1))+
     >            wx(2)*(wy(1)*fxyz(2,1,1)+wy(2)*fxyz(2,2,1))) + wz(2)*
     >            (wx(1)*(wy(1)*fxyz(1,1,2)+wy(2)*fxyz(1,2,2))+
     >            wx(2)*(wy(1)*fxyz(2,1,2)+wy(2)*fxyz(2,2,2))) )/
     >            ((wx(1)+wx(2))*(wy(1)+wy(2))*(wz(1)+wz(2)))
c
            enddo
         enddo
      enddo
C
      deallocate (ftmp)
      return
      end


!*==cgeevx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGEEVX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL,
!                          LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE,
!                          RCONDV, WORK, LWORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          BALANC, JOBVL, JOBVR, SENSE
!       INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
!       REAL               ABNRM
!       ..
!       .. Array Arguments ..
!       REAL               RCONDE( * ), RCONDV( * ), RWORK( * ),
!      $                   SCALE( * )
!       COMPLEX            A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
!      $                   W( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
!> eigenvalues and, optionally, the left and/or right eigenvectors.
!>
!> Optionally also, it computes a balancing transformation to improve
!> the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!> SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!> (RCONDE), and reciprocal condition numbers for the right
!> eigenvectors (RCONDV).
!>
!> The right eigenvector v(j) of A satisfies
!>                  A * v(j) = lambda(j) * v(j)
!> where lambda(j) is its eigenvalue.
!> The left eigenvector u(j) of A satisfies
!>               u(j)**H * A = lambda(j) * u(j)**H
!> where u(j)**H denotes the conjugate transpose of u(j).
!>
!> The computed eigenvectors are normalized to have Euclidean norm
!> equal to 1 and largest component real.
!>
!> Balancing a matrix means permuting the rows and columns to make it
!> more nearly upper triangular, and applying a diagonal similarity
!> transformation D * A * D**(-1), where D is a diagonal matrix, to
!> make its rows and columns closer in norm and the condition numbers
!> of its eigenvalues and eigenvectors smaller.  The computed
!> reciprocal condition numbers correspond to the balanced matrix.
!> Permuting rows and columns will not change the condition numbers
!> (in exact arithmetic) but diagonal scaling will.  For further
!> explanation of balancing, see section 4.10.2 of the LAPACK
!> Users' Guide.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] BALANC
!> \verbatim
!>          BALANC is CHARACTER*1
!>          Indicates how the input matrix should be diagonally scaled
!>          and/or permuted to improve the conditioning of its
!>          eigenvalues.
!>          = 'N': Do not diagonally scale or permute;
!>          = 'P': Perform permutations to make the matrix more nearly
!>                 upper triangular. Do not diagonally scale;
!>          = 'S': Diagonally scale the matrix, ie. replace A by
!>                 D*A*D**(-1), where D is a diagonal matrix chosen
!>                 to make the rows and columns of A more equal in
!>                 norm. Do not permute;
!>          = 'B': Both diagonally scale and permute A.
!>
!>          Computed reciprocal condition numbers will be for the matrix
!>          after balancing and/or permuting. Permuting does not change
!>          condition numbers (in exact arithmetic), but balancing does.
!> \endverbatim
!>
!> \param[in] JOBVL
!> \verbatim
!>          JOBVL is CHARACTER*1
!>          = 'N': left eigenvectors of A are not computed;
!>          = 'V': left eigenvectors of A are computed.
!>          If SENSE = 'E' or 'B', JOBVL must = 'V'.
!> \endverbatim
!>
!> \param[in] JOBVR
!> \verbatim
!>          JOBVR is CHARACTER*1
!>          = 'N': right eigenvectors of A are not computed;
!>          = 'V': right eigenvectors of A are computed.
!>          If SENSE = 'E' or 'B', JOBVR must = 'V'.
!> \endverbatim
!>
!> \param[in] SENSE
!> \verbatim
!>          SENSE is CHARACTER*1
!>          Determines which reciprocal condition numbers are computed.
!>          = 'N': None are computed;
!>          = 'E': Computed for eigenvalues only;
!>          = 'V': Computed for right eigenvectors only;
!>          = 'B': Computed for eigenvalues and right eigenvectors.
!>
!>          If SENSE = 'E' or 'B', both left and right eigenvectors
!>          must also be computed (JOBVL = 'V' and JOBVR = 'V').
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A has been overwritten.  If JOBVL = 'V' or
!>          JOBVR = 'V', A contains the Schur form of the balanced
!>          version of the matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is COMPLEX array, dimension (N)
!>          W contains the computed eigenvalues.
!> \endverbatim
!>
!> \param[out] VL
!> \verbatim
!>          VL is COMPLEX array, dimension (LDVL,N)
!>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!>          after another in the columns of VL, in the same order
!>          as their eigenvalues.
!>          If JOBVL = 'N', VL is not referenced.
!>          u(j) = VL(:,j), the j-th column of VL.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.  LDVL >= 1; if
!>          JOBVL = 'V', LDVL >= N.
!> \endverbatim
!>
!> \param[out] VR
!> \verbatim
!>          VR is COMPLEX array, dimension (LDVR,N)
!>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!>          after another in the columns of VR, in the same order
!>          as their eigenvalues.
!>          If JOBVR = 'N', VR is not referenced.
!>          v(j) = VR(:,j), the j-th column of VR.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1; if
!>          JOBVR = 'V', LDVR >= N.
!> \endverbatim
!>
!> \param[out] ILO
!> \verbatim
!>          ILO is INTEGER
!> \endverbatim
!>
!> \param[out] IHI
!> \verbatim
!>          IHI is INTEGER
!>          ILO and IHI are integer values determined when A was
!>          balanced.  The balanced A(i,j) = 0 if I > J and
!>          J = 1,...,ILO-1 or I = IHI+1,...,N.
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is REAL array, dimension (N)
!>          Details of the permutations and scaling factors applied
!>          when balancing A.  If P(j) is the index of the row and column
!>          interchanged with row and column j, and D(j) is the scaling
!>          factor applied to row and column j, then
!>          SCALE(J) = P(J),    for J = 1,...,ILO-1
!>                   = D(J),    for J = ILO,...,IHI
!>                   = P(J)     for J = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!> \endverbatim
!>
!> \param[out] ABNRM
!> \verbatim
!>          ABNRM is REAL
!>          The one-norm of the balanced matrix (the maximum
!>          of the sum of absolute values of elements of any column).
!> \endverbatim
!>
!> \param[out] RCONDE
!> \verbatim
!>          RCONDE is REAL array, dimension (N)
!>          RCONDE(j) is the reciprocal condition number of the j-th
!>          eigenvalue.
!> \endverbatim
!>
!> \param[out] RCONDV
!> \verbatim
!>          RCONDV is REAL array, dimension (N)
!>          RCONDV(j) is the reciprocal condition number of the j-th
!>          right eigenvector.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  If SENSE = 'N' or 'E',
!>          LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
!>          LWORK >= N*N+2*N.
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, the QR algorithm failed to compute all the
!>                eigenvalues, and no eigenvectors or condition numbers
!>                have been computed; elements 1:ILO-1 and i+1:N of W
!>                contain eigenvalues which have converged.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!  @generated from zgeevx.f, fortran z -> c, Tue Apr 19 01:47:44 2016
!
!> \ingroup complexGEeigen
!
!  =====================================================================
      SUBROUTINE CGEEVX(Balanc,Jobvl,Jobvr,Sense,N,A,Lda,W,Vl,Ldvl,Vr,  &
     &                  Ldvr,Ilo,Ihi,Scale,Abnrm,Rconde,Rcondv,Work,    &
     &                  Lwork,Rwork,Info)
      IMPLICIT NONE
!*--CGEEVX291
!
!  -- LAPACK driver routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Balanc , Jobvl , Jobvr , Sense
      INTEGER Ihi , Ilo , Info , Lda , Ldvl , Ldvr , Lwork , N
      REAL Abnrm
!     ..
!     .. Array Arguments ..
      REAL Rconde(*) , Rcondv(*) , Rwork(*) , Scale(*)
      COMPLEX A(Lda,*) , Vl(Ldvl,*) , Vr(Ldvr,*) , W(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , scalea , wantvl , wantvr , wntsnb , wntsne ,     &
     &        wntsnn , wntsnv
      CHARACTER job , side
      INTEGER hswork , i , icond , ierr , itau , iwrk , k ,             &
     &        lwork_trevc , maxwrk , minwrk , nout
      REAL anrm , bignum , cscale , eps , scl , smlnum
      COMPLEX tmp
!     ..
!     .. Local Arrays ..
      LOGICAL select(1)
      REAL dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL SLABAD , SLASCL , XERBLA , CSSCAL , CGEBAK , CGEBAL ,    &
     &         CGEHRD , CHSEQR , CLACPY , CLASCL , CSCAL , CTREVC3 ,    &
     &         CTRSNA , CUNGHR
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ISAMAX , ILAENV
      REAL SLAMCH , SCNRM2 , CLANGE
      EXTERNAL LSAME , ISAMAX , ILAENV , SLAMCH , SCNRM2 , CLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC REAL , CMPLX , CONJG , AIMAG , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      wantvl = LSAME(Jobvl,'V')
      wantvr = LSAME(Jobvr,'V')
      wntsnn = LSAME(Sense,'N')
      wntsne = LSAME(Sense,'E')
      wntsnv = LSAME(Sense,'V')
      wntsnb = LSAME(Sense,'B')
      IF ( .NOT.(LSAME(Balanc,'N') .OR. LSAME(Balanc,'S') .OR.          &
     &     LSAME(Balanc,'P') .OR. LSAME(Balanc,'B')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantvl) .AND. (.NOT.LSAME(Jobvl,'N')) ) THEN
         Info = -2
      ELSEIF ( (.NOT.wantvr) .AND. (.NOT.LSAME(Jobvr,'N')) ) THEN
         Info = -3
      ELSEIF ( .NOT.(wntsnn .OR. wntsne .OR. wntsnb .OR. wntsnv) .OR.   &
     &         ((wntsne .OR. wntsnb) .AND. .NOT.(wantvl .AND. wantvr)) )&
     &         THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvl<1 .OR. (wantvl .AND. Ldvl<N) ) THEN
         Info = -10
      ELSEIF ( Ldvr<1 .OR. (wantvr .AND. Ldvr<N) ) THEN
         Info = -12
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       CWorkspace refers to complex workspace, and RWorkspace to real
!       workspace. NB refers to the optimal block size for the
!       immediately following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by CHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            minwrk = 1
            maxwrk = 1
         ELSE
            maxwrk = N + N*ILAENV(1,'CGEHRD',' ',N,1,N,0)
!
            IF ( wantvl ) THEN
               CALL CTREVC3('L','B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,   &
     &                      nout,Work,-1,Rwork,-1,ierr)
               lwork_trevc = INT(Work(1))
               maxwrk = MAX(maxwrk,lwork_trevc)
               CALL CHSEQR('S','V',N,1,N,A,Lda,W,Vl,Ldvl,Work,-1,Info)
            ELSEIF ( wantvr ) THEN
               CALL CTREVC3('R','B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,   &
     &                      nout,Work,-1,Rwork,-1,ierr)
               lwork_trevc = INT(Work(1))
               maxwrk = MAX(maxwrk,lwork_trevc)
               CALL CHSEQR('S','V',N,1,N,A,Lda,W,Vr,Ldvr,Work,-1,Info)
            ELSEIF ( wntsnn ) THEN
               CALL CHSEQR('E','N',N,1,N,A,Lda,W,Vr,Ldvr,Work,-1,Info)
            ELSE
               CALL CHSEQR('S','N',N,1,N,A,Lda,W,Vr,Ldvr,Work,-1,Info)
            ENDIF
            hswork = INT(Work(1))
!
            IF ( (.NOT.wantvl) .AND. (.NOT.wantvr) ) THEN
               minwrk = 2*N
               IF ( .NOT.(wntsnn .OR. wntsne) )                         &
     &              minwrk = MAX(minwrk,N*N+2*N)
               maxwrk = MAX(maxwrk,hswork)
               IF ( .NOT.(wntsnn .OR. wntsne) )                         &
     &              maxwrk = MAX(maxwrk,N*N+2*N)
            ELSE
               minwrk = 2*N
               IF ( .NOT.(wntsnn .OR. wntsne) )                         &
     &              minwrk = MAX(minwrk,N*N+2*N)
               maxwrk = MAX(maxwrk,hswork)
               maxwrk = MAX(maxwrk,N+(N-1)                              &
     &                  *ILAENV(1,'CUNGHR',' ',N,1,N,-1))
               IF ( .NOT.(wntsnn .OR. wntsne) )                         &
     &              maxwrk = MAX(maxwrk,N*N+2*N)
               maxwrk = MAX(maxwrk,2*N)
            ENDIF
            maxwrk = MAX(maxwrk,minwrk)
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -20
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGEEVX',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = SLAMCH('P')
      smlnum = SLAMCH('S')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      icond = 0
      anrm = CLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL CLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!     Balance the matrix and compute ABNRM
!
      CALL CGEBAL(Balanc,N,A,Lda,Ilo,Ihi,Scale,ierr)
      Abnrm = CLANGE('1',N,N,A,Lda,dum)
      IF ( scalea ) THEN
         dum(1) = Abnrm
         CALL SLASCL('G',0,0,cscale,anrm,1,1,dum,1,ierr)
         Abnrm = dum(1)
      ENDIF
!
!     Reduce to upper Hessenberg form
!     (CWorkspace: need 2*N, prefer N+N*NB)
!     (RWorkspace: none)
!
      itau = 1
      iwrk = itau + N
      CALL CGEHRD(N,Ilo,Ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvl ) THEN
!
!        Want left eigenvectors
!        Copy Householder vectors to VL
!
         side = 'L'
         CALL CLACPY('L',N,N,A,Lda,Vl,Ldvl)
!
!        Generate unitary matrix in VL
!        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL CUNGHR(N,Ilo,Ihi,Vl,Ldvl,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
!
!        Perform QR iteration, accumulating Schur vectors in VL
!        (CWorkspace: need 1, prefer HSWORK (see comments) )
!        (RWorkspace: none)
!
         iwrk = itau
         CALL CHSEQR('S','V',N,Ilo,Ihi,A,Lda,W,Vl,Ldvl,Work(iwrk),      &
     &               Lwork-iwrk+1,Info)
!
         IF ( wantvr ) THEN
!
!           Want left and right eigenvectors
!           Copy Schur vectors to VR
!
            side = 'B'
            CALL CLACPY('F',N,N,Vl,Ldvl,Vr,Ldvr)
         ENDIF
!
      ELSEIF ( wantvr ) THEN
!
!        Want right eigenvectors
!        Copy Householder vectors to VR
!
         side = 'R'
         CALL CLACPY('L',N,N,A,Lda,Vr,Ldvr)
!
!        Generate unitary matrix in VR
!        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL CUNGHR(N,Ilo,Ihi,Vr,Ldvr,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
!
!        Perform QR iteration, accumulating Schur vectors in VR
!        (CWorkspace: need 1, prefer HSWORK (see comments) )
!        (RWorkspace: none)
!
         iwrk = itau
         CALL CHSEQR('S','V',N,Ilo,Ihi,A,Lda,W,Vr,Ldvr,Work(iwrk),      &
     &               Lwork-iwrk+1,Info)
!
      ELSE
!
!        Compute eigenvalues only
!        If condition numbers desired, compute Schur form
!
         IF ( wntsnn ) THEN
            job = 'E'
         ELSE
            job = 'S'
         ENDIF
!
!        (CWorkspace: need 1, prefer HSWORK (see comments) )
!        (RWorkspace: none)
!
         iwrk = itau
         CALL CHSEQR(job,'N',N,Ilo,Ihi,A,Lda,W,Vr,Ldvr,Work(iwrk),      &
     &               Lwork-iwrk+1,Info)
      ENDIF
!
!     If INFO .NE. 0 from CHSEQR, then quit
!
      IF ( Info==0 ) THEN
!
!
!        Compute left and/or right eigenvectors
!        (CWorkspace: need 2*N, prefer N + 2*N*NB)
!        (RWorkspace: need N)
!
         IF ( wantvl .OR. wantvr ) CALL CTREVC3(side,'B',select,N,A,Lda,&
     &        Vl,Ldvl,Vr,Ldvr,N,nout,Work(iwrk),Lwork-iwrk+1,Rwork,N,   &
     &        ierr)
!
!     Compute condition numbers if desired
!     (CWorkspace: need N*N+2*N unless SENSE = 'E')
!     (RWorkspace: need 2*N unless SENSE = 'E')
!
         IF ( .NOT.wntsnn ) CALL CTRSNA(Sense,'A',select,N,A,Lda,Vl,    &
     &                                  Ldvl,Vr,Ldvr,Rconde,Rcondv,N,   &
     &                                  nout,Work(iwrk),N,Rwork,icond)
!
         IF ( wantvl ) THEN
!
!        Undo balancing of left eigenvectors
!
            CALL CGEBAK(Balanc,'L',N,Ilo,Ihi,Scale,N,Vl,Ldvl,ierr)
!
!        Normalize left eigenvectors and make largest component real
!
            DO i = 1 , N
               scl = ONE/SCNRM2(N,Vl(1,i),1)
               CALL CSSCAL(N,scl,Vl(1,i),1)
               DO k = 1 , N
                  Rwork(k) = REAL(Vl(k,i))**2 + AIMAG(Vl(k,i))**2
               ENDDO
               k = ISAMAX(N,Rwork,1)
               tmp = CONJG(Vl(k,i))/SQRT(Rwork(k))
               CALL CSCAL(N,tmp,Vl(1,i),1)
               Vl(k,i) = CMPLX(REAL(Vl(k,i)),ZERO)
            ENDDO
         ENDIF
!
         IF ( wantvr ) THEN
!
!        Undo balancing of right eigenvectors
!
            CALL CGEBAK(Balanc,'R',N,Ilo,Ihi,Scale,N,Vr,Ldvr,ierr)
!
!        Normalize right eigenvectors and make largest component real
!
            DO i = 1 , N
               scl = ONE/SCNRM2(N,Vr(1,i),1)
               CALL CSSCAL(N,scl,Vr(1,i),1)
               DO k = 1 , N
                  Rwork(k) = REAL(Vr(k,i))**2 + AIMAG(Vr(k,i))**2
               ENDDO
               k = ISAMAX(N,Rwork,1)
               tmp = CONJG(Vr(k,i))/SQRT(Rwork(k))
               CALL CSCAL(N,tmp,Vr(1,i),1)
               Vr(k,i) = CMPLX(REAL(Vr(k,i)),ZERO)
            ENDDO
         ENDIF
      ENDIF
!
!     Undo scaling if necessary
!
      IF ( scalea ) THEN
         CALL CLASCL('G',0,0,cscale,anrm,N-Info,1,W(Info+1),            &
     &               MAX(N-Info,1),ierr)
         IF ( Info==0 ) THEN
            IF ( (wntsnv .OR. wntsnb) .AND. icond==0 )                  &
     &           CALL SLASCL('G',0,0,cscale,anrm,N,1,Rcondv,N,ierr)
         ELSE
            CALL CLASCL('G',0,0,cscale,anrm,Ilo-1,1,W,N,ierr)
         ENDIF
      ENDIF
!
      Work(1) = maxwrk
!
!     End of CGEEVX
!
      END SUBROUTINE CGEEVX


C
C $Id: ngritd.f,v 1.4 2008-07-27 00:17:18 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE NGRITD (IAXS,ANGL,UCRD,VCRD,WCRD)
C
C Define a multiplicative constant to convert from degrees to radians.
C
        DATA DTOR / .017453292519943 /
C
C This routine rotates the point with coordinates (UCRD,VCRD,WCRD) by
C the angle ANGL about the axis specified by IAXS (1 for the U axis,
C 2 for the V axis, 3 for the W axis).  A right-handed coordinate
C system is assumed.
C
        SINA=SIN(DTOR*ANGL)
        COSA=COS(DTOR*ANGL)
C
        UTMP=UCRD
        VTMP=VCRD
        WTMP=WCRD
C
        IF (IAXS.EQ.1) THEN
          VCRD=VTMP*COSA-WTMP*SINA
          WCRD=WTMP*COSA+VTMP*SINA
        ELSE IF (IAXS.EQ.2) THEN
          UCRD=UTMP*COSA+WTMP*SINA
          WCRD=WTMP*COSA-UTMP*SINA
        ELSE
          UCRD=UTMP*COSA-VTMP*SINA
          VCRD=VTMP*COSA+UTMP*SINA
        END IF
C
        RETURN
C
      END


      subroutine gfdhc(adh,bt,fdhc,fdhcp,fdhcpp,fxi)
c
c     This subroutine computes the Debye-Huckel function f and its
c     derivatives with respect to ionic strength for the case of the
c     Debye-Huckel-charging (DHC) model.
c
c     This subroutine is called by:
c
c       EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       adh    = the Debye-Huckel A(gamma) parameter
c       bt     = product of Debye-Huckel B and the hard core diameter
c       fxi    = the ionic strength (the 2nd-order electrostatic
c                  moment function I)
c
c     Output:
c
c       fdhc   = Debye-Huckel function f (DHC model)
c       fdhcp  = f' (df/dI)
c       fdhcpp = f'' (d2f/dI2)
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      real*8 adh,bt,fdhc,fdhcp,fdhcpp,fxi
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      real*8 fxisqt,vx,vxp1
c
c-----------------------------------------------------------------------
c
      fxisqt = sqrt(fxi)
      vx = bt*fxisqt
      vxp1 = vx + 1.
c
      fdhc = -6.*adh*(vx*(vx-2.) + 2.*log(vxp1))/(bt**3)
      fdhcp = -6.*adh*fxisqt/vxp1
      fdhcpp = -3.*adh/(fxisqt*vxp1*vxp1)
c
      end


      subroutine time_conc_init

      use ru_module
      use hru_module, only : brt, hru, ihru, t_ov, tconc
      use hydrograph_module, only : sp_ob, ru_def, ru_elem, sp_ob1, ob
      use topography_data_module
      use time_module
      use basin_module

      implicit none

      integer :: ii                !none         |counter
      integer :: ielem             !none         |counter
      integer :: iob               !             |
      integer :: ith               !             |
      integer :: ifld              !             |
      real :: tov                  !             |
      real :: ch_slope             !             |
      real :: ch_n                 !             |
      real :: ch_l                 !             |
      real :: t_ch                 !hr           |time for flow entering the farthest upstream
                                   !             |channel to reach the subbasin outlet

     ! compute weighted Mannings n for each subbasin
      do iru = 1, sp_ob%ru
        ru_n(iru) = 0.
        do ii = 1, ru_def(iru)%num_tot
          ielem = ru_def(iru)%num(ii)
          if (ru_elem(ielem)%obtyp == "hru") then
            ihru = ru_elem(ielem)%obtypno
            ru_n(iru) = ru_n(iru) + hru(ihru)%luse%ovn * hru(ihru)%km
          else
            ru_n(iru) = 0.1
          end if
        end do
      end do

      do iru = 1, sp_ob%ru
        iob = sp_ob1%ru + iru - 1
        ru(iru)%da_km2 = ob(iob)%area_ha / 100.
        ru_n(iru) = ru_n(iru) / ru(iru)%da_km2
        ith = ru(iru)%dbs%toposub_db
        ifld = ru(iru)%dbs%field_db
        !if (ith > 0 .and. ichan > 0) then
        ! compute tc for the subbasin
          tov = .0556 * (topo_db(ith)%slope_len * ru_n(iru)) ** .6 /     &
                                              (topo_db(ith)%slope + .0001) ** .3
          ch_slope = .5 * (topo_db(ith)%slope + 0001)
          ch_n = ru_n(iru)
          ch_l = field_db(ifld)%length / 1000.
          t_ch = .62 * ch_l * ch_n**.75 / (ru(iru)%da_km2**.125 * ch_slope**.375)
          ru_tc(iru) = tov + t_ch
        !end if
      end do

      !!compute time of concentration (sum of overland and channel times)
      do ihru = 1, sp_ob%hru
        ith = hru(ihru)%dbs%topo
        ifld = hru(ihru)%dbs%field
        t_ov(ihru) = .0556 * (hru(ihru)%topo%slope_len *                    &
           hru(ihru)%luse%ovn) ** .6 / (hru(ihru)%topo%slope + .00001) ** .3
        ch_slope = .5 * topo_db(ith)%slope
        ch_n = hru(ihru)%luse%ovn
        ch_l = field_db(ifld)%length / 1000.
        t_ch = .62 * ch_l * ch_n**.75 / (hru(ihru)%km**.125 * (ch_slope + .00001)**.375)
        tconc(ihru) = t_ov(ihru) + t_ch
        !! compute fraction of surface runoff that is reaching the main channel
        if (time%step > 0) then
          brt(ihru) = 1.-Exp(-bsn_prm%surlag / (tconc(ihru) /               &
              (time%dtm / 60.)))	!! urban modeling by J.Jeong
        else
          brt(ihru) = 1. - Exp(-bsn_prm%surlag / tconc(ihru))
        endif
      end do

     return
     end subroutine time_conc_init


!-------------------------------------------------------------------
! Update Algorithm
!-------------------------------------------------------------------

subroutine update_1d2f1v(fwL, fhL, fbL, w, prim, h, b, fwR, fhR, fbR, unum, u, weights, &
                         inK, gamma, muref, omega, pr, dx, dt, res, avg)

    integer, intent(in):: unum
    real(kind=8), intent(in) :: fwL(3), fhL(unum), fbL(unum)
    real(kind=8), intent(inout) :: w(3), h(unum), b(unum)
    real(kind=8), intent(in) :: fwR(3), fhR(unum), fbR(unum)
    real(kind=8), intent(in) :: u(unum), weights(unum)
    real(kind=8), intent(in) :: inK, gamma
    real(kind=8), intent(in) :: muref, omega, pr
    real(kind=8), intent(in) :: dx, dt
    real(kind=8), intent(inout) :: res(3), avg(3)

    ! t=t^n
    real(kind=8) :: MH_old(unum), MB_old(unum)
    real(kind=8) :: w_old(3), prim_old(3)
    real(kind=8) :: tau_old

    ! t=t^n+1
    real(kind=8) :: MH(unum), MB(unum)
    real(kind=8) :: MH_plus(unum), MB_plus(unum)

    real(kind=8) :: prim(3)
    real(kind=8) :: qf
    real(kind=8) :: tau

    !--------------------------------------------------
    ! store W^n and calculate H^n,B^n,\tau^n
    !--------------------------------------------------
    w_old = w
    prim_old = conserve_prim_1d(w_old, gamma)

    call maxwell_2f1v(MH_old, MB_old, prim_old, u, inK)
    tau_old = collision_time_1d(prim_old, muref, omega)

    !--------------------------------------------------
    ! update W^{n+1} and calculate H^{n+1},B^{n+1},\tau^{n+1}
    !--------------------------------------------------
    w = w + (fwL - fwR) / dx
    prim = conserve_prim_1d(w, gamma)

    call maxwell_2f1v(MH, MB, prim, u, inK)
    tau = collision_time_1d(prim, muref, omega)

    !--------------------------------------------------
    ! record residual
    !--------------------------------------------------
    res = res + (w_old - w)**2
    avg = avg + abs(w)

    !--------------------------------------------------
    ! Shakhov part
    !--------------------------------------------------
    ! heat flux at t=t^n
    qf = heat_flux_2f1v(h, b, prim_old, u, weights)

    ! h^+ = H+H^+ at t=t^n
    call shakhov_part(MH_old, MB_old, qf, prim_old, MH_plus, MB_plus, u, weights, inK, pr)
    MH_old = MH_old + MH_plus !h^+
    MB_old = MB_old + MB_plus !b^+

    ! h^+ = H+H^+ at t=t^{n+1}
    call shakhov_part(MH, MB, qf, prim, MH_plus, MB_plus, u, weights, inK, pr)
    MH = MH + MH_plus
    MB = MB + MB_plus

    !--------------------------------------------------
    ! update distribution function
    !--------------------------------------------------
    h = (h + (fhL - fhR) / dx + &
        0.5 * dt * (MH / tau + (MH_old - h) / tau_old))/(1.0 + 0.5 * dt / tau)
    b = (b + (fbL - fbR) / dx + &
        0.5 * dt * (MB / tau + (MB_old - b) / tau_old))/(1.0 + 0.5 * dt / tau)

end