!====================================================================
!-----------------------------------------------------------------------
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOP
! !MODULE: m_ellipsoid -- Routines for solving geodetic problems on an ellipsoid
!
! !DESCRIPTION:
!     This module contains routines that solve the direct and indirect
!     problems in geodesy on an ellipsoid according to the formulae
!     described in Vincenty (1975).  The direct problem is the
!     determination of the latitude and longitude and the reverse azimuth
!     angle given the latitude and longitude at another point, the azimuth
!     angle and angular ellipsoidal distance (with respect to the polar
!     radius).  The inverse problem is the determination of the angular
!     ellipsoidal distance and forward and reverse azimuth angles given
!     the latitude and longitude of two points.  According to Vincenty
!     (1975), "the inverse formulae may give no solution over a line
!     between two nearly antipodal points."
!
! !REFERENCES:
!     Vincenty, T., 1975: Direct and Inverse Solutions of Geodesics on the
!          Ellipsoid with Application of Nested Equations.  Survey Review,
!          176, 88-93.
!
! !INTERFACE:
!
      module      m_ellipsoid
      implicit    NONE
      private        ! except

      public ::
     .   PI,         ! pi (in double precision )
     .   Deg2Rad,    ! Factor for convert degrees to radians
     .   REarthEq,   ! Equatorial radius (m, in double precision)
     .   REarthPole, ! Polar radius (m, in double precision)
     .   REarthMean, ! Mean earth radius (m, in double precision)
     .   Direct,     ! Solve the direct problem
     .   Inverse,    ! ... and the inverse problem
     .   InvSph,     ! Solve the inverse problem
     .   DirSph      !  ... and the inverse problem on a sphere

! !REVISION HISTORY:
!     09Nov2001  C. Redder  Original code
!
      interface Direct
         module procedure
     .      Direct_LP,   ! for arguments in low (single) precision
     .      Direct_HP    ! ... and high (double) precision
      end interface
      interface Inverse
         module procedure
     .      Inverse_LP,  ! for arguments in low (single) precision
     .      Inverse_HP   ! ... and high (double) precision
      end interface
!EOP
!-----------------------------------------------------------------

      integer,     parameter ::
     .   LP   = selected_real_kind (6),
     .   HP   = selected_real_kind (12),
     .   MaxP = HP

      real (MaxP), parameter ::
     .   PI         = 3.141592653589793238462643383279502884_MaxP,
     .   flMax      = 0.99_MaxP,        ! Maximum flattening factor
     .   REarthEq   = 6378137.000_MaxP, ! Earth's equatorial ...
     .   REarthPole = 6356752.314_MaxP, ! ... polar ...
     .   REarthMean = ( REarthEq + REarthPole ) / 2.0_MaxP,
     .                                  ! ... and mean radius (m)
     .   flEarth    = ( REarthEq - REarthPole ) / REarthEq,
     .                                  ! and its flattening factor
     .   Deg2Rad    = PI / 180.0_MaxP   ! Factor for converting degrees to
                                        !   to radians.
      integer,     parameter ::
     .   Valid      = 0,                ! Valid return status
     .   NIter_max  = 200               ! Maximum number of iterations
      contains

!....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: Direct_LP - Solve the direct problem with low precision arguments
!
! !DESCRIPTION:
!     This routine solves the direct problem in geodesy.  All input and
!     output arguments are in low (single) precision floating point numbers.
!
! !INTERFACE:
!
      pure subroutine Direct_LP ( lat1, lon1, dist, azim12,
     .                            lat2, lon2,       azim21, fl )
      implicit   NONE
!
! !INPUT PARAMETERS:
      real (LP),     intent (in)  ::
     .   lat1   (:), ! geodetic latitude (deg, -90 = 90S)
     .   lon1   (:), ! ... longitude     (deg, -90 = 90W) for each point
     .   dist   (:), ! angular ellipsoidal distance, arc / b, (radians) where
                     !   arc is the arc distance and b is the minor semi-axis
     .   azim12 (:)  ! azimuth angle on ellipsoid (deg, 90 = due east)
      real (LP),     intent (in), optional ::
     .   fl          ! flatness (a-b)/a where a and b are the major and minor
                     !   semi-axis.  Range: [0,0.99].  Default: Earth's value
! !OUTPUT PARAMETERS:
      real (LP),     intent (out) ::
     .   lat2   (:), ! latitude (deg)
     .   lon2   (:), ! ... longitude for each second point (deg)
     .   azim21 (:)  ! reverse azimuth angle (deg).  Range: (0,360]
!
!     Note: The number of points is determined by the size of the arrays.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     12Nov2001  C. Redder  Original code.
!     18Apr2002  C. Redder  Modified the way the number of points are
!                           determined.
!
! EOP
!-------------------------------------------------------------------------

      real (LP) :: Deg2R, l1, l2, f1, f2, a12, a21, f, tol, SPI
      real (LP) :: aa, bb,  cc, h,  x, y, xsq, usq, dis, fm1, fMax
      real (LP) :: sina12, cosa12, sig2m, coss2m
      real (LP) :: sinU1,  cosU1,  sina,  cosa
      real (LP) :: sig,    sig1,   dsig,  dsigLast, sins, coss
      logical   :: converged
      integer   :: iPt, NPts, Iter
      real (LP), parameter :: reltol = 10.0_LP ** ( -precision ( tol ))

      fMax   = flMax
      f      = flEarth                     ! flatness of an ellipsoid
      if ( present ( fl )) f = min ( fMax, abs ( fl ))
      fm1    = 1.0_LP - f

      SPI     = PI
      Deg2R   = Deg2Rad
      NPts    = min ( size ( lat1 ), size ( lon1 ), size ( azim12 ),
     .                size ( dist ),
     .                size ( lat2 ), size ( lon2 ), size ( azim21 ))
      do iPt  = 1, NPts
         f1   = lat1   (iPt) * Deg2R       ! Convert the latitude
         l1   = lon1   (iPt) * Deg2R       ! ... longitude of the first point
         a12  = azim12 (iPt) * Deg2R       ! ... and direction angle to radians
                                           ! Compute the trignometric
                                           !   functions  of the ...
         sina12 = sin ( a12 )              ! ... direction angle
         cosa12 = cos ( a12 )
         y      = sin ( f1 ) * fm1         ! ... reduced latitude, U1,
         x      = cos ( f1 )               !   where tan (U1) = (1-f) tan (f1)
         h      = sqrt ( x ** 2 + y ** 2 )
         sinU1  = y / h
         cosU1  = x / h
         sina   = cosU1 * sina12           ! ... azimuth of the geodesic
         cosa   = sqrt ( 1.0_LP            !   ... at the equator
     .                 - sina ** 2 )

         sig1   = atan2 ( sinU1, cosU1 * cosa12 )
         usq    = ( 1.0_LP / fm1 ** 2 - 1.0_LP ) * cosa ** 2
         aa     = 1.0_LP + usq * ( 4096.0_LP
     .                   - usq * (  768.0_LP
     .                   - usq * (  320.0_LP - 175.0_LP * usq )))
     .                   / 16384.0_LP
         bb     =          usq * (  256.0_LP
     .                   - usq * (  128.0_LP
     .                   - usq * (   74.0_LP -  47.0_LP * usq )))
     .                   / 1024.0_LP

         dis    = dist (iPt)
         sig    = dis    / aa
         tol    = reltol / aa
         dsigLast  = 0.0_LP
         converged = .false.

         do Iter   = 1, NIter_max          ! Interatively adjust the
            sig2m  = sig1 + sig1 + sig     !   distance between the points
            coss2m = cos ( sig2m )         !   and their trignometric
            sins   = sin ( sig   )         !   functions.
            coss   = cos ( sig   )
            if ( converged ) exit          ! ... until iteration converges
            dsig   = bb * sins * ( coss2m  !   to within machine round-off
     .                  + ( bb / 4.0_LP ) * ( coss
     .                    * ( -1.0_LP + 2.0_LP * coss2m ** 2 )
     .                  - ( bb / 6.0_LP ) *   coss2m
     .                    * ( -3.0_LP + 4.0_LP * sins   ** 2 )
     .                    * ( -3.0_LP + 4.0_LP * coss2m ** 2 )))
            sig       = dis / aa + dsig
            converged = abs ( dsigLast - dsig ) .le. tol ! Test for
            dsigLast  = dsig                             ! convergence
         end do
                                           ! Compute (in radians) ...
         y   = sinU1 * coss                ! ... the latitude
     .       + cosU1 * sins * cosa12
         xsq = sina ** 2 + ( sinU1 * sins - cosU1 * coss * cosa12 ) ** 2
         f2  = atan2 ( y, fm1 * sqrt ( xsq ) )

         y   = sins  * sina12              ! ... and longitude for the
         x   = cosU1 * coss - sinU1 * sins * cosa12     ! second point
         l2  = atan2 ( y, x ) + l1
         cc  = ( f / 16.0_LP ) * cosa ** 2
     .                        * ( 4.0_LP + f
     .                        * ( 4.0_LP - 3.0_LP * cosa ** 2 ))
         l2  = l2 - ( 1.0_LP - cc ) * f * sina * ( sig
     .       + cc * sins * ( coss2m
     .       + cc * coss * ( -1.0_LP + 2.0_LP * coss2m ** 2 )))

         y    = sina                       ! ... and the reverse angle
         x    = cosU1 * coss * cosa12 - sinU1 * sins
         a21  = atan2 ( y, x )

         lat2   (iPt) =  f2  / Deg2R       ! Convert output to degrees
         lon2   (iPt) =  l2  / Deg2R
         azim21 (iPt) = modulo ( a21 / Deg2R, 360.0_LP )
         if ( azim21(iPt) .le. 0.0_LP ) azim21(iPt) = 360.0_LP

      end do

      return
      end subroutine Direct_LP
!....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: Direct_HP - Solve the direct problem with hight precision arguments
!
! !DESCRIPTION:
!     This routine solves the direct problem in geodesy.  All input and
!     output arguments are in hight (double) precision floating point numbers.
!
! !INTERFACE:
!
      pure subroutine Direct_HP ( lat1, lon1, dist, azim12,
     .                            lat2, lon2,       azim21, fl )
      implicit   NONE
!
! !INPUT PARAMETERS:
      real (HP),     intent (in)  ::
     .   lat1   (:), ! geodetic latitude (deg, -90 = 90S)
     .   lon1   (:), ! ... longitude     (deg, -90 = 90W) for each point
     .   dist   (:), ! angular ellipsoidal distance, arc / b, (radians) where
                     !   arc is the arc distance and b is the minor semi-axis
     .   azim12 (:)  ! azimuth angle on ellipsoid (deg, 90 = due east)
      real (HP),     intent (in), optional ::
     .   fl          ! flatness (a-b)/a where a and b are the major and minor
                     !   semi-axis.  Range: [0,0.99].  Default: Earth's value
! !OUTPUT PARAMETERS:
      real (HP),     intent (out) ::
     .   lat2   (:), ! latitude (deg)
     .   lon2   (:), ! ... longitude for each second point (deg)
     .   azim21 (:)  ! reverse azimuth angle (deg).  Range: (0,360]
!
!     Note: The number of points is determined by the size of the arrays.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     12Nov2001  C. Redder  Original code.
!     18Apr2002  C. Redder  Modified the way the number of points are
!                           determined.
!
! EOP
!-------------------------------------------------------------------------

      real (HP) :: Deg2R, l1, l2, f1, f2, a12, a21, f, tol, SPI
      real (HP) :: aa, bb,  cc, h,  x, y, xsq, usq, dis, fm1, fMax
      real (HP) :: sina12, cosa12, sig2m, coss2m
      real (HP) :: sinU1,  cosU1,  sina,  cosa
      real (HP) :: sig,    sig1,   dsig,  dsigLast, sins, coss
      logical   :: converged
      integer   :: iPt, NPts, Iter
      real (HP), parameter :: reltol = 10.0_HP ** ( -precision ( tol ))

      fMax   = flMax
      f      = flEarth                     ! flatness of an ellipsoid
      if ( present ( fl )) f = min ( fMax, abs ( fl ))
      fm1    = 1.0_HP - f

      SPI     = PI
      Deg2R   = Deg2Rad
      NPts    = min ( size ( lat1 ), size ( lon1 ), size ( azim12 ),
     .                size ( dist ),
     .                size ( lat2 ), size ( lon2 ), size ( azim21 ))
      do iPt  = 1, NPts
         f1   = lat1   (iPt) * Deg2R       ! Convert the latitude
         l1   = lon1   (iPt) * Deg2R       ! ... longitude of the first point
         a12  = azim12 (iPt) * Deg2R       ! ... and direction angle to radians
                                           ! Compute the trignometric
                                           !   functions  of the ...
         sina12 = sin ( a12 )              ! ... direction angle
         cosa12 = cos ( a12 )
         y      = sin ( f1 ) * fm1         ! ... reduced latitude, U1,
         x      = cos ( f1 )               !   where tan (U1) = (1-f) tan (f1)
         h      = sqrt ( x ** 2 + y ** 2 )
         sinU1  = y / h
         cosU1  = x / h
         sina   = cosU1 * sina12           ! ... azimuth of the geodesic
         cosa   = sqrt ( 1.0_HP            !   ... at the equator
     .                 - sina ** 2 )

         sig1   = atan2 ( sinU1, cosU1 * cosa12 )
         usq    = ( 1.0_HP / fm1 ** 2 - 1.0_HP ) * cosa ** 2
         aa     = 1.0_HP + usq * ( 4096.0_HP
     .                   - usq * (  768.0_HP
     .                   - usq * (  320.0_HP - 175.0_HP * usq )))
     .                   / 16384.0_HP
         bb     =          usq * (  256.0_HP
     .                   - usq * (  128.0_HP
     .                   - usq * (   74.0_HP -  47.0_HP * usq )))
     .                   / 1024.0_HP

         dis    = dist (iPt)
         sig    = dis    / aa
         tol    = reltol / aa
         dsigLast  = 0.0_HP
         converged = .false.

         do Iter   = 1, NIter_max          ! Interatively adjust the
            sig2m  = sig1 + sig1 + sig     !   distance between the points
            coss2m = cos ( sig2m )         !   and their trignometric
            sins   = sin ( sig   )         !   functions.
            coss   = cos ( sig   )
            if ( converged ) exit          ! ... until iteration converges
            dsig   = bb * sins * ( coss2m  !   to within machine round-off
     .                  + ( bb / 4.0_HP ) * ( coss
     .                    * ( -1.0_HP + 2.0_HP * coss2m ** 2 )
     .                  - ( bb / 6.0_HP ) *   coss2m
     .                    * ( -3.0_HP + 4.0_HP * sins   ** 2 )
     .                    * ( -3.0_HP + 4.0_HP * coss2m ** 2 )))
            sig       = dis / aa + dsig
            converged = abs ( dsigLast - dsig ) .le. tol ! Test for
            dsigLast  = dsig                             ! convergence
         end do
                                           ! Compute (in radians) ...
         y   = sinU1 * coss                ! ... the latitude
     .       + cosU1 * sins * cosa12
         xsq = sina ** 2 + ( sinU1 * sins - cosU1 * coss * cosa12 ) ** 2
         f2  = atan2 ( y, fm1 * sqrt ( xsq ) )

         y   = sins  * sina12              ! ... and longitude for the
         x   = cosU1 * coss - sinU1 * sins * cosa12     ! second point
         l2  = atan2 ( y, x ) + l1
         cc  = ( f / 16.0_HP ) * cosa ** 2
     .                        * ( 4.0_HP + f
     .                        * ( 4.0_HP - 3.0_HP * cosa ** 2 ))
         l2  = l2 - ( 1.0_HP - cc ) * f * sina * ( sig
     .       + cc * sins * ( coss2m
     .       + cc * coss * ( -1.0_HP + 2.0_HP * coss2m ** 2 )))

         y    = sina                       ! ... and the reverse angle
         x    = cosU1 * coss * cosa12 - sinU1 * sins
         a21  = atan2 ( y, x )

         lat2   (iPt) =  f2  / Deg2R       ! Convert output to degrees
         lon2   (iPt) =  l2  / Deg2R
         azim21 (iPt) = modulo ( a21 / Deg2R, 360.0_HP )
         if ( azim21(iPt) .le. 0.0_HP ) azim21(iPt) = 360.0_HP

      end do

      return
      end subroutine Direct_HP
!....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: Inverse_LP - Solve the inverse problem with low precision arguments
!
! !DESCRIPTION:
!     This routine solves the inverse problem in geodesy.  All input and
!     output arguments are in low (single) precision floating point numbers.
!
! !INTERFACE:
!
      pure subroutine Inverse_LP ( lat1, lon1,   lat2,   lon2,
     .                             dist, azim12, azim21, stat, fl )
      implicit   NONE
!
! !INPUT PARAMETERS:
      real (LP),     intent (in)  ::
     .   lat1   (:), ! geodetic latitude (deg, -90 = 90S)
     .   lon1   (:), ! ... longitude     (deg, -90 = 90W) for each point
     .   lat2   (:), ! latitude (deg)
     .   lon2   (:)  ! ... longitude (deg) for each second point
      real (LP),     intent (in), optional ::
     .   fl          ! flatness (a-b)/a where a and b are the major and minor
                     !   semi-axis.  Range: [0,0.99].  Default: Earth's value
! !OUTPUT PARAMETERS:
      real (LP),     intent (out) ::
     .   dist   (:), ! angular ellipsoidal distance, arc / b, (radians) where
     .               !   arc is the arc distance and b is the minor semi-axis
     .   azim12 (:), ! azimuth angle (deg, 90 = due east) and ...
     .   azim21 (:)  ! ... reverse azimuth angle on the ellipsoid (deg).
                     !   Range: (0,360]
      integer,       intent (out), optional ::
     .   stat   (:)  ! = 0 if algorithm converged properly.  If > 0, then
                     !   stat = number of iterations without converging to a
                     !   a solution (at least to within machine round-off).
!
!     Note: The number of points is determined by the size of the arrays.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!       Jan1976  INGE NESBO  Original code, originally called INVINC
!     12Nov2001  C. Redder   Adapted the routine and renamed it
!     18Apr2002  C. Redder   Modified the way the number of points are
!                            determined.
!
! EOP
!-------------------------------------------------------------------------

      real (LP) :: Deg2R, l1, l2, f1, f2, a12, a21, f, tol, SPI
      real (LP) :: h, x, y, fm1, fMax
      real (LP) :: sina12, cosa12
      real (LP) :: sinU1,  cosU1, sinU2, cosU2, sina, cossqa
      real (LP) :: dl, sindl, cosdl, dl0, ddl, ddlLast
      real (LP) :: aa, bb, cc, dd, ee, ff, usq
      real (LP) :: sig, dsig, sins, coss, coss2m
      logical   :: converged
      integer   :: iPt, NPts, Iter, iret
      real (LP), parameter :: reltol = 10.0_LP ** ( -precision ( tol ))

      fMax    = flMax
      f       = flEarth                    ! flatness of an ellipsoid
      if ( present ( fl )) f = min ( fMax, abs ( fl ))
      fm1     = 1.0_LP - f

      SPI     = PI
      Deg2R   = Deg2Rad
      NPts    = min ( size ( lat1 ), size ( lon1   ),
     .                size ( lat2 ), size ( lon2   ),
     .                size ( dist ), size ( azim12 ), size ( azim21 ))
      OuterLoop: do iPt  = 1, NPts
         f1   = lat1 (iPt) * Deg2R         ! Convert the latitude
         l1   = lon1 (iPt) * Deg2R         ! ... longitude of the first point
         f2   = lat2 (iPt) * Deg2R         ! ... and of the second point
         l2   = lon2 (iPt) * Deg2R
                                           ! Compute the trignometric
                                           !   functions  of the ...
         y      = sin ( f1 ) * fm1         ! ... reduced latitude, U1,
         x      = cos ( f1 )               !   where tan (U1) = (1-f) tan (f1)
         h      = sqrt ( x ** 2 + y ** 2 ) !   for the first point
         sinU1  = y / h
         cosU1  = x / h
         y      = sin ( f2 ) * fm1         ! ... and for the second point
         x      = cos ( f2 )
         h      = sqrt ( x ** 2 + y ** 2 )
         sinU2  = y / h
         cosU2  = x / h

         dl     = l2 - l1
         dl0    = dl
         tol    = reltol
         ddl    = 0.0_LP
         converged = .false.

         do Iter = 1, NIter_max            ! Interatively determine the
            ddlLast = ddl                  !   adjusted difference of the
            sindl   = sin ( dl )           !   longitudes.
            cosdl   = cos ( dl )
            sins    = sqrt ( ( cosU2 * sindl ) ** 2
     .                     + ( cosU1 * sinU2
     .                       - sinU1 * cosU2 * cosdl ) ** 2 )
            if ( sins .le. tol ) then      ! If the points are identical ...
               azim12 (iPt) = 0.0_LP       ! ... then set the output
               azim21 (iPt) = 0.0_LP       !   arguments to zero and ...
               dist   (iPt) = 0.0_LP
               if ( present ( stat ) ) stat (iPt) = Valid
               cycle OuterLoop             ! ... go to next pair of points
            end if

            coss    = sinU1 * sinU2 + cosU1 * cosU2 * cosdl
            sig     = atan2 ( sins, coss )
            sina    = cosU1 * cosU2 * sindl / sins
            cossqa  = 1.0_LP - sina * sina
            coss2m  = coss
            if ( cossqa .gt. tol )
     .         coss2m = coss2m - 2.0_LP * sinU1 * sinU2 / cossqa
            cc      = ( f * cossqa / 16.0_LP )
     .              * ( 4.0_LP + f * ( 4.0_LP - 3.0_LP * cossqa ))
            ddl     = ( 1.0_LP - cc ) * f * sina
     .              * ( sig    + cc * sins
     .              * ( coss2m + cc * coss
     .              * ( -1.0_LP + 2.0_LP * coss2m * coss2m )))

            dl = dl0 + ddl
            converged = abs ( ddl - ddlLast ) .le. tol
            if ( converged ) exit          ! If convergence criteria is
                                           !   statisfied, then exit loop.
         end do
         sindl   = sin ( dl )
         cosdl   = cos ( dl )

                                           ! Now compute angular distance
         usq    = ( 1.0_LP / fm1 ** 2 - 1.0_LP ) * cossqa
         aa     = 1.0_LP + usq * ( 4096.0_LP
     .                   - usq * (  768.0_LP
     .                   - usq * (  320.0_LP - 175.0_LP * usq )))
     .                   / 16384.0_LP
         bb     =          usq * (  256.0_LP
     .                   - usq * (  128.0_LP
     .                   - usq * (   74.0_LP -  47.0_LP * usq )))
     .                   / 1024.0_LP
         dsig =  bb * sins * ( coss2m  + bb *  ( coss
     .                     * ( -1.0_LP + 2.0_LP * coss2m * coss2m )
     .                     - bb * coss2m
     .                     * ( -3.0_LP + 4.0_LP *   sins *   sins )
     .                     * ( -3.0_LP + 4.0_LP * coss2m * coss2m )
     .                     / 6.0_LP ) / 24.0_LP )
         sig  =  aa * ( sig - dsig )

         y    =  cosU2 * sindl             ! ... azimuth angle
         x    =  cosU1 * sinU2 - sinU1 * cosU2 * cosdl
         a12  =  atan2 ( y, x )

         y    =  cosU1 * sindl             ! ... and the reverse angle
         x    = -sinU1 * cosU2 + cosU1 * sinU2 * cosdl
         a21  =  atan2 ( y, x )

         iret = NIter_max                  ! ... if desired set the
         if ( converged ) iret = Valid     !     covergence status code.

         dist   (iPt) = sig                ! Convert angles to degrees
         azim12 (iPt) = modulo ( a12 / Deg2R, 360.0_LP )
         if ( azim12(iPt) .le. 0.0 ) azim12(iPt) = 360.0_LP
         azim21 (iPt) = modulo ( a21 / Deg2R, 360.0_LP )
         if ( azim21(iPt) .le. 0.0 ) azim21(iPt) = 360.0_LP
         if ( present ( stat ) ) stat (iPt) = iret

      end do OuterLoop

      return
      end subroutine Inverse_LP

!....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: Inverse_LP - Solve the inverse problem with high precision arguments
!
! !DESCRIPTION:
!     This routine solves the inverse problem in geodesy.  All input and
!     output arguments are in high (double) precision floating point numbers.
!
! !INTERFACE:
!
      pure subroutine Inverse_HP ( lat1, lon1,   lat2,   lon2,
     .                             dist, azim12, azim21, stat, fl )
      implicit   NONE
!
! !INPUT PARAMETERS:
      real (HP),     intent (in)  ::
     .   lat1   (:), ! geodetic latitude (deg, -90 = 90S)
     .   lon1   (:), ! ... longitude     (deg, -90 = 90W) for each point
     .   lat2   (:), ! latitude (deg)
     .   lon2   (:)  ! ... longitude (deg) for each second point
      real (HP),     intent (in), optional ::
     .   fl          ! flatness (a-b)/a where a and b are the major and minor
                     !   semi-axis.  Range: [0,0.99].  Default: Earth's value
! !OUTPUT PARAMETERS:
      real (HP),     intent (out) ::
     .   dist   (:), ! angular ellipsoidal distance, arc / b, (radians) where
     .               !   arc is the arc distance and b is the minor semi-axis
     .   azim12 (:), ! azimuth angle (deg, 90 = due east) and ...
     .   azim21 (:)  ! ... reverse azimuth angle on the ellipsoid (deg).
                     !   Range: (0,360]
      integer,       intent (out), optional ::
     .   stat   (:)  ! = 0 if algorithm converged properly.  If > 0, then
                     !   stat = number of iterations without converging to a
                     !   a solution (at least to within machine round-off).
!
!     Note: The number of points is determined by the size of the arrays.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!       Jan1976  INGE NESBO  Original code, originally called INVINC
!     12Nov2001  C. Redder   Adapted the routine and renamed it
!     18Apr2002  C. Redder   Modified the way the number of points are
!                            determined.
! EOP
!-------------------------------------------------------------------------

      real (HP) :: Deg2R, l1, l2, f1, f2, a12, a21, f, tol, SPI
      real (HP) :: h, x, y, fm1, fMax
      real (HP) :: sina12, cosa12
      real (HP) :: sinU1,  cosU1, sinU2, cosU2, sina, cossqa
      real (HP) :: dl, sindl, cosdl, dl0, ddl, ddlLast
      real (HP) :: aa, bb, cc, dd, ee, ff, usq
      real (HP) :: sig, dsig, sins, coss, coss2m
      logical   :: converged
      integer   :: iPt, NPts, Iter, iret
      real (HP), parameter :: reltol = 10.0_HP ** ( -precision ( tol ))

      fMax    = flMax
      f       = flEarth                    ! flatness of an ellipsoid
      if ( present ( fl )) f = min ( fMax, abs ( fl ))
      fm1     = 1.0_HP - f

      SPI     = PI
      Deg2R   = Deg2Rad
      NPts    = min ( size ( lat1 ), size ( lon1   ),
     .                size ( lat2 ), size ( lon2   ),
     .                size ( dist ), size ( azim12 ), size ( azim21 ))
      OuterLoop: do iPt  = 1, NPts
         f1   = lat1 (iPt) * Deg2R         ! Convert the latitude
         l1   = lon1 (iPt) * Deg2R         ! ... longitude of the first point
         f2   = lat2 (iPt) * Deg2R         ! ... and of the second point
         l2   = lon2 (iPt) * Deg2R
                                           ! Compute the trignometric
                                           !   functions  of the ...
         y      = sin ( f1 ) * fm1         ! ... reduced latitude, U1,
         x      = cos ( f1 )               !   where tan (U1) = (1-f) tan (f1)
         h      = sqrt ( x ** 2 + y ** 2 ) !   for the first point
         sinU1  = y / h
         cosU1  = x / h
         y      = sin ( f2 ) * fm1         ! ... and for the second point
         x      = cos ( f2 )
         h      = sqrt ( x ** 2 + y ** 2 )
         sinU2  = y / h
         cosU2  = x / h

         dl     = l2 - l1
         dl0    = dl
         tol    = reltol
         ddl    = 0.0_HP
         converged = .false.

         do Iter = 1, NIter_max            ! Interatively determine the
            ddlLast = ddl                  !   adjusted difference of the
            sindl   = sin ( dl )           !   longitudes.
            cosdl   = cos ( dl )
            sins    = sqrt ( ( cosU2 * sindl ) ** 2
     .                     + ( cosU1 * sinU2
     .                       - sinU1 * cosU2 * cosdl ) ** 2 )
            if ( sins .le. tol ) then      ! If the points are identical ...
               azim12 (iPt) = 0.0_HP       ! ... then set the output
               azim21 (iPt) = 0.0_HP       !   arguments to zero and ...
               dist   (iPt) = 0.0_HP
               if ( present ( stat ) ) stat (iPt) = Valid
               cycle OuterLoop             ! ... go to next pair of points
            end if

            coss    = sinU1 * sinU2 + cosU1 * cosU2 * cosdl
            sig     = atan2 ( sins, coss )
            sina    = cosU1 * cosU2 * sindl / sins
            cossqa  = 1.0_HP - sina * sina
            coss2m  = coss
            if ( cossqa .gt. tol )
     .         coss2m = coss2m - 2.0_HP * sinU1 * sinU2 / cossqa
            cc      = ( f * cossqa / 16.0_HP )
     .              * ( 4.0_HP + f * ( 4.0_HP - 3.0_HP * cossqa ))
            ddl     = ( 1.0_HP - cc ) * f * sina
     .              * ( sig    + cc * sins
     .              * ( coss2m + cc * coss
     .              * ( -1.0_HP + 2.0_HP * coss2m * coss2m )))

            dl = dl0 + ddl
            converged = abs ( ddl - ddlLast ) .le. tol
            if ( converged ) exit          ! If convergence criteria is
                                           !   statisfied, then exit loop.
         end do
         sindl   = sin ( dl )
         cosdl   = cos ( dl )

                                           ! Now compute angular distance
         usq    = ( 1.0_HP / fm1 ** 2 - 1.0_HP ) * cossqa
         aa     = 1.0_HP + usq * ( 4096.0_HP
     .                   - usq * (  768.0_HP
     .                   - usq * (  320.0_HP - 175.0_HP * usq )))
     .                   / 16384.0_HP
         bb     =          usq * (  256.0_HP
     .                   - usq * (  128.0_HP
     .                   - usq * (   74.0_HP -  47.0_HP * usq )))
     .                   / 1024.0_HP
         dsig =  bb * sins * ( coss2m  + bb *  ( coss
     .                     * ( -1.0_HP + 2.0_HP * coss2m * coss2m )
     .                     - bb * coss2m
     .                     * ( -3.0_HP + 4.0_HP *   sins *   sins )
     .                     * ( -3.0_HP + 4.0_HP * coss2m * coss2m )
     .                     / 6.0_HP ) / 24.0_HP )
         sig  =  aa * ( sig - dsig )

         y    =  cosU2 * sindl             ! ... azimuth angle
         x    =  cosU1 * sinU2 - sinU1 * cosU2 * cosdl
         a12  =  atan2 ( y, x )

         y    =  cosU1 * sindl             ! ... and the reverse angle
         x    = -sinU1 * cosU2 + cosU1 * sinU2 * cosdl
         a21  =  atan2 ( y, x )

         iret = NIter_max                  ! ... if desired set the
         if ( converged ) iret = Valid     !     covergence status code.

         dist   (iPt) = sig                ! Convert angles to degrees
         azim12 (iPt) = modulo ( a12 / Deg2R, 360.0_HP )
         if ( azim12(iPt) .le. 0.0 ) azim12(iPt) = 360.0_HP
         azim21 (iPt) = modulo ( a21 / Deg2R, 360.0_HP )
         if ( azim21(iPt) .le. 0.0 ) azim21(iPt) = 360.0_HP
         if ( present ( stat ) ) stat (iPt) = iret

      end do OuterLoop

      return
      end subroutine Inverse_HP
!....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: DirSph - Solve the direct problem on a sphere
!
! !DESCRIPTION:
!     This routine solves the direct problem in geodesy for a sphere.  The
!     algorithm is a special case of the formulae for an ellipsoid as
!     presented by Vincenty (1975).
!
! !INTERFACE:
!
      pure subroutine DirSph ( lat1, lon1, dist, azim12,
     .                         lat2, lon2,       azim21 )
      implicit   NONE
!
! !INPUT PARAMETERS:
      real,          intent (in)  ::
     .   lat1   (:), ! geodetic latitude (deg, -90 = 90S)
     .   lon1   (:), ! ... longitude     (deg, -90 = 90W) for each point
     .   dist   (:), ! angular ellipsoidal distance, arc / b, (radians) where
     .               !   arc is the arc distance and b the spherical radius
     .   azim12 (:)  ! azimuth angle on ellipsoid (deg, 90 = due east)
!
! !OUTPUT PARAMETERS:
      real,          intent (out) ::
     .   lat2   (:), ! latitude (deg)
     .   lon2   (:), ! ... longitude for each second point (deg)
     .   azim21 (:)  ! reverse azimuth angle (deg).  Range: (0,360]
!
!     Note: The number of points is determined by the size of the arrays.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     15Nov2001  C. Redder   Original code.
!     18Apr2002  C. Redder   Modified the way the number of points are
!                            determined.
!     11Mar2007  C. Redder   Fixed bug for the case when points 1 and 2
!                            are identical.
! EOP
!-------------------------------------------------------------------------

      real    :: Deg2R, l1, l2, f1, f2, a12, a21, SPI
      real    :: x, y, xsq, sig, sins, coss
      real    :: sina12, cosa12, sinU1, cosU1, sina, cosa
      integer :: iPt, NPts

      SPI     = PI
      Deg2R   = Deg2Rad
      NPts    = min ( size ( lat1 ), size ( lon1 ), size ( azim12 ),
     .                size ( dist ),
     .                size ( lat2 ), size ( lon2 ), size ( azim21 ))
      do iPt  = 1, NPts                    ! Convert (to radians) ...
         f1     = lat1   (iPt) * Deg2R     ! ... the latitude
         l1     = lon1   (iPt) * Deg2R     ! ... longitude of the first point
         a12    = azim12 (iPt) * Deg2R     ! ... and direction angle
                                           ! Compute the trignometric
                                           !   functions of the ...
         sina12 = sin ( a12 )              ! ... direction angle
         cosa12 = cos ( a12 )
         sinU1  = sin ( f1 )               ! ... latitude
         cosU1  = cos ( f1 )
         sina   = cosU1 * sina12           ! ... azimuth of the geodesic
         cosa   = sqrt ( 1.0 - sina ** 2 ) !     at the equator

         f2     = f1
         l2     = l1
         a21    = 0.0
         sig    = dist (iPt)
         if ( sig  .ne. 0.0 ) then
            sins = sin ( sig )             ! ... angular distance between the
            coss = cos ( sig )             !   two points
                                           ! For the second point, compute
                                           !   (in radians)
            y    = sinU1 * coss            ! ... the latitude ...
     .           + cosU1 * sins * cosa12
            xsq  = sina ** 2 + ( sinU1 * sins - cosU1 * coss * cosa12 ) ** 2
            f2   = atan2 ( y, sqrt ( xsq ) )

            y    = sins  * sina12          ! ... and longitude for the
            x    = cosU1 * coss - sinU1 * sins * cosa12
            l2   = atan2 ( y, x ) + l1     !   second point in radians

            y    = sina                    ! Compute the reverse angle
            x    = cosU1 * coss * cosa12 - sinU1 * sins
            a21  = atan2 ( y, x )
         end if

         lat2   (iPt) =  f2  / Deg2R       ! Convert output to degrees
         lon2   (iPt) =  l2  / Deg2R
         azim21 (iPt) = modulo ( a21 / Deg2R, 360.0 )
         if ( azim21(iPt) .le. 0.0 ) azim21(iPt) = 360.0
      end do

      return
      end subroutine DirSph
!....................................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE: InvSph - Solve the inverse problem for a sphere
!
! !DESCRIPTION:
!     This routine solves the inverse problem in geodesy for a sphere.  The
!     algorithm is a special case of the formulae for an ellipsoid as
!     presented by Vincenty (1975).
!
! !INTERFACE:
!
      pure subroutine InvSph ( lat1, lon1,   lat2,   lon2,
     .                         dist, azim12, azim21 )
      implicit   NONE
!
! !INPUT PARAMETERS:
      real,          intent (in)  ::
     .   lat1   (:), ! geodetic latitude (deg, -90 = 90S)
     .   lon1   (:), ! ... longitude     (deg, -90 = 90W) for each point
     .   lat2   (:), ! latitude (deg)
     .   lon2   (:)  ! ... longitude (deg) for each second point
!
! !OUTPUT PARAMETERS:
      real,          intent (out) ::
     .   dist   (:), ! angular ellipsoidal distance, arc / b, (radians) where
     .               !   arc is the arc distance and b the spherical radius
     .   azim12 (:), ! azimuth angle (deg, 90 = due east) and ...
     .   azim21 (:)  ! ... reverse azimuth angle on the ellipsoid (deg).
                     !   Range: (0,360]
!
!     Note: The number of points is determined by the size of the arrays.
!
! !SEE ALSO:
!
! !REVISION HISTORY:
!     15Nov2001  C. Redder   Original code
!     18Apr2002  C. Redder   Modified the way the number of points are
!                            determined.
!     11Mar2007  C. Redder   Fixed bug for the case when points 1 and 2
!                            are identical.
! EOP
!-------------------------------------------------------------------------

      real    :: Deg2R, l1, l2, f1, f2, a12, a21, SPI, x, y
      real    :: sinU1, cosU1, sinU2, cosU2
      real    :: dl, sindl, cosdl, sig, sins, coss
      integer :: iPt, NPts

      SPI     = PI
      Deg2R   = Deg2Rad
      NPts    = min ( size ( lat1 ), size ( lon1   ),
     .                size ( lat2 ), size ( lon2   ),
     .                size ( dist ), size ( azim12 ), size ( azim21 ))
      do iPt  = 1, NPts
         f1    =  lat1 (iPt) * Deg2R       ! Convert the latitude
         l1    =  lon1 (iPt) * Deg2R       ! ... longitude of the first point
         f2    =  lat2 (iPt) * Deg2R       ! ... and of the second point
         l2    =  lon2 (iPt) * Deg2R
                                           ! Compute the trignometric
                                           !   functions  of the ...
         sinU1 =  sin ( f1 )               ! ... latitude for the first
         cosU1 =  cos ( f1 )
         sinU2 =  sin ( f2 )               ! ... and second point
         cosU2 =  cos ( f2 )

         dl    =  l2 - l1                  ! Compute the difference in
         sindl =  sin ( dl )               !   longitudes and their
         cosdl =  cos ( dl )               !   trignometric functions
         sins  =  sqrt ( ( cosU2 * sindl ) ** 2
     .                 + ( cosU1 * sinU2
     .                   - sinU1 * cosU2 * cosdl ) ** 2 )
         coss  =  sinU1 * sinU2 + cosU1 * cosU2 * cosdl
                                           ! Now compute (in radians)
         sig   =  atan2 ( sins, coss )     ! ... the angular distance

         y     =  cosU2 * sindl            ! ... azimuth angle
         x     =  cosU1 * sinU2 - sinU1 * cosU2 * cosdl
         a12   = 0.0
         if ( x .ne. 0.0 .or. y .ne. 0 ) a12 = atan2 ( y, x )

         y     =  cosU1 * sindl            ! ... and the reverse angle
         x     = -sinU1 * cosU2 + cosU1 * sinU2 * cosdl
         a21   = 0.0
         if ( x .ne. 0.0 .or. y .ne. 0 ) a21 = atan2 ( y, x )

         dist   (iPt) = sig                ! Convert angles to degrees
         azim12 (iPt) = modulo ( a12 / Deg2R, 360.0 )
         if ( azim12(iPt) .le. 0.0 ) azim12(iPt) = 360.0
         azim21 (iPt) = modulo ( a21 / Deg2R, 360.0 )
         if ( azim21(iPt) .le. 0.0 ) azim21(iPt) = 360.0

      end do

      return
      end subroutine InvSph
!....................................................................
      end module m_ellipsoid
!====================================================================


module dmrgfun_lib
 use tt_lib
 use ttaux_lib
 use ttop_lib
 use rnd_lib
 double precision,parameter,private :: tpi=6.28318530717958647692528676655900577d0
contains
 subroutine dtt_dmrg(arg, tol, rhs, maxiter, coresize, demo)
  ![tt] fit rhs using dmrg
  implicit none
  type(dtt),intent(inout),target :: arg
  double precision,intent(in) :: tol
  double precision,intent(in) :: rhs(*)
  integer,intent(in),optional :: maxiter,coresize,demo
  character(len=*),parameter :: subnam='dtt_dmrg'
  integer :: l,m,dd,it,itt,maxit,g,nn,nu,nv,ng,ld,rd,mn,lwork,info,i,j,k,ii,jj,kk,bit(64),p
  integer :: idum(tt_size)
  integer,pointer :: r(:),n(:)
  double precision,allocatable :: work(:),u(:,:),v(:,:),sv(:),a(:),d(:)
  double precision :: eps,nrm,err,hx,hy
  double precision,external :: dnrm2
  double precision,external :: dfun
  type(dtt) :: tmp
  character(len=64) :: str

  l=arg%l; m=arg%m; if(l.gt.m)return; dd=m-l+1
  if(arg%r(l-1).ne.1)then;write(*,*)subnam,': left border rank should be 1';stop;endif
  if(arg%r(m).ne.1)then;write(*,*)subnam,': right border rank should be 1';stop;endif
  !if(.not.all(arg%n(l:m)==2))then;write(*,*)subnam,': not bitt on input';stop;endif
  r=>arg%r; n=>arg%n
  eps=tol/dsqrt(dble(dd))
  maxit=16;if(present(maxiter))maxit=maxiter
  g=1;if(present(coresize))g=max(coresize-1,1)
  if(m-l.le.g)then
   nn=product(n(l:m))
   call svd(n(l:m),rhs,arg,tol)
   return
  end if

  call dtt_rev(arg)
  call ort(arg)
  call dtt_rev(arg)

       !nn=product(n(l:m))
       !allocate(work(nn))
       !call full(arg,work)
       !nrm=maxval(work)
       !call dscal(nn,1.d0/nrm,work,1)
       !hx=1.d0/nn
       !write(str,'(a,i2.2,a)') '_sin_m',m,'_init'
       !open(10,file=str)
       !do i=1,nn
       ! write(10,'(2(f15.12,1x))')i*hx-hx/2,work(i)
       !end do
       !close(10)
       !STOP

  do it=1,maxit
   write(*,'(a,i2,a)') ' DMRG  --(',it,')-- '

   k=l-1
   do itt=-(m-g-l),m-g-l
    if(itt.le.0)then;k=k+1;else;k=k-1;endif
    write(*,'(a,3(i3,a))') 'itt: ',itt,' supercore [',k,':',k+g,']'
    nu=max(1,product(n(l:k-1))); ng=product(n(k:k+g)); nv=max(1,product(n(k+g+1:m)))
    allocate(d(r(k-1)*ng*r(k+g)),u(nu,r(k-1)),v(r(k+g),nv),a(r(k-1)*ng*nv),stat=info)
    if(info.ne.0)then;write(*,*)subnam,': cannot allocate ';stop;endif

    ! form supercore
    if(k.gt.l)then; call dtt_full(arg,u,part=(/l,k-1/)); else; u=1.d0; endif
    if(k+g.lt.m)then; call dtt_full(arg,v,part=(/k+g+1,m/)); else; v=1.d0; endif
    call dgemm('t','n',r(k-1),ng*nv,nu,1.d0,u,nu,rhs,nu,0.d0,a,r(k-1))
    call dgemm('n','t',r(k-1)*ng,r(k+g),nv,1.d0,a,r(k-1)*ng,v,r(k+g),0.d0,d,r(k-1)*ng)
    deallocate(u,v,a,stat=info)
    if(info.ne.0)then;write(*,*)subnam,': cannot deallocate';stop;endif

    ! decompose the supercore and recover train format
    if(g.eq.1)then
     ld=r(k-1)*n(k); rd=product(n(k+1:k+g))*r(k+g); mn=min(ld,rd); lwork=128*mn*maxval(r(l:m))
     allocate(u(ld,mn),v(mn,rd),sv(mn),work(lwork), stat=info)
     if(info.ne.0)then;write(*,*)subnam,': cannot allocate ';stop;endif
     call dgesvd('s','s',ld,rd,d,ld,sv,u,ld,v,mn,work,lwork,info)
     if(info.ne.0)then; write(*,*)subnam,': dgesvd info: ',info; stop; end if
     r(k)=chop(sv,tol=eps)
     deallocate(arg%u(k)%p,arg%u(k+1)%p)
     allocate(arg%u(k)%p(r(k-1),n(k),r(k)),arg%u(k+1)%p(r(k),n(k+1),r(k+1)))
     call dcopy(r(k-1)*n(k)*r(k),u,1,arg%u(k)%p,1)
     call d2submat(r(k),n(k+1)*r(k+1),v,mn,arg%u(k+1)%p)
     if(itt.lt.0)then
      write(*,*) 'ort->'
      forall(i=1:r(k))arg%u(k+1)%p(i,:,:)=sv(i)*arg%u(k+1)%p(i,:,:)
     else
      write(*,*) '<-ort'
      forall(i=1:r(k))arg%u(k)%p(:,:,i)=sv(i)*arg%u(k)%p(:,:,i)
     endif
     deallocate(u,v,sv,work)
    else
     idum(1)=r(k-1)*n(k);idum(2:g)=n(k+1:k+g-1);idum(g+1)=n(k+g)*r(k+g); tmp%l=1
     call svd(idum(1:g+1),d,tmp,tol=eps)
     if(itt.lt.0)call ort(tmp)
     r(k:k+g-1)=tmp%r(1:g)
     do j=k,k+g
      deallocate(arg%u(j)%p)
      allocate(arg%u(j)%p(r(j-1),n(j),r(j)))
      call dcopy(size(tmp%u(j-k+1)%p),tmp%u(j-k+1)%p,1,arg%u(j)%p,1)
     enddo
     call dealloc(tmp)
    endif

    deallocate(d,stat=info)
    if(info.ne.0)then;write(*,*)subnam,': cannot deallocate';stop;endif
    call say(arg)
!----
    nn=product(n(l:m))
    allocate(work(nn))
    call full(arg,work)

    if(present(demo))then
     select case(demo)
      case(1)
       hx=1.d0/nn
       write(str,'(3(a,i2.2))') '_sin_m',m,'_',it,'.',itt+m-g-l
       open(10,file=str)
       do i=1,nn
        write(10,'(2(f15.12,1x))')i*hx-hx/2,work(i)
       end do
       close(10)

      case(2)
       p=2**(m/2); hx=1.d0/p; hy=1.d0/p; allocate(u(p,p))
       do i=1,nn
        do j=0,31
         bit(j)=ibits(i-1,j,1)
        enddo
        ii=1;jj=1
        do kk=0,m/2-1
         ii=ii+bit(2*kk)*(2**kk)
         jj=jj+bit(2*kk+1)*(2**kk)
        enddo
        u(ii,jj)=work(i)
       enddo

       write(str,'(3(a,i2.2))') '_simplex_k2_m',m/2,'_',it,'.',itt+m-g-l
       open(10,file=str)
       do ii=0,p
        do jj=0,p
         if(ii.gt.0.and.jj.gt.0)then
          write(10,'(3(f15.12,1x))')ii*hx,jj*hy,u(ii,jj)
         else
          write(10,'(3(f15.12,1x))')ii*hx,jj*hy,0.d0
         endif
        end do
        write(10,*)
       end do
       close(10)
       deallocate(u)
     end select
    end if

    nrm=dnrm2(nn,work,1)
    call daxpy(nn,-1.d0,rhs,1,work,1)
    err=dnrm2(nn,work,1)
    write(*,*) err/nrm
    deallocate(work)
!----
   end do

  end do
 end subroutine

 subroutine dtt_dmrgf(arg, tol, dfun, maxiter, coresize, kick)
  ![tt] fit rhs using dmrg and maxvol
  use maxvol_lib
  use sort_lib
  use ort_lib
  implicit none
  type(dtt),intent(inout),target :: arg
  double precision,intent(in) :: tol
  integer,intent(in),optional :: maxiter,coresize,kick
  character(len=*),parameter :: subnam='dtt_dmrgf'
  integer,pointer :: r(:),n(:)
  type(pointi2) :: vip(0:tt_size,2)
  type(pointd2) :: mat(0:tt_size,2),inv(0:tt_size,2)
  type(ttind) :: ind
  double precision,allocatable :: b(:),c(:),work(:),u(:,:),v(:,:),sv(:)
  integer :: ijk,i,j,k,p,pp,q,qq,l,m,mm,dd,d1,nn,n1,t,s,rl,rr,g,mn,ld,rd,lp,rp,dir,lft,rgt,it,maxit,lwork,info
  double precision :: hx,eps,er2,err,nrm,mean,nval
  character*60 :: frm, sdir
  double precision,external :: dnrm2
  double precision, external :: dfun
  logical :: done

  l=arg%l; m=arg%m;
  print *, l,m
  if(l.gt.m)return
  dd=m-l+1; hx=1.d0/dsqrt(2.d0**dd); d1=dd/3; hx=1.d0/(2.d0**d1); n1=2**d1
  if(arg%r(l-1).ne.1)then;write(*,*)subnam,': left border rank should be 1';stop;endif
  if(arg%r(m).ne.1)then;write(*,*)subnam,': right border rank should be 1';stop;endif
  !if(.not.all(arg%n(l:m)==2))then;write(*,*)subnam,': not bitt on input';stop;endif
  r=>arg%r; n=>arg%n
  maxit=16;if(present(maxiter))maxit=maxiter
  eps=dmax1(tol/(10*dd),1.d-13)
  g=2;if(present(coresize))g=max(coresize,g)
  q=1;if(present(kick))q=max(kick,0)
  write(frm,'(a,i2.2,a)')'(',dd,'i1,f20.14)'
  if(m-l.le.g)then;write(*,*)'tensor smaller than coresize: ',m-l,coresize;return;end if

  ! maxvol ->
  lft=1; rgt=2
  allocate(vip(0,lft)%p(r(l-1),1)); forall(i=1:r(l-1))vip(0,lft)%p(i,1)=i
  allocate(mat(0,lft)%p(r(l-1),r(l-1))); call eye(mat(0,lft)%p)
  allocate(inv(0,lft)%p(r(l-1),r(l-1))); call eye(inv(0,lft)%p)
  ! maxvol <-
  call reverse(arg)
  call ort(arg); call maxvol(arg,vip(:,rgt),mat(:,rgt))
  call reverse(arg)
  do i=0,dd-1
   allocate(inv(i,rgt)%p(r(m-i),r(m-i)))
   call matinv(mat(i,rgt)%p,inv(i,rgt)%p)
  enddo

  ! iterate
  done=.false.; it=0; nval=0.d0
  do while(.not.done)
   it=it+1; er2=0.d0
   do dir=1,2
    lft=dir;rgt=3-dir
    if(dir.eq.1)then;sdir='>>';else if(dir.eq.2)then;sdir='<<';else;sdir='??';endif
    do p=l,m-g+1
     r=>arg%r; n=>arg%n
     !call say(arg)
     pp=p-l+1; lp=pp-1; rp=dd-lp-g
     rl=r(p-1); rr=r(p+g-1)
     mm=product(n(p:p+g-1))

      !write(*,*)'(a)'
     ! compute long indices and form rhs
     allocate(b(rl*mm*rr),c(rl*mm*rr),stat=info)
     if(info.ne.0)then;write(*,*)subnam,': cannot allocate rhs';stop;endif

     do ijk=1,rl*mm*rr
      k=(ijk-1)/(mm*rl)+1
      j=(ijk-1)/rl-(k-1)*mm+1
      i=ijk-(k-1)*mm*rl-(j-1)*rl
      ind%p=0; ind%n(1:dd)=arg%n(l:m); ind%m=dd
      t=i; do s=lp,1,-1; ind%p(s)=vip(s,lft)%p(t,2); t=vip(s,lft)%p(t,1); enddo
      call mindex(j,n(p:p+g-1),ind%p(pp:pp+g-1))
      t=k; do s=rp,1,-1; ind%p(dd-s+1)=vip(s,rgt)%p(t,2); t=vip(s,rgt)%p(t,1); enddo
      if(dir.eq.2)call reverse(ind)
      !print *,'dd=',dd,'Index set is:', ind%p(1:dd)
      b(ijk)=dfun(dd,ind%p(1:dd))
      !write(*,frm)ind%p(1:dd),b(i+rl*(j-1)+rl*mm*(k-1))
     end do
     nval=nval+rl*mm*rr
      !write(*,*)'(b)'

     ! compute supercore
     ld=rl*mm; rd=rr; call dgemm('n','t',ld,rd,rr,1.d0,b,ld,inv(rp,rgt)%p,rr,0.d0,c,ld)
     ld=rl; rd=mm*rr; call dgemm('n','n',ld,rd,rl,1.d0,inv(lp,lft)%p,rl,c,ld,0.d0,b,ld)

      !write(*,*)'(c)'

     ! check step size
     ld=rl*n(p); rd=n(p+1)*rr; call dcopy(ld*rd,b,1,c,1); nrm=dnrm2(ld*rd,c,1)
     call dgemm('n','n',ld,rd,r(p),-1.d0,arg%u(p)%p,ld,arg%u(p+1)%p,r(p),1.d0,c,ld)
     err=dnrm2(ld*rd,c,1); er2=er2+err*err

      !write(*,*)'(d)'

     ! decompose the supercore and recover train format
     if(g.eq.1)then
      stop
     else if(g.eq.2)then
      ld=rl*n(p); rd=n(p+1)*rr; mn=min(ld,rd); lwork=128*mn*max(ld,rd)
      allocate(u(ld,mn+q),v(mn,rd),sv(mn),work(lwork), stat=info)
      if(info.ne.0)then;write(*,*)subnam,': cannot allocate ';stop;endif
      call dgesvd('s','s',ld,rd,b,ld,sv,u,ld,v,mn,work,lwork,info)
      if(info.ne.0)then; write(*,*)subnam,': dgesvd info: ',info; stop; end if
      r(p)=chop(sv,tol=eps)
      qq=min(q,ld-r(p))
      if(qq.gt.0)then
       call random(u(:,r(p)+1:r(p)+qq))
       call orto(u(:,1:r(p)),u(:,r(p)+1:r(p)+qq))
      end if
      deallocate(arg%u(p)%p,arg%u(p+1)%p)
      allocate(arg%u(p)%p(r(p-1),n(p),r(p)+qq),arg%u(p+1)%p(r(p)+qq,n(p+1),r(p+1)))
      call dcopy(r(p-1)*n(p)*(r(p)+qq),u,1,arg%u(p)%p,1)
      forall(i=1:r(p),        j=1:n(p+1),k=1:r(p+1)) arg%u(p+1)%p(i,j,k)=sv(i)*v(i,j+(k-1)*n(p+1))
      forall(i=r(p)+1:r(p)+qq,j=1:n(p+1),k=1:r(p+1)) arg%u(p+1)%p(i,j,k)=0.d0
      r(p)=r(p)+qq
      deallocate(u,v,sv,work)
     else
      stop
     end if
     deallocate(b,c)

      !write(*,*)'(e)'

     mean=sumall(arg)/numel(arg)
     !write(*,'(i2,a2,i3,a,f7.3,2(a,e14.7),a,e10.3)') it,sdir,p,' rank ',rank(arg),' mean ',mean,' nrm ',nrm,' err ',err/nrm

     ! compute new maxvol positions
     allocate(u(r(p-1)*n(p),r(p)),v(r(p-1)*n(p),r(p)),stat=info)
     if(info.ne.0)then;write(*,*)subnam,': cannot allocate u,v';stop;endif

      !write(*,*)'(f)'

     call dgemm('n','n',r(p-1),n(p)*r(p),r(p-1),1.d0,mat(pp-1,lft)%p,r(p-1),arg%u(p)%p,r(p-1), 0.d0,u,r(p-1))
     if(associated(vip(pp,lft)%p))deallocate(vip(pp,lft)%p); allocate(vip(pp,lft)%p(r(p),2)); vip(pp,lft)%p=0
     if(associated(mat(pp,lft)%p))deallocate(mat(pp,lft)%p); allocate(mat(pp,lft)%p(r(p),r(p)))
     if(associated(inv(pp,lft)%p))deallocate(inv(pp,lft)%p); allocate(inv(pp,lft)%p(r(p),r(p)))

     call ort0(u,v); call maxvol(v,vip(pp,lft)%p(:,1)); call sort(vip(pp,lft)%p(:,1))
     forall(i=1:r(p),j=1:r(p))mat(pp,lft)%p(i,j)=u(vip(pp,lft)%p(i,1),j)
     call matinv(mat(pp,lft)%p,inv(pp,lft)%p)

     vip(pp,lft)%p(:,2)=(vip(pp,lft)%p(:,1)-1)/r(p-1)
     vip(pp,lft)%p(:,1)=vip(pp,lft)%p(:,1)-vip(pp,lft)%p(:,2)*r(p-1)
     vip(pp,lft)%p(:,2)=vip(pp,lft)%p(:,2)+1
     deallocate(u,v)
    end do
    call reverse(arg)
   end do
   mean=sumall(arg)/numel(arg); err=dsqrt(er2); nrm=norm(arg); done=err.le.tol*nrm .or. it.ge.maxit
   write(*,'(i3,a,f7.3,2(a,e14.7),2(a,e10.3))')it,' rank ',rank(arg),' mean ',mean,' nrm ',nrm/dsqrt(numel(arg)),' nval ',nval,' err ',err/nrm
  end do
  call svd(arg,tol)
 end subroutine

end module


C FISHPAK2 FROM PORTLIB                                  12/30/83
      SUBROUTINE HWSCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C          SUBROUTINE HWSCRT SOLVES THE STANDARD FIVE-POINT FINITE
C     DIFFERENCE APPROXIMATION TO THE HELMHOLTZ EQUATION IN CARTESIAN
C     COORDINATES:
C
C          (D/DX)(DU/DX) + (D/DY)(DU/DY) + LAMBDA*U = F(X,Y).
C
C
C
C     * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C             * * * * * *   ON INPUT    * * * * * *
C
C     A,B
C       THE RANGE OF X, I.E., A .LE. X .LE. B.  A MUST BE LESS THAN B.
C
C     M
C       THE NUMBER OF PANELS INTO WHICH THE INTERVAL (A,B) IS
C       SUBDIVIDED.  HENCE, THERE WILL BE M+1 GRID POINTS IN THE
C       X-DIRECTION GIVEN BY X(I) = A+(I-1)DX FOR I = 1,2,...,M+1,
C       WHERE DX = (B-A)/M IS THE PANEL WIDTH. M MUST BE GREATER THAN 3.
C
C     MBDCND
C       INDICATES THE TYPE OF BOUNDARY CONDITIONS AT X = A AND X = B.
C
C       = 0  IF THE SOLUTION IS PERIODIC IN X, I.E., U(I,J) = U(M+I,J).
C       = 1  IF THE SOLUTION IS SPECIFIED AT X = A AND X = B.
C       = 2  IF THE SOLUTION IS SPECIFIED AT X = A AND THE DERIVATIVE OF
C            THE SOLUTION WITH RESPECT TO X IS SPECIFIED AT X = B.
C       = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C            SPECIFIED AT X = A AND X = B.
C       = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C            SPECIFIED AT X = A AND THE SOLUTION IS SPECIFIED AT X = B.
C
C     BDA
C       A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = A.
C       WHEN MBDCND = 3 OR 4,
C
C            BDA(J) = (D/DX)U(A,Y(J)), J = 1,2,...,N+1  .
C
C       WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A DUMMY VARIABLE.
C
C     BDB
C       A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = B.
C       WHEN MBDCND = 2 OR 3,
C
C            BDB(J) = (D/DX)U(B,Y(J)), J = 1,2,...,N+1  .
C
C       WHEN MBDCND HAS ANY OTHER VALUE BDB IS A DUMMY VARIABLE.
C
C     C,D
C       THE RANGE OF Y, I.E., C .LE. Y .LE. D.  C MUST BE LESS THAN D.
C
C     N
C       THE NUMBER OF PANELS INTO WHICH THE INTERVAL (C,D) IS
C       SUBDIVIDED.  HENCE, THERE WILL BE N+1 GRID POINTS IN THE
C       Y-DIRECTION GIVEN BY Y(J) = C+(J-1)DY FOR J = 1,2,...,N+1, WHERE
C       DY = (D-C)/N IS THE PANEL WIDTH.  N MUST BE GREATER THAN 3.
C
C     NBDCND
C       INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Y = C AND Y = D.
C
C       = 0  IF THE SOLUTION IS PERIODIC IN Y, I.E., U(I,J) = U(I,N+J).
C       = 1  IF THE SOLUTION IS SPECIFIED AT Y = C AND Y = D.
C       = 2  IF THE SOLUTION IS SPECIFIED AT Y = C AND THE DERIVATIVE OF
C            THE SOLUTION WITH RESPECT TO Y IS SPECIFIED AT Y = D.
C       = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C            SPECIFIED AT Y = C AND Y = D.
C       = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C            SPECIFIED AT Y = C AND THE SOLUTION IS SPECIFIED AT Y = D.
C
C     BDC
C       A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = C.
C       WHEN NBDCND = 3 OR 4,
C
C            BDC(I) = (D/DY)U(X(I),C), I = 1,2,...,M+1  .
C
C       WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A DUMMY VARIABLE.
C
C     BDD
C       A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT SPECIFIES THE VALUES
C       OF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = D.
C       WHEN NBDCND = 2 OR 3,
C
C            BDD(I) = (D/DY)U(X(I),D), I = 1,2,...,M+1  .
C
C       WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A DUMMY VARIABLE.
C
C     ELMBDA
C       THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION.  IF
C       LAMBDA .GT. 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HWSCRT WILL
C       ATTEMPT TO FIND A SOLUTION.
C
C     F
C       A TWO-DIMENSIONAL ARRAY WHICH SPECIFIES THE VALUES OF THE RIGHT
C       SIDE OF THE HELMHOLTZ EQUATION AND BOUNDARY VALUES (IF ANY).
C       FOR I = 2,3,...,M AND J = 2,3,...,N
C
C            F(I,J) = F(X(I),Y(J)).
C
C       ON THE BOUNDARIES F IS DEFINED BY
C
C            MBDCND     F(1,J)        F(M+1,J)
C            ------     ---------     --------
C
C              0        F(A,Y(J))     F(A,Y(J))
C              1        U(A,Y(J))     U(B,Y(J))
C              2        U(A,Y(J))     F(B,Y(J))     J = 1,2,...,N+1
C              3        F(A,Y(J))     F(B,Y(J))
C              4        F(A,Y(J))     U(B,Y(J))
C
C
C            NBDCND     F(I,1)        F(I,N+1)
C            ------     ---------     --------
C
C              0        F(X(I),C)     F(X(I),C)
C              1        U(X(I),C)     U(X(I),D)
C              2        U(X(I),C)     F(X(I),D)     I = 1,2,...,M+1
C              3        F(X(I),C)     F(X(I),D)
C              4        F(X(I),C)     U(X(I),D)
C
C       F MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C       NOTE
C
C       IF THE TABLE CALLS FOR BOTH THE SOLUTION U AND THE RIGHT SIDE F
C       AT  A CORNER THEN THE SOLUTION MUST BE SPECIFIED.
C
C     IDIMF
C       THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C       PROGRAM CALLING HWSCRT.  THIS PARAMETER IS USED TO SPECIFY THE
C       VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M+1  .
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.  W MAY REQUIRE UP TO 4*(N+1) +
C       (13 + INT(LOG2(N+1)))*(M+1) LOCATIONS.  THE ACTUAL NUMBER OF
C       LOCATIONS USED IS COMPUTED BY HWSCRT AND IS RETURNED IN LOCATION
C       W(1).
C
C
C             * * * * * *   ON OUTPUT     * * * * * *
C
C     F
C       CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C       APPROXIMATION FOR THE GRID POINT (X(I),Y(J)), I = 1,2,...,M+1,
C       J = 1,2,...,N+1  .
C
C     PERTRB
C       IF A COMBINATION OF PERIODIC OR DERIVATIVE BOUNDARY CONDITIONS
C       IS SPECIFIED FOR A POISSON EQUATION (LAMBDA = 0), A SOLUTION MAY
C       NOT EXIST.  PERTRB IS A CONSTANT, CALCULATED AND SUBTRACTED FROM
C       F, WHICH ENSURES THAT A SOLUTION EXISTS.  HWSCRT THEN COMPUTES
C       THIS SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO THE ORIGINAL
C       APPROXIMATION.  THIS SOLUTION PLUS ANY CONSTANT IS ALSO A
C       SOLUTION.  HENCE, THE SOLUTION IS NOT UNIQUE.  THE VALUE OF
C       PERTRB SHOULD BE SMALL COMPARED TO THE RIGHT SIDE F.  OTHERWISE,
C       A SOLUTION IS OBTAINED TO AN ESSENTIALLY DIFFERENT PROBLEM.
C       THIS COMPARISON SHOULD ALWAYS BE MADE TO INSURE THAT A
C       MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C       FOR NUMBERS 0 AND 6, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  A .GE. B.
C       = 2  MBDCND .LT. 0 OR MBDCND .GT. 4  .
C       = 3  C .GE. D.
C       = 4  N .LE. 3
C       = 5  NBDCND .LT. 0 OR NBDCND .GT. 4  .
C       = 6  LAMBDA .GT. 0  .
C       = 7  IDIMF .LT. M+1  .
C       = 8  M .LE. 3
C
C       SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY INCORRECT
C       CALL TO HWSCRT, THE USER SHOULD TEST IERROR AFTER THE CALL.
C
C     W
C       W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C
C     DIMENSION OF   BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1),
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         JUNE 1, 1976
C     REVISION
C
C     SUBPROGRAMS    HWSCRT,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,
C     REQUIRED       TRIX,TRI3,PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         NONE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        STANDARDIZED SEPTEMBER 1, 1973
C                    REVISED APRIL 1, 1976
C
C     ALGORITHM      THE ROUTINE DEFINES THE FINITE DIFFERENCE
C                    EQUATIONS, INCORPORATES BOUNDARY DATA, AND ADJUSTS
C                    THE RIGHT SIDE OF SINGULAR SYSTEMS AND THEN CALLS
C                    GENBUN TO SOLVE THE SYSTEM.
C
C     SPACE          13110(OCTAL) = 5704(DECIMAL) LOCATIONS ON THE NCAR
C     REQUIRED       CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE HWSCRT IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N), BUT ALSO DEPENDS ON THE INPUT
C                    PARAMETERS NBDCND AND MBDCND.  SOME TYPICAL VALUES
C                    ARE LISTED IN THE TABLE BELOW.
C                       THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                    OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR N AND
C                    M AS LARGE AS 64.  MORE DETAILED INFORMATION ABOUT
C                    ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                    SUBROUTINE GENBUN WHICH IS THE ROUTINE THAT
C                    SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32        0         0          31
C                        32        1         1          23
C                        32        3         3          36
C                        64        0         0         128
C                        64        1         1          96
C                        64        3         3         142
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REFERENCE      SWARZTRAUBER,P. AND R. SWEET, 'EFFICIENT FORTRAN
C                    SUBPROGRAMS FOR THE SOLUTION OF ELLIPTIC EQUATIONS'
C                    NCAR TN/IA-109, JULY, 1975, 138 PP.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      DIMENSION       F(IDIMF,1)
      DIMENSION       BDA(1)     ,BDB(1)     ,BDC(1)     ,BDD(1)     ,
     1                W(1)
C
C     CHECK FOR INVALID PARAMETERS.
C
      IERROR = 0
      IF (A .GE. B) IERROR = 1
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2
      IF (C .GE. D) IERROR = 3
      IF (N .LE. 3) IERROR = 4
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5
      IF (IDIMF .LT. M+1) IERROR = 7
      IF (M .LE. 3) IERROR = 8
      IF (IERROR .NE. 0) RETURN
      NPEROD = NBDCND
      MPEROD = 0
      IF (MBDCND .GT. 0) MPEROD = 1
      DELTAX = (B-A)/FLOAT(M)
      TWDELX = 2./DELTAX
      DELXSQ = 1./DELTAX**2
      DELTAY = (D-C)/FLOAT(N)
      TWDELY = 2./DELTAY
      DELYSQ = 1./DELTAY**2
      NP = NBDCND+1
      NP1 = N+1
      MP = MBDCND+1
      MP1 = M+1
      NSTART = 1
      NSTOP = N
      NSKIP = 1
      GO TO (104,101,102,103,104),NP
  101 NSTART = 2
      GO TO 104
  102 NSTART = 2
  103 NSTOP = NP1
      NSKIP = 2
  104 NUNK = NSTOP-NSTART+1
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      MSTART = 1
      MSTOP = M
      MSKIP = 1
      GO TO (117,105,106,109,110),MP
  105 MSTART = 2
      GO TO 107
  106 MSTART = 2
      MSTOP = MP1
      MSKIP = 2
  107 DO 108 J=NSTART,NSTOP
         F(2,J) = F(2,J)-F(1,J)*DELXSQ
  108 CONTINUE
      GO TO 112
  109 MSTOP = MP1
      MSKIP = 2
  110 DO 111 J=NSTART,NSTOP
         F(1,J) = F(1,J)+BDA(J)*TWDELX
  111 CONTINUE
  112 GO TO (113,115),MSKIP
  113 DO 114 J=NSTART,NSTOP
         F(M,J) = F(M,J)-F(MP1,J)*DELXSQ
  114 CONTINUE
      GO TO 117
  115 DO 116 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-BDB(J)*TWDELX
  116 CONTINUE
  117 MUNK = MSTOP-MSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (127,118,118,120,120),NP
  118 DO 119 I=MSTART,MSTOP
         F(I,2) = F(I,2)-F(I,1)*DELYSQ
  119 CONTINUE
      GO TO 122
  120 DO 121 I=MSTART,MSTOP
         F(I,1) = F(I,1)+BDC(I)*TWDELY
  121 CONTINUE
  122 GO TO (123,125),NSKIP
  123 DO 124 I=MSTART,MSTOP
         F(I,N) = F(I,N)-F(I,NP1)*DELYSQ
  124 CONTINUE
      GO TO 127
  125 DO 126 I=MSTART,MSTOP
         F(I,NP1) = F(I,NP1)-BDD(I)*TWDELY
  126 CONTINUE
C
C    MULTIPLY RIGHT SIDE BY DELTAY**2.
C
  127 DELYSQ = DELTAY*DELTAY
      DO 129 I=MSTART,MSTOP
         DO 128 J=NSTART,NSTOP
            F(I,J) = F(I,J)*DELYSQ
  128    CONTINUE
  129 CONTINUE
C
C     DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      S = DELYSQ*DELXSQ
      ST2 = 2.*S
      DO 130 I=1,MUNK
         W(I) = S
         J = ID2+I
         W(J) = -ST2+ELMBDA*DELYSQ
         J = ID3+I
         W(J) = S
  130 CONTINUE
      IF (MP .EQ. 1) GO TO 131
      W(1) = 0.
      W(ID4) = 0.
  131 CONTINUE
      GO TO (135,135,132,133,134),MP
  132 W(ID2) = ST2
      GO TO 135
  133 W(ID2) = ST2
  134 W(ID3+1) = ST2
  135 CONTINUE
      PERTRB = 0.
      IF (ELMBDA) 144,137,136
  136 IERROR = 6
      GO TO 144
  137 IF ((NBDCND.EQ.0 .OR. NBDCND.EQ.3) .AND.
     1    (MBDCND.EQ.0 .OR. MBDCND.EQ.3)) GO TO 138
      GO TO 144
C
C     FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION
C     WILL EXIST.
C
  138 A1 = 1.
      A2 = 1.
      IF (NBDCND .EQ. 3) A2 = 2.
      IF (MBDCND .EQ. 3) A1 = 2.
      S1 = 0.
      MSP1 = MSTART+1
      MSTM1 = MSTOP-1
      NSP1 = NSTART+1
      NSTM1 = NSTOP-1
      DO 140 J=NSP1,NSTM1
         S = 0.
         DO 139 I=MSP1,MSTM1
            S = S+F(I,J)
  139    CONTINUE
         S1 = S1+S*A1+F(MSTART,J)+F(MSTOP,J)
  140 CONTINUE
      S1 = A2*S1
      S = 0.
      DO 141 I=MSP1,MSTM1
         S = S+F(I,NSTART)+F(I,NSTOP)
  141 CONTINUE
      S1 = S1+S*A1+F(MSTART,NSTART)+F(MSTART,NSTOP)+F(MSTOP,NSTART)+
     1     F(MSTOP,NSTOP)
      S = (2.+FLOAT(NUNK-2)*A2)*(2.+FLOAT(MUNK-2)*A1)
      PERTRB = S1/S
      DO 143 J=NSTART,NSTOP
         DO 142 I=MSTART,MSTOP
            F(I,J) = F(I,J)-PERTRB
  142    CONTINUE
  143 CONTINUE
      PERTRB = PERTRB/DELYSQ
C
C     SOLVE THE EQUATION.
C
  144 CALL GENBUN (NPEROD,NUNK,MPEROD,MUNK,W(1),W(ID2+1),W(ID3+1),
     1             IDIMF,F(MSTART,NSTART),IERR1,W(ID4+1))
      W(1) = W(ID4+1)+3.*FLOAT(MUNK)
C
C     FILL IN IDENTICAL VALUES WHEN HAVE PERIODIC BOUNDARY CONDITIONS.
C
      IF (NBDCND .NE. 0) GO TO 146
      DO 145 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  145 CONTINUE
  146 IF (MBDCND .NE. 0) GO TO 148
      DO 147 J=NSTART,NSTOP
         F(MP1,J) = F(1,J)
  147 CONTINUE
      IF (NBDCND .EQ. 0) F(MP1,NP1) = F(1,NP1)
  148 CONTINUE
      RETURN
      END


!==============================================================================!
  real function U_Plus_Rough_Walls(turb, wall_dist)
!------------------------------------------------------------------------------!
!   Calculates U+ for rough walls.                                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: TINY
  use Turb_Mod,  only: Turb_Type, kappa
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type) :: turb
  real            :: wall_dist
!==============================================================================!

  U_Plus_Rough_Walls = log( (wall_dist + turb % z_o) / turb % z_o)  &
                            / (kappa + TINY) + TINY

  end function


!***********************************/
!	Name:基礎変数から保存変数へ変換するプログラム
!	Alias:UPrimitive2Conserve
!	Description:定義通りに計算するだけ
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.06
!	Other:
!***********************************/
subroutine UPrimitive2Conserve(UG,UCC)
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio
    implicit none
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter),intent(inout) :: UCC

    iVar => iVariable
    iDim = UG%GM%Dimension

    do iCell=1,UG%GI%AllCells
        UCC%ConservedQuantity(1,iCell,1,1) = UCC%PrimitiveVariable(1,iCell,1,1)

        UCC%ConservedQuantity(2:iDim+1,iCell,1,1) = &
            &   UCC%PrimitiveVariable(2:iDim+1,iCell,1,1)*UCC%PrimitiveVariable(1,iCell,1,1)

        UCC%ConservedQuantity(iDim+2,iCell,1,1) = &
            &   InverseGmin1 * (UCC%PrimitiveVariable(iDim+2,iCell,1,1) + 0.5d0 * UCC%PrimitiveVariable(1,iCell,1,1) &
            &   * dot_product(UCC%PrimitiveVariable(2:iDim+1,iCell,1,1),UCC%PrimitiveVariable(2:iDim+1,iCell,1,1)))
    end do

return
end subroutine UPrimitive2Conserve


      FUNCTION ZBRENT(ISMERR)
      INTEGER::IZMAX,ISMERR,II
      REAL::EPS,TOL,RMIN,RMAX,ZBRENT,A,B,FA,SEDFLUX,FB,FC
      REAL::C,D,E,TOL1,XM,S,P,Q,R
C USING BRENT'S METHOD, FIND THE ROOT OF A FUNC SEDFLUX KNOWN TO LIE
C   BETWEEN RMIN & RMAX WITHIN AN ACCURACY OF TOL (P. 253 IN NUMERICAL
C   RECIPE).
C
      EXTERNAL SEDFLUX
      PARAMETER (IZMAX=100,EPS=3.0E-8,TOL=1.0E-5,
     &    RMIN=1.0E-4,RMAX=100.0)
      ISMERR = 0
      A = RMIN
      B = RMAX
      FA = SEDFLUX(A)
      FB = SEDFLUX(B)
      ZBRENT = 0
      IF(FA*FB.GT.0.0)THEN
        ISMERR = 1
        RETURN
      ENDIF
      FC = FB
      DO II=1,IZMAX
        IF(FB*FC.GT.0.0)THEN
          C = A
          FC = FA
          D = B-A
          E = D
        ENDIF
        IF(ABS(FC).LT.ABS(FB))THEN
          A = B
          B = C
          C = A
          FA = FB
          FB = FC
          FC = FA
        ENDIF
        TOL1 = 2.0*EPS*ABS(B) + 0.5*TOL
        XM = 0.5 * (C-B)
        IF(ABS(XM).LE.TOL1 .OR. FB.EQ.0.0)THEN
          ZBRENT = B
          RETURN
        ENDIF
        IF(ABS(E).GE.TOL1 .AND. ABS(FA).GT.ABS(FB))THEN
          S = FB / FA
          IF(A.EQ.C)THEN
            P = 2.0 * XM * S
            Q = 1.0 - S
          ELSE
            Q = FA / FC
            R = FB / FC
            P = S * (2.0*XM*Q*(Q-R) - (B-A)*(R-1.0))
            Q = (Q-1.0) * (R-1.0) * (S-1.0)
          ENDIF
          IF(P.GT.0.0) Q = -Q
          P = ABS(P)
          IF(2.0*P .LT. MIN(3.0*XM*Q-ABS(TOL1*Q), ABS(E*Q)))THEN
            E = D
            D = P / Q
          ELSE
            D = XM
            E = D
          ENDIF
        ELSE
          D = XM
          E = D
        ENDIF
        A = B
        FA = FB
        IF(ABS(D).GT.TOL1)THEN
          B = B + D
        ELSE
          B = B + SIGN(TOL1,XM)
        ENDIF
        FB = SEDFLUX(B)
      ENDDO
      ISMERR = 2
      ZBRENT = B
      RETURN
      END


module model_interp_module

  use amrex_fort_module, only: rt => amrex_real
  use amrex_constants_module

  implicit none

  integer, parameter :: kx = 3, ky = 3, kz = 3, iknot = 0
  integer, parameter :: idx = 0, idy = 0, idz = 0

  interface interp1d_linear
    module procedure interp1d_linear_vec
    module procedure interp1d_linear_scalar
  end interface interp1d_linear

contains

  subroutine interp1d_linear_scalar( ix, ix_max, x_in, f_in, x_out, f_out )

    ! input variables
    integer, intent(in) :: ix, ix_max
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: f_in(:)
    real (rt), intent(in) :: x_out

    ! output variables
    real (rt), intent(out) :: f_out

    ! local variables
    real (rt) :: dx0, dx1, dx
    integer :: j

    if ( ix < ix_max ) then
      dx  = x_in(ix+1) - x_in(ix)
      dx1 = (x_out - x_in(ix))/dx
      dx0 = one - dx1
      f_out = dx0*f_in(ix) + dx1*f_in(ix+1)
    else if ( ix == 0 ) then
      f_out = f_in(1)
    else if ( ix == ix_max ) then
      f_out = f_in(ix_max)
    else
      f_out = zero
    end if

    return
  end subroutine interp1d_linear_scalar

  subroutine interp1d_linear_vec( ix, ix_max, x_in, f_in, x_out, f_out )

    ! input variables
    integer, intent(in) :: ix(:), ix_max
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: f_in(:)
    real (rt), intent(in) :: x_out(:)

    ! output variables
    real (rt), intent(out) :: f_out(size(x_out))

    ! local variables
    real (rt) :: dx0, dx1, dx
    integer :: j

    do j = 1, size(x_out)
      if ( ix(j) > 0 .and. ix(j) < ix_max ) then
        dx  = x_in(ix(j)+1) - x_in(ix(j))
        dx1 = (x_out(j) - x_in(ix(j)))/dx
        dx0 = one - dx1
        f_out(j) = dx0*f_in(ix(j)) + dx1*f_in(ix(j)+1)
      else if ( ix(j) == 0 ) then
        f_out(j) = f_in(1)
      else if ( ix(j) == ix_max ) then
        f_out(j) = f_in(ix_max)
      else
        f_out(j) = zero
      end if
    end do

    return
  end subroutine interp1d_linear_vec

  subroutine interp1d_spline( x_in, f_in, x_out, f_out )

    ! input variables
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: f_in(:)
    real (rt), intent(in) :: x_out(:)

    ! output variables
    real (rt), intent(out) :: f_out(size(x_out))

    ! local variables
    real (rt) :: fpp(size(x_in)), fval, fpval, fppval
    integer :: j, nx

    nx = size(x_in)
    fpp = zero

    call spline_cubic_set( nx, x_in, f_in, 3, zero, 3, zero, fpp )
    DO j = 1, size(x_out)
      call spline_cubic_val( nx, x_in, f_in, fpp, x_out(j), fval, fpval, fppval )
      f_out(j) = fval
    END DO

    return
  end subroutine interp1d_spline

  subroutine interp2d_linear( ix, ix_max, iy, iy_max, x_in, y_in, f_in, x_out, y_out, f_out )

    ! input variables
    integer, intent(in) :: ix(:,:), ix_max
    integer, intent(in) :: iy(:,:), iy_max
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: y_in(:)
    real (rt), intent(in) :: f_in(:,:)
    real (rt), intent(in) :: x_out(:,:)
    real (rt), intent(in) :: y_out(:,:)

    ! output variables
    real (rt), intent(out) :: f_out(size(x_out,1),size(x_out,2))

    ! local variables
    real (rt) :: dx0, dx1, dx
    real (rt) :: dy0, dy1, dy
    real (rt) :: fxy0, fxy1
    integer :: i, j

    do j = 1, size(x_out,2)
      do i = 1, size(x_out,1)

        if ( ix(i,j) > 0 .and. ix(i,j) < ix_max ) then

          dx  = x_in(ix(i,j)+1) - x_in(ix(i,j))
          dx1 = (x_out(i,j) - x_in(ix(i,j)))/dx
          dx0 = one - dx1

          if ( iy(i,j) > 0 .and. iy(i,j) < iy_max ) then

            dy  = y_in(iy(i,j)+1) - y_in(iy(i,j))
            dy1 = (y_out(i,j) - y_in(iy(i,j)))/dy
            dy0 = one - dy1

            fxy0 = dx0*f_in(ix(i,j),iy(i,j)) + dx1*f_in(ix(i,j)+1,iy(i,j))
            fxy1 = dx0*f_in(ix(i,j),iy(i,j)+1) + dx1*f_in(ix(i,j)+1,iy(i,j)+1)

            f_out(i,j) = dy0*fxy0 + dy1*fxy1

          else if ( iy(i,j) == 0 ) then
            f_out(i,j) = dx0*f_in(ix(i,j),1) + dx1*f_in(ix(i,j)+1,1)
          else if ( iy(i,j) == iy_max ) then
            f_out(i,j) = dx0*f_in(ix(i,j),iy_max) + dx1*f_in(ix(i,j)+1,iy_max)
          else
            f_out(i,j) = zero
          end if

        else if ( ix(i,j) == 0 ) then

          if ( iy(i,j) > 0 .and. iy(i,j) < iy_max ) then

            dy  = y_in(iy(i,j)+1) - y_in(iy(i,j))
            dy1 = (y_out(i,j) - y_in(iy(i,j)))/dy
            dy0 = one - dy1

            f_out(i,j) = dy0*f_in(1,iy(i,j)) + dy1*f_in(1,iy(i,j)+1)

          else if ( iy(i,j) == 0 ) then
            f_out(i,j) = f_in(1,1)
          else if ( iy(i,j) == iy_max ) then
            f_out(i,j) = f_in(1,iy_max)
          else
            f_out(i,j) = zero
          end if

        else if ( ix(i,j) == ix_max ) then

          if ( iy(i,j) > 0 .and. iy(i,j) < iy_max ) then

            dy  = y_in(iy(i,j)+1) - y_in(iy(i,j))
            dy1 = (y_out(i,j) - y_in(iy(i,j)))/dy
            dy0 = one - dy1

            f_out(i,j) = dy0*f_in(ix_max,iy(i,j)) + dy1*f_in(ix_max,iy(i,j)+1)

          else if ( iy(i,j) == 0 ) then
            f_out(i,j) = f_in(ix_max,1)
          else if ( iy(i,j) == iy_max ) then
            f_out(i,j) = f_in(ix_max,iy_max)
          else
            f_out(i,j) = zero
          end if

        else
          f_out(i,j) = zero
        end if
      end do
    end do

    return
  end subroutine interp2d_linear

  subroutine interp2d_spline( x_in, y_in, f_in, x_out, y_out, f_out )

    use amrex_error_module
    use bspline_module, only: db2ink, db2val

    ! input variables
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: y_in(:)
    real (rt), intent(in) :: f_in(:,:)
    real (rt), intent(in) :: x_out(:,:)
    real (rt), intent(in) :: y_out(:,:)

    ! output variables
    real (rt), intent(out) :: f_out(size(x_out,1),size(x_out,2))

    ! local variables
    real (rt) :: tx(size(x_in)+kx)
    real (rt) :: ty(size(y_in)+ky)
    real (rt) :: bcoef(size(x_in),size(y_in))

    integer :: inbvx, inbvy, iloy
    integer :: nx, ny
    real (rt) :: x, y, fval
    integer :: i, j, iflag

    nx = size( x_in )
    ny = size( y_in )

    inbvx = 1
    inbvy = 1
    iloy = 1

    call db2ink( x_in, nx, y_in, ny, f_in, kx, ky, iknot, tx, ty, bcoef, iflag )
    if ( iflag /= 0 ) then
      write(*,*) "error in db2ink: ", iflag
      call bl_error("error in db2ink")
    end if

    do j = 1, size(x_out,2)
      do i = 1, size(x_out,1)
        x = min( max( x_out(i,j), x_in(1) ), x_in(nx) )
        y = min( max( y_out(i,j), y_in(1) ), y_in(ny) )
        call db2val( x, y, idx, idy, tx, ty, nx, ny, kx, ky, bcoef, fval, iflag, inbvx, inbvy, iloy )
        if ( iflag /= 0 ) then
          write(*,*) "error in db2val: ", x, y, iflag
          call bl_error("error in db2val")
        end if
        f_out(i,j) = fval
      end do
    end do

    return
  end subroutine interp2d_spline

  subroutine interp3d_linear( ix, ix_max, iy, iy_max, iz, iz_max, &
  &                           x_in, y_in, z_in, f_in, x_out, y_out, z_out, f_out )

    ! input variables
    integer, intent(in) :: ix(:,:,:), ix_max
    integer, intent(in) :: iy(:,:,:), iy_max
    integer, intent(in) :: iz(:,:,:), iz_max
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: y_in(:)
    real (rt), intent(in) :: z_in(:)
    real (rt), intent(in) :: f_in(:,:,:)
    real (rt), intent(in) :: x_out(:,:,:)
    real (rt), intent(in) :: y_out(:,:,:)
    real (rt), intent(in) :: z_out(:,:,:)

    ! output variables
    real (rt), intent(out) :: f_out(size(x_out,1),size(x_out,2),size(x_out,3))

    ! local variables
    integer :: ix0, iy0, iz0
    integer :: ix1, iy1, iz1
    real (rt) :: dx, dy, dz
    real (rt) :: c(8), d(8)
    integer :: i, j, k

    do k = 1, size(x_out,3)
      do j = 1, size(x_out,2)
        do i = 1, size(x_out,1)
          ix0 = max( ix(i,j,k)  , 1 )
          ix1 = min( ix(i,j,k)+1, ix_max )
          if ( ix1 > ix0 ) then
            dx = ( x_out(i,j,k) - x_in(ix0) ) / ( x_in(ix1) - x_in(ix0) )
          else
            dx = zero
          end if

          iy0 = max( iy(i,j,k)  , 1 )
          iy1 = min( iy(i,j,k)+1, iy_max )
          if ( iy1 > iy0 ) then
            dy = ( y_out(i,j,k) - y_in(iy0) ) / ( y_in(iy1) - y_in(iy0) )
          else
            dy = zero
          end if

          iz0 = max( iz(i,j,k)  , 1 )
          iz1 = min( iz(i,j,k)+1, iz_max )
          if ( iz1 > iz0 ) then
            dz = ( z_out(i,j,k) - z_in(iz0) ) / ( z_in(iz1) - z_in(iz0) )
          else
            dz = zero
          end if

          d(1) = one
          d(2) = dx
          d(3) = dy
          d(4) = dz
          d(5) = dx*dy
          d(6) = dx*dz
          d(7) = dy*dz
          d(8) = dx*dy*dz

          c(1) = f_in(ix0,iy0,iz0)
          c(2) = f_in(ix1,iy0,iz0) - f_in(ix0,iy0,iz0)
          c(3) = f_in(ix0,iy1,iz0) - f_in(ix0,iy0,iz0)
          c(4) = f_in(ix0,iy0,iz1) - f_in(ix0,iy0,iz0)
          c(5) = f_in(ix1,iy1,iz0) - f_in(ix0,iy1,iz0) + &
                 f_in(ix0,iy0,iz0) - f_in(ix1,iy0,iz0)
          c(6) = f_in(ix1,iy0,iz1) - f_in(ix0,iy0,iz1) + &
                 f_in(ix0,iy0,iz0) - f_in(ix1,iy0,iz0)
          c(7) = f_in(ix0,iy1,iz1) - f_in(ix0,iy0,iz1) + &
                 f_in(ix0,iy0,iz0) - f_in(ix0,iy1,iz0)
          c(8) = f_in(ix1,iy1,iz1) - f_in(ix0,iy1,iz1) + &
                 f_in(ix0,iy0,iz1) - f_in(ix1,iy0,iz1) + &
                 f_in(ix0,iy1,iz0) - f_in(ix1,iy1,iz0) + &
                 f_in(ix1,iy0,iz0) - f_in(ix0,iy0,iz0)

          f_out(i,j,k) = sum( d*c )

        end do
      end do
    end do

    return
  end subroutine interp3d_linear

  subroutine interp3d_spline( x_in, y_in, z_in, f_in, x_out, y_out, z_out, f_out )

    use amrex_error_module
    use bspline_module, only: db3ink, db3val

    ! input variables
    real (rt), intent(in) :: x_in(:)
    real (rt), intent(in) :: y_in(:)
    real (rt), intent(in) :: z_in(:)
    real (rt), intent(in) :: f_in(:,:,:)
    real (rt), intent(in) :: x_out(:,:,:)
    real (rt), intent(in) :: y_out(:,:,:)
    real (rt), intent(in) :: z_out(:,:,:)

    ! output variables
    real (rt), intent(out) :: f_out(size(x_out,1),size(x_out,2),size(x_out,3))

    ! local variables
    real (rt) :: tx(size(x_in)+kx)
    real (rt) :: ty(size(y_in)+ky)
    real (rt) :: tz(size(z_in)+kz)
    real (rt) :: bcoef(size(x_in),size(y_in),size(z_in))

    integer :: inbvx, inbvy, inbvz, iloy, iloz
    integer :: nx, ny, nz
    real (rt) :: x, y, z, fval
    integer :: i, j, k, iflag

    nx = size( x_in )
    ny = size( y_in )
    nz = size( z_in )

    inbvx = 1
    inbvy = 1
    inbvz = 1
    iloy = 1
    iloz = 1

    call db3ink( x_in, nx, y_in, ny, z_in, nz, f_in, kx, ky, kz, iknot, tx, ty, tz, bcoef, iflag )
    if ( iflag /= 0 ) then
      write(*,*) "error in db3ink: ", iflag
      call bl_error("error in db3ink")
    end if

    do k = 1, size(x_out,3)
      do j = 1, size(x_out,2)
        do i = 1, size(x_out,1)
          x = min( max( x_out(i,j,k), x_in(1) ), x_in(nx) )
          y = min( max( y_out(i,j,k), y_in(1) ), y_in(ny) )
          z = min( max( z_out(i,j,k), z_in(1) ), z_in(nz) )
          call db3val( x, y, z, idx, idy, idz, tx, ty, tz, nx, ny, nz, kx, ky, kz, bcoef, &
          &            fval, iflag, inbvx, inbvy, inbvz, iloy, iloz )
          if ( iflag /= 0 ) then
            write(*,*) "error in db3val: ", x, y, z, iflag
            call bl_error("error in db3val")
          end if
          f_out(i,j,k) = fval
        end do
      end do
    end do

    return
  end subroutine interp3d_spline

end module model_interp_module


program test_parpack
use arpack, only: eig
use types, only: dp
use utils, only: stop_error, assert
use mpi2, only: mpi_finalize, MPI_COMM_WORLD, mpi_comm_rank, &
    mpi_comm_size, mpi_init, mpi_recv, mpi_send, MPI_DOUBLE_PRECISION, &
    MPI_STATUS_SIZE, MPI_SUM, mpi_allreduce
use arpack, only: peig
implicit none

integer :: n, nloc, nev, ncv, i
real(dp), allocatable :: d(:), v(:,:), tmp(:)
real(dp), parameter :: e_ref(4) =  [5.4780178344413200_dp, &
    5.7004342714592289_dp, 5.8649444588087105_dp, 5.9659461993678038_dp]
real(dp) :: r

integer :: comm, myid, nproc, ierr

call mpi_init(ierr)
comm  = MPI_COMM_WORLD
call mpi_comm_rank(comm, myid, ierr)
call mpi_comm_size(comm, nproc, ierr)

n = 16 ! global vector dimension
nev = 4
ncv = 8
nloc = n / nproc ! local vector dimension
call assert(nloc*nproc == n)
allocate(v(nloc,ncv), d(ncv))
allocate(tmp(nloc))
call peig(comm, myid, nloc, nev, ncv, "LM", av, d, v)
if (myid == 0) print *, "  lambda                    error                     ||A*x-lambda*x||"
do i = 1, nev
    ! Compute || A*x - lambda*x ||
    call av(v(:,i), tmp) ! A*x
    tmp = tmp - d(i)*v(:,i) ! - lambda*x
    r = sqrt(psum(comm, tmp**2)) ! l2 norm
    if (myid == 0) print *, d(i), abs(d(i) - e_ref(i)), r
    if (abs(d(i) - e_ref(i)) > 1e-13_dp) call stop_error("Error in ref. check")
end do

if (myid == 0) print *, "Done"

call mpi_finalize(ierr)

contains

  subroutine av(x, y)
  ! Compute y = A*x
  real(dp), intent(in) :: x(:)
  real(dp), intent(out) :: y(:)
  real(dp) :: dd, dl, du, buf
  integer :: j, status(MPI_STATUS_SIZE)

  call assert(size(x) >= 2)
  dd = 4
  dl = -1
  du = -1
  y(1) = dd*x(1) + du*x(2)
  do j = 2, size(y)-1
     y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1)
  end do
  y(size(y)) = dl*x(size(y)-1) + dd*x(size(y))
  if (myid < nproc-1) then
     call mpi_send(x(size(x)), 1, MPI_DOUBLE_PRECISION, myid+1, myid+1, comm, &
         ierr)
  endif
  if (myid > 0 ) then
     call mpi_recv(buf, 1, MPI_DOUBLE_PRECISION, myid-1, myid, comm, &
         status, ierr)
     y(1) = y(1) + dl*buf
  endif
  if (myid > 0 ) then
     call mpi_send(x(1), 1, MPI_DOUBLE_PRECISION, myid-1, myid-1, comm, &
         ierr)
  endif
  if (myid < nproc-1) then
     call mpi_recv(buf, 1, MPI_DOUBLE_PRECISION, myid+1, myid, comm, &
         status, ierr)
     y(size(y)) = y(size(y)) + du*buf
  endif
  end

    real(dp) function psum(comm, f) result(r)
    ! Calculates the sum over 'f' in parallel, returns the answer on all
    ! processors.
    integer, intent(in) :: comm
    real(dp), intent(in) :: f(:)
    real(dp) :: myr
    integer :: ierr
    myr = sum(f)
    call mpi_allreduce(myr, r, 1, MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr)
    end function

end


*DECK CGBDI
      SUBROUTINE CGBDI (ABD, LDA, N, ML, MU, IPVT, DET)
C***BEGIN PROLOGUE  CGBDI
C***PURPOSE  Compute the determinant of a complex band matrix using the
C            factors from CGBCO or CGBFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D3C2
C***TYPE      COMPLEX (SGBDI-S, DGBDI-D, CGBDI-C)
C***KEYWORDS  BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK,
C             MATRIX
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CGBDI computes the determinant of a band matrix
C     using the factors computed by CGBCO or CGBFA.
C     If the inverse is needed, use CGBSL  N  times.
C
C     On Entry
C
C        ABD     COMPLEX(LDA, N)
C                the output from CGBCO or CGBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C
C        IPVT    INTEGER(N)
C                the pivot vector from CGBCO or CGBFA.
C
C     On Return
C
C        DET     COMPLEX(2)
C                determinant of original matrix.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. CABS1(DET(1)) .LT. 10.0
C                or  DET(1) = 0.0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CGBDI
      INTEGER LDA,N,ML,MU,IPVT(*)
      COMPLEX ABD(LDA,*),DET(2)
C
      REAL TEN
      INTEGER I,M
      COMPLEX ZDUM
      REAL CABS1
C
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C***FIRST EXECUTABLE STATEMENT  CGBDI
      M = ML + MU + 1
      DET(1) = (1.0E0,0.0E0)
      DET(2) = (0.0E0,0.0E0)
      TEN = 10.0E0
      DO 50 I = 1, N
         IF (IPVT(I) .NE. I) DET(1) = -DET(1)
         DET(1) = ABD(M,I)*DET(1)
         IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60
   10    IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20
            DET(1) = CMPLX(TEN,0.0E0)*DET(1)
            DET(2) = DET(2) - (1.0E0,0.0E0)
         GO TO 10
   20    CONTINUE
   30    IF (CABS1(DET(1)) .LT. TEN) GO TO 40
            DET(1) = DET(1)/CMPLX(TEN,0.0E0)
            DET(2) = DET(2) + (1.0E0,0.0E0)
         GO TO 30
   40    CONTINUE
   50 CONTINUE
   60 CONTINUE
      RETURN
      END


function r8i8_uniform_01 ( seed )

!*****************************************************************************80
!
!! R8I8_UNIFORM_01 returns a unit pseudorandom R8 using an I8 seed.
!
!  Discussion:
!
!    An R8 is a real ( kind = 8 ) value.
!
!    An I8 is an integer ( kind = 8 ) value.
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r8_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R8I8_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    20 September 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley Interscience, page 95, 1998.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input/output, integer ( kind = 8 ) SEED, the "seed" value, which should
!    NOT be 0. On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R8I8_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 8 ) k
  real ( kind = 8 ) r8i8_uniform_01
  integer ( kind = 8 ) seed

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8I8_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + huge ( seed )
  end if

  r8i8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

  return
end


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2019 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program generate_minij_matrix
  use rokko
  implicit none
  integer :: dim
  type(rokko_eigen_matrix) :: mat

  integer :: i, j

  dim = 10
  print *,"dimension = ", dim

  call rokko_construct(mat, dim, dim, rokko_matrix_col_major)

  ! generate minij matrix
  do i = 1, dim
     do j = 1, dim
        call rokko_set_elem(mat, i, j, dble(min(i,j)))
     enddo
  enddo
  call rokko_print(mat)

  call rokko_destruct(mat)

end program generate_minij_matrix


      integer function popcnt(inum)
C
C #####################################################################
C
C     PURPOSE -
C
C        THIS ROUTINE PERFORMS A POP COUNT ON AN INTEGER NUMBER. THE
C           SUM OF BITS IN ARE SUMMED TO RETURN THE TOTAL NUMBER OF
C           BITS TURNED ON.
C
C     INPUT ARGUMENTS -
C
C        inum - THE NUMBER TO BE SCANNED.
C
C     OUTPUT ARGUMENTS -
C
C        popcnt - THE (INTEGER) COUNT OF BITS TURNED ON.
C
C     CHANGE HISTORY -
C
C        $Log: popcnt.f,v $
C        Revision 2.00  2007/11/09 20:03:58  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.1   30 Sep 2004 09:46:20   dcg
CPVCS    use iand in place of .and. for integers
CPVCS
CPVCS       Rev 1.0   Thu Dec 18 16:17:54 1997   dcg
CPVCS    Initial revision.
C
C ######################################################################
C
      integer inum, inum1
      popcnt=0
      do ipos1=1,32
         inum1=iand(inum,(2**(ipos1-1)))
         nwd1=ishft(inum1,-(ipos1-1))
         popcnt=popcnt+nwd1
      enddo
      return
      end


PROGRAM LA_DGEES_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_GEES
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
   INTERFACE
     LOGICAL FUNCTION SELECT(WR, WI)
        USE LA_PRECISION, ONLY: WP => DP
        REAL(WP), INTENT(IN) :: WR, WI
     END FUNCTION SELECT
   END INTERFACE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, INFO, N, SDIM
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:)
   REAL(WP), ALLOCATABLE :: A(:,:), VS(:,:), DUMMY(:,:)
   REAL(WP), ALLOCATABLE :: WR(:), WI(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'GEES ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N
   PRINT *, 'N = ', N
   ALLOCATE ( A(N,N), AA(N,N), WR(N), WI(N), VS(N,N) )
!
      READ (NIN, *) AA
   A=AA
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N; WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:); ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_DGEES LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI, VS, SELECT, SDIM, INFO )'
   A=AA
   CALL LA_GEES( A, WR, WI, VS, SELECT, SDIM, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' SDIM = ', SDIM, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
   WRITE(NOUT,*) 'Schur vectors:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VS(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI, VS )'
   A=AA; VS = HUGE(1.0_WP)
   CALL LA_GEES( A, WR, WI, VS )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
   WRITE(NOUT,*) 'Schur vectors:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) VS(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI, SELECT=SELECT, SDIM=SDIM, INFO=INFO )'
   A=AA
   CALL LA_GEES( A, WR, WI, SELECT=SELECT, SDIM = SDIM, INFO = INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' SDIM = ', SDIM, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI )'
   A=AA
   CALL LA_GEES( A, WR, WI )
   WRITE(NOUT,*) 'INFO = ', INFO, ' Eigenvalues:'
   WRITE(NOUT,FMT) WR
   WRITE(NOUT,FMT) WI
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( DUMMY, WR, WI, VS, SELECT, SDIM, INFO )'
   A=AA
   CALL LA_GEES( DUMMY, WR, WI, VS, SELECT, SDIM, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR(1:N-1), WI, VS, SELECT, SDIM, INFO )'
   A=AA
   CALL LA_GEES( A, WR(1:N-1), WI, VS, SELECT, SDIM, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI(1:N-1), VS, SELECT, SDIM, INFO )'
   A=AA
   CALL LA_GEES( A, WR, WI(1:N-1), VS, SELECT, SDIM, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI, VS(1:N-1,:), SELECT, SDIM, INFO )'
   A=AA
   CALL LA_GEES( A, WR, WI, VS(1:N-1,:), SELECT, SDIM, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI, VS(:,1:N-1), SELECT, SDIM, INFO )'
   A=AA
   CALL LA_GEES( A, WR, WI, VS(:,1:N-1), SELECT, SDIM, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GEES( A, WR, WI, VS, SDIM=SDIM )'
   A=AA
   CALL LA_GEES( A, WR, WI, VS, SDIM=SDIM )
   WRITE(NOUT,*) 'INFO = ', INFO
!
END PROGRAM LA_DGEES_ET_EXAMPLE
!  CONTAINS
   LOGICAL FUNCTION SELECT(WR, WI)
      USE LA_PRECISION, ONLY: WP => DP
      REAL(WP), INTENT(IN) :: WR, WI
      IF( WR > 0.0_WP ) THEN; SELECT = .TRUE.
      ELSE; SELECT = .FALSE.; END IF
   END FUNCTION SELECT


program Interface_test
    use Sherman_Morrison
    implicit none

    integer i, j !! Iterators
    integer(c_int) :: Dim, N_updates
    integer(c_int), dimension(:), allocatable :: Updates_index
    real(c_double), dimension(:,:), allocatable :: A, S, Updates
    real(c_double), dimension(:,:), allocatable :: S_inv

    Dim = 3
    N_updates = 3
    allocate(Updates_index(Dim), A(Dim,Dim), S(Dim,Dim), Updates(Dim,Dim), S_inv(Dim,Dim))

    !! Initialize A with M=3 and fill acc. to Eq. (17) from paper
    A(1,1) = 1.0d0
    A(1,2) = 1.0d0
    A(1,3) = -1.0d0
    A(2,1) = 1.0d0
    A(2,2) = 1.0d0
    A(2,3) = 0.0d0
    A(3,1) = -1.0d0
    A(3,2) = 0.0d0
    A(3,3) = -1.0d0

    do i=1,Dim
        do j=1,Dim
            write(*,"(F3.0,3X)", advance="no") A(i,j)
        end do
        write(*,*)
    end do
    write(*,*)

    !! Prepare the diagonal matrix S and the update matrix Updates
    do i=1,Dim
        Updates_index(i) = i
        do j=1,Dim
            if (i == j) then
                S(i,j) = A(i,j)
                S_inv(i,j) = 1.0d0 / S(i,j)
            else
                S(i,j) = 0.0d0
                S_inv(i,j) = 0.0d0
            end if
            Updates(i,j) = A(i,j) - S(i,j)
        end do
    end do

    call MaponiA3(S_inv, Dim, N_updates, Updates, Updates_index)

    do i=1,Dim
        do j=1,Dim
            write(*,"(F3.0,3X)", advance="no") S_inv(i,j)
        end do
        write(*,*)
    end do

    deallocate(Updates_index, A, S, Updates, S_inv)
end program