c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file tvshifte.f is a test program illustrating the
c     use of subroutine vshifte (see documentation for vshifte)
c
c ... required files off spherepack3.0
c
c     hrfft.f, vshifte.f
c
c     Let the analytic vector field (u,v) in geophysical coordinates be
c     given by
c
c          u  = -exp(x)*sin(p) + exp(-z)*cos(p) + exp(y)*sin(t)*sin(p)
c
c          v  = exp(y)*cos(p) + exp(z)*cos(t) - exp(x)*sin(t)*cos(p)
c
c     where t is the latitude coordinate, p is the longitude coordinate,
c     and x=cos(t)*cos(p),y=cos(t)*sin(p),z=sin(t) are the cartesian coordinates
c     restricted to the sphere.

c     The "offset" vector field (uoff,voff) is set equal to (u,v).
c     This is transferred to the "regular" grid in (ureg,vreg).  (ureg,vreg)
c     is then compared with (u,v) on the regular grid.  Finally (ureg,vreg)
c     is transferred back to (uoff,voff) which is again compared with (u,v).
c     The least squares error after each transformation with vshifte
c     is computed and printed.  Results from running the program on
c     a 2.5 degree equally spaced regular and offset grid is given.
c     Output from runs on separate platforms with 32 bit and 64 bit
c     floating point arithmetic is listed.
c
C *********************************************
C     OUTPUT
C *********************************************
c
c       vshifte arguments
c       ioff =  0 nlon = 144 nlat =  72
c       lsave =   608 lwork = 21024
c       ier =  0
c       least squares error
C ***   32 BIT ARITHMETIC
c       err2u =  0.377E-06 err2v =  0.328E-06
C ***   64 BIT ARITHMETIC
c       err2u =  0.777E-13 err2v =  0.659E-13

c       vshifte arguments
c       ioff =  1 nlon = 144 nlat =  72
c       lsave =   608 lwork = 21024
c       ier =  0
c       least squares error
C ***   32 BIT ARITHMETIC
c       err2u =  0.557E-06 err2v =  0.434E-06
C ***   64 BIT AIRTHMETIC
c       err2u =  0.148E-12 err2v =  0.118E-12
c
C *********************************************
C     END OF OUTPUT (CODE FOLLOWS)
C *********************************************
c
      program testvshifte
      implicit none
      integer nnlon,nnlat,nnlatp1,nnlat2,llsave,llwork
c
c     set equally spaced grid sizes in nnlat,nnlon
c
      parameter(nnlon=144,nnlat=72)
c
c     set parameters which depend on nnlat,nnlon
c
      parameter(nnlatp1=nnlat+1,nnlat2=nnlat+nnlat)
c     save work space
      parameter (llsave=2*(2*nnlat+nnlon)+32)
c     unsaved work space for nnlon even
      parameter (llwork = 2*nnlon*(nnlat+1))
c     unsaved work space for nnlon odd
c     parameter (llwork = nnlon*(5*nnlat+1))
      integer ioff,nlon,nlat,nlat2,j,i,lsave,lwork,ier
      real pi,dlat,dlon,dlat2,dlon2,lat,long,x,y,z,ex,ey,ez,emz
      real err2u,err2v,ue,ve,sint,sinp,cost,cosp
      real uoff(nnlon,nnlat),voff(nnlon,nnlat)
      real ureg(nnlon,nnlatp1),vreg(nnlon,nnlatp1)
      real wsave(llsave),work(llwork)
c
c     set resolution, work space lengths, and grid increments
c
      nlat = nnlat
      nlon = nnlon
      lsave = llsave
      nlat2 = nnlat2
      lwork = llwork
      pi = 4.0*atan(1.0)
      dlat = pi/nlat
      dlon = (pi+pi)/nlon
      dlat2 = 0.5*dlat
      dlon2 = 0.5*dlon
c
c     set (uoff,voff) = (u,v) on offset grid
c
      do j=1,nlon
	long = dlon2+(j-1)*dlon
	sinp = sin(long)
	cosp = cos(long)
	do i=1,nlat
	  lat = -0.5*pi+dlat2+(i-1)*dlat
	  sint = sin(lat)
	  cost = cos(lat)
	  x = cost*cosp
	  y = cost*sinp
	  z = sint
	  ex = exp(x)
	  ey = exp(y)
	  ez = exp(z)
	  emz = exp(-z)
	  uoff(j,i) =-ex*sinp+emz*cost+ey*sint*sinp
	  voff(j,i) = ey*cosp+ez*cost-ex*sint*cosp
	end do
      end do
c
c    initialize wsav for offset to regular shift
c
      ioff = 0
      call vshifti(ioff,nlon,nlat,lsave,wsave,ier)
c
c     write input arguments to vshifte
c
      write(*,100) ioff,nlon,nlat,lsave,lwork
  100 format(' vshifte arguments',
     +/' ioff = ',i2, ' nlon = ',i3,' nlat = ',i3,
     +/' lsave = ',i5, ' lwork = ',i5)
c
c     shift offset to regular grid
c
      call vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg,
     +             wsave,lsave,work,lwork,ier)
      write(*,200) ier
  200 format(' ier = ',i2)
      if (ier.eq.0) then
c
c     compute error in ureg,vreg
c
      err2u = 0.0
      err2v = 0.0
      do j=1,nlon
	long = (j-1)*dlon
	sinp = sin(long)
	cosp = cos(long)
	do i=1,nlat+1
	  lat = -0.5*pi+(i-1)*dlat
	  sint = sin(lat)
	  cost = cos(lat)
	  x = cost*cosp
	  y = cost*sinp
	  z = sint
	  ex = exp(x)
	  ey = exp(y)
	  ez = exp(z)
	  emz = exp(-z)
	  ue = -ex*sinp+emz*cost+ey*sint*sinp
	  ve = ey*cosp+ez*cost-ex*sint*cosp
	  err2u = err2u + (ureg(j,i)-ue)**2
	  err2v = err2v + (vreg(j,i)-ve)**2
	end do
      end do
      err2u = sqrt(err2u/(nlon*(nlat+1)))
      err2v = sqrt(err2v/(nlon*(nlat+1)))
      write(*,300) err2u,err2v
  300 format(' least squares error ',
     +/' err2u = ',e10.3, ' err2v = ',e10.3)
      end if
c
c    initialize wsav for regular to offset shift
c
      ioff = 1
      call vshifti(ioff,nlon,nlat,lsave,wsave,ier)
c
c     transfer regular grid values in (ureg,vreg) to offset grid in (uoff,voff)
c
      do j=1,nlon
	do i=1,nlat
	  uoff(j,i) = 0.0
	  voff(j,i) = 0.0
	end do
      end do
      write(*,100) ioff,nlon,nlat,lsave,lwork
      call vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg,
     +             wsave,lsave,work,lwork,ier)
      write(*,200) ier
      if (ier .eq. 0) then
c
c     compute error in uoff,voff
c
      err2u = 0.0
      err2v = 0.0
      do j=1,nlon
	long = dlon2+(j-1)*dlon
	sinp = sin(long)
	cosp = cos(long)
	do i=1,nlat
	  lat = -0.5*pi+dlat2+(i-1)*dlat
	  sint = sin(lat)
	  cost = cos(lat)
	  x = cost*cosp
	  y = cost*sinp
	  z = sint
	  ex = exp(x)
	  ey = exp(y)
	  ez = exp(z)
	  emz = exp(-z)
	  ue = -ex*sinp+emz*cost+ey*sint*sinp
	  ve = ey*cosp+ez*cost-ex*sint*cosp
	  err2u = err2u + (uoff(j,i)-ue)**2
	  err2v = err2v + (voff(j,i)-ve)**2
	end do
      end do
      err2u = sqrt(err2u/(nlon*(nlat+1)))
      err2v = sqrt(err2v/(nlon*(nlat+1)))
      write(*,300) err2u,err2v
      end if
      end


module slf_deriv

    use iso_fortran_env, only: r64 => real64
    implicit none

contains

    subroutine deriv(x,yin,yout)
        real(r64), intent(in) :: x(:), yin(:)
        real(r64), intent(out) :: yout(:)
        real(r64) :: dx2
        integer :: i,n

        n = size(yout)

        if ( n .lt. 3 ) then
            write (0,*) 'n should be at least 3!'
            return
        end if

        do i=2,n-1
            yout(i) = (yin(i+1)-yin(i-1))/(x(i+1)-x(i-1))
        end do
        dx2 = 2 * ( yin(3) + yin(1) - 2 * yin(2) ) / ( (x(3)-x(2))**2 + (x(2)-x(1))**2 )
        yout(1) = yout(2) + (x(1)-x(2))*dx2
        dx2 = 2 * ( yin(n) + yin(n-2) - 2 * yin(n-1) ) / ( (x(n)-x(n-1))**2 + (x(n-1)-x(n-2))**2 )
        yout(n) = yout(n-1) + (x(n)-x(n-1))*dx2
    end subroutine

    subroutine deriv2(x,yin,yout)
        real(r64), intent(in) :: x(:), yin(:)
        real(r64), intent(out) :: yout(:)
        integer :: i,n
        n = size(yout)

        do i=2,n-1
            yout(i) = 2 * ( yin(i+1) + yin(i-1) - 2 * yin(i) ) / ( (x(i+1)-x(i))**2 + (x(i-1)-x(i))**2 )
        end do
        yout(1) = yout(2) + ( x(1) - x(2) )*( yout(3)-yout(2) )/( x(3)-x(2) )
        yout(n) = yout(n-1) + ( x(n) - x(n-1) )*( yout(n-1)-yout(n-2) )/( x(n-1)-x(n-2) )
    end subroutine

end module


program combinations

  implicit none
  integer, parameter :: m_max = 3
  integer, parameter :: n_max = 5
  integer, dimension (m_max) :: comb
  character (*), parameter :: fmt = '(i0' // repeat (', 1x, i0', m_max - 1) // ')'

  call gen (1)

contains

  recursive subroutine gen (m)

    implicit none
    integer, intent (in) :: m
    integer :: n

    if (m > m_max) then
      write (*, fmt) comb
    else
      do n = 1, n_max
        if ((m == 1) .or. (n > comb (m - 1))) then
          comb (m) = n
          call gen (m + 1)
        end if
      end do
    end if

  end subroutine gen

end program combinations


!!# FUNCTION MODULE: <FUN_xyINTEGRALXX>
MODULE FUN_xyINTEGRALXX

!!## PURPOSE
!! Integrates the function $XX$ over a polygon in 2D.

!*******************************************************************************
!
!! xyINTEGRALXX_Pg integrates the function X*X over a polygon in 2D.
!
!  Discussion:
!
!    The polygon is bounded by the points (X(1:N), Y(1:N)).
!
!    INTEGRAL = (1/12) * sum ( 1 <= I <= N )
!      ( X(I)**3 + X(I)**2 * X(I-1) + X(I) * X(I-1)**2 + X(I-1)**3 )
!      * ( Y(I) - Y(I-1) )
!
!    where X(0) and Y(0) should be replaced by X(N) and Y(N).
!
!  Modified:
!
!    10 July 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    SF Bockman,
!    Generalizing the Formula for Areas of Polygons to Moments,
!    American Mathematical Society Monthly,
!    1989, pages 131-132.
!
!  Parameters:
!
!    Input, integer N, the number of vertices of the polygon.
!    N should be at least 3 for a nonzero INTEGRALXX.
!
!    Input, real ( kind = 8 ) Pg(2,N), the coordinates of the vertices
!    of the polygon.  These vertices should be given in
!    counter clockwise order.
!
!    Output, real ( kind = 8 ) INTEGRALXX, the value of the integral.
!

!!## EXTERNAL MODULES
USE FUN_Error                                   !!((04-A-FUN_Error.f90))
USE FUN_xyAVERAGEX                              !!((05-A-FUN_xyAVERAGEX.f90))
USE FUN_xyINTEGRAL1                             !!((06-A-FUN_xyINTEGRAL1.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALXX_Pg
 MODULE PROCEDURE xyINTEGRALXX_Pg_Rsp
 MODULE PROCEDURE xyINTEGRALXX_Pg_Rdp
END INTERFACE

!!## PROCEDURE OVERLOADING
!INTERFACE xyINTEGRALXX_Ls
! MODULE PROCEDURE xyINTEGRALXX_Ls_Rsp
! MODULE PROCEDURE xyINTEGRALXX_Ls_Rdp
!END INTERFACE
!
!!!## PUBLIC ACCESS LIST
!PUBLIC :: xyINTEGRALXX_Ls
!PUBLIC :: xyINTEGRALXX_Ls_Rsp
!PUBLIC :: xyINTEGRALXX_Ls_Rdp

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALXX_Pg
PUBLIC :: xyINTEGRALXX_Pg_Rsp
PUBLIC :: xyINTEGRALXX_Pg_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!
!!!### FUNCTION <xyINTEGRALXX_Ls_Rsp>
!FUNCTION xyINTEGRALXX_Ls_Rsp( Ls ) RESULT(INTEGRALX)
!
!!!#### LOCAL MAPPINGS
!USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
!USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
!INCLUDE "06-A-FUN_xyINTEGRALXX_Ls.f90.hdr"
!!!--begin--
!INCLUDE "06-A-FUN_xyINTEGRALXX_Ls.f90.bdy"
!!!--end--
!END FUNCTION
!
!
!
!!!### FUNCTION <xyINTEGRALXX_Ls_Rdp>
!FUNCTION xyINTEGRALXX_Ls_Rdp( Ls ) RESULT(INTEGRALX)
!
!!!#### LOCAL MAPPINGS
!USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rsp.f90))
!USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
!INCLUDE "06-A-FUN_xyINTEGRALXX_Ls.f90.hdr"
!!!--begin--
!INCLUDE "06-A-FUN_xyINTEGRALXX_Ls.f90.bdy"
!!!--end--
!END FUNCTION

!!### FUNCTION <xyINTEGRALXX_Pg_Rsp>
FUNCTION xyINTEGRALXX_Pg_Rsp( N , Pg ) RESULT(INTEGRALXX)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALXX_Pg.f90.hdr"

!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALXX_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### FUNCTION <xyINTEGRALXX_Pg_Rdp>
FUNCTION xyINTEGRALXX_Pg_Rdp( N , Pg ) RESULT(INTEGRALXX)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALXX_Pg.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALXX_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE


submodule(forlab) forlab_eye
    use forlab_kinds

contains
    !! Default Versions
    module procedure eye_1_default
        integer :: i
        eye_1_default = zeros(dim1, dim1)
        do i = 1, dim1
            eye_1_default (i, i) = 1.0d0
        end do
        return
    end procedure

    module procedure eye_2_default
        integer :: i
        eye_2_default = zeros(dim1, dim2)
        do i = 1, min(dim1, dim2)
            eye_2_default (i, i) = 1.0d0
        end do
        return
    end procedure

    !! Multi-precision versions
    module procedure eye_1_sp
        integer :: i
        eye_1_sp = zeros(dim1, dim1, flag)
        do i = 1, dim1
            eye_1_sp (i, i) = 1.0_sp
        end do
        return
    end procedure

    module procedure eye_2_sp
        integer :: i
        eye_2_sp = zeros(dim1, dim2, flag)
        do i = 1, min(dim1, dim2)
            eye_2_sp (i, i) = 1.0_sp
        end do
        return
    end procedure

    module procedure eye_1_dp
        integer :: i
        eye_1_dp = zeros(dim1, dim1, flag)
        do i = 1, dim1
            eye_1_dp (i, i) = 1.0_dp
        end do
        return
    end procedure

    module procedure eye_2_dp
        integer :: i
        eye_2_dp = zeros(dim1, dim2, flag)
        do i = 1, min(dim1, dim2)
            eye_2_dp (i, i) = 1.0_dp
        end do
        return
    end procedure

    module procedure eye_1_qp
        integer :: i
        eye_1_qp = zeros(dim1, dim1, flag)
        do i = 1, dim1
            eye_1_qp (i, i) = 1.0_qp
        end do
        return
    end procedure

    module procedure eye_2_qp
        integer :: i
        eye_2_qp = zeros(dim1, dim2, flag)
        do i = 1, min(dim1, dim2)
            eye_2_qp (i, i) = 1.0_qp
        end do
        return
    end procedure

end submodule


program mydebug
use hybrid
! call test1()
! call qrtest()

! call finitedifftest
! call doglegtest
call FsolveHybridTest
write(*,*) 'press any key to continue'
read(*,*)

end program mydebug

subroutine doglegtest
use myutility; use hybrid
! subroutine to test dogleg

implicit none
real(kind=db), dimension(3,3) :: jacob, Q, R
real(kind=db), dimension(3) :: x0, p, Qtf
external  :: funs2
real(kind=db), dimension(3) ::  fval
real(kind=db) :: delta
integer :: flag
! real(kind=db), dimension(2,2) :: GetJacobian

x0(1) = 0.5_db
x0(2) = 1.0_db
x0(3) = 1.5_db
delta = 0.10_db

call funs2(x0,fval)
write(*,*) 'funs2([0.50, 1.00. 1.50 ]):'
write(*,*) fval

x0 = x0+1
call funs2(x0,fval)
call GetJacobian(jacob,  funs2, x0, 0.0001_db,fval)
call QRfactorization(jacob,Q,R)

Qtf = matmul(transpose(Q), fval)
call dogleg(p,Q,R,delta,Qtf,flag)

write(*,*) 'p:'
write(*,*) p
write(*,*) 'flag:'
write(*,*) flag

end subroutine doglegtest

subroutine finitedifftest()
use myutility; use hybrid, only : GetJacobian
! test finite difference
implicit none

real(kind=db), dimension(2,2) :: jacob
real(kind=db), dimension(2) :: x0
external  :: funs1
real(kind=db), dimension(2) ::  fval
! real(kind=db), dimension(2,2) :: GetJacobian

x0(1) = 2.0_db
x0(2) = 3.0_db

call funs1(x0, fval)
call GetJacobian(jacob,  funs1, x0, 0.001_db,fval)

call MatrixWrite(jacob)

end subroutine finitedifftest

subroutine funs1(x, fval0)
use myutility;
implicit none
real(kind=db), intent(IN), dimension(:) :: x
real(kind=db), intent(OUT), dimension(:) :: fval0

fval0(1) = x(2) - x(1)**2
fval0(2) = 2 - x(1) - x(2)

end subroutine funs1

subroutine funs3(x, fval0)
use myutility;
implicit none
real(kind=db), intent(IN), dimension(:) :: x
real(kind=db), intent(OUT), dimension(:) :: fval0

fval0(1) = 10_db*(x(2) - x(1)**2)
fval0(2) = 2 - x(1) - x(2)

end subroutine funs3

subroutine funs2(x, fval0)
use myutility;
! a little difficult function
! solution x = [0.50, 1.00. 1.50 ]  (+ 2pi*n)

implicit none
real(kind=db), intent(IN), dimension(:) :: x
real(kind=db), intent(OUT), dimension(:) :: fval0

fval0(1) = 1.20_db * sin(x(1)) -1.40_db*cos(x(2))+ 0.70_db*sin(x(3)) &
			- 0.517133908732486_db

fval0(2) = 0.80_db * cos(x(1)) -0.50_db*sin(x(2))+ 1.00_db*cos(x(3)) &
			- 0.352067758776053_db

fval0(3) = 3.50_db * sin(x(1)) -4.25_db*cos(x(2))+ 2.80_db*cos(x(3))  &
			+ 0.4202312501553165_db

end subroutine funs2

subroutine qrtest
use myutility; use hybrid, only : QRfactorization, QRupdate
! test QR factorization and update

implicit none
real(kind=db), dimension(5,5) ::  Q,  A3
real(kind=db), dimension(5,5) :: A, R ,A2, A4, A5, A6, B1, B2
real(kind=db), dimension(5) :: u,v
INTEGER              :: isize
INTEGER,ALLOCATABLE  :: iseed(:)

! set a seed.
CALL RANDOM_SEED(SIZE=isize)
ALLOCATE( iseed(isize) )
CALL RANDOM_SEED(GET=iseed)
iseed = 1
CALL RANDOM_SEED(PUT = iseed)

CALL RANDOM_NUMBER(A)           ! generate  random number
A = A - 0.5
write(*,*) 'A:'
call MatrixWrite( A )

Q = 1
R = 1
call QRfactorization(A,Q,R)

A2 = matmul(Q , R)
A3 = matmul(Q , transpose(Q))

write(*,*) 'Q:'
call MatrixWrite( Q )
write(*,*) 'R:'
call MatrixWrite( R )
write(*,*) 'Q*R:'
call MatrixWrite( A2)
write(*,*) "Q*Q':"
call MatrixWrite( A3)
A3 = A2 - A
write(*,*) "Q*R - A:"
call MatrixWrite( A3)

! update test
call RANDOM_NUMBER(u)
call RANDOM_NUMBER(v)
u = (u-0.5) * 1
v = (v-0.5) * 1

write(*,*) ' '
write(*,*) 'update A '
call MatrixWrite( A+outer(u,v))
call QRupdate(Q,R,u,v)

write(*,*) 'update Q:'
call MatrixWrite( Q )
write(*,*) 'update R:'
call MatrixWrite( R )
write(*,*) "Q*Q':"
call MatrixWrite( matmul(Q , transpose(Q)))
write(*,*) "Q*R - A:"
call MatrixWrite( matmul(Q , R) - (A + outer(u,v)))

! write(*,*) "Q*Q':"
! call MatrixWrite( A3)
!

end subroutine qrtest

subroutine temp
! temp place to put code

end subroutine temp


! RUN: %python %S/test_folding.py %s %flang_fc1
! Test operation folding edge case (both expected value and messages)
! These tests make assumptions regarding real(4) and integer(4) extrema.

#define TEST_ISNAN(v) logical, parameter :: test_##v =.NOT.(v.EQ.v)

module integer_tests
  integer(4), parameter :: i4_pmax = 2147483647_4
  ! Fortran grammar rule R605 prevents from writing -2147483648_4 in an
  ! expression because literal-constant are not signed so this would parse
  ! to -(2147483648_4) and 2147483648_4 is not accepted as a literal-constant.
  ! However, one can reach this value with operations.
  integer(4), parameter :: i4_nmax = -2147483647_4 - 1_4

  ! Integer division by zero are not tested here because they are handled as fatal
  ! errors in constants.

  !WARN: warning: INTEGER(4) negation overflowed
  logical, parameter :: test_overflow_unary_minus1 = (-i4_nmax).EQ.i4_nmax
  logical, parameter :: test_no_overflow_unary_minus1 = (-i4_pmax).EQ.(i4_nmax+1_4)
  logical, parameter :: test_no_overflow_unary_plus1 = (+i4_pmax).EQ.i4_pmax
  logical, parameter :: test_no_overflow_unary_plus2 = (+i4_nmax).EQ.i4_nmax

  !WARN: warning: INTEGER(4) addition overflowed
  logical, parameter :: test_overflow_add1 = (i4_pmax+1_4).EQ.i4_nmax
  !WARN: warning: INTEGER(4) addition overflowed
  logical, parameter :: test_overflow_add2 = (i4_nmax + (-1_4)).EQ.i4_pmax
  !WARN: warning: INTEGER(4) addition overflowed
  logical, parameter :: test_overflow_add3 = (i4_pmax + i4_pmax).EQ.(-2_4)
  !WARN: warning: INTEGER(4) addition overflowed
  logical, parameter :: test_overflow_add4 = (i4_nmax + i4_nmax).EQ.(0_4)
  logical, parameter :: test_no_overflow_add1 = (i4_pmax + 0_4).EQ.i4_pmax
  logical, parameter :: test_no_overflow_add2 = (i4_nmax + (-0_4)).EQ.i4_nmax
  logical, parameter :: test_no_overflow_add3 = (i4_pmax + i4_nmax).EQ.(-1_4)
  logical, parameter :: test_no_overflow_add4 = (i4_nmax + i4_pmax).EQ.(-1_4)

  !WARN: warning: INTEGER(4) subtraction overflowed
  logical, parameter :: test_overflow_sub1 = (i4_nmax - 1_4).EQ.i4_pmax
  !WARN: warning: INTEGER(4) subtraction overflowed
  logical, parameter :: test_overflow_sub2 = (i4_pmax - (-1_4)).EQ.i4_nmax
  !WARN: warning: INTEGER(4) subtraction overflowed
  logical, parameter :: test_overflow_sub3 = (i4_nmax - i4_pmax).EQ.(1_4)
  !WARN: warning: INTEGER(4) subtraction overflowed
  logical, parameter :: test_overflow_sub4 = (i4_pmax - i4_nmax).EQ.(-1_4)
  logical, parameter :: test_no_overflow_sub1 = (i4_nmax - 0_4).EQ.i4_nmax
  logical, parameter :: test_no_overflow_sub2 = (i4_pmax - (-0_4)).EQ.i4_pmax
  logical, parameter :: test_no_overflow_sub3 = (i4_nmax - i4_nmax).EQ.0_4
  logical, parameter :: test_no_overflow_sub4 = (i4_pmax - i4_pmax).EQ.0_4

  !WARN: warning: INTEGER(4) multiplication overflowed
  logical, parameter :: test_overflow_mult1 = (i4_pmax*2_4).EQ.(-2_4)
  !WARN: warning: INTEGER(4) multiplication overflowed
  logical, parameter :: test_overflow_mult2 = (i4_nmax*2_4).EQ.(0_4)
  !WARN: warning: INTEGER(4) multiplication overflowed
  logical, parameter :: test_overflow_mult3 = (i4_nmax*i4_nmax).EQ.(0_4)
  !WARN: warning: INTEGER(4) multiplication overflowed
  logical, parameter :: test_overflow_mult4 = (i4_pmax*i4_pmax).EQ.(1_4)

  !WARN: warning: INTEGER(4) division overflowed
  logical, parameter :: test_overflow_div1 = (i4_nmax/(-1_4)).EQ.(i4_nmax)
  logical, parameter :: test_no_overflow_div1 = (i4_nmax/(-2_4)).EQ.(1_4 + i4_pmax/2_4)
  logical, parameter :: test_no_overflow_div2 = (i4_nmax/i4_nmax).EQ.(1_4)

  !WARN: warning: INTEGER(4) power overflowed
  logical, parameter :: test_overflow_pow1 = (i4_pmax**2_4).EQ.(1_4)
  !WARN: warning: INTEGER(4) power overflowed
  logical, parameter :: test_overflow_pow3 = (i4_nmax**2_4).EQ.(0_4)
  logical, parameter :: test_no_overflow_pow1 = ((-1_4)**i4_nmax).EQ.(1_4)
  logical, parameter :: test_no_overflow_pow2 = ((-1_4)**i4_pmax).EQ.(-1_4)

end module

module real_tests
  ! Test real(4) operation folding on edge cases (inf and NaN)

  real(4), parameter :: r4_pmax = 3.4028235E38
  real(4), parameter :: r4_nmax = -3.4028235E38
  !WARN: warning: invalid argument on division
  real(4), parameter :: r4_nan = 0._4/0._4
  TEST_ISNAN(r4_nan)
  !WARN: warning: division by zero
  real(4), parameter :: r4_pinf = 1._4/0._4
  !WARN: warning: division by zero
  real(4), parameter :: r4_ninf = -1._4/0._4

  logical, parameter :: test_r4_nan_parentheses1 = .NOT.(((r4_nan)).EQ.r4_nan)
  logical, parameter :: test_r4_nan_parentheses2 = .NOT.(((r4_nan)).NE.r4_nan)
  logical, parameter :: test_r4_pinf_parentheses = ((r4_pinf)).EQ.r4_pinf
  logical, parameter :: test_r4_ninf_parentheses = ((r4_ninf)).EQ.r4_ninf

  ! No warnings expected
  logical, parameter :: test_r4_negation1 = (-r4_pmax).EQ.r4_nmax
  logical, parameter :: test_r4_negation2 = (-r4_nmax).EQ.r4_pmax
  logical, parameter :: test_r4_negation3 = (-r4_pinf).EQ.r4_ninf
  logical, parameter :: test_r4_negation4 = (-r4_ninf).EQ.r4_pinf
  logical, parameter :: test_r4_plus1 = (+r4_pmax).EQ.r4_pmax
  logical, parameter :: test_r4_plus2 = (+r4_nmax).EQ.r4_nmax
  logical, parameter :: test_r4_plus3 = (+r4_pinf).EQ.r4_pinf
  logical, parameter :: test_r4_plus4 = (+r4_ninf).EQ.r4_ninf
  ! NaN propagation , no warnings expected (quiet)
  real(4), parameter :: r4_nan_minus = (-r4_nan)
  TEST_ISNAN(r4_nan_minus)
  real(4), parameter :: r4_nan_plus = (+r4_nan)
  TEST_ISNAN(r4_nan_plus)

  !WARN: warning: overflow on addition
  logical, parameter :: test_inf_r4_add9 = (r4_pmax + r4_pmax).eq.(r4_pinf)
  !WARN: warning: overflow on addition
  logical, parameter :: test_inf_r4_add10 = (r4_nmax + r4_nmax).eq.(r4_ninf)
  !WARN: warning: overflow on subtraction
  logical, parameter :: test_inf_r4_sub9 = (r4_pmax - r4_nmax).eq.(r4_pinf)
  !WARN: warning: overflow on subtraction
  logical, parameter :: test_inf_r4_sub10 = (r4_nmax - r4_pmax).eq.(r4_ninf)

  ! No warnings expected below (inf propagation).
  logical, parameter :: test_inf_r4_add1 = (r4_pinf + r4_pinf).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_add2 = (r4_ninf + r4_ninf).EQ.(r4_ninf)
  logical, parameter :: test_inf_r4_add3 = (r4_pinf + r4_nmax).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_add4 = (r4_pinf + r4_pmax).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_add5 = (r4_ninf + r4_pmax).EQ.(r4_ninf)
  logical, parameter :: test_inf_r4_add6 = (r4_ninf + r4_nmax).EQ.(r4_ninf)
  logical, parameter :: test_inf_r4_add7 = (r4_ninf + 0._4).EQ.(r4_ninf)
  logical, parameter :: test_inf_r4_add8 = (r4_pinf + 0._4).EQ.(r4_pinf)

  !WARN: warning: invalid argument on subtraction
  real(4), parameter :: r4_nan_sub1 = r4_pinf - r4_pinf
  TEST_ISNAN(r4_nan_sub1)
  !WARN: warning: invalid argument on subtraction
  real(4), parameter :: r4_nan_sub2 = r4_ninf - r4_ninf
  TEST_ISNAN(r4_nan_sub2)
  !WARN: warning: invalid argument on addition
  real(4), parameter :: r4_nan_add1 = r4_ninf + r4_pinf
  TEST_ISNAN(r4_nan_add1)
  !WARN: warning: invalid argument on addition
  real(4), parameter :: r4_nan_add2 = r4_pinf + r4_ninf
  TEST_ISNAN(r4_nan_add2)

  ! No warnings expected here (quite NaN propagation)
  real(4), parameter :: r4_nan_sub3 = 0._4 - r4_nan
  TEST_ISNAN(r4_nan_sub3)
  real(4), parameter :: r4_nan_sub4 = r4_nan - r4_pmax
  TEST_ISNAN(r4_nan_sub4)
  real(4), parameter :: r4_nan_sub5 = r4_nan - r4_nmax
  TEST_ISNAN(r4_nan_sub5)
  real(4), parameter :: r4_nan_sub6 = r4_nan - r4_nan
  TEST_ISNAN(r4_nan_sub6)
  real(4), parameter :: r4_nan_add3 = 0._4 + r4_nan
  TEST_ISNAN(r4_nan_add3)
  real(4), parameter :: r4_nan_add4 = r4_nan + r4_pmax
  TEST_ISNAN(r4_nan_add4)
  real(4), parameter :: r4_nan_add5 = r4_nmax + r4_nan
  TEST_ISNAN(r4_nan_add5)
  real(4), parameter :: r4_nan_add6 = r4_nan + r4_nan
  TEST_ISNAN(r4_nan_add6)

  !WARN: warning: overflow on multiplication
  logical, parameter :: test_inf_r4_mult1 = (1.5_4*r4_pmax).eq.(r4_pinf)
  !WARN: warning: overflow on multiplication
  logical, parameter :: test_inf_r4_mult2 = (1.5_4*r4_nmax).eq.(r4_ninf)
  !WARN: warning: overflow on division
  logical, parameter :: test_inf_r4_div1 = (r4_nmax/(-0.5_4)).eq.(r4_pinf)
  !WARN: warning: overflow on division
  logical, parameter :: test_inf_r4_div2 = (r4_pmax/(-0.5_4)).eq.(r4_ninf)

  ! No warnings expected below (inf propagation).
  logical, parameter :: test_inf_r4_mult3 = (r4_pinf*r4_pinf).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_mult4 = (r4_ninf*r4_ninf).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_mult5 = (r4_pinf*0.1_4).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_mult6 = (r4_ninf*r4_nmax).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_div3 = (r4_pinf/0.).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_div4 = (r4_ninf/0.).EQ.(r4_ninf)
  logical, parameter :: test_inf_r4_div5 = (0./r4_pinf).EQ.(0.)
  logical, parameter :: test_inf_r4_div6 = (0./r4_ninf).EQ.(0.)
  logical, parameter :: test_inf_r4_div7 = (r4_pinf/r4_pmax).EQ.(r4_pinf)
  logical, parameter :: test_inf_r4_div8 = (r4_pinf/r4_nmax).EQ.(r4_ninf)
  logical, parameter :: test_inf_r4_div9 = (r4_nmax/r4_pinf).EQ.(0.)
  logical, parameter :: test_inf_r4_div10 = (r4_nmax/r4_ninf).EQ.(0.)

  !WARN: warning: invalid argument on division
  real(4), parameter :: r4_nan_div1 = 0._4/0._4
  TEST_ISNAN(r4_nan_div1)
  !WARN: warning: invalid argument on division
  real(4), parameter :: r4_nan_div2 = r4_ninf/r4_ninf
  TEST_ISNAN(r4_nan_div2)
  !WARN: warning: invalid argument on division
  real(4), parameter :: r4_nan_div3 = r4_ninf/r4_pinf
  TEST_ISNAN(r4_nan_div3)
  !WARN: warning: invalid argument on division
  real(4), parameter :: r4_nan_div4 = r4_pinf/r4_ninf
  TEST_ISNAN(r4_nan_div4)
  !WARN: warning: invalid argument on division
  real(4), parameter :: r4_nan_div5 = r4_pinf/r4_pinf
  TEST_ISNAN(r4_nan_div5)
  !WARN: warning: invalid argument on multiplication
  real(4), parameter :: r4_nan_mult1 = r4_pinf*0._4
  TEST_ISNAN(r4_nan_mult1)
  !WARN: warning: invalid argument on multiplication
  real(4), parameter :: r4_nan_mult2 = 0._4*r4_ninf
  TEST_ISNAN(r4_nan_mult2)

  ! No warnings expected here (quite NaN propagation)
  real(4), parameter :: r4_nan_div6 = 0._4/r4_nan
  TEST_ISNAN(r4_nan_div6)
  real(4), parameter :: r4_nan_div7 = r4_nan/r4_nan
  TEST_ISNAN(r4_nan_div7)
  real(4), parameter :: r4_nan_div8 = r4_nan/0._4
  TEST_ISNAN(r4_nan_div8)
  real(4), parameter :: r4_nan_div9 = r4_nan/1._4
  TEST_ISNAN(r4_nan_div9)
  real(4), parameter :: r4_nan_mult3 = r4_nan*1._4
  TEST_ISNAN(r4_nan_mult3)
  real(4), parameter :: r4_nan_mult4 = r4_nan*r4_nan
  TEST_ISNAN(r4_nan_mult4)
  real(4), parameter :: r4_nan_mult5 = 0._4*r4_nan
  TEST_ISNAN(r4_nan_mult5)

  ! TODO: ** operator folding
  !  logical, parameter :: test_inf_r4_exp1 = (r4_pmax**2._4).EQ.(r4_pinf)

  ! Relational operator edge cases (No warnings expected?)
  logical, parameter :: test_inf_r4_eq1 = r4_pinf.EQ.r4_pinf
  logical, parameter :: test_inf_r4_eq2 = r4_ninf.EQ.r4_ninf
  logical, parameter :: test_inf_r4_eq3 = .NOT.(r4_pinf.EQ.r4_ninf)
  logical, parameter :: test_inf_r4_eq4 = .NOT.(r4_pinf.EQ.r4_pmax)

  logical, parameter :: test_inf_r4_ne1 = .NOT.(r4_pinf.NE.r4_pinf)
  logical, parameter :: test_inf_r4_ne2 = .NOT.(r4_ninf.NE.r4_ninf)
  logical, parameter :: test_inf_r4_ne3 = r4_pinf.NE.r4_ninf
  logical, parameter :: test_inf_r4_ne4 = r4_pinf.NE.r4_pmax

  logical, parameter :: test_inf_r4_gt1 = .NOT.(r4_pinf.GT.r4_pinf)
  logical, parameter :: test_inf_r4_gt2 = .NOT.(r4_ninf.GT.r4_ninf)
  logical, parameter :: test_inf_r4_gt3 = r4_pinf.GT.r4_ninf
  logical, parameter :: test_inf_r4_gt4 = r4_pinf.GT.r4_pmax

  logical, parameter :: test_inf_r4_lt1 = .NOT.(r4_pinf.LT.r4_pinf)
  logical, parameter :: test_inf_r4_lt2 = .NOT.(r4_ninf.LT.r4_ninf)
  logical, parameter :: test_inf_r4_lt3 = r4_ninf.LT.r4_pinf
  logical, parameter :: test_inf_r4_lt4 = r4_pmax.LT.r4_pinf

  logical, parameter :: test_inf_r4_ge1 = r4_pinf.GE.r4_pinf
  logical, parameter :: test_inf_r4_ge2 = r4_ninf.GE.r4_ninf
  logical, parameter :: test_inf_r4_ge3 = .NOT.(r4_ninf.GE.r4_pinf)
  logical, parameter :: test_inf_r4_ge4 = .NOT.(r4_pmax.GE.r4_pinf)

  logical, parameter :: test_inf_r4_le1 = r4_pinf.LE.r4_pinf
  logical, parameter :: test_inf_r4_le2 = r4_ninf.LE.r4_ninf
  logical, parameter :: test_inf_r4_le3 = .NOT.(r4_pinf.LE.r4_ninf)
  logical, parameter :: test_inf_r4_le4 = .NOT.(r4_pinf.LE.r4_pmax)

  ! Invalid relational argument
  logical, parameter :: test_nan_r4_eq1 = .NOT.(r4_nan.EQ.r4_nan)
  logical, parameter :: test_nan_r4_ne1 = .NOT.(r4_nan.NE.r4_nan)

end module

! TODO: edge case conversions
! TODO: complex tests (or is real tests enough?)

! Logical operation (with logical arguments) cannot overflow or be invalid.
! CHARACTER folding operations may cause host memory exhaustion if the
! string are very large. This will cause a fatal error for the program
! doing folding (e.g. f18), so there is nothing very interesting to test here.


! { dg-do run }

program e_53_2
  !$omp declare target (fib)
  integer :: x, fib
  !$omp target map(from: x)
    x = fib (25)
  !$omp end target
  if (x /= fib (25)) call abort
end program

integer recursive function fib (n) result (f)
  !$omp declare target
  integer :: n
  if (n <= 0) then
    f = 0
  else if (n == 1) then
    f = 1
  else
    f = fib (n - 1) + fib (n - 2)
  end if
end function


subroutine matgen(imat, a, lda, n, d, info)
  implicit none

  integer :: imat, n, lda, info
  real(kind(1.d0)) :: a(lda,n)
  real(kind(1.d0)) :: d(n)

  real(kind(1.d0)), allocatable :: work(:)
  character(len=3) :: path
  character :: type, dist, pack
  integer :: kl, ku, mode, i
  real(kind(1.d0)) :: anorm, cndnum, rcondc
  integer :: iseed(4)
  real(kind(1.d0)), parameter :: done=1.d0, dmone=-1.d0

  iseed = (/1988, 1989, 1990, 1991/)
  info  = 0
  path(1:1) = 'Double precision'
  path(2:3) = 'SY'

  select case(imat)
  case(1)
     dist   = 'U'  ! uniform distribution
     type   = 'P'  ! symmetric, positive-definite
     mode   = 0    ! use D
     cndnum = n    ! the condition number
     anorm  = n    ! the matrix norm
     kl     = n-1  ! upper bandwidth
     ku     = n-1  ! lower bandwidth
     pack   = 'N'  ! no pack
     !write(*,'("=======================")')
     !write(*,'("Dist  : ",a1)')dist
     !write(*,'("Type  : ",a1)')type
     !write(*,'("Mode  : ",i1)')mode
     !write(*,'("Anorm : ",es10.3)')anorm
     !write(*,'("Cond  : ",es10.3)')cndnum
     !write(*,'(" ")')

     allocate(work(3*n), stat=info)
     if(info .ne. 0) return

     do i=1,n
        d(i) = n-i+1
     end do

     call dlatms( n, n, dist, iseed, type, &
          & d, mode, cndnum, anorm, kl, ku, &
          & pack, a, n, work, info )

     deallocate(work, stat=info)

     if(info .ne. 0) return

  case(2)
     dist   = 'N'  ! uniform distribution
     type   = 'P'  ! symmetric, positive-definite
     mode   = 5    ! random numbers in the range
                   ! ( 1/COND , 1 ) such that their logarithms
                   ! are uniformly distributed.
     cndnum = 1e10 ! the condition number
     anorm  = 1.d0 ! the matrix norm
     kl     = n-1  ! upper bandwidth
     ku     = n-1  ! lower bandwidth
     pack   = 'N'  ! no pack
     !write(*,'("=======================")')
     !write(*,'("Dist  : ",a1)')dist
     !write(*,'("Type  : ",a1)')type
     !write(*,'("Mode  : ",i1)')mode
     !write(*,'("Anorm : ",es10.3)')anorm
     !write(*,'("Cond  : ",es10.3)')cndnum
     !write(*,'(" ")')

     allocate(work(3*n), stat=info)
     if(info .ne. 0) return

     call dlatms( n, n, dist, iseed, type, &
          & d, mode, cndnum, anorm, kl, ku, &
          & pack, a, n, work, info )
     if(info .ne. 0) return

     call sort(d, n)

     deallocate(work, stat=info)

  case(3)
     dist   = 'N'  ! uniform distribution
     type   = 'P'  ! symmetric, positive-definite
     mode   = 3    ! D(I)=COND**(-(I-1)/(N-1))
     cndnum = 1e5  ! the condition number
     anorm  = 100.d0 ! the matrix norm
     kl     = n-1  ! upper bandwidth
     ku     = n-1  ! lower bandwidth
     pack   = 'N'  ! no pack
     !write(*,'("=======================")')
     !write(*,'("Dist  : ",a1)')dist
     !write(*,'("Type  : ",a1)')type
     !write(*,'("Mode  : ",i1)')mode
     !write(*,'("Anorm : ",es10.3)')anorm
     !write(*,'("Cond  : ",es10.3)')cndnum
     !write(*,'(" ")')

     allocate(work(3*n), stat=info)
     if(info .ne. 0) return

     call dlatms( n, n, dist, iseed, type, &
          & d, mode, cndnum, anorm, kl, ku, &
          & pack, a, n, work, info )
     if(info .ne. 0) return

     deallocate(work, stat=info)

  case(4)
     dist   = 'N'  ! uniform distribution
     type   = 'P'  ! symmetric, positive-definite
     mode   = 4    ! D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
     cndnum = 1e2  ! the condition number
     anorm  = 1000.d0 ! the matrix norm
     kl     = n-1  ! upper bandwidth
     ku     = n-1  ! lower bandwidth
     pack   = 'N'  ! no pack
     !write(*,'("=======================")')
     !write(*,'("Dist  : ",a1)')dist
     !write(*,'("Type  : ",a1)')type
     !write(*,'("Mode  : ",i1)')mode
     !write(*,'("Anorm : ",es10.3)')anorm
     !write(*,'("Cond  : ",es10.3)')cndnum
     !write(*,'(" ")')

     allocate(work(3*n), stat=info)
     if(info .ne. 0) return

     call dlatms( n, n, dist, iseed, type, &
          & d, mode, cndnum, anorm, kl, ku, &
          & pack, a, n, work, info )
     if(info .ne. 0) return

     deallocate(work, stat=info)
  case default
     write(*,'("Wrong matrix id")')
     info = 1
  end select

  !write(*,'("Matrix generated")')

  return
end subroutine matgen

! --------------------------------------------------------------------
! SUBROUTINE  Sort():
!    This subroutine receives an array x() and sorts it into descending
! order.
! --------------------------------------------------------------------

SUBROUTINE  Sort(x, Size)
  IMPLICIT  NONE
  DOUBLE PRECISION, DIMENSION(Size), INTENT(INOUT) :: x
  INTEGER, INTENT(IN)                   :: Size
  INTEGER                               :: i
  INTEGER                               :: Location
  DOUBLE PRECISION                      :: Temp

  DO i = 1, Size-1
    Location = FindMaximum(x, i, Size)
    Temp = x(i)
    x(i) = x(Location)
    x(Location) = Temp
  END DO

  CONTAINS

    INTEGER FUNCTION  FindMaximum(x, Start, End)
      IMPLICIT  NONE
      DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: x
      INTEGER, INTENT(IN)                :: Start, End
      DOUBLE PRECISION                   :: Maximum
      INTEGER                            :: Location
      INTEGER                            :: i

      Maximum  = x(Start)
      Location = Start
      DO i = Start+1, End
        IF (x(i) > Maximum) THEN
          Maximum  = x(i)
          Location = i
        END IF
      END DO
      FindMaximum = Location            ! return the position
    END FUNCTION  FindMaximum

END SUBROUTINE  Sort

Projects/Eigenfaces/2 - Calcul des couples propres/Code Fortran+matlab/Fortran/matgen/matgen.f90


program sqrt_01
implicit none
real :: x
x = sqrt(4.0)
if (abs(x - 2) > 1e-5) error stop
x = sqrt(2.0)
if (abs(x - 1.4142135623730951) > 1e-5) error stop
end program


function OnMult(n_a, n_b)
	integer, intent(in) :: n_a
	integer, intent(in) :: n_b

	integer :: i, j, k
	real :: temp

	!Create arrays
	real, dimension(n_a*n_a) :: a
	real, dimension(n_b*n_b) :: b
	real, dimension(n_a*n_b) :: c

  	!Initialize array a
	do i=1,n_a*n_a
		a(i) = 1
	end do

	!Initialize array b
	do i=0,n_b*n_b - 1
		b(i+1) = i/n_b + 1
	end do

	!Matrix Multiplication
	do i=0,n_a - 1
		do j=0,n_b - 1
			temp = 0
			do k=0,n_a - 1
				temp = temp + a(i*n_a+k+1) * b(k*n_b+k+1)
			end do
			c(i*n_a+j+1) = temp
		end do
	end do

	!Print Result Matrix
	print *, "Result matrix: "
	do i=1,min(n_a*n_b, 10)
		print *, c(i)
	end do

 end function

function OnMultLine(n_a, n_b)
	integer, intent(in) :: n_a
	integer, intent(in) :: n_b

	integer :: i, j, k

	!Create arrays
	real, dimension(n_a*n_a) :: a
	real, dimension(n_b*n_b) :: b
	real, dimension(n_a*n_b) :: c

  	!Initialize array a
	do i=1,n_a*n_a
		a(i) = 1
	end do

	!Initialize array b
	do i=0,n_b*n_b - 1
		b(i+1) = i/n_b+1
	end do

	!Initialize array b
	do i=1,n_a*n_b
		c(i) = 0
	end do

	!Matrix Multiplication
	do i=0,n_a - 1
		do k=0,n_b - 1
			do j=0,n_b - 1
				c(i*n_a+j+1) = c(i*n_a+j+1) + a(i*n_a+k+1) * b(k*n_b+j+1)
			end do
		end do
	end do

	!Print Result Matrix
	print *, "Result matrix: "
	do i=1,min(n_a*n_b, 10)
		print *, c(i)
	end do

 end function

program ex1
	print *, OnMultLine(10, 10)
end program ex1


module mod_func

   use, intrinsic :: iso_fortran_env

   real(kind=real64), parameter :: f1_exact = 61.675091159487667993149630_real64
   real(kind=real64), parameter :: pi = 3.141592653589793238462643_real64

contains

   function f1(x)

      use, intrinsic :: iso_fortran_env

      implicit none

      real(kind=real64) :: f1
      real(kind=real64) :: x

      f1 = log(pi*x)*sin(pi*x)**2 + x

      return

   end function

   function f2(x)

      use, intrinsic :: iso_fortran_env

      implicit none

      real(kind=real64) :: f2
      real(kind=real64) :: x

      f2 = 50.0D+00/(pi*(2500.0D+00*x*x + 1.0D+00))

      return

   end function

end module mod_func

program main

   use, intrinsic :: iso_fortran_env
   use mod_func
   use mpi_f08

   implicit none

   integer(kind=int32)  :: i, ierror
   integer(kind=int32)  :: master
   integer(kind=int32)  :: p
   integer(kind=int32)  :: num_proc, rank
   integer(kind=int32)  :: n, my_n
   integer(kind=int32)  :: source, destin
   integer(kind=int32)  :: tag

   real(kind=real64)    :: a, b, my_a, my_b
   real(kind=real64)    :: error
   real(kind=real64)    :: total
   real(kind=real64)    :: wtime
   real(kind=real64)    :: x
   real(kind=real64)    :: my_total
   real(kind=real64)    :: exact
   type(MPI_Status)     :: mpistatus

   a = 1.0_real64
   b = 10.0_real64
   n = huge(1_int32)

   exact = f1_exact

   master = 0

   call MPI_Init(ierror)

   call MPI_Comm_size(MPI_COMM_WORLD, num_proc, ierror)

   call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror)

   ! RANK 0 reads in the quadrature rule, and parcels out the
   ! evaluation points among the processes.
   if (rank == 0) then

      ! We want N to be the total number of evaluations.
      ! If necessary, we adjust N to be divisible by the number of processors.
      my_n = n/(num_proc - 1)
      n = (num_proc - 1)*my_n

      wtime = MPI_Wtime()

      write (*, '(a)') ' '
      write (*, '(a)') '  Quadrature of f(x) from A to B.'
      write (*, '(a)') '  f(x) = log(pi*x)*sin(pi*x)**2 + x'
      write (*, '(a)') ' '
      write (*, '(a,g14.6)') '  A        = ', a
      write (*, '(a,g14.6)') '  B        = ', b
      write (*, '(a,i12)') '  N        = ', n
      write (*, '(a,g24.16)') '  Exact    = ', exact
      write (*, '(a)') ' '
   end if

   ! Rank 0 has the computed value for my_n
   source = master

   ! Share with all the ranks the number of elements that each rank will compute
   call MPI_Bcast(my_n, 1, MPI_INTEGER, source, MPI_COMM_WORLD, ierror)

   ! Rank 0 assigns each process a subinterval of [A,B].
   if (rank == 0) then

      do p = 1, num_proc - 1

         my_a = (real(num_proc - p, kind=real64)*a &
                 + real(p - 1, kind=real64)*b) &
                /real(num_proc - 1, kind=real64)

         destin = p
         tag = 1
         call MPI_Send(my_a, 1, MPI_DOUBLE_PRECISION, destin, tag, &
                       MPI_COMM_WORLD, ierror)

         my_b = (real(num_proc - p - 1, kind=real64)*a &
                 + real(p, kind=real64)*b) &
                /real(num_proc - 1, kind=real64)

         destin = p
         tag = 2
         call MPI_Send(my_b, 1, MPI_DOUBLE_PRECISION, destin, tag, &
                       MPI_COMM_WORLD, ierror)

      end do

      total = 0.0D+00
      my_total = 0.0D+00

!  Processes receive MY_A, MY_B, and compute their part of the integral.
   else

      source = master
      tag = 1

      call MPI_Recv(my_a, 1, MPI_DOUBLE_PRECISION, source, tag, &
                    MPI_COMM_WORLD, mpistatus, ierror)

      source = master
      tag = 2

      call MPI_Recv(my_b, 1, MPI_DOUBLE_PRECISION, source, tag, &
                    MPI_COMM_WORLD, mpistatus, ierror)

      my_total = 0.0D+00
      do i = 1, my_n
         x = (real(my_n - i, kind=real64)*my_a &
              + real(i - 1, kind=real64)*my_b) &
             /real(my_n - 1, kind=real64)
         my_total = my_total + f1(x)
      end do

      my_total = (my_b - my_a)*my_total/real(my_n, kind=real64)

      write (*, '(a,i3,a,g14.6)') &
         '  RANK: ', rank, ' Partial Quadrature: ', my_total

   end if

   ! Each process sends its value of MY_TOTAL to the master process, to
   ! be summed in TOTAL.
   call MPI_Reduce(my_total, total, 1, MPI_DOUBLE_PRECISION, &
                   MPI_SUM, master, MPI_COMM_WORLD, ierror)

   ! Report the results.
   if (rank == master) then

      error = abs(total - exact)
      wtime = MPI_Wtime() - wtime

      write (*, '(a)') ' '
      write (*, '(a,g24.16)') '  Estimate = ', total
      write (*, '(a,g14.6)') '  Error    = ', error
      write (*, '(a,g14.6)') '  Time     = ', wtime

   end if

!  Terminate MPI.
   call MPI_Finalize(ierror)

!  Terminate.
   if (rank == master) then
      write (*, '(a)') ' '
      write (*, '(a)') '  Normal end of execution.'
   end if

   stop

end program


      real function sum(n, a)
      real s, a(100)
      s  = 0.
      do i = 1, n
         s = s + 2. * a(i)
      enddo
      sum = s
      end


@process free(f90) init(f90ptr) nosave
!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-C41                                                         *
!    5765-G18                                                         *
!    (C) COPYRIGHT IBM CORP. 1997, 2003. ALL RIGHTS RESERVED.         *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
!
! This sample program shows how to build and solve a sparse linear
! system using the subroutines in the  sparse section of Parallel
! ESSL. The matrix and RHS are generated
! in  parallel, so that there is no serial bottleneck.
!
! The program  solves a linear system based on the partial differential
! equation
!
!
!   b1 dd(u)  b2 dd(u)    b3 dd(u)    a1 d(u)   a2 d(u)  a3 d(u)
! -   ------ -  ------ -  ------ -  -----  -  ------  -  ------ + a4 u
!      dxdx     dydy       dzdz        dx       dy         dz
!
!  = 0
!
! with  Dirichlet boundary conditions on the unit cube
!
!    0<=x,y,z<=1
!
! The equation is discretized with finite differences and uniform stepsize;
! the resulting  discrete  equation is
!
! ( u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+
!  + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3)*(1/h**2)
!
!
! In this sample program the index space of the discretized
! computational domain is first numbered sequentially in a standard way,
! then the corresponding vector is distributed according to an HPF BLOCK
! distribution directive.
!
! Boundary conditions are set in a very simple way, by adding
! equations of the form
!
!   u(x,y,z) = rhs(x,y,z)
!
Program PDE90
  USE F90SPARSE
  Implicit none

  INTERFACE PART_BLOCK
     !   .....user defined subroutine.....
     SUBROUTINE PART_BLOCK(GLOBAL_INDX,N,NP,PV,NV)
       IMPLICIT NONE
       INTEGER, INTENT(IN)  :: GLOBAL_INDX, N, NP
       INTEGER, INTENT(OUT) :: NV
       INTEGER, INTENT(OUT) :: PV(*)
     END SUBROUTINE PART_BLOCK
  END INTERFACE

  ! Input parameters
  Character*10 :: CMETHD, PREC
  Integer      :: IDIM, IRET

  ! Miscellaneous
  Integer, Parameter   :: IZERO=0, IONE=1
  Character, PARAMETER :: ORDER='R'
  INTEGER              :: IARGC
  REAL(KIND(1.D0)), PARAMETER :: DZERO = 0.D0, ONE = 1.D0
  REAL(KIND(1.D0)) :: TIMEF, T1, T2, TPREC, TSOLVE, T3, T4
  EXTERNAL  TIMEF

  ! Sparse Matrix and preconditioner
  TYPE(D_SPMAT) :: A
  TYPE(D_PRECN) :: APRC
  ! Descriptor
  TYPE(DESC_TYPE)    :: DESC_A
  ! Dense Matrices
  REAL(KIND(1.d0)), POINTER :: B(:), X(:)

  ! BLACS parameters
  INTEGER            :: nprow, npcol, icontxt, iam, np, myprow, mypcol

  ! Solver parameters
  INTEGER            :: ITER, ITMAX,IERR,ITRACE, METHD,IPREC, ISTOPC,&
       & IPARM(20)
  REAL(KIND(1.D0))   :: ERR, EPS, RPARM(20)

  ! Other variables
  INTEGER            :: I,INFO
  INTEGER            :: INTERNAL, M,II

  ! Initialize BLACS
  CALL BLACS_PINFO(IAM, NP)
  CALL BLACS_GET(IZERO, IZERO, ICONTXT)

  ! Rectangular Grid,  P x 1

  CALL BLACS_GRIDINIT(ICONTXT, ORDER, NP, IONE)
  CALL BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL)

  !
  !  Get parameters
  !
  CALL GET_PARMS(ICONTXT,CMETHD,PREC,IDIM,ISTOPC,ITMAX,ITRACE)

  !
  !  Allocate and fill in the coefficient matrix, RHS and initial guess
  !

  CALL BLACS_BARRIER(ICONTXT,'All')
  T1 = TIMEF()
  CALL CREATE_MATRIX(PART_BLOCK,IDIM,A,B,X,DESC_A,ICONTXT)
  T2 = TIMEF() - T1

  CALL DGAMX2D(ICONTXT,'A',' ',IONE, IONE,T2,IONE,T1,T1,-1,-1,-1)
  IF (IAM.EQ.0) Write(6,*) 'Matrix creation Time : ',T2/1.D3

  !
  !  Prepare the preconditioner.
  !
  SELECT CASE (PREC)
  CASE ('ILU')
     IPREC = 2
  CASE ('DIAGSC')
     IPREC = 1
  CASE ('NONE')
     IPREC = 0
  CASE DEFAULT
     WRITE(0,*) 'Unknown preconditioner'
     CALL BLACS_ABORT(ICONTXT,-1)
  END SELECT
  CALL BLACS_BARRIER(ICONTXT,'All')
  T1 = TIMEF()
  CALL PSPGPR(IPREC,A,APRC,DESC_A,INFO=IRET)
  TPREC = TIMEF()-T1

  CALL DGAMX2D(icontxt,'A',' ',IONE, IONE,TPREC,IONE,t1,t1,-1,-1,-1)

  IF (IAM.EQ.0) WRITE(6,*) 'Preconditioner Time : ',TPREC/1.D3

  IF (IRET.NE.0) THEN
     WRITE(0,*) 'Error on preconditioner',IRET
     CALL BLACS_ABORT(ICONTXT,-1)
     STOP
  END IF

  !
  ! Iterative method parameters
  !
  IF (CMETHD(1:6).EQ.'CGSTAB') Then
     METHD = 1
  ELSE IF (CMETHD(1:3).EQ.'CGS') Then
     METHD = 2
  ELSE IF (CMETHD(1:5).EQ.'TFQMR') THEN
     METHD = 3
  ELSE
     WRITE(0,*) 'Unknown method '
     CALL BLACS_ABORT(ICONTXT,-1)
     METHD = 0
  END IF
  EPS   = 1.D-9
  IPARM = 0
  RPARM = 0.D0
  IPARM(1) = METHD
  IPARM(2) = ISTOPC
  IPARM(3) = ITMAX
  IPARM(4) = ITRACE
  RPARM(1) = EPS
  CALL BLACS_BARRIER(ICONTXT,'All')
  T1 = TIMEF()
  CALL PSPGIS(A,B,X,APRC,DESC_A,&
       & IPARM=IPARM,RPARM=RPARM,INFO=IERR)
  CALL BLACS_BARRIER(ICONTXT,'All')
  T2 = TIMEF() - T1
  ITER = IPARM(5)
  ERR  = RPARM(2)
  CALL DGAMX2D(ICONTXT,'A',' ',IONE, IONE,T2,IONE,T1,T1,-1,-1,-1)

  IF (IAM.EQ.0) THEN
     WRITE(6,*) 'Time to Solve Matrix : ',T2/1.D3
     WRITE(6,*) 'Time per iteration : ',T2/(ITER*1.D3)
     WRITE(6,*) 'Number of iterations : ',ITER
     WRITE(6,*) 'Error on exit : ',ERR
     WRITE(6,*) 'INFO  on exit : ',IERR
  END IF

  !
  !  Cleanup storage and exit
  !
  CALL PGEFREE(B,DESC_A)
  CALL PGEFREE(X,DESC_A)

  CALL PSPFREE(APRC,DESC_A)
  CALL PSPFREE(A,DESC_A)

  CALL PADFREE(DESC_A)

  CALL BLACS_GRIDEXIT(ICONTXT)
  CALL BLACS_EXIT(0)

  STOP

CONTAINS
  !
  !  Subroutine to allocate and fill in the coefficient matrix and
  !  the RHS.
  !
  SUBROUTINE CREATE_MATRIX(PARTS,IDIM,A,B,T,DESC_A,ICONTXT)
!
!   Discretize the partial diferential equation
!
!   b1 dd(u)  b2 dd(u)    b3 dd(u)    a1 d(u)   a2 d(u)  a3 d(u)
! -   ------ -  ------ -  ------ -  -----  -  ------  -  ------ + a4 u
!      dxdx     dydy       dzdz        dx       dy         dz
!
!  = 0
!
! boundary condition: Dirichlet
!    0< x,y,z<1
!
!  u(x,y,z)(2b1+2b2+2b3+a1+a2+a3)+u(x-1,y,z)(-b1-a1)+u(x,y-1,z)(-b2-a2)+
!  + u(x,y,z-1)(-b3-a3)-u(x+1,y,z)b1-u(x,y+1,z)b2-u(x,y,z+1)b3
    USE F90SPARSE
    Implicit None
    INTEGER                  :: IDIM
    INTERFACE PARTS
       SUBROUTINE PARTS(GLOBAL_INDX,N,P,PV,NV)
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: GLOBAL_INDX, N, P
         INTEGER, INTENT(OUT) :: NV
         INTEGER, INTENT(OUT) :: PV(*)

       END SUBROUTINE PARTS
    END INTERFACE
    Real(Kind(1.D0)),Pointer :: B(:),T(:)
    Type (DESC_TYPE)         :: DESC_A
    Integer                  :: ICONTXT
    Type(D_SPMAT)            :: A
    Real(Kind(1.d0))         :: ZT(10),GLOB_X,GLOB_Y,GLOB_Z
    Integer                  :: M,N,NNZ,GLOB_ROW,J
    Type (D_SPMAT)           :: ROW_MAT
    Integer                  :: X,Y,Z,COUNTER,IA,I,INDX_OWNER
    INTEGER                  :: NPROW,NPCOL,MYPROW,MYPCOL
    Integer                  :: ELEMENT
    INTEGER                  :: INFO, NV, INV
    INTEGER, ALLOCATABLE     :: PRV(:)
    ! deltah dimension of each grid cell
    ! deltat discretization time
    Real(Kind(1.D0))         :: DELTAH
    Real(Kind(1.d0)),Parameter   :: RHS=0.d0,ONE=1.d0,ZERO=0.d0
    Real(Kind(1.d0))   :: TIMEF, T1, T2, TINS
    external            timef
    ! common area

    CALL BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL)

    DELTAH = 1.D0/(IDIM-1)

    ! Initialize array descriptor and sparse matrix storage. Provide an
    ! estimate of the number of non zeroes

    M   = IDIM*IDIM*IDIM
    N   = M
    NNZ = (N*7)/(NPROW*NPCOL)
    Call PADALL(N,PARTS,DESC_A,ICONTXT)
    Call PSPALL(A,DESC_A,NNZ=NNZ)
    ! Define  RHS from boundary conditions; also build initial guess
    Call PGEALL(B,DESC_A)
    Call PGEALL(T,DESC_A)

    ! We build an auxiliary matrix consisting of one row at a
    ! time
    ROW_MAT%DESCRA(1:1) = 'G'
    ROW_MAT%FIDA        = 'CSR'
    ALLOCATE(ROW_MAT%AS(20))
    ALLOCATE(ROW_MAT%IA1(20))
    ALLOCATE(ROW_MAT%IA2(20))
    ALLOCATE(PRV(NPROW))
    ROW_MAT%IA2(1)=1

    TINS = 0.D0
    CALL BLACS_BARRIER(ICONTXT,'ALL')
    T1 = TIMEF()

    ! Loop over rows belonging to current process in a BLOCK
    ! distribution.

    DO GLOB_ROW = 1, N
       CALL PARTS(GLOB_ROW,N,NPROW,PRV,NV)
       DO INV = 1, NV
          INDX_OWNER = PRV(INV)
          IF (INDX_OWNER == MYPROW) THEN
             ! Local matrix pointer
             ELEMENT=1
             ! Compute gridpoint Coordinates
             IF (MOD(GLOB_ROW,(IDIM*IDIM)).EQ.0) THEN
                X = GLOB_ROW/(IDIM*IDIM)
             ELSE
                X = GLOB_ROW/(IDIM*IDIM)+1
             ENDIF
             IF (MOD((GLOB_ROW-(X-1)*IDIM*IDIM),IDIM).EQ.0) THEN
                Y = (GLOB_ROW-(X-1)*IDIM*IDIM)/IDIM
             ELSE
                Y = (GLOB_ROW-(X-1)*IDIM*IDIM)/IDIM+1
             ENDIF
             Z = GLOB_ROW-(X-1)*IDIM*IDIM-(Y-1)*IDIM
	     ! GLOB_X, GLOB_Y, GLOB_X coordinates
	     GLOB_X=X*DELTAH
	     GLOB_Y=Y*DELTAH
	     GLOB_Z=Z*DELTAH

             ! Check on boundary points
             IF (X.EQ.1) THEN
                ROW_MAT%AS(ELEMENT)=ONE
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ELSE IF (Y.EQ.1) THEN
                ROW_MAT%AS(ELEMENT)=ONE
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ELSE IF (Z.EQ.1) THEN
                ROW_MAT%AS(ELEMENT)=ONE
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ELSE IF (X.EQ.IDIM) THEN
                ROW_MAT%AS(ELEMENT)=ONE
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ELSE IF (Y.EQ.IDIM) THEN
                ROW_MAT%AS(ELEMENT)=ONE
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ELSE IF (Z.EQ.IDIM) THEN
                ROW_MAT%AS(ELEMENT)=ONE
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ELSE
                ! Internal point: build discretization
                !
                !  Term depending on   (x-1,y,z)
                !
                ROW_MAT%AS(ELEMENT)=-B1(GLOB_X,GLOB_Y,GLOB_Z)&
                     & -A1(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X-2)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
                !  Term depending on     (x,y-1,z)
                ROW_MAT%AS(ELEMENT)=-B2(GLOB_X,GLOB_Y,GLOB_Z)&
                     & -A2(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-2)*IDIM+(Z)
                ELEMENT=ELEMENT+1
                !  Term depending on     (x,y,z-1)
                ROW_MAT%AS(ELEMENT)=-B3(GLOB_X,GLOB_Y,GLOB_Z)&
                     & -A3(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z-1)
                ELEMENT=ELEMENT+1
                !  Term depending on     (x,y,z)
                ROW_MAT%AS(ELEMENT)=2*B1(GLOB_X,GLOB_Y,GLOB_Z)&
                     & +2*B2(GLOB_X,GLOB_Y,GLOB_Z)&
                     & +2*B3(GLOB_X,GLOB_Y,GLOB_Z)&
                     & +A1(GLOB_X,GLOB_Y,GLOB_Z)&
                     & +A2(GLOB_X,GLOB_Y,GLOB_Z)&
                     & +A3(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
                !  Term depending on     (x,y,z+1)
                ROW_MAT%AS(ELEMENT)=-B1(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z+1)
                ELEMENT=ELEMENT+1
                !  Term depending on     (x,y+1,z)
                ROW_MAT%AS(ELEMENT)=-B2(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X-1)*IDIM*IDIM+(Y)*IDIM+(Z)
                ELEMENT=ELEMENT+1
                !  Term depending on     (x+1,y,z)
                ROW_MAT%AS(ELEMENT)=-B3(GLOB_X,GLOB_Y,GLOB_Z)
                ROW_MAT%AS(ELEMENT) = ROW_MAT%AS(ELEMENT)/(DELTAH*&
                     & DELTAH)
                ROW_MAT%IA1(ELEMENT)=(X)*IDIM*IDIM+(Y-1)*IDIM+(Z)
                ELEMENT=ELEMENT+1
             ENDIF
             ROW_MAT%M=1
             ROW_MAT%N=N
             ROW_MAT%IA2(2)=ELEMENT
             ! IA== GLOBAL ROW INDEX
             IA=(X-1)*IDIM*IDIM+(Y-1)*IDIM+(Z)
             T3 = TIMEF()
             CALL PSPINS(A,IA,1,ROW_MAT,DESC_A)
             TINS = TINS + (TIMEF()-T3)
	     ! Build RHS
             IF (X==1) THEN
                GLOB_Y=(Y-IDIM/2)*DELTAH
                GLOB_Z=(Z-IDIM/2)*DELTAH
                ZT(1) = EXP(-GLOB_Y**2-GLOB_Z**2)
             ELSE IF ((Y==1).OR.(Y==IDIM).OR.(Z==1).OR.(Z==IDIM)) THEN
                GLOB_X=3*(X-1)*DELTAH
                GLOB_Y=(Y-IDIM/2)*DELTAH
                GLOB_Z=(Z-IDIM/2)*DELTAH
                ZT(1) = EXP(-GLOB_Y**2-GLOB_Z**2)*EXP(-GLOB_X)
             ELSE
                ZT(1) = 0.D0
             ENDIF
             CALL PGEINS(B,ZT(1:1),DESC_A,IA)
             ZT(1)=0.D0
             CALL PGEINS(T,ZT(1:1),DESC_A,IA)
          END IF
       END DO
    END DO

    CALL BLACS_BARRIER(ICONTXT,'ALL')
    T2 = TIMEF()

    IF (MYPROW.EQ.0) THEN
       WRITE(0,*) '     pspins  time',TINS/1.D3
       WRITE(0,*) '   Insert time',(T2-T1)/1.D3
    ENDIF

    DEALLOCATE(ROW_MAT%AS,ROW_MAT%IA1,ROW_MAT%IA2)

    CALL BLACS_BARRIER(ICONTXT,'ALL')
    T1 = TIMEF()

    CALL PSPASB(A,DESC_A,INFO=INFO,DUPFLAG=0,MTYPE='GEN  ')

    CALL BLACS_BARRIER(ICONTXT,'ALL')
    T2 = TIMEF()

    IF (MYPROW.EQ.0) THEN
       WRITE(0,*) '   Assembly  time',(T2-T1)/1.D3
    ENDIF

    CALL PGEASB(B,DESC_A)
    CALL PGEASB(T,DESC_A)
    RETURN
  END SUBROUTINE CREATE_MATRIX
  !
  ! Functions parameterizing the differential equation
  !
  FUNCTION A1(X,Y,Z)
    REAL(KIND(1.D0)) :: A1
    REAL(KIND(1.D0)) :: X,Y,Z
    A1=1.D0
  END FUNCTION A1
  FUNCTION A2(X,Y,Z)
    REAL(KIND(1.D0)) ::  A2
    REAL(KIND(1.D0)) :: X,Y,Z
    A2=2.D1*Y
  END FUNCTION A2
  FUNCTION A3(X,Y,Z)
    REAL(KIND(1.D0)) ::  A3
    REAL(KIND(1.D0)) :: X,Y,Z
    A3=1.D0
  END FUNCTION A3
  FUNCTION A4(X,Y,Z)
    REAL(KIND(1.D0)) ::  A4
    REAL(KIND(1.D0)) :: X,Y,Z
    A4=1.D0
  END FUNCTION A4
  FUNCTION B1(X,Y,Z)
    REAL(KIND(1.D0)) ::  B1
    REAL(KIND(1.D0)) :: X,Y,Z
    B1=1.D0
  END FUNCTION B1
  FUNCTION B2(X,Y,Z)
    REAL(KIND(1.D0)) ::  B2
    REAL(KIND(1.D0)) :: X,Y,Z
    B2=1.D0
  END FUNCTION B2
  FUNCTION B3(X,Y,Z)
    REAL(KIND(1.D0)) ::  B3
    REAL(KIND(1.D0)) :: X,Y,Z
    B3=1.D0
  END FUNCTION B3
  !
  ! Get iteration parameters from the command line
  !
  SUBROUTINE  GET_PARMS(ICONTXT,CMETHD,PREC,IDIM,ISTOPC,ITMAX,ITRACE)
    IMPLICIT NONE
    integer      :: icontxt
    Character*10 :: CMETHD, PREC
    Integer      :: IDIM, IRET, ISTOPC,ITMAX,ITRACE
    Character*40 :: CHARBUF
    INTEGER      :: IARGC, NPROW, NPCOL, MYPROW, MYPCOL
    EXTERNAL     IARGC
    INTEGER      :: INTBUF(10), IP

    CALL BLACS_GRIDINFO(ICONTXT, NPROW, NPCOL, MYPROW, MYPCOL)

    IF (MYPROW==0) THEN
       ! Read command line parameters
       IP=IARGC()
       IF (IARGC().GE.3) THEN
          CALL GETARG(1,CHARBUF)
          READ(CHARBUF,*) CMETHD
          CALL GETARG(2,CHARBUF)
          READ(CHARBUF,*) PREC

        ! Convert strings in array
          DO I = 1, LEN(CMETHD)
             INTBUF(I) = IACHAR(CMETHD(I:I))
          END DO
        ! Broadcast parameters to all processors
          CALL IGEBS2D(ICONTXT,'ALL',' ',10,1,INTBUF,10)

          DO I = 1, LEN(PREC)
             INTBUF(I) = IACHAR(PREC(I:I))
          END DO
        ! Broadcast parameters to all processors
          CALL IGEBS2D(ICONTXT,'ALL',' ',10,1,INTBUF,10)

          CALL GETARG(3,CHARBUF)
          READ(CHARBUF,*) IDIM
          IF (IARGC().GE.4) THEN
             CALL GETARG(4,CHARBUF)
             READ(CHARBUF,*) ISTOPC
          ELSE
             ISTOPC=1
          ENDIF
          IF (IARGC().GE.5) THEN
             CALL GETARG(5,CHARBUF)
             READ(CHARBUF,*) ITMAX
          ELSE
             ITMAX=500
          ENDIF
          IF (IARGC().GE.6) THEN
             CALL GETARG(6,CHARBUF)
             READ(CHARBUF,*) ITRACE
          ELSE
             ITRACE=0
          ENDIF
        ! Broadcast parameters to all processors
          CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,IDIM,1)
          CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,ISTOPC,1)
          CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,ITMAX,1)
          CALL IGEBS2D(ICONTXT,'ALL',' ',1,1,ITRACE,1)
          WRITE(6,*)'Solving matrix: ELL1'
          WRITE(6,*)'on  grid',IDIM,'x',IDIM,'x',IDIM
          WRITE(6,*)' with BLOCK data distribution, NP=',Np,&
               & ' Preconditioner=',PREC,&
               & ' Iterative methd=',CMETHD
       ELSE
        ! Wrong number of parameter, print an error message and exit
          CALL PR_USAGE(0)
          CALL BLACS_ABORT(ICONTXT,-1)
          STOP 1
       ENDIF
    ELSE
   ! Receive Parameters
       CALL IGEBR2D(ICONTXT,'ALL',' ',10,1,INTBUF,10,0,0)
       DO I = 1, 10
          CMETHD(I:I) = ACHAR(INTBUF(I))
       END DO
       CALL IGEBR2D(ICONTXT,'ALL',' ',10,1,INTBUF,10,0,0)
       DO I = 1, 10
          PREC(I:I) = ACHAR(INTBUF(I))
       END DO
       CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,IDIM,1,0,0)
       CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,ISTOPC,1,0,0)
       CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,ITMAX,1,0,0)
       CALL IGEBR2D(ICONTXT,'ALL',' ',1,1,ITRACE,1,0,0)
    END IF
    RETURN

  END SUBROUTINE GET_PARMS
  !
  !  Print an error message
  !
  SUBROUTINE PR_USAGE(IOUT)
    IMPLICIT NONE
    INTEGER :: IOUT
    WRITE(IOUT,*)'Incorrect parameter(s) found'
    WRITE(IOUT,*)' Usage:  pde90 methd prec dim &
         &[istop itmax itrace]'
    WRITE(IOUT,*)' Where:'
    WRITE(IOUT,*)'     methd:    CGSTAB TFQMR CGS'
    WRITE(IOUT,*)'     prec :    ILU DIAGSC NONE'
    WRITE(IOUT,*)'     dim       number of points along each axis'
    WRITE(IOUT,*)'               the size of the resulting linear '
    WRITE(IOUT,*)'               system is dim**3'
    WRITE(IOUT,*)'     istop     Stopping criterion  1, 2 or 3 [1]  '
    WRITE(IOUT,*)'     itmax     Maximum number of iterations [500] '
    WRITE(IOUT,*)'     itrace    0  (no tracing, default) or '
    WRITE(IOUT,*)'               >= 0 do tracing every ITRACE'
    WRITE(IOUT,*)'               iterations '
  END SUBROUTINE PR_USAGE

END PROGRAM PDE90


C

C
C
      PURE SUBROUTINE PARTS(COMP, XMOD, ANGL, SMALLNUM, PI)

      IMPLICIT NONE
C
C Dummy arguments
C
      REAL(8) :: ANGL
      real(8), intent(in) :: PI
      real(8), intent(in) :: SMALLNUM
      REAL(8) :: XMOD
      REAL(8) , DIMENSION(2) :: COMP

      INTENT (IN) COMP
      INTENT (OUT) ANGL , XMOD
C Local variables
      REAL(8) :: DABS
      REAL(8) :: DATAN2
      REAL(8) :: DSQRT
      REAL(8) :: R1
      REAL(8) :: R2

C
      R1 = COMP(1)
      IF(DABS(R1) <= SMALLNUM)R1 = 0.D0
      R2 = COMP(2)
      IF(DABS(R2) <= SMALLNUM)R2 = 0.D0
C
      XMOD  = DSQRT(R1*R1 + R2*R2)
C
      IF( DABS(R1) > SMALLNUM .AND. DABS(R2) > SMALLNUM )THEN
        ANGL = DATAN2(R2,R1)
      ELSE IF( DABS(R1) > SMALLNUM .AND. DABS(R2) < SMALLNUM )THEN
        IF( R1 > 0 )THEN
          ANGL = 0.D0
        ELSE
          ANGL = PI
        END IF
      ELSE IF( DABS(R1) < SMALLNUM .AND. DABS(R2) > SMALLNUM )THEN
        IF( R2 > 0 )THEN
          ANGL = PI * 0.5
        ELSE
          ANGL = PI * 1.5
        END IF
      ELSE
        ANGL = 0.D0
      END IF
C
      RETURN
C
      END


module vallado
!! based on http://www.smad.com/vallado/
use, intrinsic:: iso_fortran_env, only: @wp_real@

implicit none (type, external)
private
public:: toGST, toJulian, toLST, radec2azel, azel2radec

real(wp), parameter :: pi = 4._wp * atan(1.0_wp)

type,public :: datetime
integer :: year, month, day, hour, minute
real(wp) :: second
end type

contains

elemental subroutine azel2radec(azz,ell,llat,llon,jd, ra,decl)
! convert azimuth, elevation to right ascension, declination
!
! inputs
! ------
! az, el: azimuth, elevation (degrees)
! lat, lon: geodetic latitude, longitude (degrees)
! jd: julian date (decimal)
!
! outputs
! -------
! ra, decl: right ascension, declination (degrees)

real(wp), intent(in) :: azz,ell,llat,llon
real(wp), intent(in) :: jd ! Julian Date
real(wp), intent(out) :: ra, decl

real(wp) :: lst, lha, sinv, cosv, az, el, lat, lon

az = radians(azz)
el = radians(ell)
lat = radians(llat)
lon = radians(llon)

Decl = ASIN(SIN(El)*SIN(lat) + &
            COS(el)*COS(lat)*COS(Az) )

Sinv = -(SIN(az)*COS(el)*COS(lat)) / &
        (COS(lat)*COS(Decl))

Cosv = (SIN(el) - SIN(lat)*SIN(decl)) / &
       (COS(lat)*COS(Decl))

LHA  = ATAN2(Sinv,Cosv)
lst = toLST(Lon, JD)

ra = modulo(degrees(LST - LHA), 360._wp)
decl = degrees(decl)

end subroutine azel2radec

elemental SUBROUTINE radec2azel(rra,dDecl,llat,llon,jd, Az,El)
! convert right ascension, declination to azimuth, elevation
!
! inputs
! ------
! ra, decl: right ascension, declination (degrees)
! lat, lon: geodetic latitude, longitude (degrees)
! jd: julian date (decimal)
!
! outputs
! -------
! az, el: azimuth, elevation (degrees)

REAL(wp), intent(in) :: rra,dDecl, llat, llon
real(wp), intent(in) :: jd
real(wp), intent(out) :: Az,El

REAL(wp) :: Sinv, Cosv, LHA, lat, lon, ra, decl

lat = radians(llat)
lon = radians(llon)
ra = radians(rra)
decl = radians(ddecl)

LHA = toLST(Lon, JD) - ra

El = ASIN( SIN(Decl)*SIN(lat) + &
            COS(Decl)*COS(lat)*COS(LHA) )

Sinv = -SIN(LHA)*COS(Decl)*COS(lat) / &
      (COS(el)*COS(lat))

Cosv = ( SIN(Decl)-SIN(el)*SIN(lat) ) / &
       (COS(el)*COS(lat))

Az = modulo(degrees(ATAN2(Sinv,Cosv)), 360._wp)
el = degrees(el)

END subroutine radec2azel

elemental real(wp) function toLST(Lon, JD) result(LST)
!! Julian Date => local sidereal time
!!
!! ## inputs
!!
!! *  lon: geodetic longitude (radians)
!! *  jd: Julian Date (decimal)

REAL(wp), intent(in) :: Lon, JD

LST = Lon + toGST(jd)

LST = modulo(LST, 2*pi )

END function toLST

elemental real(wp) function toJulian(t) result(jd)
! Gregorian date, time => Julian Date
!
! inputs
! ------
! time: Gregorian user-defined type
!
! output
! -----
! JD: Julian Date

type(datetime), intent(in) :: t
real(wp) :: B, y, m

y = t%year
m = t%month

IF ( M <= 2 ) THEN
  Y = y - 1
  M = m + 12
ENDIF

B = 2 - INT(Y*0.01_wp) + INT(INT(Y*0.01_wp)*0.25_wp)

JD= INT( 365.25_wp*(Y + 4716) ) + &
    INT( 30.6001_wp*(M+1) ) + &
    t%day + B - 1524.5_wp + &
    ( (t%second/60.0_wp + t%minute ) / 60.0_wp + t%hour ) / 24.0_wp

END function toJulian

elemental real(wp) FUNCTION toGST(JD) result(GST)
! Julian Date => to Greenwich Sidereal Time
!
! inputs
! ------
! JD: Julian Date (decimal)
!
! output
! ------
! GST: Greenwich Sidereal Time (decimal)

real(wp), intent(in) :: JD
real(wp) :: TUT1

TUT1= ( JD - 2451545._wp ) / 36525._wp
gst = -6.2e-6_wp*TUT1**3 + &
            0.093104_wp*TUT1**2 + &
           (876600._wp*3600._wp + 8640184.812866_wp)*TUT1 + &
            67310.54841_wp

gst = modulo(radians(gst) / 240._wp, 2*pi) ! 360/86400 = 1/240, to deg, to rad

end function toGST

elemental real(wp) function degrees(rad)
real(wp), intent(in) :: rad

degrees = 180._wp / pi * rad
end function degrees

elemental real(wp) function radians(deg)
real(wp), intent(in) :: deg

radians = pi / 180._wp * deg
end function radians

end module vallado


!!---------------------------------------------------------------------------------------
!!----- Multi-material and multi-phase (EOS module)
!!----- by
!!----- Aditya K Pandare
!!---------------------------------------------------------------------------------------

MODULE eos

USE glob_var

implicit none

CONTAINS

!----------------------------------------------------------------------------------------------
!----- Density from pressure using isothermal 'ideal-gas' eos
!----------------------------------------------------------------------------------------------

function eos1_density(pres)

real*8, intent(in) :: pres

real*8  :: eos1_density

    eos1_density = pres / (rgas*tinf)

end function

!----------------------------------------------------------------------------------------------
!----- Density from pressure using Tait eos
!----------------------------------------------------------------------------------------------

function eos2_density(pres)

real*8, intent(in) :: pres

real*8  :: eos2_density

    eos2_density = rho0 * (1.0 + n0/k0 * (pres - p0))**(1.0/n0)

end function

!----------------------------------------------------------------------------------------------
!----- speed of sound using Tait eos
!----------------------------------------------------------------------------------------------

function eos2_ssound(rho)

real*8, intent(in) :: rho

real*8  :: eos2_ssound

    eos2_ssound = dsqrt(k0/(rho0**n0) * (rho**(n0-1.0)))

end function

!----------------------------------------------------------------------------------------------
!----- Density from pressure and temperature using stiffened gas eos
!----------------------------------------------------------------------------------------------

function eos3_density(gam, cp, p_c, pres, temp)

real*8, intent(in) :: gam, cp, p_c, pres, temp

real*8  :: eos3_density

    eos3_density = gam * (pres + p_c) / ((gam - 1.0) * cp * temp)

end function

!----------------------------------------------------------------------------------------------
!----- Total energy from pressure and density using stiffened gas eos
!----------------------------------------------------------------------------------------------

function eos3_rhoe(gam, p_c, pres, rho, u)

real*8, intent(in) :: gam, p_c, pres, rho, u

real*8  :: eos3_rhoe

    eos3_rhoe = (pres + p_c)/(gam - 1.0) + (0.5*rho*u*u) + p_c;

end function

!----------------------------------------------------------------------------------------------
!----- Pressure from total energy and density using stiffened gas eos
!----------------------------------------------------------------------------------------------

function eos3_pr(gam, p_c, rho, rhoe, u)

real*8, intent(in) :: gam, p_c, rho, rhoe, u

real*8  :: eos3_pr

    eos3_pr = (gam - 1.0) * (rhoe - 0.5*rho*u*u - p_c) - p_c;

end function

!----------------------------------------------------------------------------------------------
!----- Vol-frac times pressure from total energy and density using sgeos
!----------------------------------------------------------------------------------------------

function eos3_alphapr(gam, p_c, alpha, arho, arhoe, u)

real*8, intent(in) :: gam, p_c, alpha, arho, arhoe, u

real*8  :: eos3_alphapr

    eos3_alphapr = (gam - 1.0) * (arhoe - 0.5*arho*u*u - alpha*p_c) - alpha*p_c;

end function

!----------------------------------------------------------------------------------------------
!----- Temperature from total energy and density using stiffened gas eos
!----------------------------------------------------------------------------------------------

function eos3_t(gam, cp, p_c, rho, rhoe, u)

real*8, intent(in) :: gam, cp, p_c, rho, rhoe, u

real*8  :: eos3_t

    eos3_t = (rhoe - (0.5*rho*u*u) - p_c) * (gam/(rho * cp));

end function

!----------------------------------------------------------------------------------------------
!----- speed of sound from density and pressure using stiffened gas eos
!----------------------------------------------------------------------------------------------

function eos3_ss(gam, p_c, arho, al, apr)

real*8, intent(in) :: gam, p_c, arho, al, apr

real*8  :: pre, eos3_ss

    pre = max(apr+al*p_c, 1.0d-14);
    if (arho .lt. 1.0d-16) then
      if (al .le. 100.0*g_alphamin) then
        eos3_ss = 0.0
      else
        write(*,*) "Error: zero/negative density encountered in speed of sound calculation: ", arho
        write(*,*) "  Volume-fraction: ", al
        call exit
      end if
    else
      eos3_ss = dsqrt(gam *pre/arho);
    end if

end function

!----------------------------------------------------------------------------------------------
!----- Get primitive variables for a mesh element from conserved
!----------------------------------------------------------------------------------------------

subroutine get_uprim_mm6eq(ucons, uprim)

real*8, intent(in) :: ucons(g_neqns)

integer :: i
real*8  :: almat(g_mmi%nummat), pmat(g_mmi%nummat), tmat(g_mmi%nummat), &
           rhomat(g_mmi%nummat), rhoemat(g_mmi%nummat), u, rho
real*8  :: uprim(g_neqns)

associate (nummat=>g_mmi%nummat)

  ! bulk state
  rho = sum( ucons(g_mmi%irmin:g_mmi%irmax) )
  u = ucons(g_mmi%imome) / rho
  uprim(g_mmi%imome) = u

  ! material states
  do i = 1,nummat
    ! conserved variables
    almat(i) = ucons(i)
    rhomat(i) = ucons(g_mmi%irmin+i-1) / almat(i)
    rhoemat(i) = ucons(g_mmi%iemin+i-1) / almat(i)
    ! primitive variables
    pmat(i) = eos3_pr(g_gam(i), g_pc(i), rhomat(i), rhoemat(i), u)
    tmat(i) = eos3_t(g_gam(i), g_cp(i), g_pc(i), rhomat(i), rhoemat(i), u)

    uprim(i) = almat(i)
    uprim(g_mmi%irmin+i-1) = pmat(i)
    uprim(g_mmi%iemin+i-1) = tmat(i)
  end do !i

end associate

end subroutine get_uprim_mm6eq

!----------------------------------------------------------------------------------------------
!----- Tiny phase treatment for mm6eq:
!----- ignore it
!----------------------------------------------------------------------------------------------

subroutine ignore_tinyphase_mm6eq(ucons, uprim)

integer :: ie, i, mmax
real*8  :: almat(g_mmi%nummat), pmax, tmax, &
           rhomat, rhoemat, &
           al_eps, rho, u, alsum, d_al, d_are, are_new, &
           apk, ak, kmat(g_mmi%nummat), &
           p_target, ratio, &
           ucons(g_tdof,g_neqns,0:imax+1), &
           uprim(g_tdof,g_nprim,0:imax+1)

associate (nummat=>g_mmi%nummat)

  al_eps = 1d-2

  do ie = 1,imax

    !--- find material in largest quantity
    almat = ucons(1,g_mmi%iamin:g_mmi%iamax,ie)
    mmax = maxloc(almat, 1)

    rhomat  = ucons(1,g_mmi%irmin+mmax-1,ie)/almat(mmax)
    rhoemat = ucons(1,g_mmi%iemin+mmax-1,ie)/almat(mmax)
    rho     = sum(ucons(1,g_mmi%irmin:g_mmi%irmax,ie))
    u       = uprim(1,vel_idx(nummat, 0),ie)
    pmax = uprim(1,apr_idx(nummat, mmax),ie)/almat(mmax)
    tmax = eos3_t(g_gam(mmax), g_cp(mmax), g_pc(mmax), rhomat, rhoemat, u)

    !--- get equilibrium pressure
    !p_target = 0.0
    !ratio = 0.0
    !do i = 1,nummat
    !  rhomat = ucons(1,g_mmi%irmin+i-1,ie)
    !  apk = uprim(1,apr_idx(nummat, i),ie)
    !  ak = eos3_ss(g_gam(i), g_pc(i), rhomat, almat(i), apk)
    !  kmat(i) = rhomat * ak * ak / almat(i)

    !  p_target = p_target + (almat(i) * apk / kmat(i))
    !  ratio = ratio + (almat(i) * almat(i) / kmat(i))
    !end do !i
    !p_target = p_target / ratio
    !p_target = max(p_target, 1d-14)
    p_target = max(pmax, 1d-14)

    !--- correct minority materials and store volume/energy changes
    d_al = 0.0
    d_are = 0.0
    do i = 1,nummat
      apk = uprim(1,apr_idx(nummat, i),ie)/almat(i)
      ! positive volfrac
      if (almat(i) > 0.0) then
        ! pressure relaxation
        if ((almat(i) <= al_eps) &! .and. dabs(apk-pmax)/pmax > 1e-4) &
          .or. (apk+g_pc(i) < 0.0)) then
          rhomat = ucons(1,g_mmi%irmin+i-1,ie) / almat(i)
          are_new = almat(i) * eos3_rhoe(g_gam(i), g_pc(i), p_target, rhomat, u)
          d_are = d_are + ucons(1,g_mmi%iemin+i-1,ie) - are_new

          ucons(1,g_mmi%iemin+i-1,ie) = are_new
          uprim(1,apr_idx(nummat, i),ie) = almat(i) * p_target
        end if
      ! negative volfrac
      else if (almat(i) < 0.0) then
        rhomat = eos3_density(g_gam(i), g_cp(i), g_pc(i), p_target, tmax)
        d_al = d_al + (almat(i) - 1d-14)

        ucons(1,g_mmi%iamin+i-1,ie) = 1d-14
        ucons(1,g_mmi%irmin+i-1,ie) = 1d-14 * rhomat
        ucons(1,g_mmi%iemin+i-1,ie) = 1d-14 * eos3_rhoe(g_gam(i), g_pc(i), &
          p_target, rhomat, u)
        uprim(1,apr_idx(nummat, i),ie) = 1d-14 * p_target
      end if
    end do !i

    !--- update state of majority material
    ucons(1,g_mmi%iamin+mmax-1,ie) = ucons(1,g_mmi%iamin+mmax-1,ie) + d_al
    almat(mmax) = ucons(1,g_mmi%iamin+mmax-1,ie)
    ucons(1,g_mmi%iemin+mmax-1,ie) = ucons(1,g_mmi%iemin+mmax-1,ie) + d_are
    uprim(1,apr_idx(nummat, mmax),ie) = eos3_alphapr(g_gam(mmax), g_pc(mmax), &
      almat(mmax), ucons(1,g_mmi%irmin+mmax-1,ie), &
      ucons(1,g_mmi%iemin+mmax-1,ie), u)

    !--- enforce unit sum
    alsum = 0.0
    do i = 1,nummat
      alsum = alsum + ucons(1,g_mmi%iamin+i-1,ie)
    end do !i

    do i = 1,nummat
      ucons(1,g_mmi%iamin+i-1,ie) = ucons(1,g_mmi%iamin+i-1,ie) / alsum
      ucons(1,g_mmi%irmin+i-1,ie) = ucons(1,g_mmi%irmin+i-1,ie) / alsum
      ucons(1,g_mmi%iemin+i-1,ie) = ucons(1,g_mmi%iemin+i-1,ie) / alsum
      uprim(1,apr_idx(nummat, i),ie) = uprim(1,apr_idx(nummat, i),ie) / alsum
    end do !i

  end do !ie

end associate

end subroutine ignore_tinyphase_mm6eq

!----------------------------------------------------------------------------------------------
!----- Check if volume fraction satisfies [0,1] bounds
!----------------------------------------------------------------------------------------------

subroutine check_volfrac(ie,uc)

integer, intent(in) :: ie
real*8,  intent(in) :: uc(g_neqns)

integer :: imat, mmax
real*8  :: eps

associate (nummat=>g_mmi%nummat)

  eps = 0.0001*g_alphamin

  !do imat = 1,nummat

  !  if ( (uc(imat) .lt. eps) .or. (uc(imat) .gt. 1.0-eps) ) then
  !    write(*,*) "------------------------------------------------------------------"
  !    write(*,*) "Bound-violating volume fraction: ", uc(imat)
  !    write(*,*) "  in cell ", ie
  !    write(*,*) "  material-id:  ", imat
  !    write(*,*) "  density:      ", uc(g_mmi%irmin+imat-1)
  !    write(*,*) "  total-energy: ", uc(g_mmi%iemin+imat-1)
  !    write(*,*) "------------------------------------------------------------------"
  !    write(*,*) " "
  !  end if

  !end do !imat

end associate

end subroutine check_volfrac

!----------------------------------------------------------------------------------------------

END MODULE eos


!  VERSION 1.0     2/5/99
!*********************************************************************

!               MODIFIED BESSEL FUNCTIONS OF THE FIRST
!               KIND OF INTEGER ORDER AND REAL ARGUMENT
!               ---------------------------------------

!       This double precision function subroutine calculates the
!       value of the modified Bessel function of the first kind of
!       integer order and strictly real argument via a backward
!       recurrence scheme taken from "Numerical Recipes", W. H. Press,
!       B. P. Flannery, S. A. Teulosky and W. T. Vetterling, 1st ed.,
!       Cambridge Univ. Press, 1986.

!       written by DJS 10-SEP-87
!       Bug in small-argument Taylor series expansion fixed by DEB OCT-92

!       Includes:
!               rndoff.inc

!       Uses:
!               bessi0.f
!               bessi1.f

!*********************************************************************

    function bessi(n,z)
    implicit none
    integer :: n
    double precision :: bessi,z

    include 'rndoff.inc'

    double precision :: bessi0,bessi1
    external bessi0,bessi1

    integer :: iacc
    double precision :: bigno,bigni
    parameter (iacc=40,bigno=1.0D10,bigni=1.0D-10)

    integer :: i,m,mmax
    double precision :: x,phase,twobyx,bi,bip,bim

    intrinsic abs

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

!---------------------------------------------------------------------
!       get proper phase factor if argument is negative with the
!       following rules
!                                         n
!       I (z) = I (z)  and   I (-z) = (-1) I (z)
!        n       -n           n             n
!---------------------------------------------------------------------

    m=abs(n)
    x=abs(z)

    if ((z < 0.0D0) .AND. (mod(m,2) == 1)) then
        phase=-1.0D0
    else
        phase=1.0D0
    end if

!---------------------------------------------------------------------
!       return proper values if argument is zero
!---------------------------------------------------------------------

    if (x < rndoff) then
        if (m == 0) then
            bessi=1.0D0
        else
            bessi=0.0D0
        end if
        return
    end if

!---------------------------------------------------------------------
!       call bessi0 if n=0, bessi1 if n=1, or go through
!       downward recurrence if n>1.
!---------------------------------------------------------------------

    if (m == 0) then
        bessi=phase*bessi0(x)
    else if (m == 1) then
        bessi=phase*bessi1(x)
    else
        bessi=0.0D0
        twobyx=2.0D0/x
        bip=0.0D0
        bi=1.0D0
        mmax=2*((m+int(sqrt(dble(iacc*m)))))
        do 10 i=mmax,1,-1
            bim=bip+dble(i)*twobyx*bi
            bip=bi
            bi=bim
            if (abs(bi) > bigno) then
                bessi=bessi*bigni
                bi=bi*bigni
                bip=bip*bigni
            end if
            if (i == m) bessi=bip
        10 END DO
        bessi=phase*bessi*bessi0(x)/bi
    end if

    return
    end function bessi

!*********************************************************************

!               MODIFIED BESSEL FUNCTION OF THE FIRST
!               KIND OF ORDER ZERO AND REAL ARGUMENT
!               -------------------------------------

!       This double precision function subroutine calculates the
!       modified Bessel function of the first kind of order zero
!       and real argument by either the Taylor series expansion
!       for small arguments or the first term of the asymptotic
!       series for sufficiently large arguments.

!       written by DJS 10-SEP-87

!       Includes:
!               rndoff.inc
!               pidef.inc

!       Uses:

!*********************************************************************

    function bessi0(z)

    include 'rndoff.inc'
!    include 'pidef.inc'
    double precision :: pi,radian
    parameter (pi=3.1415926535897932384D0,radian=pi/180.0D0)

    double precision :: bessi0
    double precision :: z

    integer :: i,j
    double precision :: x,y,smax,temp1,temp2,temp3,sum

    integer :: nmax
    parameter (nmax=40)

    double precision :: tser
    dimension tser(nmax)

    double precision :: cutoff
    parameter (cutoff=20.0D0)

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

    y=abs(z)

!------------------------------------------------------------
!     Set function value to unity if argument is too small
!------------------------------------------------------------
    if (y < rndoff) then
        bessi0=1.0D0

    !-------------------------------------------------------------
    !     Taylor series expansion for small to moderate arguments
    !-------------------------------------------------------------
    else if (y <= cutoff) then
        x=y*y*0.25D0
        temp1=1.0D0
        smax=1.0D0
        i=1
        10 temp1=(temp1/dble(i))*(x/dble(i))
        if (i > nmax) then
            write(*,1000)
            stop
        end if
        tser(i)=temp1
        i=i+1
        if (temp1 > smax) smax=temp1
        if (temp1/smax > rndoff) go to 10

        bessi0=0.0D0
        do 20 j=i-1,1,-1
            bessi0=bessi0+tser(j)
        20 END DO
        bessi0=bessi0+1.0D0

    !----------------------------------------------
    !     Asymptotic expansion for large arguments
    !----------------------------------------------
    else
        x=0.125D0/y
        sum=0.0D0
        temp3=1.0D0
        smax=1.0D0
        i=1
        30 temp1=dble(2*i-1)
        temp2=(x*temp1)*(temp1/dble(i))
        if (temp2 > 1.0D0) go to 40
        temp3=temp3*temp2
        if (temp3 > smax) smax=temp3
        if (temp3/smax < rndoff) go to 40
        sum=sum+temp3
        i=i+1
        go to 30
        40 bessi0=dexp(y)*((sum+1.0D0)/dsqrt(y*(pi+pi)))
    end if

    return

    1000 format('bessi0: Taylor series did not converge')
    end function bessi0

!*********************************************************************

!               MODIFIED BESSEL FUNCTION OF THE FIRST
!               KIND OF ORDER ONE AND REAL ARGUMENT
!               -------------------------------------

!       This double precision function subroutine calculates the
!       modified Bessel function of the first kind of order one
!       and real argument by either the Taylor series expansion
!       for small arguments or the first term of the asymptotic
!       series for sufficiently large arguments.

!       written by DJS 10-SEP-87

!       Includes:
!               rndoff.inc
!               pidef.inc

!       Uses:

!*********************************************************************

    function bessi1(z)

    include 'rndoff.inc'
!    include 'pidef.inc'
    double precision :: pi,radian
    parameter (pi=3.1415926535897932384D0,radian=pi/180.0D0)

    double precision :: bessi1
    double precision :: z

    integer :: i,j
    double precision :: x,y,smax,temp1,temp2,temp3,phase,sum

    integer :: nmax
    parameter (nmax=40)

    double precision :: series
    dimension series(nmax)

    double precision :: cutoff
    parameter (cutoff=20.0D0)

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

    if (z > 0.0D0) then
        phase=1.0D0
        y=z
    else
        phase=-1.0D0
        y=-z
    end if

!----------------------------------------------------------------------
!     set answer to zero if argument is too small, otherwise
!----------------------------------------------------------------------
    if (y < rndoff) then
        bessi1=0.0D0

    !----------------------------------------------------------------------
    !     Use Taylor series expansion for small to moderate arguments or
    !----------------------------------------------------------------------
    else if (y <= cutoff) then
        x=y*y*0.25D0
        temp1=1.0D0
        smax=1.0D0
        i=1
        10 temp1=(temp1/dble(i))*(x/dble(i+1))
        if (i > nmax) then
            write(*,1000)
            stop
        end if
        series(i)=temp1
        i=i+1
        if (temp1 > smax) smax=temp1
        if (temp1/smax > rndoff) go to 10
        bessi1=0.0D0
        do 20 j=i-1,1,-1
            bessi1=bessi1+series(j)
        20 END DO
        bessi1=phase*y*0.5D0*(bessi1+1.0D0)

    !----------------------------------------------------------------------
    !     asymptotic expansion for large arguments
    !----------------------------------------------------------------------
    else
        x=0.125D0/y
        sum=3.0D0*x
        temp3=sum
        smax=1.0D0
        i=2
        30 temp1=dble(2*i-1)
        temp1=temp1*temp1-4.0D0
        temp2=(x*temp1)/dble(i)
        if (temp2 > 1.0D0) go to 40
        temp3=temp3*temp2
        if (temp3 > smax) smax=temp3
        if (temp3/smax < rndoff) go to 40
        sum=sum+temp3
        i=i+1
        go to 30
        40 bessi1=dexp(y)*(1.0D0-sum)/dsqrt(y*(pi+pi))
    end if

    return

!----------------------------------------------------------------------
    1000 format('bessi0: Taylor series did not converge')
    end function bessi1


      real*8 function theta(r20,thk,tmp) result (r_theta)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function corrects rate constants for temperature
!!    Equation is III-52 from QUAL2E

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    r20         |1/day         |value of the reaction rate coefficient at
!!                               |the standard temperature (20 degrees C)
!!    thk         |none          |temperature adjustment factor (empirical
!!                               |constant for each reaction coefficient)
!!    tmp         |deg C         |temperature on current day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    theta       |1/day         |value of the reaction rate coefficient at
!!                               |the local temperature
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real*8, intent (in) :: r20, thk, tmp

      r_theta = 0.
      r_theta = r20 * thk ** (tmp - 20.)

      return
      end


C Return radius for a given lat,lon.
C Longitudes may be either east or west.
C
      subroutine ellipse_radius(lat,lon,ra,rb,rc,lora,gcr)
      implicit none
      real*8 lat,lon		!Input lat,lon coordinates
      real*8 ra,rb,rc		!Input target body radii
      real*8 lora		!Longitude of semi-major axis
      real*8 gcr		!geocentric radius
      real*8 rlat,rlon,clat,slat,clon,slon,dtor,PI

      PI = 3.141592653589793D0
      dtor = PI/180.d0		!degrees to radians
      rlat = lat*dtor		!convert to radians
      rlon = (lon-lora)*dtor
      clat = dcos(rlat)
      slat = dsin(rlat)
      clon = dcos(rlon)
      slon = dsin(rlon)
      gcr = 1.d0/dsqrt((clat*clon/ra)**2+(clat*slon/rb)**2+(slat/rc)**2)
      return
      end


SUBROUTINE fmplat(d2x,d2y,d2xy,points,aa,bb,i)
!
! This subroutine forms the 2nd derivatives for rectangular
! plate bending elements.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::points(:,:),aa,bb
 REAL(iwp),INTENT(OUT)::d2x(:),d2y(:),d2xy(:)
 INTEGER,INTENT(IN)::i
 REAL(iwp)::x,e,xp1,xp12,xp13,ep1,ep12,ep13,p1,q1,p2,q2,p3,q3,p4,q4,dp1,  &
   dq1,dp2,dq2,dp3,dq3,dp4,dq4,d2p1,d2p2,d2p3,d2p4,d2q1,d2q2,d2q3,d2q4,   &
   pt25=0.25_iwp,pt375=0.375_iwp,pt5=0.5_iwp,pt75=0.75_iwp,one=1.0_iwp,   &
   opt5=1.5_iwp,d3=3.0_iwp
 x=points(i,1)
 e=points(i,2)
 xp1=x+one
 xp12=xp1*xp1
 xp13=xp12*xp1
 ep1=e+one
 ep12=ep1*ep1
 ep13=ep12*ep1
 p1=one-pt75*xp12+pt25*xp13
 q1=one-pt75*ep12+pt25*ep13
 p2=pt5*aa*xp1*(one-xp1+pt25*xp12)
 q2=pt5*bb*ep1*(one-ep1+pt25*ep12)
 p3=pt25*xp12*(d3-xp1)
 q3=pt25*ep12*(d3-ep1)
 p4=pt25*aa*xp12*(pt5*xp1-one)
 q4=pt25*bb*ep12*(pt5*ep1-one)
 dp1=opt5*xp1*(pt5*xp1-one)
 dq1=opt5*ep1*(pt5*ep1-one)
 dp2=aa*(pt5-xp1+pt375*xp12)
 dq2=bb*(pt5-ep1+pt375*ep12)
 dp3=opt5*xp1*(one-pt5*xp1)
 dq3=opt5*ep1*(one-pt5*ep1)
 dp4=pt5*aa*xp1*(pt75*xp1-one)
 dq4=pt5*bb*ep1*(pt75*ep1-one)
 d2p1=opt5*x
 d2p2=pt25*aa*(d3*x-one)
 d2p3=-d2p1
 d2p4=pt25*aa*(d3*x+one)
 d2q1=opt5*e
 d2q2=pt25*bb*(d3*e-one)
 d2q3=-d2q1
 d2q4=pt25*bb*(d3*e+one)
 d2x(1)=d2p1*q1
 d2x(2)=d2p2*q1
 d2x(3)=d2p1*q2
 d2x(4)=d2p2*q2
 d2x(5)=d2p1*q3
 d2x(6)=d2p2*q3
 d2x(7)=d2p1*q4
 d2x(8)=d2p2*q4
 d2x(9)=d2p3*q3
 d2x(10)=d2p4*q3
 d2x(11)=d2p3*q4
 d2x(12)=d2p4*q4
 d2x(13)=d2p3*q1
 d2x(14)=d2p4*q1
 d2x(15)=d2p3*q2
 d2x(16)=d2p4*q2
 d2y(1)=p1*d2q1
 d2y(2)=p2*d2q1
 d2y(3)=p1*d2q2
 d2y(4)=p2*d2q2
 d2y(5)=p1*d2q3
 d2y(6)=p2*d2q3
 d2y(7)=p1*d2q4
 d2y(8)=p2*d2q4
 d2y(9)=p3*d2q3
 d2y(10)=p4*d2q3
 d2y(11)=p3*d2q4
 d2y(12)=p4*d2q4
 d2y(13)=p3*d2q1
 d2y(14)=p4*d2q1
 d2y(15)=p3*d2q2
 d2y(16)=p4*d2q2
 d2xy(1)=dp1*dq1
 d2xy(2)=dp2*dq1
 d2xy(3)=dp1*dq2
 d2xy(4)=dp2*dq2
 d2xy(5)=dp1*dq3
 d2xy(6)=dp2*dq3
 d2xy(7)=dp1*dq4
 d2xy(8)=dp2*dq4
 d2xy(9)=dp3*dq3
 d2xy(10)=dp4*dq3
 d2xy(11)=dp3*dq4
 d2xy(12)=dp4*dq4
 d2xy(13)=dp3*dq1
 d2xy(14)=dp4*dq1
 d2xy(15)=dp3*dq2
 d2xy(16)=dp4*dq2
RETURN
END SUBROUTINE fmplat


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Clausen function \f$\operatorname{Cl}_4(\theta) = \operatorname{Im}(\operatorname{Li}_4(e^{i\theta}))\f$
!> @param x real angle
!> @return \f$\operatorname{Cl}_4(\theta)\f$
!> @author Alexander Voigt
!> Implemented as rational function approximation.
!*********************************************************************

double precision function dcl4(x)
  implicit none
  double precision :: x, y, z, z2, z4, p, q, p0, p1, h, sgn
  double precision, parameter :: PI = 3.14159265358979324D0
  double precision, parameter :: PI2 = 2*PI, PIH = PI/2, PI28 = PI*PI/8
  double precision, parameter :: zeta3 = 1.2020569031595943D0
  double precision, parameter :: cp(4) = (/ &
     -3.0555555555555556D-1,                &
      6.0521392328447206D-3,                &
     -1.9587493942041528D-5,                &
     -3.1137343767030358D-8                 /)
  double precision, parameter :: cq(4) = (/ &
      1.0000000000000000D+0,                &
     -2.2079728398400851D-2,                &
      1.0887447112236682D-4,                &
     -6.1847621370547954D-8                 /)
  double precision, parameter :: cr(6) = (/ &
      7.6223911686491336D-1,                &
     -2.4339587368267260D-1,                &
      2.8715364937979943D-2,                &
     -1.5368612510964667D-3,                &
      3.6261044225761673D-5,                &
     -2.8557977333851308D-7                 /)
  double precision, parameter :: cs(6) = (/ &
      1.0000000000000000D+0,                &
     -1.7465715261403233D-1,                &
      9.5439417991615653D-3,                &
     -1.7325070821666274D-4,                &
      5.9283675098376635D-7,                &
      9.4127575773361230D-10                /)

  sgn = 1

  if (x .lt. 0) then
     x = -x
     sgn = -1
  endif

  if (x .ge. PI2) then
     x = mod(x, PI2)
  endif

  if (x .gt. PI) then
     p0 = 6.28125D0
     p1 = 0.0019353071795864769253D0
     x = (p0 - x) + p1
     sgn = -sgn
  endif

  if (x .eq. 0 .or. x .eq. PI) then
     dcl4 = 0
     return
  endif

  if (x .lt. PIH) then
    y = x*x
    z = y*y
    p = cp(1) + y * cp(2) + z * (cp(3) + y * cp(4))
    q = cq(1) + y * cq(2) + z * (cq(3) + y * cq(4))
    h = x*(zeta3 + y*(p/q + log(x)/6))
  else
    y = PI - x
    z = y*y - PI28
    z2 = z*z
    z4 = z2*z2
    p = cr(1) + z * cr(2) + z2 * (cr(3) + z * cr(4)) + &
        z4 * (cr(5) + z * cr(6))
    q = cs(1) + z * cs(2) + z2 * (cs(3) + z * cs(4)) + &
        z4 * (cs(5) + z * cs(6))
    h = y*p/q
  endif

  dcl4 = sgn*h

end function dcl4


subroutine interp2(x,y,v,n1,n2,a,b,NZ)
   implicit none
   integer*4::n1,n2;
   integer*4,dimension(1)::sx,sy;
   real*8(n2,n1)::v;
   real*8(n1):: x;
   real*8(n2):: y;
   real*8(1,1):: NZ1,v1,v2,v3,v4,v5;
   real*8(1):: x1,x2,x3,y1,y2,y3
   real*8::a,b,NZ
   sx=minloc(abs(x-a));sy=minloc(abs(y-b));
   y1=y(sy);x1=x(sx);
   y2=y(sy-1);x2=x(sx-1);y3=y(sy+1);x3=x(sx+1);
   v1=v(sy,sx);v2=v(sy,sx-1);v3=v(sy-1,sx);v4=v(sy+1,sx);
   v5=v(sy,sx+1);
   if((y1(1)>b).AND.(x1(1)>a))then
      NZ1=v1(1,1)-(v1(1,1)-v2(1,1))/(x1(1)-x2(1))*(x1(1)-a)&
      &-(v1(1,1)-v3(1,1))/(y1(1)-y2(1))*(y1(1)-b);
      else if((y1(1)<=b).AND.(x1(1)>a))then
      NZ1=v1(1,1)-(v1(1,1)-v2(1,1))/(x1(1)-x2(1))*(x1(1)-a)&
      &-(v4(1,1)-v1(1,1))/(y3(1)-y1(1))*(y1(1)-b);
      else if(y1(1)>b.AND.x1(1)<=a)then
      NZ1=v1(1,1)-(v5(1,1)-v1(1,1))/(x3(1)-x1(1))*(x1(1)-a)&
      &-(v1(1,1)-v3(1,1))/(y1(1)-y2(1))*(y1(1)-b);
   else
      NZ1=v1(1,1)-(v5(1,1)-v1(1,1))/(x3(1)-x1(1))*(x1(1)-a)&
      &-(v4(1,1)-v1(1,1))/(y3(1)-y1(1))*(y1(1)-b);
    end if
    NZ=NZ1(1,1);
   return;
end subroutine


/* Examples for testing */

 lambda x:A. x;

lambda x:Bool. x;
(lambda x:Bool->Bool. if x false then true else false)
  (lambda x:Bool. if x then false else true);

lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);

(lambda x:X. lambda y:X->X. y x);
(lambda x:X->X. x 0) (lambda y:Nat. y);


subroutine nbody_acceleration(position,velocity,acceleration)
! Routine drives calculation of all different acceleration terms

use embryodata,only: nbodies
implicit none

real,dimension(3,nbodies), intent(in) :: position,velocity
real,dimension(3,nbodies), intent(out) :: acceleration

acceleration(:,:) = 0.0

call nbody_grav_acceleration(position,acceleration)
call nbody_drag_terms(position,velocity,acceleration)

end subroutine nbody_acceleration


subroutine interp1(x,v,n1,n2,C,NZ)
   implicit none;
 integer*4 i,n1,n2;
   double precision,dimension(n1):: x,v;
 double precision,dimension(n2):: C,NZ;
 double precision,dimension(1)::NZ1,P1,P2,P3,V1,V2,V3;
 do i=1,n2
 P1=x(minloc(abs(x-C(i)))-1);P2=x(minloc(abs(x-C(i))));
 P3=x(minloc(abs(x-C(i)))+1);
 V1=v(minloc(abs(x-C(i)))-1);V2=v(minloc(abs(x-C(i))));
 V3=v(minloc(abs(x-C(i)))+1);
if (C(i)==x(i)) then
NZ1(1)=v(i);
else
 if (C(i)>P2(1)) then
  NZ1(1)=V2(1)+(V3(1)-V2(1))/(P3(1)-P2(1))*(C(i)-P2(1));
  else
  NZ1(1)=V2(1)+(V2(1)-V1(1))/(P2(1)-P1(1))*(C(i)-P2(1));
  end if;
end if;
  NZ(i)=NZ1(1);
  end do ;

   return;
end subroutine


       program NS
       parameter (nvar=3,nxm=2000,nym=2000)
       real phi1(nvar,nxm,nym)
       real xcoef(nxm,nym)

       nx=101
       ny=101

! This loop nest should be parallelized on j
! xco, px and py should be privatized
       do j=2,ny-1
          do i=2,nx-1
             xco=xcoef(i,j)
             px=(phi1(3,i+1,j)-phi1(3,i-1,j))*h1p2
             py=(phi1(3,i,j+1)-phi1(3,i,j-1))*h2p2
             phi1(1,i,j)=phi1(1,i,j)-dt*px*xco
             phi1(2,i,j)=phi1(2,i,j)-dt*py*xco
          enddo
       enddo
       end


!Implemented by Anant Dixit (Oct, 2014)
program mdr
implicit none
integer :: i, mdr, mp, n, j
character(len=*), parameter :: hfmt = '(A18)', nfmt = '(I6)'
character(len=*), parameter :: cfmt = '(A3)', rfmt = '(I3)', ffmt = '(I9)'

write(*,hfmt) 'Number   MDR   MP '
write(*,*) '------------------'

i = 123321
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 3939
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 8822
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 39398
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

write(*,*)
write(*,*)
write(*,*) 'First five numbers with MDR in first column: '
write(*,*) '---------------------------------------------'

do i = 0,9
  n = 0
  j = 0
  write(*,rfmt,advance='no') i
  do
    call root_pers(j,mdr,mp)
    if(mdr.eq.i) then
      n = n+1
      if(n.eq.5) then
        write(*,ffmt) j
        exit
      else
        write(*,ffmt,advance='no') j
      end if
    end if
    j = j+1
  end do
end do

end program

subroutine root_pers(i,mdr,mp)
implicit none
integer :: N, s, a, i, mdr, mp
n = i
a = 0
if(n.lt.10) then
  mdr = n
  mp = 0
  return
end if
do while(n.ge.10)
  a = a + 1
  s = 1
  do while(n.gt.0)
    s = s * mod(n,10)
    n = int(real(n)/10.0D0)
  end do
  n = s
end do
mdr = s
mp = a
end subroutine