module loglikelihood_module
    use utils_module, only: dp
    use utils_module, only: logzero

    real(dp), parameter :: sigma  = 0.1d0   ! all sigma set relatively small
    real(dp), parameter :: radius = 2d0

    real(dp) :: A = logzero

    contains

    function loglikelihood(theta,phi)
        use utils_module, only: logTwoPi,Vn,loggamma,logincexp,Hypergeometric1F1
        implicit none
        !> Input parameters
        real(dp), intent(in), dimension(:)   :: theta
        !> Output derived parameters
        real(dp), intent(out),  dimension(:) :: phi

        real(dp) :: loglikelihood
        real(dp) :: loglikelihood_temp

        real(dp), dimension(size(theta)) :: mu    ! Mean

        real(dp),parameter :: logsqrttwopi = log(sqrt(8d0*atan(1d0)))
        real(dp),parameter :: logpi = log(4d0*atan(1d0))

        integer :: ndims
        integer :: i

        real(dp) :: r0,sigma0,logf0

        ndims  = size(theta)

        if(A==logzero) then
            r0 = (radius + sqrt(radius**2 + 4*(ndims-1)*sigma**2))/2
            logf0 = - (radius - r0)**2/2/sigma**2 + (ndims-1)*log(r0) + log(ndims+0d0) + ndims/2d0*logpi -loggamma(1+ndims/2d0)
            sigma0 = sigma*sqrt((1+radius/sqrt(radius**2 + 4*(ndims-1)*sigma**2))/2d0)
            A = logf0 + logsqrttwopi + log(sigma0)
        end if

        mu=0
        ! Initialise the mean and standard deviation
        mu(1)  = -3.5   ! mean in the center

        ! Gaussian normalisation
        loglikelihood_temp = -A - ( (sqrt( sum( (mu-theta)**2 ) ) -radius)**2d0 /(2d0*sigma*sigma) )

        loglikelihood = loglikelihood_temp

        mu(1)  = +3.5   ! mean in the center

        loglikelihood_temp = -A - ( (sqrt( sum( (mu-theta)**2 ) ) -radius)**2d0 /(2d0*sigma*sigma) )

        call logincexp(loglikelihood,loglikelihood_temp)
        loglikelihood = loglikelihood - log(2d0)

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        implicit none
        type(program_settings), intent(in) :: settings

    end subroutine setup_loglikelihood

end module loglikelihood_module


SUBROUTINE comred(bk,n)
! gaussian reduction on a vector stored as an upper triangle : complex
IMPLICIT NONE
INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
COMPLEX(iwp),INTENT(in out)::bk(:);INTEGER,INTENT(IN)::n
INTEGER::i,il1,kbl,j,ij,nkb,m,ni,nj,iw ; COMPLEX(iwp)::sum
 iw = UBOUND(bk,1)/n-1
       DO i=2,n
          il1=i-1;kbl=il1+iw+1
          IF(kbl-n>0)kbl=n
          DO j=i,kbl
             ij=(j-i)*n+i;sum=bk(ij);nkb=j-iw
             IF(nkb<=0)nkb=1
             IF(nkb-il1<=0)THEN
                DO m=nkb,il1
                   ni=(i-m)*n+m ; nj=(j-m)*n+m
                   sum=sum-bk(ni)*bk(nj)/bk(m)
                END DO
             END IF
             bk(ij)=sum
           END DO
       END DO
RETURN
END SUBROUTINE COMRED


**********************************************************************
**********************************************************************
      double precision function massf(dum1)
*
* sets masses according to certain massfunction: power, minmass, maxmass
*           uses random numbers;
*
*
*  INPUT:
*      dum1        = random number in interval {0,1}
*
*  OUTPUT:
*      massf(function value)   = weighted mass according to power law
*
*
*
* called in:
*           setstar
*
* use of subroutines:
*           none
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      double precision dum1,dum2,minmass,maxmass,power,powerp1
     &	,powerp2,powerp3,aaa1,aaa2
*
      common/m/minmass,maxmass,power,powerp1,powerp2,powerp3,aaa1,aaa2
*
* maps random number in interval {0,1}  to interval {0.740,16.583}:
*
      dum2 = -powerp1 * (aaa1*dum1 + aaa2)
      massf = dum2**(1.0/powerp1)
*
* {0.740,16.583}  --->  { minmass, maxmass }
*
      if(massf.lt.minmass-1.0e-10)then
	 write(44,*)' MASSF:  too low ! massf, minmass:',massf,minmass
	 write(44,*)'  ----------> STOP 345 in  MASSF'
	 stop 345
      elseif(massf.gt.maxmass+1.0e-10)then
	 write(44,*)' MASSF:  mass too high !! ----> STOP 346 in  MASSF'
	 stop 346
      else
	 return
      endif
*
      end
************************************************************************
************************************************************************
      double precision function massav()
*
* calculates average mass for given massfunction, minmass, maxmass;
*
*
*  input:
*      (just numbers from common block /m/ )
*
*  output:
*      massav(function value)   = average mass according to power law
*					and upper and lower cut-off
*
* called in:
*           input
*
* use of subroutines:
*           none
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      double precision dumfm,dumf,minmass,maxmass,power,powerp1,powerp2
     &	,powerp3,aaa1,aaa2
*
      common/m/minmass,maxmass,power,powerp1,powerp2,powerp3,aaa1,aaa2
*
      if(maxmass-minmass.lt.1.0e-10)then
	 massav   = minmass
      else
	 dumfm    =  ( maxmass**powerp2 - minmass**powerp2 ) / powerp2
	 dumf     =  ( maxmass**powerp1 - minmass**powerp1 ) / powerp1
	 massav   = dumfm/dumf
      endif
*
      if(massav.lt.minmass)then
	 write(44,*)' average mass too low -------> STOP 365 in  MASSF'
	 stop 365
      elseif(massav.gt.maxmass)then
	 write(44,*)' average mass too high -------> STOP 366 in  MASSF'
	 stop 366
      else
	 return
      endif
*
      end


Real Function xppbar(srt)
  Parameter (pmass=0.9383, xmax=400.)
  Save
  xppbar = 1.E-06
  plab2 = (srt**2/(2.*pmass)-pmass)**2 - pmass**2
  If (plab2>0) Then
    plab = sqrt(plab2)
    xppbar = 67./(plab**0.7)
    If (xppbar>xmax) xppbar = xmax
  End If
  Return
End Function xppbar


SUBROUTINE derivax(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida
!real(8), dimension(dimx,dimy,dimz) :: a1

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i+1,j,k)-a1(i-1,j,k))/(2.*dx)
  enddo
 enddo
enddo

END SUBROUTINE derivax

!##############################################################

SUBROUTINE derivay(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i,j+1,k)-a1(i,j-1,k))/(2.*dy)
  enddo
 enddo
enddo

END SUBROUTINE derivay

!##############################################################

SUBROUTINE derivaz(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i,j,k+1)-a1(i,j,k-1))/(2.*dz)
  enddo
 enddo
enddo

END SUBROUTINE derivaz

!##############################################################

SUBROUTINE derivaxu2p(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida
!real(8), dimension(dimx,dimy,dimz) :: a1

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=1,dimx-1
    campo_saida(i,j,k)=0.5*(-a1(i+2,j,k)+4*a1(i+1,j,k)-3*a1(i,j,k))/dx
  enddo
 enddo
enddo

i = dimx
do k=1,dimz
 do j=1,dimy
    campo_saida(i,j,k)=0.5*(a1(i+1,j,k)-a1(i-1,j,k))/dx
  enddo
 enddo

END SUBROUTINE derivaxu2p

!##############################################################

SUBROUTINE derivayu2p(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy-1
  do i=1,dimx
    campo_saida(i,j,k)=0.5*(-a1(i,j+2,k)+4*a1(i,j+1,k)-3*a1(i,j,k))/dy
  enddo
 enddo
enddo

j = dimy
do k=1,dimz
 do i=1,dimx
    campo_saida(i,j,k)=0.5*(a1(i,j+1,k)-a1(i,j-1,k))/dy
  enddo
 enddo

END SUBROUTINE derivayu2p

!##############################################################

SUBROUTINE derivazu2p(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz-1
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=0.5*(-a1(i,j,k+2)+4*a1(i,j,k+1)-3*a1(i,j,k))/dz
  enddo
 enddo
enddo

k = dimz
do j=1,dimy
 do i=1,dimx
    campo_saida(i,j,k)=0.5*(a1(i,j,k+1)-a1(i,j,k-1))/dz
  enddo
 enddo

END SUBROUTINE derivazu2p

!##############################################################

SUBROUTINE derivaxu2n(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida
!real(8), dimension(dimx,dimy,dimz) :: a1

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=2,dimx
    campo_saida(i,j,k)=0.5*(a1(i-2,j,k)-4*a1(i-1,j,k)+3*a1(i,j,k))/dx
  enddo
 enddo
enddo

i = 1
do k=1,dimz
 do j=1,dimy
    campo_saida(i,j,k)=0.5*(a1(i+1,j,k)-a1(i-1,j,k))/dx
  enddo
 enddo

END SUBROUTINE derivaxu2n

!##############################################################

SUBROUTINE derivayu2n(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=2,dimy
  do i=1,dimx
    campo_saida(i,j,k)=0.5*(a1(i,j-2,k)-4*a1(i,j-1,k)+3*a1(i,j,k))/dy
  enddo
 enddo
enddo

j = 1
do k=1,dimz
 do i=1,dimx
    campo_saida(i,j,k)=0.5*(a1(i,j+1,k)-a1(i,j-1,k))/dy
  enddo
 enddo

END SUBROUTINE derivayu2n

!##############################################################

SUBROUTINE derivazu2n(a1,dimx,dimy,dimz,campo_saida)

USE disc

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(0:dimx+1,0:dimy+1,0:dimz+1)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=2,dimz
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=0.5*(a1(i,j,k-2)-4*a1(i,j,k-1)+3*a1(i,j,k))/dz
  enddo
 enddo
enddo

k = 1
do j=1,dimy
 do i=1,dimx
    campo_saida(i,j,k)=0.5*(a1(i,j,k+1)-a1(i,j,k-1))/dz
  enddo
 enddo

END SUBROUTINE derivazu2n

!##############################################################

SUBROUTINE interpx_cf(a1,dimx,dimy,dimz,campo_saida) !cf --> centro pra face fc--> face pro centro

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(dimx,dimy,dimz)  :: a1
real(8), intent(OUT), dimension(dimx+1,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=2,dimx
    campo_saida(i,j,k)=(a1(i,j,k)+a1(i-1,j,k))*0.5
  enddo
  i=1
   !campo_saida(i,j,k)=2.*campo_saida(i+1,j,k)-campo_saida(i+2,j,k)
   campo_saida(i,j,k)=campo_saida(i+1,j,k)
  i=dimx+1
   !campo_saida(i,j,k)=2.*campo_saida(i-1,j,k)-campo_saida(i-2,j,k)
   campo_saida(i,j,k)=campo_saida(i-1,j,k)
 enddo
enddo

END SUBROUTINE interpx_cf

!##############################################################

SUBROUTINE interpx_fc(a1,dimx,dimy,dimz,campo_saida) !cf --> centro pra face fc--> face pro centro

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(dimx,dimy,dimz)  :: a1
real(8), intent(OUT), dimension(dimx-1,dimy,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy
  do i=1,dimx-1
    campo_saida(i,j,k)=(a1(i,j,k)+a1(i+1,j,k))*0.5
  enddo
 enddo
enddo

END SUBROUTINE interpx_fc

!##############################################################

SUBROUTINE interpy_cf(a1,dimx,dimy,dimz,campo_saida) !cf --> centro pra face fc--> face pro centro

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(dimx,dimy,dimz)  :: a1
real(8), intent(OUT), dimension(dimx,dimy+1,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=2,dimy
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i,j,k)+a1(i,j-1,k))*0.5
  enddo
 enddo
enddo
do k=1,dimz
 do i=1,dimx
  j=1
   !campo_saida(i,j,k)=2.*campo_saida(i,j+1,k)-campo_saida(i,j+2,k)
   campo_saida(i,j,k)=campo_saida(i,j+1,k)
  j=dimy+1
   !campo_saida(i,j,k)=2.*campo_saida(i,j-1,k)-campo_saida(i,j-2,k)
   campo_saida(i,j,k)=campo_saida(i,j-1,k)
 enddo
enddo

END SUBROUTINE interpy_cf

!##############################################################

SUBROUTINE interpy_fc(a1,dimx,dimy,dimz,campo_saida) !cf --> centro pra face fc--> face pro centro

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(dimx,dimy,dimz)  :: a1
real(8), intent(OUT), dimension(dimx,dimy-1,dimz) :: campo_saida

!a1=campo_entrada
do k=1,dimz
 do j=1,dimy-1
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i,j,k)+a1(i,j+1,k))*0.5
  enddo
 enddo
enddo

END SUBROUTINE interpy_fc

!##############################################################

SUBROUTINE interpz_cf(a1,dimx,dimy,dimz,campo_saida) !cf --> centro pra face fc--> face pro centro

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(dimx,dimy,dimz)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz+1) :: campo_saida

!a1=campo_entrada
do k=2,dimz
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i,j,k)+a1(i,j,k-1))*0.5
  enddo
 enddo
enddo
do j=1,dimy
 do i=1,dimx
  k=1
   !campo_saida(i,j,k)=2.*campo_saida(i,j,k+1)-campo_saida(i,j,k+2)
   campo_saida(i,j,k)=campo_saida(i,j,k+1)
  k=dimz+1
   !campo_saida(i,j,k)=2.*campo_saida(i,j,k-1)-campo_saida(i,j,k-2)
   campo_saida(i,j,k)=campo_saida(i,j,k-1)

 enddo
enddo

END SUBROUTINE interpz_cf

!##############################################################

SUBROUTINE interpz_fc(a1,dimx,dimy,dimz,campo_saida) !cf --> centro pra face fc--> face pro centro

IMPLICIT NONE
integer :: i, j, k
integer, intent(IN) :: dimx,dimy,dimz
real(8), intent(IN), dimension(dimx,dimy,dimz)  :: a1
real(8), intent(OUT), dimension(dimx,dimy,dimz-1) :: campo_saida

!a1=campo_entrada
do k=1,dimz-1
 do j=1,dimy
  do i=1,dimx
    campo_saida(i,j,k)=(a1(i,j,k)+a1(i,j,k+1))*0.5
  enddo
 enddo
enddo

END SUBROUTINE interpz_fc


! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:quaternions.f90
!--------------------------------------------------------------------------
!
! MODULE: quaternions
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief module with basic quaternion functions (some overloaded operators)
!
!> @details   [verified against Mathematica Quaternion package on 3/15/12]
!>
!> REMEMBER THAT QUATERNION MULTIPLICATION IS NON-COMMUTATIVE !!!!!
!>
!> quaternions are defined as arrays of 4 single or double precision reals;
!> the first entry is the scalar part, the remaining three form the vector part.
!>
!> If you want to try it out, here is an example test program\n
!>\n
!> program qtest\n
!>\n
!>use local\n
!>use quaternions\n
!>\n
!>IMPLICIT NONE\n
!>\n
!>! for single precision, use the following lines\n
!>!real(kind=sgl)  ::  u(4), v(4), w(4)\n
!>!real(kind=sgl) :: x, a=2\n
!>! define two quaternions (single)\n
!>!u = (/1.0,2.0,3.0,4.0/)\n
!>!v = (/5.0,6.0,7.0,8.0/)\n
!>\n
!>! for double precision, uncomment the next set and comment the previous set lines\n
!>real(kind=dbl)  ::  u(4), v(4), w(4)\n
!>real(kind=dbl) :: x, a=2.D0\n
!>! double\n
!>u = (/1.D0,2.D0,3.D0,4.D0/)\n
!>v = (/5.D0,6.D0,7.D0,8.D0/)\n
!>\n
!>\n
!>write (stdout,*) ' quaternion u '\n
!>call quaternion_print(u)\n
!>write (stdout,*) ' quaternion v '\n
!>call quaternion_print(v)\n
!>\n
!>! next, do all the operations to make sure that they are correct\n
!>\n
!>write (stdout,*) '   addition u+v '\n
!>w = u+v\n
!>call quaternion_print(w)\n
!>write (stdout,*) ' '\n
!>\n
!>write (stdout,*) '   subtraction u-v '\n
!>w = u-v\n
!>call quaternion_print(w)\n
!>write (stdout,*) ' '\n
!>\n
!>write (stdout,*) '   scalar multiplication (both orderings)  '\n
!>w = a*u\n
!>call quaternion_print(w)\n
!>w = u*a\n
!>call quaternion_print(w)\n
!>write (stdout,*) ' '\n
!>\n
!>write (stdout,*) '   multiplication uv '\n
!>w = quat_mult(u,v)\n
!>call quaternion_print(w)\n
!>write (stdout,*) ' '\n
!>\n
!write (stdout,*) '   conjugate u '\n
!>w = conjg(u)\n
!>call quaternion_print(w)\n
!>write (stdout,*) ' '\n
!>\n
!>write (stdout,*) '   norm(u) '\n
!>x = cabs(u)\n
!>write (stdout,*) x\n
!>write (stdout,*) ' '\n
!>\n
!>write (stdout,*) '   division u/v '\n
!>w = quat_div(u,v)\n
!>call quaternion_print(w)\n
!>write (stdout,*) ' '\n
!>\n
!>end program qtest\n
!>
!
!> @note Quaternions are defined with the scalar part in position 1, and the
!> vector part in positions 2:4.
!
!> @date 03/15/12   MDG 1.0 original
!> @date 08/04/13   MDG 1.1 moved rotation conversion functions to rotations.f90
!> @date 08/12/13   MDG 2.0 re-defined quaternions to be arrays of 4 reals rather than by letter ...
!> @date 02/06/15   MDG 2.1 added quat_slerp interpolation routines
!> @date 03/11/15   MDG 2.2 renamed quaternion vector rotation routines and split into active and passive
!> @date 03/11/15   MDG 2.3 redefined quaternion product using epsijk constant (see rotations tutorial paper)
!> @date 03/14/15   MDG 2.4 sign change in quaternion product; removed quat_Lpstar routines
!--------------------------------------------------------------------------
module quaternions

use local

IMPLICIT NONE

! only this routine is public; all the others are done via overloaded operators
public :: quaternion_print
interface quaternion_print
        module procedure quaternion_print
        module procedure quaternion_print_d
 end interface

! quaternion multiplication (single and double precision)
public :: quat_mult
interface quat_mult
     module procedure quat_mult
     module procedure quat_mult_d
  end interface

! complex conjugation (single and double precision)
intrinsic :: conjg
public :: conjg
interface conjg
     module procedure quat_conjg
     module procedure quat_conjg_d
  end interface

! quaternion norm (single and double precision)
intrinsic :: cabs
public :: cabs
interface cabs
     module procedure quat_norm
     module procedure quat_norm_d
  end interface

! quaternion division (single and double precision)
public :: quat_div
interface quat_div
     module procedure quat_div
     module procedure quat_div_d
  end interface

! quaternion inner product (single and double precision)
public :: quat_innerproduct
interface quat_innerproduct
     module procedure quat_innerproduct
     module procedure quat_innerproduct_d
  end interface

! interquaternion angle (single and double precision)
public :: quat_angle
interface quat_angle
     module procedure quat_angle
     module procedure quat_angle_d
  end interface

! active quaternion rotation of a unit vector  q v q*
public :: quat_Lp
interface quat_Lp
        module procedure quat_Lp
        module procedure quat_Lp_d
end interface

! quaternion SLERP interpolation between two quaternions
public :: quat_slerp
interface quat_slerp
        module procedure quat_slerp
        module procedure quat_slerp_d
end interface

contains

!--------------------------------------------------------------------------
!
! SUBROUTINE: quaternion_print
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief print a quaternion (for debugging purposes mostly)
!
!> @param q quaternion to be printed (single precision)
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive subroutine quaternion_print(q)
!DEC$ ATTRIBUTES DLLEXPORT :: quaternion_print

use io

    real(kind=sgl), intent(in)  :: q(4)         !< input quaternion (single precision)

    call WriteValue('', q, 4, "('(',4f12.6,')')")

end subroutine quaternion_print

!--------------------------------------------------------------------------
!
! SUBROUTINE:quaternion_print_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief print a quaternion (for debugging purposes mostly)
!
!> @param q quaternion to be printed (double precision)
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive subroutine quaternion_print_d(q)
!DEC$ ATTRIBUTES DLLEXPORT :: quaternion_print_d

use io

    real(kind=dbl), intent(in)  :: q(4)         !< input quaternion (double precision)

    call WriteValue('', q, 4, "('(',4f15.9,')')")

end subroutine quaternion_print_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_mult
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion multiplication   (single precision)
!
!> @param x first quaternion
!> @param y second quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!> @date 3/11/15   MDG 3.0 redefined quaternion product (see rotations tutorial paper)
!--------------------------------------------------------------------------
recursive function quat_mult(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_mult

use constants

    real(kind=sgl), intent(in)          :: x(4), y(4)           !< input quaternions
    real(kind=sgl)                      :: res(4)

! the following is a way to reduce the number of multiplications
! needs to be tested and merged with epsijk approach
!
! QuatMul(QUAT *q1, QUAT *q2, QUAT *res){
! float A, B, C, D, E, F, G, H;
! A = (q1->w + q1->x)*(q2->w + q2->x);
! B = (q1->z - q1->y)*(q2->y - q2->z);
! C = (q1->w - q1->x)*(q2->y + q2->z);
! D = (q1->y + q1->z)*(q2->w - q2->x);
! E = (q1->x + q1->z)*(q2->x + q2->y);
! F = (q1->x - q1->z)*(q2->x - q2->y);
! G = (q1->w + q1->y)*(q2->w - q2->z);
! H = (q1->w - q1->y)*(q2->w + q2->z);
! res->w = B + (-E - F + G + H) /2;
! res->x = A - (E + F + G + H)/2;
! res->y = C + (E - F + G - H)/2;
! res->z = D + (E - F - G + H)/2;
! }

    res = (/ x(1)*y(1) - x(2)*y(2) - x(3)*y(3) - x(4)*y(4), &
             x(1)*y(2) + x(2)*y(1) + epsijk * ( x(3)*y(4) - x(4)*y(3) ), &
             x(1)*y(3) + x(3)*y(1) + epsijk * ( x(4)*y(2) - x(2)*y(4) ), &
             x(1)*y(4) + x(4)*y(1) + epsijk * ( x(2)*y(3) - x(3)*y(2) ) /)

end function quat_mult

!--------------------------------------------------------------------------
!
! FUNCTION: quat_mult_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion multiplication   (double precision)
!
!> @param x first quaternion
!> @param y second quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_mult_d(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_mult_d

use constants

    real(kind=dbl), intent(in)          :: x(4), y(4)           !< input quaternions
    real(kind=dbl)                      :: res(4)

    res = (/ x(1)*y(1) - x(2)*y(2) - x(3)*y(3) - x(4)*y(4), &
             x(1)*y(2) + x(2)*y(1) + epsijkd * ( x(3)*y(4) - x(4)*y(3) ), &
             x(1)*y(3) + x(3)*y(1) + epsijkd * ( x(4)*y(2) - x(2)*y(4) ), &
             x(1)*y(4) + x(4)*y(1) + epsijkd * ( x(2)*y(3) - x(3)*y(2) ) /)

end function quat_mult_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_conjg
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion complex conjugation (extends intrinsic routine conjg)
!
!> @param x quaternion to be conjugated (single precision)
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_conjg(x) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_conjg

    real(kind=sgl), intent(in)          :: x(4)         !< input quaternion
    real(kind=sgl)                      :: res(4)

    res = (/ x(1), -x(2), -x(3), -x(4) /)

end function quat_conjg

!--------------------------------------------------------------------------
!
! FUNCTION: quat_conjg_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion complex conjugation (extends intrinsic routine conjg)
!
!> @param x quaternion to be conjugated (double precision)
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_conjg_d(x) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_conjg_d

    real(kind=dbl), intent(in)          :: x(4)         !< input quaternion
    real(kind=dbl)                      :: res(4)

    res = (/ x(1), -x(2), -x(3), -x(4) /)

end function quat_conjg_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_norm
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion norm (extends intrinsic routine cabs)
!
!> @param x quaternion to be normed (single precision)
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_norm(x) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_norm

   real(kind=sgl), intent(in)           :: x(4)         !< input quaternion
   real(kind=sgl)                       :: res

    res =  sqrt( sum(x*x) )

end function quat_norm

!--------------------------------------------------------------------------
!
! FUNCTION: quat_norm_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion norm (extends intrinsic routine cabs)
!
!> @param x quaternion to be normed (double precision)
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_norm_d(x) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_norm_d

    real(kind=dbl), intent(in)  :: x(4)         !< input quaternion
    real(kind=dbl)              :: res

    res =  dsqrt( sum(x*x) )

end function quat_norm_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_div
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion division (single precision)
!
!> @param x nominator quaternion
!> @param y denominator quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_div(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_div

    real(kind=sgl), intent(in)          :: x(4),y(4)            !< input quaternions
    real(kind=sgl)                      :: res(4), p(4), q

    q = quat_norm(y)
    p = quat_conjg(y)/(q*q)
    res =  quat_mult(x,p)

end function quat_div

!--------------------------------------------------------------------------
!
! FUNCTION: quat_div_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief quaternion division (double precision)
!
!> @param x nominator quaternion
!> @param y denominator quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_div_d(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_div_d

    real(kind=dbl), intent(in)          :: x(4),y(4)            !< input quaternions
    real(kind=dbl)                      :: res(4), p(4), q

    q = quat_norm_d(y)
    p = quat_conjg_d(y)/(q*q)
    res =  quat_mult_d(x,p)

end function quat_div_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_innerproduct
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief  quaternion inner product  (single precision)
!
!> @param x nominator quaternion
!> @param y denominator quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_innerproduct(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_innerproduct

    real(kind=sgl), intent(in)          :: x(4),y(4)            !< input quaternions
    real(kind=sgl)                      :: res

    res = sum(x * y)

end function quat_innerproduct

!--------------------------------------------------------------------------
!
! FUNCTION: quat_innerproduct_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief  quaternion inner product  (double precision)
!
!> @param x nominator quaternion
!> @param y denominator quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------
recursive function quat_innerproduct_d(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_innerproduct_d

    real(kind=dbl), intent(in)          :: x(4),y(4)            !< input quaternions
    real(kind=dbl)                      :: res

    res = sum(x * y)

end function quat_innerproduct_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_angle
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   interquaternion angle   (single precision)
!
!> @param x first quaternion
!> @param y second quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------!
recursive function quat_angle(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_angle

    real(kind=sgl), intent(in)                  :: x(4),y(4)            !< input quaternions
    real(kind=sgl)                              :: res, q

    q = quat_innerproduct(x,y)
    res = acos( 2.0_sgl*q*q - 1.0_sgl )

end function quat_angle

!--------------------------------------------------------------------------
!
! FUNCTION: quat_angle_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   interquaternion angle   (double precision)
!
!> @param x first quaternion
!> @param y second quaternion
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!--------------------------------------------------------------------------!
recursive function quat_angle_d(x,y) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_angle_d

    real(kind=dbl), intent(in)          :: x(4),y(4)            !< input quaternions
    real(kind=dbl)                      :: res, q

    q = quat_innerproduct_d(x,y)
    res = dacos( 2.0_dbl*q*q - 1.0_dbl )

end function quat_angle_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_Lp
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   actively rotate a unit vector by a unit quaternion, L_p = p v p*
!
!> @param q quaternion
!> @param v vector to be rotated
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!> @date 3/11/15   MDG 3.0 name change, to be compatible with rotations tutorial paper
!--------------------------------------------------------------------------!
recursive function quat_Lp(q,v) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_Lp

    real(kind=sgl),intent(in)                   :: q(4)         !< input quaternion
    real(kind=sgl),intent(in)                   :: v(3)         !< input vector
    real(kind=sgl)                              :: qv(4), rqv(4)
    real(kind=sgl)                              :: res(3)

    qv = (/ 0.0, v(1), v(2), v(3) /)
    rqv = quat_mult(q,quat_mult(qv,quat_conjg(q) ) )
    res = rqv(2:4)

end function quat_Lp

!--------------------------------------------------------------------------
!
! FUNCTION: quat_Lp_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   actively rotate a unit vector by a unit quaternion, L_p = p v p*
!
!> @param q quaternion
!> @param v vector to be rotated
!
!> @date 3/15/12   MDG 1.0 original
!> @date 8/12/13   MDG 2.0 rewrite
!> @date 3/11/15   MDG 3.0 name change, to be compatible with rotations tutorial paper
!--------------------------------------------------------------------------!
recursive function quat_Lp_d(q,v) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_Lp_d

    real(kind=dbl),intent(in)                   :: q(4)         !< input quaternion
    real(kind=dbl),intent(in)                   :: v(3)         !< input vector
    real(kind=dbl)                              :: qv(4), rqv(4)
    real(kind=dbl)                              :: res(3)

    qv = (/ 0.D0, v(1), v(2), v(3) /)
    rqv = quat_mult_d(q,quat_mult_d(qv,quat_conjg_d(q) ) )
    res = rqv(2:4)

end function quat_Lp_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_slerp
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   return an array of interpolated quaternions
!
!> @param qa starting quaternion
!> @param qb ending quaternion
!> @param n number of interpolation points
!
!> @date 02/06/15   MDG 1.0 original
!--------------------------------------------------------------------------!
recursive function quat_slerp(qa,qb,n) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_slerp

    real(kind=sgl),intent(in)                   :: qa(4)         !< input quaternion
    real(kind=sgl),intent(in)                   :: qb(4)         !< input quaternion
    integer(kind=irg),intent(in)                :: n

    real(kind=sgl)                              :: qv(4), theta, phi, dphi, s
    real(kind=sgl)                              :: res(4,n)
    integer(kind=irg)                           :: i

    res = 0.0
    theta = acos( dot_product(qb, quat_conjg(qa) ))
    if (theta.ne.0.0) then
      s = 1.0/sin(theta)
      dphi = theta/real(n-1)

      do i=1,n
        phi = real(i-1)*dphi
        res(1:4,i) = s * ( qa(1:4) * sin(theta-phi) + qb(1:4) * sin(phi) )
      end do
    else
      do i=1,n
        res(1:4,i) = qa(1:4)
      end do
    end if

end function quat_slerp

!--------------------------------------------------------------------------
!
! FUNCTION: quat_slerp_d
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   return an array of interpolated quaternions (double precision)
!
!> @param qa starting quaternion
!> @param qb ending quaternion
!> @param n number of interpolation points
!
!> @date 02/06/15   MDG 1.0 original
!--------------------------------------------------------------------------!
recursive function quat_slerp_d(qa,qb,n) result (res)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_slerp_d

    real(kind=dbl),intent(in)                   :: qa(4)         !< input quaternion
    real(kind=dbl),intent(in)                   :: qb(4)         !< input quaternion
    integer(kind=irg),intent(in)                :: n

    real(kind=dbl)                              :: qv(4), theta, phi, dphi, s
    real(kind=dbl)                              :: res(4,n)
    integer(kind=irg)                           :: i

    res = 0.D0
    theta = dacos( dot_product(qb, quat_conjg_d(qa) ) )
    if (theta.ne.0.D0) then
      s = 1.D0/dsin(theta)
      dphi = theta/dble(n-1)

      do i=1,n
        phi = dble(i-1)*dphi
        res(1:4,i) = s * ( qa(1:4) * dsin(theta-phi) + qb(1:4) * dsin(phi) )
      end do
    else
      do i=1,n
        res(1:4,i) = qa(1:4)
      end do
    end if

end function quat_slerp_d

!--------------------------------------------------------------------------
!
! FUNCTION: quat_Marsaglia
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief   return a single random quaternion using the Marsaglia approach
!
!> @param seed seed number
!
!> @date 04/23/18   MDG 1.0 original
!--------------------------------------------------------------------------!
recursive function quat_Marsaglia(seed) result (q)
!DEC$ ATTRIBUTES DLLEXPORT :: quat_Marsaglia

use rng

IMPLICIT NONE

type(rng_t),INTENT(INOUT)           :: seed
!f2py intent(in,out) ::  seed
real(kind=dbl)                      :: q(4)

real(kind=dbl)                      :: x1,x2,y1,y2,s1,s2

x1 = 2.D0*rng_uniform(seed)-1.D0
y1 = 2.D0*rng_uniform(seed)-1.D0
s1 = x1*x1+y1*y1
if (s1.gt.1.D0) then
  do while (s1.gt.1.D0)
    x1 = 2.D0*rng_uniform(seed)-1.D0
    x2 = 2.D0*rng_uniform(seed)-1.D0
    s1 = x1*x1+y1*y1
  end do
end if

x2 = 2.D0*rng_uniform(seed)-1.D0
y2 = 2.D0*rng_uniform(seed)-1.D0
s2 = x2*x2+y2*y2
if (s2.gt.1.D0) then
  do while (s2.gt.1.D0)
    x2 = 2.D0*rng_uniform(seed)-1.D0
    y2 = 2.D0*rng_uniform(seed)-1.D0
    s2 = x2*x2+y2*y2
  end do
end if

s1 = sqrt( (1.D0-s2)/s2 )

q = (/ x1, y1, x2*s1, y2*s1 /)

end function quat_Marsaglia

end module quaternions


module geometry
   implicit none

   public::Vprime, init_geometry, jacob

   private

   abstract interface

      function Vprime_iface(r)
         real,intent(in):: r
         real:: Vprime_iface
      end function Vprime_iface

   end interface

   procedure (Vprime_iface), pointer:: Vprime => null()

   contains

   subroutine init_geometry()
      use input
      implicit none

      select case (geometry_type)
      case("flat")
         Vprime => Vprime_flat
      case("cylindrical")
         Vprime => Vprime_cylindrical
      case default
         print*,"ERROR. ", geometry_type, " is an invalid geometry_type."
      end select

   end subroutine

   !> The Jacobian of our coordinates. ***Not to be confused with the Jacobian of the residual for the linear solver.***
   !! This is the phase space volume element for our chosen coordinates.
   !! Leaving in terms of x ini case that gets changed.
   function jacob(r,p,x)
      use constants
      implicit none
      real, intent(in):: r,p,x
      real:: jacob
      jacob =  2*pi*Vprime(r)*p**2
      return
   end function

   function Vprime_flat(r)
      use input
      use constants
      implicit none
      real,intent(in):: r
      real:: Vprime_flat

      ! For cartesian geometry, treat rmaj as a cross-sectional radius
      Vprime_flat = pi*rmaj**2
      return
   end function Vprime_flat

   function Vprime_cylindrical(r)
      use input
      use constants
      implicit none
      real,intent(in):: r
      real:: Vprime_cylindrical

      Vprime_cylindrical = (4*pi*r)*(2*pi*rmaj)
      return
   end function Vprime_cylindrical

end module geometry


! In program name, - is not allowed
program evenodd
character(len=10) :: argument
Character(26) :: low = 'abcdefghijklmnopqrstuvwxyz'
Character(26) :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
integer :: number, check_capital_letters, check_small_letters, remainder
! Anything not equal to single argument, Print Error
IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN
  write(*,'(g0.8)')"Usage: please input a number"
  STOP
ENDIF

CALL GET_COMMAND_ARGUMENT(1,argument)
if (argument == "") then
  write(*,'(g0.8)')"Usage: please input a number"
  STOP
endif
! Scan for letters
check_capital_letters = scan(argument, cap)
check_small_letters = scan(argument, low)
! If capital letters exist, print error
if (check_capital_letters > 0) then
  write(*,'(g0.8)')"Usage: please input a number"
  STOP
endif
! If small letters exist, print error
if (check_small_letters > 0) then
  write(*,'(g0.8)')"Usage: please input a number"
  STOP
endif
! read the cmd line arg into number
read (argument, '(I10)') number
! get the remainder
remainder = modulo(number, 2)
if (remainder == 0) then
  write(*,'(g0.8)') "Even"
else
  write(*,'(g0.8)') "Odd"
end if
end program


module model_ideal_gas_sst
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: HALF, ONE
    use mod_fluid,          only: Rgas, gam
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  An equation of state model for an ideal gas.
    !!
    !!  Model Fields:
    !!      - Pressure
    !!      - Temperature
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: ideal_gas_sst_t

    contains

        procedure   :: init
        procedure   :: compute

    end type ideal_gas_sst_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(ideal_gas_sst_t), intent(inout)   :: self

        call self%set_name('Ideal Gas SST')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Pressure')
        call self%add_model_field('Temperature')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing the Pressure and Temperature.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(ideal_gas_sst_t),     intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: &
            density, mom1, mom2, mom3, energy, density_k, k, pressure, temperature

        !
        ! Interpolate solution to quadrature nodes
        !
        density = worker%get_field('Density',    'value')
        mom1    = worker%get_field('Momentum-1', 'value')
        mom2    = worker%get_field('Momentum-2', 'value')
        mom3    = worker%get_field('Momentum-3', 'value')
        energy  = worker%get_field('Energy',     'value')

        !k  = worker%get_field('k',     'value')
        density_k  = worker%get_field('Density * k',     'value')

        !
        ! Account for cylindrical. Get tangential momentum from angular momentum.
        !
        if (worker%coordinate_system() == 'Cylindrical') then
            mom2 = mom2 / worker%coordinate('1')
        end if

        pressure = (gam-ONE)*(energy - HALF*( (mom1*mom1) + (mom2*mom2) + (mom3*mom3) )/density - density_k)
        temperature = pressure/(density*Rgas)

        call worker%store_model_field('Pressure',    'value', pressure)
        call worker%store_model_field('Temperature', 'value', temperature)

    end subroutine compute
    !***************************************************************************************

end module model_ideal_gas_sst


      MODULE GEOM
!@sum  GEOM contains spherical geometric variables and arrays
!@auth Original development team
!@ver  1.0 (B grid version)
!@cont GEOM_B
      USE CONSTANT, only : OMEGA,RADIUS,TWOPI,SDAY,radian
      USE MODEL_COM, only : IM,JM,LM,FIM,BYIM
      IMPLICIT NONE
C**** The primary grid is the A grid (including both poles)
C**** The secondary grid is for the B grid velocities, located on the
C**** vertices of the A grid (Note: first velocity point is J=2)
C**** Polar boxes can have different latitudinal size and are treated
C**** as though they were 1/IM of their actual area
      SAVE
!@param  DLON grid spacing in longitude (deg)
      REAL*8, PARAMETER :: DLON = TWOPI*BYIM
C**** For the wonderland model set DLON=DLON/3
c      REAL*8, PARAMETER :: DLON=TWOPI/(IM*3)
!@param  DLAT,DLAT_DG grid spacing in latitude (rad,deg)
      REAL*8  :: DLAT,DLAT_DG
!@param  FJEQ equatorial value of J
      REAL*8, PARAMETER :: FJEQ=.5*(1+JM)
!@var  J1U index of southernmost latitude (currently 2, later 1)
      INTEGER, parameter :: J1U = 2
!@var  JRANGE_HEMI lowest,highest lat index for SH,NH for A,B grid
      INTEGER, parameter, dimension(2,2,2) :: JRANGE_HEMI = reshape(
     *  (/1,JM/2,  1+JM/2,JM,  J1U,J1U-1+JM/2, J1U-1+JM/2,JM+J1U-2/),
     *  (/2,2,2/))
!@var  LAT latitude of mid point of primary grid box (radians)
      REAL*8, DIMENSION(JM) :: LAT
!@var  LAT_DG latitude of mid points of primary and sec. grid boxs (deg)
      REAL*8, DIMENSION(JM,2) :: LAT_DG
!@var  LON longitude of mid points of primary grid box (radians)
      REAL*8, DIMENSION(IM) :: LON
!@var  LON_DG longitude of mid points of prim. and sec. grid boxes (deg)
      REAL*8, DIMENSION(IM,2) :: LON_DG
!@var  DXYP,BYDXYP area of grid box (+inverse) (m^2)
C**** Note that this is not the exact area, but is what is required for
C**** some B-grid conservation quantities
      REAL*8, DIMENSION(JM) :: DXYP,BYDXYP
!@var AREAG global integral of area (m^2)
      REAL*8 :: AREAG
!@var WTJ area weighting used in JLMAP, JKMAP (for hemispheric means)
      REAL*8, DIMENSION(JM,2,2) :: WTJ

!@var DXYV,BYDXYV area of grid box around velocity point (recip.)(m^2)
      REAL*8, DIMENSION(JM) :: DXYV,BYDXYV

!@var  DXP,DYP,BYDXP,BYDYP distance between points on primary grid
!@+     (+inverse)
      REAL*8, DIMENSION(JM) :: DXP,DYP,BYDXP,BYDYP
!@var  DXV,DYV distance between velocity points (secondary grid)
      REAL*8, DIMENSION(JM) :: DXV,DYV
!@var  DXYN,DXYS half box areas to the North,South of primary grid point
      REAL*8, DIMENSION(JM) :: DXYS,DXYN
!@var  SINP sin of latitude at primary grid points
      REAL*8, DIMENSION(JM) :: SINP
!@var  COSP, COSV cos of latitude at primary, secondary latitudes
      REAL*8, DIMENSION(JM) :: COSP,COSV
!@var  RAPVS,RAPVN,RAVPS,RAVPN area scalings for primary and sec. grid
      REAL*8, DIMENSION(JM) :: RAPVS,RAPVN,RAVPS,RAVPN

!@var SINIV,COSIV,SINIP,COSIP longitud. sin,cos for wind,pressure grid
      REAL*8, DIMENSION(IM) :: SINIV,COSIV,SINIP,COSIP
!@var  RAVJ scaling for A grid U/V to B grid points (func. of lat. j)
!@var  RAPJ scaling for B grid -> A grid conversion (1/4,1/im at poles)
      REAL*8, DIMENSION(IM,JM) :: RAPJ,RAVJ
!@var  IDJJ J index of adjacent U/V points for A grid (func. of lat. j)
      INTEGER, DIMENSION(IM,JM) :: IDJJ
!@var  IDIJ I index of adjacent U/V points for A grid (func. of lat/lon)
      INTEGER, DIMENSION(IM,IM,JM) :: IDIJ
!@var  KMAXJ varying number of adjacent velocity points
      INTEGER, DIMENSION(JM) :: KMAXJ
!@var  IMAXJ varying number of used longitudes
      INTEGER, DIMENSION(JM) :: IMAXJ
!@var  FCOR latitudinally varying coriolis parameter
      REAL*8, DIMENSION(JM) :: FCOR

      CONTAINS

      SUBROUTINE GEOM_B
!@sum  GEOM_B Calculate spherical geometry for B grid
!@auth Original development team (modifications by G. Schmidt)
!@ver  1.0 (B grid version)
      IMPLICIT NONE
      REAL*8, PARAMETER :: EDPERD=1.,EDPERY = 365.

      INTEGER :: I,J,K,IM1  !@var I,J,K,IM1  loop variables
      INTEGER :: JVPO,JMHALF
      REAL*8  :: RAVPO

C**** latitudinal spacing depends on whether you have even spacing or
C**** a partial box at the pole
      DLAT_DG=180./JM                     ! even spacing (default)
      IF (JM.eq.46) DLAT_DG=180./(JM-1)   ! 1/2 box at pole for 4x5
cc    IF (JM.eq.24) DLAT_DG=180./(JM-1)   ! 1/2 box at pole, orig 8x10
      IF (JM.eq.24) DLAT_DG=180./(JM-1.5) ! 1/4 box at pole, 'real' 8x10
      DLAT=DLAT_DG*radian
      LAT(1)  = -.25*TWOPI
      LAT(JM) = -LAT(1)
      SINP(1)  = -1.
      SINP(JM) = 1.
      COSP(1)  = 0.
      COSP(JM) = 0.
      DXP(1)  = 0.
      DXP(JM) = 0.
      DO J=2,JM-1
        LAT(J)  = DLAT*(J-FJEQ)
        SINP(J) = SIN(LAT(J))
        COSP(J) = COS(LAT(J))
        DXP(J)  = RADIUS*DLON*COSP(J)
      END DO
      BYDXP(2:JM-1) = 1.D0/DXP(2:JM-1)
      DO J=2,JM
        COSV(J) = .5*(COSP(J-1)+COSP(J))
        DXV(J)  = .5*(DXP(J-1)+DXP(J))
        DYV(J)  = RADIUS*(LAT(J)-LAT(J-1))
      END DO
      DYP(1)  = RADIUS*(LAT(2)-LAT(1)-0.5*DLAT)
      DYP(JM) = RADIUS*(LAT(JM)-LAT(JM-1)-0.5*DLAT)
      DXYP(1) = .5*DXV(2)*DYP(1)
      BYDXYP(1) = 1./DXYP(1)
      DXYP(JM)= .5*DXV(JM)*DYP(JM)
      BYDXYP(JM) = 1./DXYP(JM)
      DXYS(1)  = 0.
      DXYS(JM) = DXYP(JM)
      DXYN(1)  = DXYP(1)
      DXYN(JM) = 0.
      AREAG = DXYP(1)+DXYP(JM)
      DO J=2,JM-1
        DYP(J)  = .5*(DYV(J)+DYV(J+1))
        DXYP(J) = .5*(DXV(J)+DXV(J+1))*DYP(J)
        BYDXYP(J) = 1./DXYP(J)
        DXYS(J) = .5*DXYP(J)
        DXYN(J) = .5*DXYP(J)
        AREAG = AREAG+DXYP(J)
      END DO
      BYDYP(:) = 1.D0/DYP(:)
      AREAG = AREAG*FIM
      RAVPS(1)  = 0.
      RAPVS(1)  = 0.
      RAVPN(JM) = 0.
      RAPVN(JM) = 0.
      DO J=2,JM
        DXYV(J) = DXYN(J-1)+DXYS(J)
        BYDXYV(J) = 1./DXYV(J)
        RAPVS(J)   = .5*DXYS(J)/DXYV(J)
        RAPVN(J-1) = .5*DXYN(J-1)/DXYV(J)
        RAVPS(J)   = .5*DXYS(J)/DXYP(J)
        RAVPN(J-1) = .5*DXYN(J-1)/DXYP(J-1)
      END DO
C**** LONGITUDES (degrees); used in ILMAP
      LON_DG(1,1) = -180.+360./(2.*FLOAT(IM))
      LON_DG(1,2) = -180.+360./    FLOAT(IM)
      DO I=2,IM
        LON_DG(I,1) = LON_DG(I-1,1)+360./FLOAT(IM)
        LON_DG(I,2) = LON_DG(I-1,2)+360./FLOAT(IM)
      END DO
C**** LATITUDES (degrees); used extensively in the diagn. print routines
      LAT_DG(1,1:2)=-90.
      LAT_DG(JM,1)=90.
      DO J=2,JM-1
        LAT_DG(J,1)=DLAT_DG*(J-FJEQ)    ! primary (tracer) latitudes
      END DO
      DO J=2,JM
        LAT_DG(J,2)=DLAT_DG*(J-JM/2-1)  ! secondary (velocity) latitudes
      END DO
C**** WTJ: area weighting for JKMAP, JLMAP hemispheres
      JMHALF= JM/2
      DO J=1,JM
        WTJ(J,1,1)=1.
        WTJ(J,2,1)=2.*FIM*DXYP(J)/AREAG
      END DO
      DO J=2,JM
        WTJ(J,1,2)=1.
        WTJ(J,2,2)=2.*FIM*DXYV(J)/AREAG
      END DO
      WTJ(JMHALF+1,1,2)=.5
      WTJ(JMHALF+1,2,2)=WTJ(JMHALF+1,2,2)/2.
      WTJ(1,1,2)=0.
      WTJ(1,2,2)=0.
C**** CALCULATE CORIOLIS PARAMETER
c      OMEGA = TWOPI*(EDPERD+EDPERY)/(EDPERD*EDPERY*SDAY)
      FCOR(1)  = -RADIUS*OMEGA*.5*COSP(2)*DXV(2)
      FCOR(JM) = -FCOR(1)
      DO J=2,JM-1
        FCOR(J) = OMEGA*(DXV(J)*DXV(J)-DXV(J+1)*DXV(J+1))/DLON
      END DO

C**** Set indexes and scalings for the influence of A grid points on
C**** adjacent velocity points

C**** Calculate relative directions of polar box to nearby U,V points
      DO I=1,IM
        SINIV(I)=SIN((I-1)*DLON)
        COSIV(I)=COS((I-1)*TWOPI*BYIM) ! DLON)
        LON(I)=DLON*(I-.5)
        SINIP(I)=SIN(LON(I))
        COSIP(I)=COS(LON(I))
      END DO

C**** Conditions at the poles
      DO J=1,JM,JM-1
        IF(J.EQ.1) THEN
          JVPO=2
          RAVPO=2.*RAPVN(1)
        ELSE
          JVPO=JM
          RAVPO=2.*RAPVS(JM)
        END IF
        KMAXJ(J)=IM
        IMAXJ(J)=1
        RAVJ(1:KMAXJ(J),J)=RAVPO
        RAPJ(1:KMAXJ(J),J)=BYIM
        IDJJ(1:KMAXJ(J),J)=JVPO
        DO K=1,KMAXJ(J)
          IDIJ(K,1:IM,J)=K
        END DO
      END DO
C**** Conditions at non-polar points
      DO J=2,JM-1
        KMAXJ(J)=4
        IMAXJ(J)=IM
        DO K=1,2
          RAVJ(K,J)=RAPVS(J)
          RAPJ(K,J)=RAVPS(J)    ! = .25
          IDJJ(K,J)=J
          RAVJ(K+2,J)=RAPVN(J)
          RAPJ(K+2,J)=RAVPN(J)  ! = .25
          IDJJ(K+2,J)=J+1
        END DO
        IM1=IM
        DO I=1,IM
          IDIJ(1,I,J)=IM1
          IDIJ(2,I,J)=I
          IDIJ(3,I,J)=IM1
          IDIJ(4,I,J)=I
          IM1=I
        END DO
      END DO

      RETURN
      END SUBROUTINE GEOM_B

      END MODULE GEOM


      SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG,
     $                   U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reorder a matrix X in skew-Hamiltonian Schur form:
C
C                   [  A   G  ]          T
C             X  =  [       T ],   G = -G,
C                   [  0   A  ]
C
C     or in Hamiltonian Schur form:
C
C                   [  A   G  ]          T
C             X  =  [       T ],   G =  G,
C                   [  0  -A  ]
C
C     where A is in upper quasi-triangular form, so that a selected
C     cluster of eigenvalues appears in the leading diagonal blocks
C     of the matrix A (in X) and the leading columns of [ U1; -U2 ] form
C     an orthonormal basis for the corresponding right invariant
C     subspace.
C
C     If X is skew-Hamiltonian, then each eigenvalue appears twice; one
C     copy corresponds to the j-th diagonal element and the other to the
C     (n+j)-th diagonal element of X. The logical array LOWER controls
C     which copy is to be reordered to the leading part of A.
C
C     If X is Hamiltonian then the eigenvalues appear in pairs
C     (lambda,-lambda); lambda corresponds to the j-th diagonal
C     element and -lambda to the (n+j)-th diagonal element of X.
C     The logical array LOWER controls whether lambda or -lambda is to
C     be reordered to the leading part of A.
C
C     The matrix A must be in Schur canonical form (as returned by the
C     LAPACK routine DHSEQR), that is, block upper triangular with
C     1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has
C     its diagonal elements equal and its off-diagonal elements of
C     opposite sign.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYP     CHARACTER*1
C             Specifies the type of the input matrix X:
C             = 'S': X is skew-Hamiltonian;
C             = 'H': X is Hamiltonian.
C
C     COMPU   CHARACTER*1
C             = 'U': update the matrices U1 and U2 containing the
C                    Schur vectors;
C             = 'N': do not update U1 and U2.
C
C     SELECT  (input/output) LOGICAL array, dimension (N)
C             SELECT specifies the eigenvalues in the selected cluster.
C             To select a real eigenvalue w(j), SELECT(j) must be set
C             to .TRUE.. To select a complex conjugate pair of
C             eigenvalues w(j) and w(j+1), corresponding to a 2-by-2
C             diagonal block, both SELECT(j) and SELECT(j+1) must be set
C             to .TRUE.; a complex conjugate pair of eigenvalues must be
C             either both included in the cluster or both excluded.
C
C     LOWER   (input/output) LOGICAL array, dimension (N)
C             LOWER controls which copy of a selected eigenvalue is
C             included in the cluster. If SELECT(j) is set to .TRUE.
C             for a real eigenvalue w(j); then LOWER(j) must be set to
C             .TRUE. if the eigenvalue corresponding to the (n+j)-th
C             diagonal element of X is to be reordered to the leading
C             part; and LOWER(j) must be set to .FALSE. if the
C             eigenvalue corresponding to the j-th diagonal element of
C             X is to be reordered to the leading part. Similarly, for
C             a complex conjugate pair of eigenvalues w(j) and w(j+1),
C             both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the
C             eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1)
C             diagonal block of X are to be reordered to the leading
C             part.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi-triangular matrix A in Schur
C             canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the reordered matrix A, again in Schur canonical form,
C             with the selected eigenvalues in the diagonal blocks.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, if TYP = 'S', the leading N-by-N part of this
C             array must contain the strictly upper triangular part of
C             the skew-symmetric matrix G. The rest of this array is not
C             referenced.
C             On entry, if TYP = 'H', the leading N-by-N part of this
C             array must contain the upper triangular part of the
C             symmetric matrix G. The rest of this array is not
C             referenced.
C             On exit, if TYP = 'S', the leading N-by-N part of this
C             array contains the strictly upper triangular part of the
C             skew-symmetric matrix G, updated by the orthogonal
C             symplectic transformation which reorders X.
C             On exit, if TYP = 'H', the leading N-by-N part of this
C             array contains the upper triangular part of the symmetric
C             matrix G, updated by the orthogonal symplectic
C             transformation which reorders X.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On entry, if COMPU = 'U', the leading N-by-N part of this
C             array must contain U1, the (1,1) block of an orthogonal
C             symplectic matrix U = [ U1, U2; -U2, U1 ].
C             On exit, if COMPU = 'U', the leading N-by-N part of this
C             array contains the (1,1) block of the matrix U,
C             postmultiplied by the orthogonal symplectic transformation
C             which reorders X. The leading M columns of U form an
C             orthonormal basis for the specified invariant subspace.
C             If COMPU = 'N', this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= MAX(1,N),  if COMPU = 'U';
C             LDU1 >= 1,         otherwise.
C
C     U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On entry, if COMPU = 'U', the leading N-by-N part of this
C             array must contain U2, the (1,2) block of an orthogonal
C             symplectic matrix U = [ U1, U2; -U2, U1 ].
C             On exit, if COMPU = 'U', the leading N-by-N part of this
C             array contains the (1,2) block of the matrix U,
C             postmultiplied by the orthogonal symplectic transformation
C             which reorders X.
C             If COMPU = 'N', this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= MAX(1,N),  if COMPU = 'U';
C             LDU2 >= 1,         otherwise.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             The real and imaginary parts, respectively, of the
C             reordered eigenvalues of A. The eigenvalues are stored
C             in the same order as on the diagonal of A, with
C             WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal
C             block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an
C             eigenvalue is sufficiently ill-conditioned, then its value
C             may differ significantly from its value before reordering.
C
C     M       (output) INTEGER
C             The dimension of the specified invariant subspace.
C             0 <= M <= N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -18,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C             = 1:  reordering of X failed because some eigenvalue pairs
C                   are too close to separate (the problem is very
C                   ill-conditioned); X may have been partially
C                   reordered, and WR and WI contain the eigenvalues in
C                   the same order as in X.
C
C     REFERENCES
C
C     [1] Bai, Z. and Demmel, J.W.
C         On Swapping Diagonal Blocks in Real Schur Form.
C         Linear Algebra Appl., 186, pp. 73-95, 1993.
C
C     [2] Benner, P., Kressner, D., and Mehrmann, V.
C         Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory,
C         Algorithms and Applications. Techn. Report, TU Berlin, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD).
C
C     KEYWORDS
C
C     Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COMPU, TYP
      INTEGER           INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N
C     .. Array Arguments ..
      LOGICAL           LOWER(*), SELECT(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*),
     $                  U2(LDU2,*), WI(*), WR(*)
C     .. Local Scalars ..
      LOGICAL           FLOW, ISHAM, PAIR, SWAP, WANTU
      INTEGER           HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT,
     $                  WRKMIN
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          MB03TS, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Decode and check input parameters.
C
      ISHAM = LSAME( TYP, 'H' )
      WANTU = LSAME( COMPU, 'U' )
      WRKMIN = MAX( 1, N )
      INFO = 0
      IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN
         INFO = -11
      ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN
         INFO = -13
      ELSE IF ( LDWORK.LT.WRKMIN ) THEN
         INFO = -18
         DWORK(1) = DBLE( WRKMIN )
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03TD', -INFO )
         RETURN
      END IF
C
C     Set M to the dimension of the specified invariant subspace.
C
      M = 0
      PAIR = .FALSE.
      DO 10 K = 1, N
         IF ( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            IF ( K.LT.N ) THEN
               IF ( A(K+1,K).EQ.ZERO ) THEN
                  IF ( SELECT(K) )
     $               M = M + 1
               ELSE
                  PAIR = .TRUE.
                  IF ( SELECT(K) .OR. SELECT(K+1) )
     $               M = M + 2
               END IF
            ELSE
               IF ( SELECT(N) )
     $            M = M + 1
            END IF
         END IF
   10 CONTINUE
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Collect the selected blocks at the top-left corner of X.
C
      KS = 0
      PAIR = .FALSE.
      DO 60 K = 1, N
         IF ( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            SWAP = SELECT(K)
            FLOW = LOWER(K)
            IF  ( K.LT.N ) THEN
               IF ( A(K+1,K).NE.ZERO ) THEN
                  PAIR = .TRUE.
                  SWAP = SWAP.OR.SELECT(K+1)
                  FLOW = FLOW.OR.LOWER(K+1)
               END IF
            END IF
C
            IF ( PAIR ) THEN
               NBF = 2
            ELSE
               NBF = 1
            END IF
C
            IF ( SWAP ) THEN
               KS = KS + 1
               IF ( FLOW ) THEN
C
C                 Step 1: Swap the K-th block to position N.
C
                  IFST = K
                  ILST = N
                  NBL = 1
                  IF ( ILST.GT.1 ) THEN
                     IF ( A(ILST,ILST-1).NE.ZERO ) THEN
                        ILST = ILST - 1
                        NBL = 2
                     END IF
                  END IF
C
C                 Update ILST.
C
                  IF ( NBF.EQ.2 .AND. NBL.EQ.1 )
     $               ILST = ILST - 1
                  IF ( NBF.EQ.1 .AND. NBL.EQ.2 )
     $               ILST = ILST + 1
C
                  IF ( ILST.EQ.IFST )
     $               GO TO 30
C
                  HERE = IFST
C
   20             CONTINUE
C
C                 Swap block with next one below.
C
                  IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C                    Current block is either 1-by-1 or 2-by-2.
C
                     NBNEXT = 1
                     IF ( HERE+NBF+1.LE.N ) THEN
                        IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO )
     $                     NBNEXT = 2
                     END IF
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, HERE, NBF, NBNEXT,
     $                            DWORK, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        GO TO 70
                     END IF
                     HERE = HERE + NBNEXT
C
C                    Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                     IF ( NBF.EQ.2 ) THEN
                        IF ( A(HERE+1,HERE).EQ.ZERO )
     $                     NBF = 3
                     END IF
C
                  ELSE
C
C                    Current block consists of two 1-by-1 blocks each of
C                    which must be swapped individually.
C
                     NBNEXT = 1
                     IF ( HERE+3.LE.N ) THEN
                        IF ( A(HERE+3,HERE+2).NE.ZERO )
     $                     NBNEXT = 2
                     END IF
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, HERE+1, 1, NBNEXT,
     $                            DWORK, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        GO TO 70
                     END IF
                     IF ( NBNEXT.EQ.1 ) THEN
C
C                       Swap two 1-by-1 blocks, no problems possible.
C
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE, 1,
     $                               NBNEXT, DWORK, IERR )
                        HERE = HERE + 1
                     ELSE
C
C                       Recompute NBNEXT in case 2 by 2 split.
C
                        IF ( A(HERE+2,HERE+1).EQ.ZERO )
     $                     NBNEXT = 1
                        IF ( NBNEXT.EQ.2 ) THEN
C
C                          2-by-2 block did not split
C
                           CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                                  U1, LDU1, U2, LDU2, HERE, 1,
     $                                  NBNEXT, DWORK, IERR )
                           IF ( IERR.NE.0 ) THEN
                              INFO = 1
                              GO TO 70
                           END IF
                           HERE = HERE + 2
                        ELSE
C
C                          2-by-2 block did split
C
                           CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                                  U1, LDU1, U2, LDU2, HERE, 1, 1,
     $                                  DWORK, IERR )
                           CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                                  U1, LDU1, U2, LDU2, HERE+1, 1,
     $                                  1, DWORK, IERR )
                           HERE = HERE + 2
                        END IF
                     END IF
                  END IF
                  IF ( HERE.LT.ILST )
     $               GO TO 20
C
   30             CONTINUE
C
C                 Step 2: Apply an orthogonal symplectic transformation
C                         to swap the last blocks in A and -A' (or A').
C
                  IF ( NBF.EQ.1 ) THEN
C
C                    Exchange columns/rows N <-> 2*N. No problems
C                    possible.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                            U1, LDU1, U2, LDU2, N, 1, 1,
     $                            DWORK, IERR )
C
                  ELSE IF ( NBF.EQ.2 ) THEN
C
C                    Swap last block with its equivalent by an
C                    orthogonal symplectic transformation.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                            U1, LDU1, U2, LDU2, N-1, 2, 2,
     $                            DWORK, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        GO TO 70
                     END IF
C
C                    Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                     IF ( A(N-1,N).EQ.ZERO )
     $                  NBF = 3
                  ELSE
C
C                    Block did split. Swap (N-1)-th and N-th elements
C                    consecutively by symplectic generalized
C                    permutations and one rotation.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, N, 1, 1, DWORK, IERR )
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, N-1, 1, 1, DWORK,
     $                            IERR )
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, N, 1, 1, DWORK, IERR )
                  END IF
                  IFST = N
                  IF ( PAIR )
     $               IFST = N-1
               ELSE
                  IFST = K
               END IF
C
C              Step 3: Swap the K-th / N-th block to position KS.
C
               ILST = KS
               NBL = 1
               IF ( ILST.GT.1 ) THEN
                  IF ( A(ILST,ILST-1).NE.ZERO ) THEN
                     ILST = ILST - 1
                     NBL = 2
                  END IF
               END IF
C
               IF ( ILST.EQ.IFST )
     $            GO TO 50
C
               HERE = IFST
   40          CONTINUE
C
C              Swap block with next one above.
C
               IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C                 Current block either 1 by 1 or 2 by 2.
C
                  NBNEXT = 1
                  IF ( HERE.GE.3 ) THEN
                     IF ( A(HERE-1,HERE-2).NE.ZERO )
     $                  NBNEXT = 2
                  END IF
                  CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                         LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT,
     $                         NBF, DWORK, IERR )
                  IF ( IERR.NE.0 ) THEN
                     INFO = 1
                     GO TO 70
                  END IF
                  HERE = HERE - NBNEXT
C
C                 Test if 2-by-2 block breaks into two 1-by-1 blocks.
C
                  IF ( NBF.EQ.2 ) THEN
                     IF ( A(HERE+1,HERE).EQ.ZERO )
     $                  NBF = 3
                  END IF
C
               ELSE
C
C                 Current block consists of two 1 by 1 blocks each of
C                 which must be swapped individually.
C
                  NBNEXT = 1
                  IF ( HERE.GE.3 ) THEN
                     IF ( A(HERE-1,HERE-2).NE.ZERO )
     $                  NBNEXT = 2
                  END IF
                  CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                         LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT,
     $                         1, DWORK, IERR )
                  IF ( IERR.NE.0 ) THEN
                     INFO = 1
                     GO TO 70
                  END IF
                  IF ( NBNEXT.EQ.1 ) THEN
C
C                    Swap two 1-by-1 blocks, no problems possible.
C
                     CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1,
     $                            LDU1, U2, LDU2, HERE, NBNEXT, 1,
     $                            DWORK, IERR )

                     HERE = HERE - 1
                  ELSE
C
C                    Recompute NBNEXT in case 2-by-2 split.
C
                     IF ( A(HERE,HERE-1).EQ.ZERO )
     $                  NBNEXT = 1
                     IF ( NBNEXT.EQ.2 ) THEN
C
C                       2-by-2 block did not split
C
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE-1, 2, 1,
     $                               DWORK, IERR )
                        IF ( IERR.NE.0 ) THEN
                           INFO = 1
                           GO TO 70
                        END IF
                        HERE = HERE - 2
                     ELSE
C
C                       2-by-2 block did split
C
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE, 1, 1,
     $                               DWORK, IERR )
                        CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG,
     $                               U1, LDU1, U2, LDU2, HERE-1, 1, 1,
     $                               DWORK, IERR )
                        HERE = HERE - 2
                     END IF
                  END IF
               END IF
C
               IF ( HERE.GT.ILST )
     $            GO TO 40
C
   50          CONTINUE
               IF ( PAIR )
     $            KS = KS + 1
            END IF
         END IF
   60 CONTINUE
C
   70 CONTINUE
C
C     Store eigenvalues.
C
      DO 80 K = 1, N
         WR(K) = A(K,K)
         WI(K) = ZERO
   80 CONTINUE
      DO 90 K = 1, N - 1
         IF ( A(K+1,K).NE.ZERO ) THEN
            WI(K) = SQRT( ABS( A(K,K+1) ) )*
     $              SQRT( ABS( A(K+1,K) ) )
            WI(K+1) = -WI(K)
         END IF
   90 CONTINUE
C
      DWORK(1) = DBLE( WRKMIN )
C
      RETURN
C *** Last line of MB03TD ***
      END


*     MB03QD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 10 )
      INTEGER          LDA, LDU
      PARAMETER        ( LDA = NMAX, LDU = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      DICO, JOBU, STDOM
      INTEGER          I, INFO, J, N, NDIM, NLOW, NSUP
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), U(LDU,NMAX),
     $                 WI(NMAX), WR(NMAX)
      LOGICAL          BWORK(NMAX)
*     .. External Functions ..
      LOGICAL          SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, MB03QD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NLOW, NSUP, ALPHA, DICO, STDOM, JOBU
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Compute Schur form, eigenvalues and Schur vectors.
         CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, NDIM,
     $               WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
*           Block reordering.
            CALL MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA,
     $                   A, LDA, U, LDU, NDIM, DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99996 ) NDIM
               WRITE ( NOUT, FMT = 99994 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03QD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DGEES  = ',I2)
99997 FORMAT (' INFO on exit from MB03QD = ',I2)
99996 FORMAT (' The number of eigenvalues in the domain is ',I5)
99995 FORMAT (8X,20(1X,F8.4))
99994 FORMAT (/' The ordered Schur form matrix is ')
99993 FORMAT (/' The transformation matrix is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
      END


c
c-----------------------------------------------------------------------
c
       subroutine estdt(val,irr,mitot,mjtot,nvar,dx,dy,dtgrid,
     1                  lwidth,aux,naux,cfl)
c
       implicit double precision (a-h, o-z)
       dimension val(nvar,mitot,mjtot), irr(mitot,mjtot)
       common /userdt/ cflcart,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                 ismp,gradThreshold
c
       dt = 1.d+20
       do 20 j = lwidth+1, mjtot-lwidth
       do 10 i = lwidth+1, mitot-lwidth
         if (irr(i,j) .ne. -1) then
             rho  = val(1,i,j)
             xmom   = dabs(val(2,i,j))
             ymom   = dabs(val(3,i,j))
             etot  = val(4,i,j)
             velsq  = (xmom**2 + ymom**2 ) /rho
             eint = etot - 0.5d0*velsq
             p    = eint*gamma1
             c    = dsqrt(gamma*p/rho)
             dt1  = dx/(c + xmom/rho)
             dt2  = dy/(c + ymom/rho)
             dt   = dmin1(dt,dt1,dt2)
         endif
 10    continue
 20    continue
c
       dtgrid = cflcart * dt
c
       return
       end


chapter x. example 1. plotting some b-splines
c  from  * a practical guide to splines *  by c. de boor
calls  bsplvb, interv
      integer i,j,k,left,leftmk,mflag,n,npoint
      real dx,t(10),values(7),x,xl
c  dimension, order and knot sequence for spline space are specified...
      data n,k /7,3/, t /3*0.,2*1.,3.,4.,3*6./
c  b-spline values are initialized to 0., number of evaluation points...
      data values /7*0./, npoint /31/
c  set leftmost evaluation point  xl , and spacing  dx	to be used...
      xl = t(k)
      dx = (t(n+1)-t(k))/float(npoint-1)
c
      print 600,(i,i=1,5)
  600 format(4h1  x,8x,5(1hb,i1,3h(x),7x))
c
      do 10 i=1,npoint
	 x = xl + float(i-1)*dx
c		      locate  x  with respect to knot array  t .
	 call interv ( t, n, x, left, mflag )
	 leftmk = left - k
c	    get b(i,k)(x)  in  values(i) , i=1,...,n .	k  of these,
c	 viz.  b(left-k+1,k)(x), ..., b(left,k)(x),  are supplied by
c	 bsplvb . all others are known to be zero a priori.
	 call bsplvb ( t, k, 1, x, left, values(leftmk+1) )
c
	 print 610, x, (values(j),j=3,7)
  610	 format(f7.3,5f12.7)
c
c	    zero out the values just computed in preparation for next
c	 evalulation point .
	 do 10 j=1,k
   10	    values(leftmk+j) = 0.
					stop
      end


      subroutine linear(x,y,nx,u,v,nu)
c-----------------------------------------------------------------------
c     this subprogram evaluates y(x) at the points x=u(i) by a simple
c  linear interpolation between points.
c
c  arguements-
c
c     x-input vector of abscissa values
c     y-input vector of ordinates
c     nx-length of x and y
c     u-input vector giving abscissa values at which v is to be
c       evaluated
c     v-output vector of v(u)
c     nu-length of u and v
c
c  entry points
c
c     call linear
c         entry point for the case when x and u vector are an increasing
c         sequence  (that is x(i+1).ge.x(i) and u(i+1).ge.u(i))
c
c     call rlinear
c         alternate entry point for the case when the x and u vectors
c         are a decreasing sequence. (that is x(i+1).le.x(i) and
c         u(i+1).le.u(i))
c
c  written-july 1979
c  language-university of minnesota fortran (mnf)
c-----------------------------------------------------------------------
      dimension x(nx),y(nx)
      dimension u(nu),v(nu)
      if(nx.lt.2) return
c--initialize pointers
      ix = 2
      iu = 1
  100 if((iu.gt.nu).or.(ix.gt.nx)) go to 130
          if(x(ix).ge.u(iu)) then
               grad=(y(ix)-y(ix-1))/(x(ix)-x(ix-1))
  110          if(x(ix).lt.u(iu)) go to 120
                    v(iu)=y(ix-1)+grad*(u(iu)-x(ix-1))
                    iu=iu+1
                    if(iu.gt.nu) return
                    go to 110
  120          continue
               ix=ix+1
          else
               ix=ix+1
          endif
      go to 100
  130 continue
      return
      entry rlinear(x,y,nx,u,v,nu)
c--this is the alternate entry point for the case when x and u are in
c--reverse order.
c--now start counters at far end and decrement the pointers instead of
c--incrementing them.
      if(nx.lt.2) return
      ix=nx-1
      iu=nu
  200 if((iu.lt.1).or.(ix.lt.1))go to 230
          if(x(ix).ge.u(iu)) then
               grad=(y(ix)-y(ix+1))/(x(ix)-x(ix+1))
  210          if(x(ix).lt.u(iu)) go to 220
                    v(iu)=y(ix+1)+grad*(u(iu)-x(ix+1))
                    iu=iu-1
                    if(iu.lt.1) return
                    go to 210
  220          continue
               ix=ix-1
          else
               ix=ix-1
          endif
      go to 200
  230 continue
      return
      end

c $Id$


program matrix_test
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    use :: matrix_mod, only : norm_matrix_rows
    implicit none
    integer :: i
    real(kind=DP), dimension(3, 4) :: matrix = reshape( [ (i, i=1, 12) ], &
                                                       shape(matrix))
    print '(A)', 'Original:'
    call print_matrix(matrix)
    call norm_matrix_rows(matrix)
    print '(A)', 'Normed:'
    call print_matrix(matrix)

contains

    subroutine print_matrix(matrix)
        implicit none
        real(kind=DP), dimension(:, :), intent(in) :: matrix
        integer :: i

        do i = 1, size(matrix, 1)
            print '(*(F9.3))', matrix(i, :)
        end do
    end subroutine print_matrix

end program matrix_test


      Real Function ZtoTsa(Z)

C*  This routine converts a height in meters into a temperature in Kelvin

      If (Z.lt.11000.) Then
          ZtoTsa=288. - Z/161.764              ! ramp to 220.
      Else If (Z.lt.20000.) Then
          ZtoTsa=220.
      Else If (Z.lt.50000.) Then
          ZtoTsa=220. + (Z-20000.) * .00166666 ! ramp to 270.
      Else If (Z.lt.90000.) Then
          ZtoTsa=270. - (Z-50000.) * .002      ! ramp to 190.
      Else
          ZtoTsa=190. + (Z-90000.) * .00566666 ! ramp to 360. (120km)
      End If

      Return
      End


SUBROUTINE stiff4(km,coord,ym,pr)
!
! This subroutine generates the "analytical" stiffness matrix
! for a four node quadrilateral in plane strain based on nip=4.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
 REAL(iwp)::e1,e2,g,x1,x2,x3,x4,y1,y2,y3,y4,a2,a2st3,alph,beta,c11,c21,   &
   c31,c41,c51,c61,c71,c81,c22,c32,c42,c52,c62,c72,c82,c33,c43,c53,c63,   &
   c73,c83,c44,c54,c64,c74,c84,c55,c65,c75,c85,c66,c76,c86,c77,c87,c88,   &
   f1,f2,s1,s2,s3,s4,t1,t2,t3,t4,pt5=0.5_iwp,one=1.0_iwp,two=2.0_iwp,     &
   d3=3.0_iwp,zero=0.0_iwp
 INTEGER::i,j
 e1=ym*(one-pr)/(one+pr)/(1-two*pr)
 e2=pr*e1/(one-pr)
 g=ym/two/(one+pr)
!
 x1=coord(1,1)
 x2=coord(2,1)
 x3=coord(3,1)
 x4=coord(4,1)
 y1=coord(1,2)
 y2=coord(2,2)
 y3=coord(3,2)
 y4=coord(4,2)
!
 a2=(x4-x2)*(y3-y1)-(x3-x1)*(y4-y2)
 a2st3=d3*a2*a2
!
 CALL groupa(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c11=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(1,1)=c11
!
 CALL groupa(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c33=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(3,3)=c33
!
 CALL groupa(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c55=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,5)=c55
!
 CALL groupa(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c77=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,7)=c77
!
 CALL groupa(y4,y3,y2,y1,x4,x3,x2,x1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c88=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,8)=c88
!
 CALL groupa(y1,y4,y3,y2,x1,x4,x3,x2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c22=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(2,2)=c22
!
 CALL groupa(y2,y1,y4,y3,x2,x1,x4,x3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c44=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,4)=c44
!
 CALL groupa(y3,y2,y1,y4,x3,x2,x1,x4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c66=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,6)=c66
!
 CALL groupb(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c21=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(2,1)=c21
!
 CALL groupb(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c43=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,3)=c43
!
 CALL groupb(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c65=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,5)=c65
!
 CALL groupb(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c87=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,7)=c87
!
 CALL groupc(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c31=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(3,1)=c31
!
 CALL groupc(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c53=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,3)=c53
!
 CALL groupc(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c75=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,5)=c75
!
 CALL groupc(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c71=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,1)=c71
!
 CALL groupc(y4,y3,y2,y1,x4,x3,x2,x1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c86=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,6)=c86
!
 CALL groupc(y1,y4,y3,y2,x1,x4,x3,x2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c82=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,2)=c82
!
 CALL groupc(y2,y1,y4,y3,x2,x1,x4,x3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c42=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,2)=c42
!
 CALL groupc(y3,y2,y1,y4,x3,x2,x1,x4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c64=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,4)=c64
!
 CALL groupd(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c41=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,1)=c41
!
 CALL groupd(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c63=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,3)=c63
!
 CALL groupd(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x3,x4,x1,x2,y3,y4,y1,y2,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c85=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,5)=c85
!
 CALL groupd(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x4,x1,x2,x3,y4,y1,y2,y3,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c72=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,2)=c72
!
 CALL groupd(y1,y2,y3,y4,x1,x2,x3,x4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c32=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(3,2)=c32
!
 CALL groupd(y2,y3,y4,y1,x2,x3,x4,x1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c54=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,4)=c54
!
 CALL groupd(y3,y4,y1,y2,x3,x4,x1,x2,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x3,x4,x1,x2,y3,y4,y1,y2,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c76=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,6)=c76
!
 CALL groupd(y4,y1,y2,y3,x4,x1,x2,x3,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x4,x1,x2,x3,y4,y1,y2,y3,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c81=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,1)=c81
!
 CALL groupe(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c51=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,1)=c51
!
 CALL groupe(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c73=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,3)=c73
!
 CALL groupe(y2,y1,y4,y3,x2,x1,x4,x3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c84=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,4)=c84
!
 CALL groupe(y3,y2,y1,y4,x3,x2,x1,x4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c62=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,2)=c62
!
 CALL groupf(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c61=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,1)=c61
!
 CALL groupf(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c83=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,3)=c83
!
 CALL groupf(y1,y2,y3,y4,x1,x2,x3,x4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c52=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,2)=c52
!
 CALL groupf(y2,y3,y4,y1,x2,x3,x4,x1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c74=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,4)=c74
!
 DO i=1,8
   DO j=i+1,8
     km(i,j)=km(j,i)
   END DO
 END DO
!
RETURN
CONTAINS
SUBROUTINE groupa(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=two*(y4-y2)**2
 s2=two*(x4-x2)**2
 s3=-s1/two
 s4=-s2/two
 t1=(y2-y3)**2+(y3-y4)**2+(y4-y2)**2
 t2=(x2-x3)**2+(x3-x4)**2+(x4-x2)**2
 t3=(y4-y3)**2-(y3-y2)**2
 t4=(x4-x3)**2-(x3-x2)**2
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupa
SUBROUTINE groupb(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=two*(x2-x4)*(y4-y2)
 s2=s1
 s3=-s1/2
 s4=s3
 t1=x2*(y4-two*y2+y3)+x3*(y2-two*y3+y4)+x4*(y2-two*y4+y3)
 t2=t1
 t3=x2*(y2-y3)+x3*(y4-y2)+x4*(y3-y4)
 t4=t3
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupb
SUBROUTINE groupc(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=(y4-y2)*(two*y1-y3-y4)
 s2=(x4-x2)*(two*x1-x3-x4)
 s3=(y4-y2)*(y4-y1)
 s4=(x4-x2)*(x4-x1)
 t1=(y3-y1)*(two*y2-y3-y4)
 t2=(x3-x1)*(two*x2-x3-x4)
 t3=(y3-y1)*(y3-y2)
 t4=(x3-x1)*(x3-x2)
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupc
SUBROUTINE groupd(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4
 s1=(x3-x1)*(y4-y2)+(x4-x1)*(y4-y2)
 s2=(y3-y1)*(x4-x2)+(y4-y1)*(x4-x2)
 s3=(x4-x1)*(y2-y4)
 s4=(y4-y1)*(x2-x4)
 t1=(x3-x1)*(y4-y2)+(x3-x1)*(y3-y2)
 t2=(y3-y1)*(x4-x2)+(y3-y1)*(x3-x2)
 t3=(x3-x1)*(y2-y3)
 t4=(y3-y1)*(x2-x3)
RETURN
END SUBROUTINE groupd
SUBROUTINE groupe(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=-(y4-y2)**2
 s2=-(x4-x2)**2
 s3=zero
 s4=zero
 t1=(y3+y1)*(y4+y2)-two*(y4-y2)**2-two*(y1*y3+y2*y4)
 t2=(x3+x1)*(x4+x2)-two*(x4-x2)**2-two*(x1*x3+x2*x4)
 t3=(y4-y2)*(y1-y2+y3-y4)
 t4=(x4-x2)*(x1-x2+x3-x4)
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupe
SUBROUTINE groupf(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4
 s1=(x4-x2)*(y4-y2)
 s2=s1
 s3=zero
 s4=zero
 t1=(x4-x2)*(y4-y2)+(x2-x1)*(y2-y3)+(x4-x1)*(y4-y3)
 t2=(y4-y2)*(x4-x2)+(y2-y1)*(x2-x3)+(y4-y1)*(x4-x3)
 t3=(x2-x1)*(y3-y2)+(x4-x1)*(y4-y3)
 t4=(y2-y1)*(x3-x2)+(y4-y1)*(x4-x3)
RETURN
END SUBROUTINE groupf
SUBROUTINE f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::f1,f2
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE f1f2
END SUBROUTINE stiff4


      real*8 function isr_tilde(x,beta)
      implicit none
      real*8 x,beta
      real*8 res
      real*8 PI
      PI=4.D0*DATAN(1.D0)
      res=0d0
      if (x .lt. 0.9999999d0) then
      res=-beta*(1d0+x)/2d0
      res=res-beta*beta*(
     c   (1d0+3d0*x*x)/(1d0-x)*dlog(x)
     c      +4d0*(1d0+x)*dlog(1d0-x)+5d0+x)
     c    /8d0
      res=res*(1d0-x)**(1-beta)
      endif
      res=res+
     c (1d0+3d0/4d0*beta+(27d0-8d0*PI*PI)/96d0*beta*beta)
     c  *beta
      isr_tilde=res
      end


module mod_binary_indexed_tree
  implicit none
  type fenwick_tree
    integer :: n
    integer, pointer :: arr(:)
  end type fenwick_tree
  private
  public :: fenwick_tree, init_bit, release_bit
  public :: add, summate, update, maximum
contains
  subroutine init_bit(bit,n)
    implicit none
    type(fenwick_tree) :: bit
    integer, intent(in) :: n
    bit%n = n
    allocate(bit%arr(n))
    bit%arr = 0
    return
  end subroutine init_bit
  subroutine release_bit(bit)
    implicit none
    type(fenwick_tree) :: bit
    if (associated(bit%arr)) deallocate(bit%arr)
    return
  end subroutine release_bit
  subroutine add(bit,i,v)
    implicit none
    type(fenwick_tree) :: bit
    integer, intent(in) :: i, v
    integer :: x
    x = i
    do while (x.le.bit%n)
      bit%arr(x) = bit%arr(x)+v
      x = x+and(x,-x)
    end do
    return
  end subroutine add
  function summate(bit,i) result(s)
    implicit none
    type(fenwick_tree) :: bit
    integer, intent(in) :: i
    integer :: x, s
    x = i
    s = 0
    do while (x.gt.0)
      s = s+bit%arr(x)
      x = x-and(x,-x)
    end do
    return
  end function summate
  subroutine update(bit,i,v)
    implicit none
    type(fenwick_tree) :: bit
    integer, intent(in) :: i, v
    integer :: x
    x = i
    do while (x.le.bit%n)
      if (bit%arr(x).lt.v) bit%arr(x) = v
      x = x+and(x,-x)
    end do
    return
  end subroutine update
  function maximum(bit,i) result(m)
    implicit none
    type(fenwick_tree) :: bit
    integer, intent(in) :: i
    integer :: x, m
    x = i
    m = 0
    do while (x.gt.0)
      m = max(m,bit%arr(x))
      x = x-and(x,-x)
    end do
    return
  end function maximum
end module mod_binary_indexed_tree