module Mod_plcdExacso
   use typre
   use Mod_PLCD

   implicit none
   type plcdExacso

   ! work variables
   real(rp)    :: p

   real(rp)    :: disp(3),coord(3)
   real(rp)    :: grad(3,3)=0.0_rp, gradp(3) = 0.0_rp
   real(rp)    :: hessi(3,3,3)
   real(rp)    :: nn,xvisc,xdens

contains
      procedure :: ComputeSolution
      procedure :: GetDisplacement
      procedure :: GetPressure
      procedure :: GetForce
   end type

contains

   subroutine ComputeSolution(a,ndime,gpcod,php)
      implicit none
      class(plcdExacso) :: a
      Class(PLCDProblem) :: php
      integer(ip), intent(in) :: ndime
      real(rp),    intent(in) :: gpcod(ndime)
      real(rp) :: pi
      real(rp) :: r,phi,alpha,omega
      real(rp) :: alpsq,alpcu
      real(rp) :: cosphisq,cosphicu
      real(rp) :: sinphisq,sinphicu, invk, phi2,sum1,sum2,sum3,sum4, phi2prima,phi2prima3
      integer(ip) :: idime,jdime,kdime

!       if(ndime==3)then
!          call runend('ComputeSolution: exact solution not ready for 3d case')
!       end if

      !Coordinates and initializations.

      a%coord(1:ndime) = gpcod

      a%disp = 0.0_rp
      a%p = 0.0_rp
      a%grad = 0.0_rp
      a%gradp = 0.0_rp

      !Hessi is stored as follows:
      !First index : u, v, w
      !Second index: derivative with respect to (first one)
      !third index: derivative with respect to (second one)
      a%hessi = 0.0_rp

      pi= 4.*atan(1.)

      ! Obtain unknowns and derivatives according to the exact solution (Kexac)

      if(php%kfl_exacs==1) then !domain [0,1]x[0,1]

         !u = 2xy
         !v = -y**2
         !p = xy

         ! velocity
         a%disp(1)     =  2.0_rp*a%coord(1)*a%coord(2)
         a%disp(2)     =  -a%coord(2)*a%coord(2)

         !velocity derivatives
         !u component
         a%grad(1,1)    = 2.0_rp*a%coord(2)
         a%grad(1,2)    = 2.0_rp*a%coord(1)
         a%hessi(1,1,1)   =   0.0_rp
         a%hessi(1,2,2)   =   0.0_rp
         a%hessi(1,1,2) =   2.0_rp
         !v component
         a%grad(2,1)    = 0.0_rp
         a%grad(2,2)    = -2*a%coord(2)
         a%hessi(2,1,1)   = 0.0_rp
         a%hessi(2,2,2)   = -2.0_rp
         a%hessi(2,1,2) = 0.0_rp
         !pressure and derivatives
         a%p     = a%coord(1)*a%coord(2)
         a%gradp(1)  =  a%coord(2)
         a%gradp(2)  =  a%coord(1)

      elseif (php%kfl_exacs==2) then  !domain [0,1]x[0,1]
         !u = 0
         !v = 0
         !p = 2*x*x*y

         a%p =     2*a%coord(1)*a%coord(1)*a%coord(2)
         a%gradp(1) =  4*a%coord(2)*a%coord(1)
         a%gradp(2) =  2*a%coord(1)*a%coord(1)

      elseif (php%kfl_exacs == 3) then
         ! spherical coordinates
         r      = sqrt(a%coord(1)*a%coord(1) + a%coord(2)*a%coord(2))
         phi    = atan(a%coord(2)/a%coord(1))
         if(a%coord(1)<epsilon(0.0_rp)) phi = phi + pi
         if(abs(a%coord(1))<epsilon(0.0_rp)) then
            if(a%coord(2)>epsilon(0.0_rp)) phi = pi/2.0_rp
            if(a%coord(2)<epsilon(0.0_rp)) phi = 3*pi/2.0_rp
         end if

         alpha = 0.544483736782464
         omega  = 4.712388980384690

         alpsq  = alpha*alpha
         alpcu  = alpha*alpha*alpha
         cosphisq = cos(phi)*cos(phi)
         cosphicu = cos(phi)*cos(phi)*cos(phi)
         sinphisq = sin(phi)*sin(phi)

         if(r>epsilon(0.0_rp)) then
            sum1 = sin((1+alpha)*phi)*cos(alpha*omega)/(1+alpha);
            sum2 = -cos((1+alpha)*phi);
            sum3 = sin((alpha-1)*phi)*cos(alpha*omega)/(1-alpha);
            sum4 = cos((alpha-1)*phi);

            phi2 =sum1+sum2+sum3+sum4;
            phi2prima = 2*sin(alpha*phi)*cos(phi) + 2*alpha*cos(alpha*phi)*sin(phi) - 2*cos(alpha*omega)*sin(alpha*phi)*sin(phi)

            phi2prima3 = sin(phi*(alpha - 1))*(alpha - 1)**3 - sin(phi*(alpha + 1))*(alpha + 1)**3 + cos(alpha*omega)*cos(phi*(alpha - 1))*(alpha - 1)**2 - cos(alpha*omega)*cos(phi*(alpha + 1))*(alpha + 1)**2

            a%disp(1) = (r**alpha)*(cos(phi)*phi2prima+(1+alpha)*sin(phi)*phi2);
            a%disp(2) = (r**alpha)*(sin(phi)*phi2prima-(1+alpha)*cos(phi)*phi2);

            a%p = -r**(alpha-1)*((1+alpha)**2*phi2prima+phi2prima3)/(1-alpha);

            a%grad(1,1) = (alpha*r**(alpha - 1)*(2*sin(phi*(alpha - 1)) + 2*sin(phi*(alpha - 3)) + cos(phi + alpha*omega - alpha*phi) + cos(phi - alpha*omega - alpha*phi) - cos(3*phi + alpha*omega - alpha*phi) - cos(3*phi - alpha*omega - alpha*phi) + 2*alpha*sin(phi*(alpha - 1)) - 2*alpha*sin(phi*(alpha - 3))))/2.0_rp
            a%grad(1,2) = (alpha*r**(alpha - 1)*(sin(3*phi + alpha*omega - alpha*phi) + sin(3*phi - alpha*omega - alpha*phi) - 6*cos(phi - alpha*phi) + sin(phi + alpha*omega - alpha*phi) + sin(phi - alpha*omega - alpha*phi) - 2*cos(3*phi - alpha*phi) + 4*alpha*cos(phi - alpha*phi) + alpha*sin(phi + alpha*omega - alpha*phi) + alpha*sin(phi - alpha*omega - alpha*phi) + 4*alpha*cos(3*phi - alpha*phi) + 2*alpha**2*cos(phi - alpha*phi) - alpha*sin(3*phi + alpha*omega - alpha*phi) - alpha*sin(3*phi - alpha*omega - alpha*phi) - 2*alpha**2*cos(3*phi - alpha*phi)))/(2*(alpha - 1))
            a%grad(2,1) = (alpha*r**(alpha - 1)*(sin(3*phi + alpha*omega - alpha*phi) + sin(3*phi - alpha*omega - alpha*phi) + 2*cos(phi - alpha*phi) - 3*sin(phi + alpha*omega - alpha*phi) - 3*sin(phi - alpha*omega - alpha*phi) - 2*cos(3*phi - alpha*phi) - 4*alpha*cos(phi - alpha*phi) + alpha*sin(phi + alpha*omega - alpha*phi) + alpha*sin(phi - alpha*omega - alpha*phi) + 4*alpha*cos(3*phi - alpha*phi) + 2*alpha**2*cos(phi - alpha*phi) - alpha*sin(3*phi + alpha*omega - alpha*phi) - alpha*sin(3*phi - alpha*omega - alpha*phi) - 2*alpha**2*cos(3*phi - alpha*phi)))/(2*(alpha - 1))
            a%grad(2,2) = -(alpha*r**(alpha - 1)*(2*sin(phi*(alpha - 1)) + 2*sin(phi*(alpha - 3)) + cos(phi + alpha*omega - alpha*phi) + cos(phi - alpha*omega - alpha*phi) - cos(3*phi + alpha*omega - alpha*phi) - cos(3*phi - alpha*omega - alpha*phi) + 2*alpha*sin(phi*(alpha - 1)) - 2*alpha*sin(phi*(alpha - 3))))/2.0_rp
            a%gradp(1) = -2*alpha*r**(alpha - 2)*(cos(2*phi + alpha*omega - alpha*phi) - 2*sin(phi*(alpha - 2)) + cos(2*phi - alpha*omega - alpha*phi) + 2*alpha*sin(phi*(alpha - 2)))
            a%gradp(2) = -2*alpha*r**(alpha - 2)*(sin(2*phi + alpha*omega - alpha*phi) + sin(2*phi - alpha*omega - alpha*phi) - 2*cos(phi*(alpha - 2)) + 2*alpha*cos(phi*(alpha - 2)))
            a%hessi(1,1,1) = (alpha*r**(alpha - 2)*(4*sin(4*phi - alpha*phi) - 2*cos(2*phi + alpha*omega - alpha*phi) - 2*cos(2*phi - alpha*omega - alpha*phi) + 2*cos(4*phi + alpha*omega - alpha*phi) + 2*cos(4*phi - alpha*omega - alpha*phi) + 2*alpha*sin(2*phi - alpha*phi) - 6*alpha*sin(4*phi - alpha*phi) + alpha*cos(2*phi + alpha*omega - alpha*phi) + alpha*cos(2*phi - alpha*omega - alpha*phi) - alpha*cos(4*phi + alpha*omega - alpha*phi) - alpha*cos(4*phi - alpha*omega - alpha*phi) - 2*alpha**2*sin(2*phi - alpha*phi) + 2*alpha**2*sin(4*phi - alpha*phi)))/2.0_rp
            a%hessi(1,1,2) = (alpha*r**(alpha - 2)*(2*sin(4*phi + alpha*omega - alpha*phi) + 2*sin(4*phi - alpha*omega - alpha*phi) - 4*cos(phi*(alpha - 2)) - 4*cos(phi*(alpha - 4)) + 2*alpha**2*cos(phi*(alpha - 2)) - 2*alpha**2*cos(phi*(alpha - 4)) + 2*alpha*cos(phi*(alpha - 2)) + 6*alpha*cos(phi*(alpha - 4)) + alpha*sin(2*phi + alpha*omega - alpha*phi) + alpha*sin(2*phi - alpha*omega - alpha*phi) - alpha*sin(4*phi + alpha*omega - alpha*phi) - alpha*sin(4*phi - alpha*omega - alpha*phi)))/2.0_rp
            a%hessi(1,2,2) = -(alpha*r**(alpha - 2)*(2*cos(2*phi + alpha*omega - alpha*phi) - 4*sin(phi*(alpha - 4)) - 8*sin(phi*(alpha - 2)) + 2*cos(2*phi - alpha*omega - alpha*phi) + 2*cos(4*phi + alpha*omega - alpha*phi) + 2*cos(4*phi - alpha*omega - alpha*phi) + 2*alpha**2*sin(phi*(alpha - 2)) - 2*alpha**2*sin(phi*(alpha - 4)) + alpha*cos(2*phi + alpha*omega - alpha*phi) + alpha*cos(2*phi - alpha*omega - alpha*phi) - alpha*cos(4*phi + alpha*omega - alpha*phi) - alpha*cos(4*phi - alpha*omega - alpha*phi) + 6*alpha*sin(phi*(alpha - 2)) + 6*alpha*sin(phi*(alpha - 4))))/2.0_rp
            a%hessi(2,1,1) = -(alpha*r**(alpha - 2)*(4*sin(2*phi + alpha*omega - alpha*phi) + 4*sin(2*phi - alpha*omega - alpha*phi) - 2*sin(4*phi + alpha*omega - alpha*phi) - 2*sin(4*phi - alpha*omega - alpha*phi) - 4*cos(phi*(alpha - 2)) + 4*cos(phi*(alpha - 4)) - 2*alpha**2*cos(phi*(alpha - 2)) + 2*alpha**2*cos(phi*(alpha - 4)) + 6*alpha*cos(phi*(alpha - 2)) - 6*alpha*cos(phi*(alpha - 4)) - alpha*sin(2*phi + alpha*omega - alpha*phi) - alpha*sin(2*phi - alpha*omega - alpha*phi) + alpha*sin(4*phi + alpha*omega - alpha*phi) + alpha*sin(4*phi - alpha*omega - alpha*phi)))/2.0_rp
            a%hessi(2,1,2) = (alpha*r**(alpha - 2)*(4*sin(phi*(alpha - 4)) + 2*cos(2*phi + alpha*omega - alpha*phi) + 2*cos(2*phi - alpha*omega - alpha*phi) - 2*cos(4*phi + alpha*omega - alpha*phi) - 2*cos(4*phi - alpha*omega - alpha*phi) - 2*alpha**2*sin(phi*(alpha - 2)) + 2*alpha**2*sin(phi*(alpha - 4)) - alpha*cos(2*phi + alpha*omega - alpha*phi) - alpha*cos(2*phi - alpha*omega - alpha*phi) + alpha*cos(4*phi + alpha*omega - alpha*phi) + alpha*cos(4*phi - alpha*omega - alpha*phi) + 2*alpha*sin(phi*(alpha - 2)) - 6*alpha*sin(phi*(alpha - 4))))/2.0_rp
            a%hessi(2,2,2) = -(alpha*r**(alpha - 2)*(2*sin(4*phi + alpha*omega - alpha*phi) + 2*sin(4*phi - alpha*omega - alpha*phi) - 4*cos(phi*(alpha - 2)) - 4*cos(phi*(alpha - 4)) + 2*alpha**2*cos(phi*(alpha - 2)) - 2*alpha**2*cos(phi*(alpha - 4)) + 2*alpha*cos(phi*(alpha - 2)) + 6*alpha*cos(phi*(alpha - 4)) + alpha*sin(2*phi + alpha*omega - alpha*phi) + alpha*sin(2*phi - alpha*omega - alpha*phi) - alpha*sin(4*phi + alpha*omega - alpha*phi) - alpha*sin(4*phi - alpha*omega - alpha*phi)))/2.0_rp
         endif

      elseif (php%kfl_exacs == 4) then
         a%disp(1) = +1.0_rp/2.0_rp*a%coord(1)**2.0_rp+a%coord(2)+a%coord(3)+a%coord(1)*a%coord(2)+a%coord(1)*a%coord(3)-a%coord(2)**2.0_rp/2.0_rp-a%coord(3)**2.0_rp/2.0_rp
         a%disp(2) = +1.0_rp/2.0_rp*a%coord(2)**2.0_rp-a%coord(3)-a%coord(1)-a%coord(1)**2.0_rp/2.0_rp+a%coord(2)*a%coord(1)+a%coord(2)*a%coord(3)-a%coord(3)**2.0_rp/2.0_rp
         a%disp(3) = +1.0_rp/2.0_rp*a%coord(3)**2.0_rp-a%coord(1)+a%coord(2)-a%coord(1)**2.0_rp/2.0_rp+a%coord(3)*a%coord(2)+a%coord(3)*a%coord(1)-a%coord(2)**2.0_rp/2.0_rp

         a%grad = transpose(reshape((/ a%coord(1) + a%coord(2) + a%coord(3), a%coord(1) - a%coord(2) + 1, a%coord(1) - a%coord(3) + 1, &
                                       a%coord(2) - a%coord(1) - 1, a%coord(1) + a%coord(2) + a%coord(3), a%coord(2) - a%coord(3) - 1, &
                                       a%coord(3) - a%coord(1) - 1, a%coord(3) - a%coord(2) + 1, a%coord(1) + a%coord(2) + a%coord(3)/),shape(a%grad)))

         a%hessi(:,:,1) = transpose(reshape((/ 1, 1, 1, -1, 1, 0, -1, 0, 1/),shape(a%hessi(:,:,1))))
         a%hessi(:,:,2) = transpose(reshape((/ 1, -1, 0, 1, 1, 1, 0, -1, 1/),shape(a%hessi(:,:,2))))
         a%hessi(:,:,3) = transpose(reshape((/ 1, 0, -1, 0, 1, -1, 1, 1, 1/),shape(a%hessi(:,:,3))))

         call php%Materials(1)%p%CT%GetInverseVolumetricDeformationModulus(invK)
         if (invk == 0) call runend('Exacso 4 for plcd is to be used with compressible material')

         !Pressure from DivU
         call PressureFromDivU

      elseif (php%kfl_exacs == 5) then
         call php%Materials(1)%p%CT%GetInverseVolumetricDeformationModulus(invK)
         if (invk == 0) call runend('Exacso 5 for plcd is to be used with compressible material')

         a%p = a%coord(1)**3 + a%coord(2)**3
         a%gradp(1) = 3*a%coord(1)**2
         a%gradp(2) = 3*a%coord(2)**2
      else
         call runend('ComputeSolution exact solution number not defined')
         !define your exact solution
      end if

      !Cross derivatives (second order) are symmetric
      do idime = 1,ndime
         do jdime = 1,ndime
            do kdime = jdime+1,ndime
               a%hessi(idime,kdime,jdime) = a%hessi(idime,jdime,kdime)
            enddo
         enddo
      enddo

      if (php%UseUPFormulation) then
         call php%Materials(1)%p%CT%GetInverseVolumetricDeformationModulus(invK)

         !Compressible material, cannot fix p
         if (invk /= 0.0_rp) then

!
!             a%p = 0.0_rp
!             do idime = 1,ndime
!                a%p = a%p - (1.0_rp/invk)*(a%grad(idime,idime))
!             enddo
!             a%gradp(1:ndime) = 0.0_rp
!             do idime = 1,ndime
!                do jdime = 1,ndime
!                   a%gradp(idime) = a%gradp(idime) - (1.0_rp/invk)*a%hessi(jdime,jdime,idime)
!                enddo
!             enddo
         else
            !The one specified by the analytical solution
         endif
      endif

contains
      subroutine PressureFromDivU
         a%p = 0.0_rp
         do idime = 1,ndime
            a%p = a%p - (1.0_rp/invk)*(a%grad(idime,idime))
         enddo
         a%gradp(1:ndime) = 0.0_rp
         do idime = 1,ndime
            do jdime = 1,ndime
               a%gradp(idime) = a%gradp(idime) - (1.0_rp/invk)*a%hessi(jdime,jdime,idime)
            enddo
         enddo
      end subroutine

   end subroutine

   subroutine GetPressure(a,ndime,expre,exprg)
      implicit none
      class(plcdExacso) :: a
      integer(ip), intent(in)  :: ndime
      real(rp),    intent(out) :: expre,exprg(ndime)

      expre      = a%p
      exprg(1:ndime) = a%gradp(1:ndime)

   end subroutine

   subroutine GetDisplacement(a,ndime,exvel,exveg)
      implicit none
      class(plcdExacso) :: a
      integer(ip), intent(in)   :: ndime
      real(rp),    intent(out)  :: exvel(ndime),exveg(ndime,ndime)

      exvel(1:ndime) = a%disp(1:ndime)
      exveg(1:ndime,1:ndime) = a%grad(1:ndime,1:ndime)
   end subroutine

   subroutine GetForce(a,ndime,elext,php)
      implicit none
      class(plcdExacso) :: a
      class(plcdProblem) :: php
      integer(ip), intent(in)  :: ndime
      real(rp), intent(inout)  :: elext(:)
      real(rp) :: D1x,D2x,D1y,D2y,aux1,aux2,aux3
      integer(ip) :: convection

      real(rp), pointer :: C(:,:)
      real(rp) :: divsigma(3), invk
      integer(ip) :: idime

      !We assume that C is the same in all the elements
      call php%Materials(1)%p%CT%GetPointerToC(C)

      if (ndime == 2) then
         divsigma(1) = C(1,1)*a%hessi(1,1,1) + C(1,2)*a%hessi(2,1,2) + C(1,3)*(a%hessi(1,1,2)+a%hessi(2,1,1)) &
                     + C(3,1)*a%hessi(1,1,2) + C(3,2)*a%hessi(2,2,2) + C(3,3)*(a%hessi(2,1,2)+a%hessi(1,2,2))
         divsigma(2) = C(2,1)*a%hessi(1,1,2) + C(2,2)*a%hessi(2,2,2) + C(2,3)*(a%hessi(2,1,2)+a%hessi(1,2,2)) &
                     + C(3,1)*a%hessi(1,1,1) + C(3,2)*a%hessi(2,1,2) + C(3,3)*(a%hessi(1,1,2)+a%hessi(2,1,1))
      elseif (ndime == 3) then
         divsigma(1) = C(1,1)*a%hessi(1,1,1) + C(1,4)*a%hessi(1,1,2) + C(1,5)*a%hessi(1,1,3) + C(1,2)*a%hessi(2,1,2) + C(1,4)*a%hessi(2,1,1) + C(1,6)*a%hessi(2,1,3) + C(1,3)*a%hessi(3,1,3) + C(1,5)*a%hessi(3,1,1) + C(1,6)*a%hessi(3,1,2) + C(4,1)*a%hessi(1,1,2) + C(4,4)*a%hessi(1,2,2) + C(4,5)*a%hessi(1,3,2) + C(4,2)*a%hessi(2,2,2) + C(4,4)*a%hessi(2,1,2) + C(4,6)*a%hessi(2,3,2) + C(4,3)*a%hessi(3,3,2) + C(4,5)*a%hessi(3,1,2) + C(4,6)*a%hessi(3,2,2) + C(5,1)*a%hessi(1,1,3) + C(5,4)*a%hessi(1,2,3) + C(5,5)*a%hessi(1,3,3) + C(5,2)*a%hessi(2,2,3) + C(5,4)*a%hessi(2,1,3) + C(5,6)*a%hessi(2,3,3) + C(5,3)*a%hessi(3,3,3) + C(5,5)*a%hessi(3,1,3) + C(5,6)*a%hessi(3,2,3)
         divsigma(2) = C(4,1)*a%hessi(1,1,1) + C(4,4)*a%hessi(1,1,2) + C(4,5)*a%hessi(1,1,3) + C(4,2)*a%hessi(2,1,2) + C(4,4)*a%hessi(2,1,1) + C(4,6)*a%hessi(2,1,3) + C(4,3)*a%hessi(3,1,3) + C(4,5)*a%hessi(3,1,1) + C(4,6)*a%hessi(3,1,2) + C(2,1)*a%hessi(1,1,2) + C(2,4)*a%hessi(1,2,2) + C(2,5)*a%hessi(1,3,2) + C(2,2)*a%hessi(2,2,2) + C(2,4)*a%hessi(2,1,2) + C(2,6)*a%hessi(2,3,2) + C(2,3)*a%hessi(3,3,2) + C(2,5)*a%hessi(3,1,2) + C(2,6)*a%hessi(3,2,2) + C(6,1)*a%hessi(1,1,3) + C(6,4)*a%hessi(1,2,3) + C(6,5)*a%hessi(1,3,3) + C(6,2)*a%hessi(2,2,3) + C(6,4)*a%hessi(2,1,3) + C(6,6)*a%hessi(2,3,3) + C(6,3)*a%hessi(3,3,3) + C(6,5)*a%hessi(3,1,3) + C(6,6)*a%hessi(3,2,3)
         divsigma(3) = C(5,1)*a%hessi(1,1,1) + C(5,4)*a%hessi(1,1,2) + C(5,5)*a%hessi(1,1,3) + C(5,2)*a%hessi(2,1,2) + C(5,4)*a%hessi(2,1,1) + C(5,6)*a%hessi(2,1,3) + C(5,3)*a%hessi(3,1,3) + C(5,5)*a%hessi(3,1,1) + C(5,6)*a%hessi(3,1,2) + C(6,1)*a%hessi(1,1,2) + C(6,4)*a%hessi(1,2,2) + C(6,5)*a%hessi(1,3,2) + C(6,2)*a%hessi(2,2,2) + C(6,4)*a%hessi(2,1,2) + C(6,6)*a%hessi(2,3,2) + C(6,3)*a%hessi(3,3,2) + C(6,5)*a%hessi(3,1,2) + C(6,6)*a%hessi(3,2,2) + C(3,1)*a%hessi(1,1,3) + C(3,4)*a%hessi(1,2,3) + C(3,5)*a%hessi(1,3,3) + C(3,2)*a%hessi(2,2,3) + C(3,4)*a%hessi(2,1,3) + C(3,6)*a%hessi(2,3,3) + C(3,3)*a%hessi(3,3,3) + C(3,5)*a%hessi(3,1,3) + C(3,6)*a%hessi(3,2,3)
      endif

      !Force term
      elext(1:ndime) = elext(1:ndime) - divsigma(1:ndime)

      if (php%UseUPFormulation) then

         elext(1:ndime) = elext(1:ndime) + a%gradp(1:ndime)

         !if necessary, add the source term in the pressure equation
         call php%Materials(1)%p%CT%GetInverseVolumetricDeformationModulus(invK)

         !Compressible material, cannot fix p
         if (invk /= 0.0_rp) then
            !Force term, volumetric part
            elext(ndime+1) = +invk*a%p
            do idime = 1,ndime
               elext(ndime+1) = elext(ndime+1) + a%grad(idime,idime)
            enddo
         endif
      endif

   end subroutine

end module


! { dg-do run }
program p
 implicit none

 real   , parameter :: arr(3) = [ real    :: 2, 2.5, (1.5, 2.5) ]
 real   , parameter :: ari(3) = [ integer :: 2, 2.5, (1.5, 2.5) ]
 real   , parameter :: arc(3) = [ complex :: 2, 2.5, (1.5, 2.5) ]
 integer, parameter :: air(3) = [ real    :: 2, 2.5, (1.5, 2.5) ]
 integer, parameter :: aii(3) = [ integer :: 2, 2.5, (1.5, 2.5) ]
 integer, parameter :: aic(3) = [ complex :: 2, 2.5, (1.5, 2.5) ]
 complex, parameter :: acr(3) = [ real    :: 2, 2.5, (1.5, 2.5) ]
 complex, parameter :: aci(3) = [ integer :: 2, 2.5, (1.5, 2.5) ]
 complex, parameter :: acc(3) = [ complex :: 2, 2.5, (1.5, 2.5) ]

 real   , parameter :: mrr(3) =  4.5       * [ real    :: 2, 2.5, (3.5, 4.0) ]
 real   , parameter :: mri(3) =  4.5       * [ integer :: 2, 2.5, (3.5, 4.0) ]
 real   , parameter :: mrc(3) =  4.5       * [ complex :: 2, 2.5, (3.5, 4.0) ]
 integer, parameter :: mir(3) =  4         * [ real    :: 2, 2.5, (3.5, 4.0) ]
 integer, parameter :: mii(3) =  4         * [ integer :: 2, 2.5, (3.5, 4.0) ]
 integer, parameter :: mic(3) =  4         * [ complex :: 2, 2.5, (3.5, 4.0) ]
 complex, parameter :: mcr(3) = (4.5, 5.5) * [ real    :: 2, 2.5, (3.5, 4.0) ]
 complex, parameter :: mci(3) = (4.5, 5.5) * [ integer :: 2, 2.5, (3.5, 4.0) ]
 complex, parameter :: mcc(3) = (4.5, 5.5) * [ complex :: 2, 2.5, (3.5, 4.0) ]

 if (any(arr /= [2.00, 2.50, 1.50])) STOP 1
 if (any(ari /= [2.00, 2.00, 1.00])) STOP 2
 if (any(arc /= [2.00, 2.50, 1.50])) STOP 3

 if (any(air /= [2, 2, 1])) STOP 4
 if (any(aii /= [2, 2, 1])) STOP 5
 if (any(aic /= [2, 2, 1])) STOP 6

 if (any(acr /= [(2.00, 0.00), (2.50, 0.00), (1.50, 0.00)])) STOP 7
 if (any(aci /= [(2.00, 0.00), (2.00, 0.00), (1.00, 0.00)])) STOP 8
 if (any(acc /= [(2.00, 0.00), (2.50, 0.00), (1.50, 2.50)])) STOP 9

 if (any(mrr /= [9.00, 11.25, 15.75])) STOP 10
 if (any(mri /= [9.00,  9.00, 13.50])) STOP 11
 if (any(mrc /= [9.00, 11.25, 15.75])) STOP 12

 if (any(mir /= [8, 10, 14])) STOP 13
 if (any(mii /= [8,  8, 12])) STOP 14
 if (any(mic /= [8, 10, 14])) STOP 15

 if (any(mcr /= [(9.00, 11.00), (11.25, 13.75), (15.75, 19.25)])) STOP 16
 if (any(mci /= [(9.00, 11.00), ( 9.00, 11.00), (13.50, 16.50)])) STOP 17
 if (any(mcc /= [(9.00, 11.00), (11.25, 13.75), (-6.25, 37.25)])) STOP 18

end program p


c     comment section
c
c     fm097
c
c     this routine tests intrinsic functions where the function type is
c     real and the arguments are either integer or real.  the real and
c     integer variables and the real and integer constants contain both
c     positive and negative values.  the intrinsic functions tested by
c     fm097 include
c                                                   type of
c       intrinsic function          name       argument     function
c       ------------------          ----       --------     --------
c         absolute value            abs        real         real
c         truncation                aint       real         real
c         remaindering              amod       real         real
c         choosing largest value    amax0      integer      real
c                                   amax1      real         real
c         choosing smallest value   amin0     integer       real
c                                   amin1      real         real
c         float                     float      integer      real
c         transfer of sign          sign       real         real
c         positive difference       dim        real         real
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.1.2, type rules for data and procedure identifiers
c        section 15.3, intrinsic function
c        section 15.3.2, intrinsic functions and their reference
c
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c     test 875 through test 878 contain intrinsic function tests for
c     absolute value where argument and function are real
c
      ivtnum = 875
c
c      ****  test 875  ****
c
      if (iczero) 38750, 8750, 38750
 8750 continue
      rvcomp = abs (-38.2)
      go to 48750
38750 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48750, 8761, 48750
48750 if (rvcomp - 38.195) 28750,18750,48751
48751 if (rvcomp - 38.205) 18750,18750,28750
18750 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8761
28750 ivfail = ivfail + 1
      rvcorr = 38.200
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8761 continue
      ivtnum = 876
c
c      ****  test 876  ****
c
      if (iczero) 38760, 8760, 38760
 8760 continue
      rvon01 = 445.06
      rvcomp = abs (rvon01)
      go to 48760
38760 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48760, 8771, 48760
48760 if (rvcomp - 445.01) 28760,18760,48761
48761 if (rvcomp - 445.11) 18760,18760,28760
18760 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8771
28760 ivfail = ivfail + 1
      rvcorr = 445.06
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8771 continue
      ivtnum = 877
c
c      ****  test 877  ****
c
      if (iczero) 38770, 8770, 38770
 8770 continue
      rvon01 = -32.176
      rvcomp = abs (rvon01)
      go to 48770
38770 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48770, 8781, 48770
48770 if (rvcomp - 32.171) 28770,18770,48771
48771 if (rvcomp - 32.181) 18770,18770,28770
18770 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8781
28770 ivfail = ivfail + 1
      rvcorr = 32.176
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8781 continue
      ivtnum = 878
c
c      ****  test 878  ****
c
      if (iczero) 38780, 8780, 38780
 8780 continue
      rvon01 = -2.2e+2
      rvcomp = abs (rvon01)
      go to 48780
38780 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48780, 8791, 48780
48780 if (rvcomp - 219.95) 28780,18780,48781
48781 if (rvcomp - 220.05) 18780,18780,28780
18780 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8791
28780 ivfail = ivfail + 1
      rvcorr = 220.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8791 continue
      ivtnum = 879
c
c      ****  test 879  ****
c
c     test 879 through test 882 contain intrinsic function tests for
c     truncation where argument and function are real
c
c
      if (iczero) 38790, 8790, 38790
 8790 continue
      rvcomp = aint (38.2)
      go to 48790
38790 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48790, 8801, 48790
48790 if (rvcomp - 37.995) 28790,18790,48791
48791 if (rvcomp - 38.005) 18790,18790,28790
18790 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8801
28790 ivfail = ivfail + 1
      rvcorr = 38.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8801 continue
      ivtnum = 880
c
c      ****  test 880  ****
c
      if (iczero) 38800, 8800, 38800
 8800 continue
      rvon01 = -445.95
      rvcomp = aint (rvon01)
      go to 48800
38800 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48800, 8811, 48800
48800 if (rvcomp + 445.05) 28800,18800,48801
48801 if (rvcomp + 444.95) 18800,18800,28800
18800 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8811
28800 ivfail = ivfail + 1
      rvcorr = -445.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8811 continue
      ivtnum = 881
c
c      ****  test 881  ****
c
      if (iczero) 38810, 8810, 38810
 8810 continue
      rvon01 = 466.01
      rvcomp = aint (rvon01)
      go to 48810
38810 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48810, 8821, 48810
48810 if (rvcomp - 465.95) 28810,18810,48811
48811 if (rvcomp - 466.05) 18810,18810,28810
18810 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8821
28810 ivfail = ivfail + 1
      rvcomp = 466.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8821 continue
      ivtnum = 882
c
c      ****  test 882  ****
c
      if (iczero) 38820, 8820, 38820
 8820 continue
      rvon01 = 382e-1
      rvcomp = aint (rvon01)
      go to 48820
38820 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48820, 8831, 48820
48820 if (rvcomp - 37.995) 28820,18820,48821
48821 if (rvcomp - 38.005) 18820,18820,28820
18820 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8831
28820 ivfail = ivfail + 1
      rvcorr = 38.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8831 continue
c
c     test 883 through 886 contain intrinsic function tests for
c     remaindering where argument and function are real
c
      ivtnum = 883
c
c      ****  test 883  ****
c
      if (iczero) 38830, 8830, 38830
 8830 continue
      rvcomp = amod (42.0,19.0)
      go to 48830
38830 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48830, 8841, 48830
48830 if (rvcomp - 3.9995) 28830,18830,48831
48831 if (rvcomp - 4.0005) 18830,18830,28830
18830 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8841
28830 ivfail = ivfail + 1
      rvcorr = 4.0000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8841 continue
      ivtnum = 884
c
c      ****  test 884  ****
c
      if (iczero) 38840, 8840, 38840
 8840 continue
      rvon01 = 16.27
      rvon02 = 2.0
      rvcomp = amod (rvon01,rvon02)
      go to 48840
38840 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48840, 8851, 48840
48840 if (rvcomp - .26995) 28840,18840,48841
48841 if (rvcomp - .27005) 18840,18840,28840
18840 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8851
28840 ivfail = ivfail + 1
      rvcorr = .27000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8851 continue
      ivtnum = 885
c
c      ****  test 885  ****
c
      if (iczero) 38850, 8850, 38850
 8850 continue
      rvon01 = 225.0
      rvon02 = 5.0e1
      rvcomp = amod (rvon01,rvon02)
      go to 48850
38850 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48850, 8861, 48850
48850 if (rvcomp - 24.995) 28850,18850,48851
48851 if (rvcomp - 25.005) 18850,18850,28850
18850 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8861
28850 ivfail = ivfail + 1
      rvcorr = 25.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8861 continue
      ivtnum = 886
c
c      ****  test 886  ****
c
      if (iczero) 38860, 8860, 38860
 8860 continue
      rvon01 = -0.390e+2
      rvon02 = 5e2
      rvcomp = amod (rvon01,rvon02)
      go to 48860
38860 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48860, 8871, 48860
48860 if (rvcomp + 39.005) 28860,18860,48861
48861 if (rvcomp + 38.995) 18860,18860,28860
18860 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8871
28860 ivfail = ivfail + 1
      rvcorr = -39.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8871 continue
c
c     test 887 and 888 contain intrinsic function tests for choosing
c     largest value where arguments are integer and function is real
c
      ivtnum = 887
c
c      ****  test 887  ****
c
      if (iczero) 38870, 8870, 38870
 8870 continue
      ivon01 = 317
      ivon02 = -99
      ivon03 = 1
      rvcomp = amax0 (263,ivon01,ivon02,ivon03)
      go to 48870
38870 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48870, 8881, 48870
48870 if (rvcomp - 316.95) 28870,18870,48871
48871 if (rvcomp - 317.05) 18870,18870,28870
18870 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8881
28870 ivfail = ivfail + 1
      rvcorr = 317.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8881 continue
      ivtnum = 888
c
c      ****  test 888  ****
c
      if (iczero) 38880, 8880, 38880
 8880 continue
      ivon01 = 2572
      ivon02 = 2570
      rvcomp = amax0 (ivon01,ivon02)
      go to 48880
38880 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48880, 8891, 48880
48880 if (rvcomp - 2571.5) 28880,18880,48881
48881 if (rvcomp - 2572.5) 18880,18880,28880
18880 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8891
28880 ivfail = ivfail + 1
      rvcorr = 2572.0
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8891 continue
c
c     test 889 and 890 contain intrinsic function tests for choosing
c     largest value where the arguments and function are real
c
      ivtnum = 889
c
c      ****  test 889  ****
c
      if (iczero) 38890, 8890, 38890
 8890 continue
      rvon01 = .326e+2
      rvon02 = 22.075
      rvon03 = 76e-1
      rvcomp = amax1 (rvon01,rvon02,rvon03)
      go to 48890
38890 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48890, 8901, 48890
48890 if (rvcomp - 32.595) 28890,18890,48891
48891 if (rvcomp - 32.605) 18890,18890,28890
18890 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8901
28890 ivfail = ivfail + 1
      rvcorr = 32.600
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8901 continue
      ivtnum = 890
c
c      ****  test 890  ****
c
      if (iczero) 38900, 8900, 38900
 8900 continue
      rvon01 = -6.3e2
      rvon02 = -21.0
      rvcomp = amax1 (-463.3,rvon01,rvon02)
      go to 48900
38900 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48900, 8911, 48900
48900 if (rvcomp + 21.005) 28900,18900,48901
48901 if (rvcomp + 20.995) 18900,18900,28900
18900 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8911
28900 ivfail = ivfail + 1
      rvcorr = -21.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8911 continue
c
c     tests 891 and 892 contain intrinsic function tests for choosing
c     smallest value where arguments are integer and function is real
c
      ivtnum = 891
c
c      ****  test 891  ****
c
      if (iczero) 38910, 8910, 38910
 8910 continue
      ivon01 = -75
      ivon02 = -243
      rvcomp = amin0 (ivon01,ivon02)
      go to 48910
38910 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48910, 8921, 48910
48910 if (rvcomp + 243.05) 28910,18910,48911
48911 if (rvcomp + 242.95) 18910,18910,28910
18910 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8921
28910 ivfail = ivfail + 1
      rvcorr = -243.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8921 continue
      ivtnum = 892
c
c      ****  test 892  ****
c
      if (iczero) 38920, 8920, 38920
 8920 continue
      ivon01 = -11
      ivon02 = 11
      rvcomp = amin0 (0,ivon01,ivon02)
      go to 48920
38920 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48920, 8931, 48920
48920 if (rvcomp + 11.005) 28920,18920,48921
48921 if (rvcomp + 10.995) 18920,18920,28920
18920 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8931
28920 ivfail = ivfail + 1
      rvcorr = -11.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8931 continue
c
c     tests 893 and 894 contain intrinsic function tests for choosing
c     smallest value where arguments and function are real
c
      ivtnum = 893
c
c      ****  test 893  ****
c
      if (iczero) 38930, 8930, 38930
 8930 continue
      rvon01 = 1.1111
      rvon02 = 22.222
      rvon03 = 333.33
      rvcomp = amin1 (rvon01,rvon02,rvon03)
      go to 48930
38930 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48930, 8941, 48930
48930 if (rvcomp - 1.1106) 28930,18930,48931
48931 if (rvcomp - 1.1116) 18930,18930,28930
18930 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8941
28930 ivfail = ivfail + 1
      rvcorr = 1.1111
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8941 continue
      ivtnum = 894
c
c      ****  test 894  ****
c
      if (iczero) 38940, 8940, 38940
 8940 continue
      rvon01 = 28.8
      rvon02 = 2.88e1
      rvon03 = 288e-1
      rvon04 = 35.0
      rvcomp = amin1 (rvon01,rvon02,rvon03,rvon04)
      go to 48940
38940 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48940, 8951, 48940
48940 if (rvcomp - 28.795) 28940,18940,48941
48941 if (rvcomp - 28.805) 18940,18940,28940
18940 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8951
28940 ivfail = ivfail + 1
      rvcorr = 28.800
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8951 continue
c
c     test 895 through test 897 contain intrinsic function tests for
c     float - conversion of an integer argument to real function
c
      ivtnum = 895
c
c      ****  test 895  ****
c
      if (iczero) 38950, 8950, 38950
 8950 continue
      rvcomp = float (-606)
      go to 48950
38950 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48950, 8961, 48950
48950 if (rvcomp + 606.05) 28950,18950,48951
48951 if (rvcomp + 605.95) 18950,18950,28950
18950 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8961
28950 ivfail = ivfail + 1
      rvcorr = -606.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8961 continue
      ivtnum = 896
c
c      ****  test 896  ****
c
      if (iczero) 38960, 8960, 38960
 8960 continue
      ivon01 = 71
      rvcomp = float (ivon01)
      go to 48960
38960 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48960, 8971, 48960
48960 if (rvcomp - 70.995) 28960,18960,48961
48961 if (rvcomp - 71.005) 18960,18960,28960
18960 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8971
28960 ivfail = ivfail + 1
      rvcorr = 71.000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8971 continue
      ivtnum = 897
c
c      ****  test 897  ****
c
      if (iczero) 38970, 8970, 38970
 8970 continue
      ivon01 = 321
      rvcomp = float (-ivon01)
      go to 48970
38970 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48970, 8981, 48970
48970 if (rvcomp + 321.05) 28970,18970,48971
48971 if (rvcomp + 320.95) 18970,18970,28970
18970 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8981
28970 ivfail = ivfail + 1
      rvcorr = -321.00
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8981 continue
c
c     test 898 through test 900 contain intrinsic function tests for
c     transfer of sign - both arguments and function are real
c
      ivtnum = 898
c
c      ****  test 898  ****
c
      if (iczero) 38980, 8980, 38980
 8980 continue
      rvon01 = 64.3
      rvcomp = sign (rvon01,-1.0)
      go to 48980
38980 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48980, 8991, 48980
48980 if (rvcomp + 64.305) 28980,18980,48981
48981 if (rvcomp + 64.295) 18980,18980,28980
18980 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 8991
28980 ivfail = ivfail + 1
      rvcorr = -64.300
      write (i02,80005) ivtnum, rvcomp, rvcorr
 8991 continue
      ivtnum = 899
c
c      ****  test 899  ****
c
      if (iczero) 38990, 8990, 38990
 8990 continue
      rvon01 = -2.2
      rvon02 = 7.23e1
      rvcomp = sign (rvon01,rvon02)
      go to 48990
38990 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 48990, 9001, 48990
48990 if (rvcomp - 2.1995) 28990,18990,48991
48991 if (rvcomp - 2.2005) 18990,18990,28990
18990 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9001
28990 ivfail = ivfail + 1
      rvcorr = 2.2000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9001 continue
      ivtnum = 900
c
c      ****  test 900  ****
c
      if (iczero) 39000, 9000, 39000
 9000 continue
      rvon01 = 35.32e+1
      rvon02 = 1.0
      rvcomp = sign (rvon01,rvon02)
      go to 49000
39000 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49000, 9011, 49000
49000 if (rvcomp - 353.15) 29000,19000,49001
49001 if (rvcomp - 353.25) 19000,19000,29000
19000 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9011
29000 ivfail = ivfail + 1
      rvcorr = 353.20
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9011 continue
c
c     test 901 through test 904 contain intrinsic function tests for
c     positive difference where arguments and function are real
c
      ivtnum = 901
c
c      ****  test 901  ****
c
      if (iczero) 39010, 9010, 39010
 9010 continue
      rvon01 = 22.2
      rvcomp = dim (rvon01,1.0)
      go to 49010
39010 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49010, 9021, 49010
49010 if (rvcomp - 21.195) 29010,19010,49011
49011 if (rvcomp - 21.205) 19010,19010,29010
19010 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9021
29010 ivfail = ivfail + 1
      rvcorr = 21.200
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9021 continue
      ivtnum = 902
c
c      ****  test 902  ****
c
      if (iczero) 39020, 9020, 39020
 9020 continue
      rvon01 = 4.5e1
      rvon02 = 41.0
      rvcomp = dim (rvon01,rvon02)
      go to 49020
39020 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49020, 9031, 49020
49020 if (rvcomp - 3.9995) 29020,19020,49021
49021 if (rvcomp - 4.0005) 19020,19020,29020
19020 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9031
29020 ivfail = ivfail + 1
      rvcorr = 4.0000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9031 continue
      ivtnum = 903
c
c      ****  test 903  ****
c
      if (iczero) 39030, 9030, 39030
 9030 continue
      rvon01 = 2.0
      rvon02 = 10.0
      rvcomp = dim (rvon01,rvon02)
      go to 49030
39030 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49030, 9041, 49030
49030 if (rvcomp) 29030,19030,29030
19030 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9041
29030 ivfail = ivfail + 1
      rvcorr = 0.0000
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9041 continue
      ivtnum = 904
c
c      ****  test 904  ****
c
      if (iczero) 39040, 9040, 39040
 9040 continue
      rvon01 = 1.65e+1
      rvon02 = -2.0
      rvcomp = dim (rvon01,rvon02)
      go to 49040
39040 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49040, 9051, 49040
49040 if (rvcomp - 18.495) 29040,19040,49041
49041 if (rvcomp - 18.505) 19040,19040,29040
19040 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9051
29040 ivfail = ivfail + 1
      rvcorr = 18.500
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9051 continue
c
c     tests 905 and 906 contain expressions containing more than one
c     intrinsic function - all arguments and functions are real
c
      ivtnum = 905
c
c      ****  test 905  ****
c
      if (iczero) 39050, 9050, 39050
 9050 continue
      rvon01 = 33.3
      rvon02 = -12.1
      rvcomp = aint (rvon01) + abs (rvon02)
      go to 49050
39050 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49050, 9061, 49050
49050 if (rvcomp - 45.095) 29050,19050,49051
49051 if (rvcomp - 45.105) 19050,19050,29050
19050 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9061
29050 ivfail = ivfail + 1
      rvcorr = 45.100
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9061 continue
      ivtnum = 906
c
c      ****  test 906  ****
c
      if (iczero) 39060, 9060, 39060
 9060 continue
      rvon01 = 76.3
      rvon02 = 2.1e1
      rvon03 = 3e1
      rvcomp = amax1(rvon01,rvon02,rvon03)-amin1(rvon01,rvon02,rvon03)
      go to 49060
39060 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 49060, 9071, 49060
49060 if (rvcomp - 55.295) 29060,19060,49061
49061 if (rvcomp - 55.305) 19060,19060,29060
19060 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 9071
29060 ivfail = ivfail + 1
      rvcorr = 55.300
      write (i02,80005) ivtnum, rvcomp, rvcorr
 9071 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm097)
      end


MODULE reals

  USE ISO_C_BINDING
  IMPLICIT NONE

  INTEGER, PARAMETER :: wp = 4  ! Test named precision

CONTAINS

  ! REAL(KIND=4) and REAL get mapped to C floats
  FUNCTION add_floats(a,b,c) RESULT(y)
    REAL(KIND=4), INTENT(in) :: a
    REAL(4), INTENT(in) :: b
    REAL(wp), INTENT(in) :: c
    REAL :: y
    y = a+b+c
  END FUNCTION add_floats

  ! REAL(KIND=8), REAL*8, and DOUBLE PRECISION get mapped to C doubles
  FUNCTION add_doubles(a,b) RESULT(y)
    REAL(KIND=8), INTENT(in) :: a
    DOUBLE PRECISION, INTENT(in) :: b
    REAL*8 :: y
    y = a+b
  END FUNCTION add_doubles

  ! Test lower case parsing:

  function add_floats_lower(a,b) result(y)
    real(kind=4), intent(in) :: a,b
    real :: y
    y = a+b
  end function add_floats_lower

  function add_doubles_lower(a,b) result(y)
    real(kind=8), intent(in) :: a
    double precision, intent(in) :: b
    real*8 :: y
    y = a+b
  end function add_doubles_lower

  ! ISO_C_BINDING

  FUNCTION add_iso_floats(a,b) RESULT(y)
    REAL (C_FLOAT), INTENT(in) :: a
    REAL(C_FLOAT), INTENT(in) :: b
    REAL(C_FLOAT) :: y
    y = a+b
  END FUNCTION add_iso_floats

  FUNCTION add_iso_doubles(a,b) RESULT(y)
    REAL (C_DOUBLE), INTENT(in) :: a
    REAL(C_DOUBLE), INTENT(in) :: b
    REAL(C_DOUBLE) :: y
    y = a+b
  END FUNCTION add_iso_doubles

END MODULE reals


      SUBROUTINE cdft(which,p,q,t,df,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFT( WHICH, P, Q, T, DF, STATUS, BOUND )
C               Cumulative Distribution Function
C                         T distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the t distribution given
C     values for the others.
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which  argument
C               values is to be calculated from the others.
C               Legal range: 1..3
C               iwhich = 1 : Calculate P and Q from T and DF
C               iwhich = 2 : Calculate T from P,Q and DF
C               iwhich = 3 : Calculate DF from P,Q and T
C                    INTEGER WHICH
C
C        P <--> The integral from -infinity to t of the t-density.
C              Input range: (0,1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: (0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C        T <--> Upper limit of integration of the t-density.
C               Input range: ( -infinity, +infinity).
C               Search range: [ -1E100, 1E100 ]
C                    DOUBLE PRECISION T
C
C        DF <--> Degrees of freedom of the t-distribution.
C                Input range: (0 , +infinity).
C                Search range: [1e-100, 1E10]
C                    DOUBLE PRECISION DF
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Formula  26.5.27  of   Abramowitz   and  Stegun,   Handbook   of
C     Mathematical Functions  (1966) is used to reduce the computation
C     of the cumulative distribution function to that of an incomplete
C     beta.
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-8)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION zero,inf
      PARAMETER (zero=1.0D-100,inf=1.0D100)
      DOUBLE PRECISION rtinf
      PARAMETER (rtinf=1.0D100)
      DOUBLE PRECISION maxdf
      PARAMETER (maxdf=1.0d10)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,df,p,q,t
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ccum,cum,fx,pq
      LOGICAL qhi,qleft,qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION dt1,spmpar
      EXTERNAL dt1,spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL cumt,dinvr,dstinv
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
      IF (.NOT. ((which.LT.1).OR. (which.GT.3))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 3.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
      IF (.NOT. ((p.LE.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LE.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0D0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
      IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LE.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.3) GO TO 130
      IF (.NOT. (df.LE.0.0D0)) GO TO 120
      bound = 0.0D0
      status = -5
      RETURN

  120 CONTINUE
  130 IF (which.EQ.1) GO TO 170
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 160
      IF (.NOT. (pq.LT.0.0D0)) GO TO 140
      bound = 0.0D0
      GO TO 150

  140 bound = 1.0D0
  150 status = 3
      RETURN

  160 CONTINUE
  170 IF (.NOT. (which.EQ.1)) qporq = p .LE. q
      IF ((1).EQ. (which)) THEN
          CALL cumt(t,df,p,q)
          status = 0

      ELSE IF ((2).EQ. (which)) THEN
          t = dt1(p,q,df)
          CALL dstinv(-rtinf,rtinf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,t,fx,qleft,qhi)
  180     IF (.NOT. (status.EQ.1)) GO TO 210
          CALL cumt(t,df,cum,ccum)
          IF (.NOT. (qporq)) GO TO 190
          fx = cum - p
          GO TO 200

  190     fx = ccum - q
  200     CALL dinvr(status,t,fx,qleft,qhi)
          GO TO 180

  210     IF (.NOT. (status.EQ.-1)) GO TO 240
          IF (.NOT. (qleft)) GO TO 220
          status = 1
          bound = -rtinf
          GO TO 230

  220     status = 2
          bound = rtinf
  230     CONTINUE
  240     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
          df = 5.0D0
          CALL dstinv(zero,maxdf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,df,fx,qleft,qhi)
  250     IF (.NOT. (status.EQ.1)) GO TO 280
          CALL cumt(t,df,cum,ccum)
          IF (.NOT. (qporq)) GO TO 260
          fx = cum - p
          GO TO 270

  260     fx = ccum - q
  270     CALL dinvr(status,df,fx,qleft,qhi)
          GO TO 250

  280     IF (.NOT. (status.EQ.-1)) GO TO 310
          IF (.NOT. (qleft)) GO TO 290
          status = 1
          bound = zero
          GO TO 300

  290     status = 2
          bound = maxdf
  300     CONTINUE
  310 END IF

      RETURN

      END


      SUBROUTINE W3FM08 (A,Z,LI,LJ)
C$$$  SUBROUTINE DOCUMENTATION BLOCK ***
C SUBR: W3FM08   - NINE POINT SMOOTHER/DESMOOTHER
C   AUTHOR: HOWCROFT, J.       ORG: W342          DATE: 71-02-01
C
C ABSTRACT: NINE POINT SMOOTHER/DESMOOTHER. SMOOTHER PASS USES AN
C   EQUIVALENT LINEAR SMOOTHER WITH STENCIL (.25 .5 .25) AND THE
C   DESMOOTHER USES STENCIL (-.25 1.5 -.25). TWO GRID INTERVAL WAVES
C   ARE ANNIHILATED, FOUR GRID INTERVAL WAVES HAVE A .75 RESPONSE.
C
C PROGRAM HISTORY LOG:
C   71-02-01 J.HOWCROFT
C   84-07-01  R.E.JONES   CHANGE TO IBM VS FORTRAN
C   94-07-27  R.E.JONES   CHANGE TO CRAY CFT77 FORTRAN
C
C USAGE: CALL W3FM08 (A,Z,LI,LJ)
C
C   INPUT:
C     ' A' - REAL   SIZE (LI,LJ) ARRAY TO HOLD FIELD TO BE SMOOTHED
C     ' Z' - REAL   SIZE (LI,LJ) WORK AREA
C     'LI' - INTEGER   NUMBER OF COLUMNS
C     'LJ' - INTEGER   NUMBER OF ROWS
C   OUTPUT:
C     ' A' - ARRAY HOLDING SMOOTHED FIELD
C
C   EXIT STATES: NONE
C
C   EXTERNAL REFERENCES: NONE
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      REAL     A(LI,LJ)
      REAL     Z(LI,LJ)
C
      SAVE
C
      LI1 = LI - 1
      LJ1 = LJ - 1
      DO 1  J=2,LJ1
      DO 1  I=2,LI1
      CRUX = A(I-1,J-1) + A(I+1,J-1) + A(I+1,J+1) + A(I-1,J+1)
      PLUS = A(I,J-1) + A(I,J+1) + A(I-1,J) + A(I+1,J)
      Z(I,J) = 0.25 * A(I,J)  + .125 * PLUS + .0625 * CRUX
    1 CONTINUE
      DO 2  I=1,LI
      Z(I,1) = A(I,1)
      Z(I,LJ) = A(I,LJ)
    2 CONTINUE
      DO 3  J=1,LJ
      Z(1,J) = A(1,J)
      Z(LI,J) = A(LI,J)
    3 CONTINUE
      DO 4  J=2,LJ1
      DO 4  I=2,LI1
      CRUX = Z(I-1,J-1) + Z(I+1,J-1) + Z(I+1,J+1) + Z(I-1,J+1)
      PLUS = Z(I,J-1) + Z(I,J+1) + Z(I-1,J) + Z(I+1,J)
      A(I,J) = 2.25 * Z(I,J)  - .375 * PLUS + .0625 * CRUX
    4 CONTINUE
      RETURN
      END


!> Orchid -- 2D/3D Euler/MagnetoHydroDynamics solver in spherical/polar coorinates.
!> Copyright (C) Butakov Oleg 2019.
Module orchid_solver_params
    Implicit None

    Integer, Parameter :: dim = 2
    Logical, Parameter :: debug = .TRUE.
    Logical, Parameter :: verbose = .TRUE.
    Logical, Parameter :: mhd = .TRUE.

    Real(8), Parameter :: Mu_hydro = 0*0.000005D0
    Real(8), Parameter :: Mu_magneto = 0.0D0
    Real(8), Parameter :: Kappa = 1.0D7*0

    Real(8), Parameter :: Pi = 4.0D0*Atan(1.0D0)
    Real(8), Parameter :: S4Pi = 4.0D0*Sqrt(Atan(1.0D0))

    Real(8), Parameter :: Rgas = 8.314459848D7
    Real(8), Parameter :: Gamma = 0*1.4D0 + 1*5.0D0/3.0D0, Gamma1 = Gamma-1.0D0
    Integer, Parameter :: N_funcs = 2
    Integer, Parameter :: m_min = 0, m_max = N_funcs - 1
    Integer, Parameter :: n_min = 1, n_max = 8

    Real(8), Parameter :: Gamma_1 = ( Gamma - 1.0D0 )/( 2.0D0*Gamma )
    Real(8), Parameter :: Gamma_2 = ( Gamma + 1.0D0 )/( 2.0D0*Gamma )
    Real(8), Parameter :: Gamma_7 = ( Gamma - 1.0D0 )/2.0D0

    Real(8), Parameter :: NaN = Transfer([ Z'00000000', Z'7FF80000' ], 1.0D0)

    Contains
Elemental &
Function minmod1(a) Result(m)
    Real(8), Intent(In) :: a
    Real(8) :: m
    m = Max(0.0D0, Min(1.0D0, a))
End Function minmod1
Elemental &
Function minmod2(a, b) Result(m)
    Real(8), Intent(In) :: a, b
    Real(8) :: m
    m = ( Sign(1.0D0, a) + Sign(1.0D0, b) )/2.0D0*&
        Min(Abs(a), Abs(b))
End Function minmod2
Function minmod3(a, b, c) Result(m)
    Real(8), Intent(In) :: a, b, c
    Real(8) :: m
    m = Dble(Int( ( Sign(1.0D0, a) + Sign(1.0D0, b) + Sign(1.0D0, c) )/3.0D0))*&
        Min(Abs(a), Abs(b), Abs(c))
End Function minmod3
End Module orchid_solver_params

Module orchid_solver_helpers
    Contains
    Function to_str(k)
        ! {{{
        Integer, Intent(In) :: k
        ! ---
        Character(Len=20) :: to_str
        ! }}}
        Write (to_str, *) k
        to_str = adjustl(to_str)
    End Function to_str
End Module orchid_solver_helpers

Module orchid_solver_simulation
Use orchid_solver_grid_gauss_legendre
!Use orchid_solver_opencl
Implicit None

Contains

Subroutine print_grid3(ga, g, l)
    !> {{{
    Integer, Intent(In) :: l
    Class(MhdGrid), Intent(In) :: ga
    Real(8), Dimension(n_min:n_max, ga%ncells_min:ga%ncells_max), Intent(In) :: g
    !> }}}
    Integer :: i, j, k
    Integer :: output
    Real(8) :: r, theta, phi
    Real(8) :: x, y, z
    Real(8) :: v_r, v_t, v_p
    Real(8) :: v_x, v_y, v_z, v_l
    Real(8) :: vxy(2), vrp(2), a(2,2), vvv
    Open(NewUnit=output, file='../Results/fields-'//Trim(to_str(l))//'.csv', Status='replace')
    Write (output, *) 'x,y,z,r,e,u,v,w,bx,by,bz'
    Do i = ga%ncells_min, ga%ncells_max
       Write(output, '(E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6)') &
           ga%cells(i)%x, ',', ga%cells(i)%y, ',', ga%cells(i)%z, ',', &
           g(1, i), ',', &
           g(2, i)/g(1, i), ',', &
           g(3, i)/g(1, i), ',', g(4, i)/g(1, i), ',', g(5, i)/g(1, i), ',', &
           g(6, i)/Sqrt(4.0D0*Pi), ',', g(7, i)/Sqrt(4.0D0*Pi), ',', g(8, i)/Sqrt(4.0D0*Pi)
    End Do
    Close(output)
End Subroutine print_grid3

Subroutine print_grid4(ga, g, l)
    !> {{{
    Integer, Intent(In) :: l
    Class(MhdGrid), Intent(In) :: ga
    Real(8), Dimension(m_min:m_max, n_min:n_max, ga%ncells_min:ga%ncells_max), Intent(In) :: g
    !> }}}
    Integer :: i, j, k
    Integer :: output
    Real(8) :: r, theta, phi
    Real(8) :: x, y, z
    Real(8) :: v_r, v_t, v_p
    Real(8) :: v_x, v_y, v_z, v_l
    Real(8) :: vxy(2), vrp(2), a(2,2), vvv
    Open(NewUnit=output, file='../Results/fields-'//Trim(to_str(l))//'.csv', Status='replace')
    !Write (output, *) 'x,y,z,r,e,u,v,w,bx,by,bz'
    Do i = ga%ncells_min, ga%ncells_max
       Write(output, '(E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6,A,E12.6)') &
           ga%cells(i)%x, ',', ga%cells(i)%y, ',', ga%cells(i)%z, ',', &
           g(0, 1, i), ',', &
           g(0, 2, i)/g(0, 1, i), ',', &
           g(0, 3, i)/g(0, 1, i), ',', g(0, 4, i)/g(0, 1, i), ',', g(0, 5, i)/g(0, 1, i), ',', &
           g(0, 6, i)/Sqrt(4.0D0*Pi), ',', g(0, 7, i)/Sqrt(4.0D0*Pi), ',', g(0, 8, i)/Sqrt(4.0D0*Pi)
    End Do
    Close(output)
End Subroutine print_grid4
End Module orchid_solver_simulation

!> Sod test case (Pure FV).
Subroutine test_sod_1D()
    Use orchid_solver_simulation
    Use orchid_solver_grid
    Use orchid_solver_hydro_fv
    Use omp_lib
    Implicit None
    Integer :: l
    Real(8) :: Tstart, Tend
    Class(MhdGrid), Allocatable :: ga
    Class(MhdHydroSolver), Allocatable :: solver
    Real(8), Dimension(:,:), Allocatable :: g, gp

    Allocate(ga)
    Call ga%init1D(10.0D0, 200, -1, -1)
    Allocate(g(n_min:n_max, ga%ncells_min:ga%ncells_max))
    Allocate(gp(n_min:n_max, ga%ncells_min:ga%ncells_max))

    If (MHD) Then
        !> MHD Sod test case.
        g(:, :) = 0.0D0
        g(1, :) = 1.0D0
        g(2, :) = 1.0D0/( Gamma1*1.0D0 )
        g(6, :) = 4.0D0
        g(7, :) = 4.0D0
        g(8, :) = 2.0D0
        g(1, 1:100) = 1.08D0;
        g(2, 1:100) = 1.08D0*( 0.95D0/( Gamma1*1.08D0 ) + 0.5D0*(1.2D0**2 + 0.01D0**2 + 0.5D0**2) )
        g(3, 1:100) = 1.08D0*1.2D0;
        g(4, 1:100) = 1.08D0*0.01D0;
        g(5, 1:100) = 1.08D0*0.5D0;
        g(7, 1:100) = 3.6D0
    Else
        g(:, :) = 0.0D0
        g(1, :) = 1.0D0
        g(2, :) = 1.0D0/( Gamma1*1.0D0 )
        g(1, 1:100) = 2.0D0
        g(2, 1:100) = 10.0D0/( Gamma1*2.0D0 )
    End If

    Allocate(MhdHydroSolver :: solver)
    Call solver%init()
    Call print_grid3(ga, g, 0)
    Tstart = omp_get_wtime()
    Do l=1, 3000
        Call solver%calc_step(0.001D0, ga, g, gp)
        If (Mod(l, 100) == 0) Then
            Tend = omp_get_wtime()
            Write(*, *) 'time step:', l, TEnd - Tstart
            Tstart = Tend
            Call print_grid3(ga, g, l)
        End If
        g(:,:) = gp(:,:)
    End Do
End Subroutine test_sod_1D

!> Sod test case (DG).
Subroutine test_sod_1D_dg()
    Use orchid_solver_simulation
    Use orchid_solver_grid
    Use orchid_solver_hydro_dg
    Use omp_lib
    Implicit None
    Integer :: l
    Real(8) :: Tstart, Tend
    Class(MhdGridGaussLegendre), Allocatable :: ga
    Class(MhdHydroSolverDG), Allocatable :: solver
    Real(8), Dimension(:,:,:), Allocatable :: g, gp

    Allocate(ga)
    Call ga%init1D(10.0D0, 200, -1, -1)
    Call ga%init_gauss1D(2)
    Call ga%init_legendre1D()
    Allocate(g(m_min:m_max, n_min:n_max, ga%ncells_min:ga%ncells_max))
    Allocate(gp(m_min:m_max, n_min:n_max, ga%ncells_min:ga%ncells_max))

    !> Sod test case.
    If (MHD) Then
        !> MHD Sod test case.
        g(:, :, :) = 0.0D0
        g(0, 1, :) = 1.0D0
        g(0, 2, :) = 1.0D0/( Gamma1*1.0D0 ) + 0.125D0/Pi*(4.0D0**2 + 4.0D0**2 + 2.0D0**2)
        g(0, 6, :) = 4.0D0!/Sqrt(4.0D0*Pi)
        g(0, 7, :) = 4.0D0!/Sqrt(4.0D0*Pi)
        g(0, 8, :) = 2.0D0!/Sqrt(4.0D0*Pi)
        g(0, 1, 1:100) = 1.08D0;
        g(0, 2, 1:100) = 1.08D0*( 0.95D0/( Gamma1*1.08D0 ) + 0.5D0*(1.2D0**2 + 0.01D0**2 + 0.5D0**2)) +&
                                                        0.125D0/Pi*(4.0D0**2 + 3.6D0**2 + 2.0D0**2)
        g(0, 3, 1:100) = 1.08D0*1.2D0;
        g(0, 4, 1:100) = 1.08D0*0.01D0;
        g(0, 5, 1:100) = 1.08D0*0.5D0;
        g(0, 7, 1:100) = 3.6D0!/Sqrt(4.0D0*Pi)
    Else
        g(:, :, :) = 0.0D0
        g(0, 1, :) = 1.0D0
        g(0, 2, :) = 1.0D0/( Gamma1*1.0D0 )
        g(0, 1, 1:100) = 2.0D0
        g(0, 2, 1:100) = 10.0D0/( Gamma1*2.0D0 )
    End If

    Allocate(MhdHydroSolverDG :: solver)
    Call solver%init()
    Call print_grid4(ga, g, 0)
    Tstart = omp_get_wtime()
    Do l=1, 3000
        Call solver%calc_step_dg(0.001D0, ga, g, gp)
        If (Mod(l, 100) == 0) Then
            Tend = omp_get_wtime()
            Write(*, *) 'time step:', l, TEnd - Tstart
            Tstart = Tend
            Call print_grid4(ga, g, l)
        End If
        g(:,:,:) = gp(:,:,:)
    End Do
End Subroutine test_sod_1D_dg

Subroutine test_sod_2D
    Use orchid_solver_simulation
    Use orchid_solver_grid
    Use orchid_solver_hydro_fv
    Use omp_lib
    Implicit None
    Integer :: l
    Real(8) :: Tstart, Tend
    Class(MhdGrid), Allocatable :: ga
    Class(MhdHydroSolver), Allocatable :: solver
    Real(8), Dimension(:,:), Allocatable :: g, gp

    Allocate(ga)
    Call ga%init2D_polar(3.0D0, 10.0D0, 200, 200, -1, -2)
    Allocate(g(n_min:n_max, ga%ncells_min:ga%ncells_max))
    Allocate(gp(n_min:n_max, ga%ncells_min:ga%ncells_max))

    g(:, :) = 0.0D0
    g(1, :) = 1.0D0
    g(2, :) = 1.0D0/( Gamma1*1.0D0 )
    g(3, :) = 1.0D0
    If (MHD) Then
        !> MHD Sod test case.
        g(7, :) = 2.0D0!/Sqrt(4.0D0*Pi)
    End If

    Allocate(MhdHydroSolver :: solver)
    Call solver%init()
    Call print_grid3(ga, g, 0)
    Tstart = omp_get_wtime()
    Do l=1,1800
        Call solver%calc_step(0.001D0, ga, g, gp)
        If (Mod(l, 100) == 0) Then
            Tend = omp_get_wtime()
            Write(*, *) 'time step:', l, TEnd - Tstart
            Tstart = Tend
            Call print_grid3(ga, gp, l)
        End If
        g(:,:) = gp(:,:)
    End Do
End Subroutine test_sod_2D

Subroutine test_ot_2D
    Use orchid_solver_simulation
    Use orchid_solver_grid
    Use orchid_solver_hydro_fv
    Use orchid_solver_hydro_var
    Use omp_lib
    Implicit None
    Integer :: l, i
    Real(8) :: Tstart, Tend
    Class(MhdGrid), Allocatable :: ga
    Class(MhdHydroSolver), Allocatable :: solver
    Real(8), Dimension(:,:), Allocatable :: g, gp
    Type(MhdHydroVars3DMHD) :: vvv
    Allocate(ga)
    Call ga%init2D(1.0D0, 1.0D0, 256, 256, -3, -3, -3, -3)
    Allocate(g(n_min:n_max, ga%ncells_min:ga%ncells_max))
    Allocate(gp(n_min:n_max, ga%ncells_min:ga%ncells_max))

    g(:,:) = 0.0D0
    g(1,:) = 25.0D0/36.0D0/Pi
    g(2,:) = 5.0D0/12.0D0/Pi
    Do i = ga%ncells_min, ga%ncells_max
        g(3, i) = -Sin(2.0D0*Pi*ga%cells(i)%y)
        g(4, i) = +Sin(2.0D0*Pi*ga%cells(i)%x)
        g(6, i) = -Sin(2.0D0*Pi*ga%cells(i)%y)
        g(7, i) = +Sin(4.0D0*Pi*ga%cells(i)%x)
        vvv = mhd_hydro_vars_load3D_mhd(1.0D0, 0.0D0, 0.0D0, q_prim=g(:, i))
        g(:, i) = vvv%U(:)
    End Do

    Allocate(MhdHydroSolver :: solver)
    Call solver%init()
    Call print_grid3(ga, g, 0)
    Tstart = omp_get_wtime()
    Do l=1,50000000
        Call solver%calc_step(0.0001D0, ga, g, gp)
        If (Mod(l, 10) == 0) Then
            Tend = omp_get_wtime()
            Write(*, *) 'time step:', l, TEnd - Tstart
            Tstart = Tend
            Call print_grid3(ga, gp, l)
        End If
        g(:,:) = gp(:,:)
    End Do
End Subroutine test_ot_2D

Program orchid_solver
    Use orchid_solver_simulation
    Use orchid_solver_hydro_dg
    Use orchid_solver_pois
    Use orchid_solver_config
    use, intrinsic :: iso_fortran_env
    use omp_lib
#ifdef ORCHID_MPI
    use MPI
#endif
    Implicit None

    Class(MhdGridGaussLegendre), Allocatable :: ga
    Real(8) :: Tstart, Tend
    Real(8), Dimension(:,:,:), Allocatable :: g, gp
    Real(8), Dimension(:), Allocatable :: u, up, flu
    Real(8), Dimension(:,:), Allocatable :: fl
    Real(8), Dimension(:), Allocatable :: f

    Integer :: MPI_err, MPI_rank, MPI_size
    Integer::l, i, n, m
    Real(8) :: x, y, r
    Integer :: sz, rk

    Real(8) :: vxy(2), vrp(2), a(2,2)
    Class(MhdHydroSolverDG), Allocatable :: solver
    Class(MhdPoisSolver), Allocatable :: pois

    !Call config_test()
    !Stop

#ifdef ORCHID_MPI
    Call MPI_Init(MPI_err)
    Call MPI_Comm_Rank(MPI_COMM_WORLD, MPI_rank, MPI_err)
    Call MPI_Comm_Size(MPI_COMM_WORLD, MPI_size, MPI_err)
    !Write(*,*) mpi_err
    !Call MPI_Comm_Size(MPI_COMM_WORLD, sz, mpi_error)
    !Write(*,*) mpi_err
    Write(*,*) MPI_rank, MPI_size
    Call MPI_Finalize(mpi_err)
    Stop
#endif

    !>-------------------------------------------------------------------------------
    !> Write the damn cool Logo.
    Write(*,*) ''
    Write(*,*) '          \\\\\\ \\\\\\    \\\\\\\ \\\ \\\ \\\\\\\ \\\\\\\       '
    Write(*,*) '         /// /// ////\\\   /// /// /// ///   ///   ///  \\\      '
    Write(*,*) '        //   // //// ///  ///  // ///////   ///   ///   ///      '
    Write(*,*) '       //   // ///\\\//  ///     /// ///   ///   ///   ///       '
    Write(*,*) '      /// /// ///  \\\  ///     /// ///   ///   ///   ///        '
    Write(*,*) '      \\\\\\\ \\\   \\\ \\\\\\\ \\\ \\\ \\\\\\\ \\\\\\\\         '
    Write(*,*) ''
    Write(*,*) '        \\\\\\    \\\\\\\ \\\    \\\   \\\ \\\\\\\  \\\\\\       '
    Write(*,*) '        \\\  \\   /// /// ///    ///   /// ///      ////\\\      '
    Write(*,*) '          \\ //  //   // ///    ///   /// /////    //// ///      '
    Write(*,*) '      //   \\   //   // ///  // /// ///  ///      ///\\\//       '
    Write(*,*) '      \\   /// /// /// /// /// /// ///  ///      ///  \\\        '
    Write(*,*) '       \\\\\\  \\\\\\\ \\\\\\\  \\\\\   \\\\\\\\ \\\   \\\       '
    Write(*,*) ''
    Write(*,*) ''
    !>-------------------------------------------------------------------------------

    Call test_sod_1D_dg()
    !Call test_ot_2D()
    Stop

    !Call test_opencl

    Allocate(MhdHydroSolverDG :: solver)
    !Allocate(MhdPoisSolver :: pois)
    Allocate(ga)
    Call ga%init1D(10.0D0, 200, -1, -1)
    Call ga%init_gauss1D(2)
    Call ga%init_legendre1D()

    !Do n = ga%ncell_nodes_min, ga%ncell_nodes_max
    !   Write(*,*) ga%cell_nodes(n)%x, ga%cell_nodes(n)%y, ga%cell_nodes(n)%z, ga%cell_nodes(n)%w
    !End Do
    !Stop

    !Write(*,*) ga%node2cell
    !Call ga%init2D_polar(3.0D0, 10.0D0, 200, 200, -1, -2)
    !Call ga%init_gauss_dummy()
    !Call ga%init_legendre_dummy()
    !Call ga%init2D(1.0D0, 1.0D0, 100, 100, -2, -2, -2, -2)
    !Write(*, *) ga%faces
    !Call ga%init2D(1.0D0, 1.0D0, 100, 100, -2, -2, -2, -2)

    Allocate(f(ga%ncells_min:ga%ncells_max))
    Allocate(u(ga%ncells_min:ga%ncells_max))
    Allocate(up(ga%ncells_min:ga%ncells_max))
    Allocate(flu(ga%nfaces_min:ga%nfaces_max))

    !Do i = ga%ncells_min, ga%ncells_max
    !    x = ga%cells(i)%x
    !    y = ga%cells(i)%y
    !    r = Sqrt(x**2 + y**2)
    !    u(i) = 0.0D0
    !    up(i) = 0.0D0
    !    flu(i) = 0.0D0
    !    !u(i) = (3.0D0 - r)*(10.0D0 - r)
    !    !u(i) = (x - x**2)*(y - y**2)
    !    !f(i) = Sin(4*Pi*x)!Exp(x+y)!-8*Pi**2*Sin(2*Pi*x)*Sin(2*Pi*y)
    !    !f(i) = ( Exp(y)*Exp(x)*x*(x+3.0d0)*( y - y**2 ) + Exp(y)*Exp(x)*y*(y+3.0d0)*( x - x**2 ) )
    !    !f(i) = +2.0D0*( ( y - y**2 ) + ( x - x**2 ) )
    !    !f(i) = (Cos(r) - r*Sin(r))/r
    !    f(i) = -(4.0D0*r-13.0D0)/r
    !    !f(i) = 4.0D0*Pi*Pi*Sin(2*Pi*x)*Sin(2*Pi*y)
    !    !f(i) = (x - x**2)!*(y - y**2)
    !End Do
    !Allocate(MhdPoisSolver :: pois)
    !Call pois%init()

    !Do n = 1, 1
    !    Call pois%calc(ga, u, up, flu, f)
    !    Write(*,*) n
    !    Deallocate(pois)
    !End Do
    !Call print_grid4(ga, up, 0)
    !Read(*,*)
    !Stop

    Allocate(g(m_min:m_max, n_min:n_max, ga%ncells_min:ga%ncells_max))
    Allocate(gp(m_min:m_max, n_min:n_max, ga%ncells_min:ga%ncells_max))
    Allocate(fl(n_min:n_max, ga%nface_nodes_min:ga%nface_nodes_max))

    !> Sod test case.
    If (MHD) Then
        !> MHD Sod test case.
        g(:, :, :) = 0.0D0
        g(0, 1, :) = 1.0D0
        g(0, 2, :) = 1.0D0/( Gamma1*1.0D0 )
        g(0, 6, :) = 4.0D0!/Sqrt(4.0D0*Pi)
        g(0, 7, :) = 4.0D0!/Sqrt(4.0D0*Pi)
        g(0, 8, :) = 2.0D0!/Sqrt(4.0D0*Pi)
        g(0, 1, 1:100) = 1.08D0;
        g(0, 2, 1:100) = 1.08D0*( 0.95D0/( Gamma1*1.08D0 ) + 0.5D0*(1.2D0**2 + 0.01D0**2 + 0.5D0**2) )
        g(0, 3, 1:100) = 1.08D0*1.2D0;
        g(0, 4, 1:100) = 1.08D0*0.01D0;
        g(0, 5, 1:100) = 1.08D0*0.5D0;
        g(0, 7, 1:100) = 3.6D0!/Sqrt(4.0D0*Pi)
    Else
        g(:, :, :) = 0.0D0
        g(0, 1, :) = 1.0D0
        g(0, 2, :) = 1.0D0/( Gamma1*1.0D0 )
        g(0, 1, 1:100) = 2.0D0
        g(0, 2, 1:100) = 10.0D0/( Gamma1*2.0D0 )
    End If

    !g(:, :, :) = 0.0D0
    !g(0, 1, :) = 1.0D0
    !g(0, 2, :) = 1.0D0/( Gamma1*1.0D0 )
    !g(0, 3, :) = 1.0D0
    !g(0, 4, :) = 0.0D0
    !g(0, 7, :) = 2.0D0!/Sqrt(4.0D0*Pi)

    Call solver%init()
    Call print_grid4(ga, g, 0)
    m = 1
    Tstart = omp_get_wtime()
    Do l=1, 1800!300000000
        !f(:) = g(1, :)
        !u(:) = up(:)
        !Call pois%calc(ga, u, up, flu, f, n)
        !m = m + n
        Call solver%calc_step_dg(0.001D0, ga, g, gp)
        If (Mod(l, 100) == 0) Then
            Tend = omp_get_wtime()
            Write(*, *) 'time step:', l, TEnd - Tstart, m, (TEnd - Tstart)/Dble(m)
            Tstart = Tend
            m = 1
            Call print_grid4(ga, g, l)
        End If
        g(:,:,:)=gp(:,:,:)
    End Do
End Program orchid_solver


SUBROUTINE cgsolvesgs(g,q,its)

!-------------------------------------------------------------
!
!  Perform a preconditioned conjugate gradient solution
!  M = (D+E)*D^-1*(D+F) -- Symmetric Gauss-Seidel preconditioner
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g
INTEGER :: it, i, j
INTEGER, INTENT(OUT) :: its
REAL*8 :: alf, bet, dfmx, tmp, bnorm
REAL*8, DIMENSION(neq), INTENT(IN) :: q
REAL*8, DIMENSION(neq) :: res, rt, x, z, sd, tmp1, phio, ones

! Initialize my guess
!phi(:,g) = 0.0
!res = q

phi(:,g) = phiold
res = q - MATMUL(jmat,phi(:,g))

! Solve the pre-conditioner problem Mz = r.
rt = res
DO j = 1, neq               ! Solve the lower triangular Lx=r
   x(j) = rt(j)*dv(j)
   DO i = j+1, neq
      rt(i) = rt(i) - jmat(i,j)*x(j)
   END DO
END DO
x = x/dv
DO j = neq, 1, -1           ! Solve the upper triangular Uz=x
   z(j) = x(j)*dv(j)
   DO i = 1, j-1
      x(i) = x(i) - jmat(i,j)*z(j)
   END DO
END DO

sd = z
tmp = DOT_PRODUCT(res,z)
ones = 1.0

!bnorm = SQRT(tmp)
!! Want to use just the residual when the bnorm is larger than one, means more iterations
!IF (bnorm > 1.0) THEN
!   bnorm = 1.0
!ELSE
!   ! Want to use faster multiplications at each iteration, so take inverse and store
!   bnorm = 1.0/bnorm
!END IF

DO it = 1, itmx
   ! Copy old phi vector
   phio = phi(:,g)

   ! The CG steps...should be optimized later or use outside solver
   tmp1 = MATMUL(jmat,sd)
   alf = tmp/(DOT_PRODUCT(sd,tmp1))
   phi(:,g) = phi(:,g) + alf*sd
!   dfmx = SQRT(tmp)*bnorm
   IF (MINVAL(ABS(phio)) >= tolr) THEN
      dfmx = MAXVAL(ABS(phi(:,g)/phio - ones))
   ELSE
      dfmx = MAXVAL(ABS(phi(:,g) - phio))
   END IF

   ! Cycle if not converged, less than itmx, and it not equal to the number of
   ! equations -- CG has zero residual when iterations = number of equations
   IF (dfmx > cgr .AND. it < itmx .AND. it /= neq) THEN
      res = res - alf*tmp1

      ! Solve the pre-conditioned system Mz = r.
      rt = res
      DO j = 1, neq
         x(j) = rt(j)*dv(j)
         DO i = j+1, neq
            rt(i) = rt(i) - jmat(i,j)*x(j)
         END DO
      END DO
      x = x/dv
      DO j = neq, 1, -1
         z(j) = x(j)*dv(j)
         DO i = 1, j-1
            x(i) = x(i) - jmat(i,j)*z(j)
         END DO
      END DO

      bet = 1.0/tmp
      tmp = DOT_PRODUCT(res,z)
      bet = tmp*bet
      sd  = z + bet*sd
      CYCLE
   ELSE IF (dfmx < cgr .OR. it == neq) THEN
      cnvf(g) = 1
      its = it
      EXIT
   ELSE IF (it == itmx) THEN
      cnvf(g) = 0
      its = it
      EXIT
   END IF
END DO

RETURN
END SUBROUTINE cgsolvesgs


module drivers
use types, only: dp
use scf, only: doscf, get_nuclear_energy, kinetic_energy
use basis, only: gaussints
use constants, only: Ha2eV
implicit none
private
public rhf_gauss

contains

subroutine rhf_gauss(atno, xyz, Nscf, alpha, tolE, tolP, C, lam, int2, &
        E0, Enuc, Ekin, Etot)
integer, intent(in) :: atno(:) ! Atomic numbers (Z)
real(dp), intent(in) :: xyz(:, :) ! Atomic coordinates (3, :)
integer, intent(in) :: Nscf
real(dp), intent(in) :: alpha
real(dp), intent(in) :: tolE, tolP
real(dp), allocatable, intent(out) :: C(:, :), lam(:), int2(:)
real(dp), intent(out) :: E0, Enuc, Ekin, Etot
real(dp), allocatable :: H(:, :), S(:, :), P(:, :), T(:, :), &
    V(:, :)
integer :: i

integer :: n

integer :: Nelec

call gaussints(atno, xyz, S, T, V, int2)
n = size(S, 1)
allocate(H(n, n), P(n, n), C(n, n), lam(n))

Nelec = sum(atno)

H = T + V

print *, "SCF cycle:"
call doscf(H, int2, S, Nelec/2, Nscf, tolE, tolP, alpha, C, P, lam, E0)
Enuc = get_nuclear_energy(atno, xyz)
Ekin = kinetic_energy(P, T)
Etot = E0 + Enuc
print *, "Orbital energies:"
print *, " i      E [Ha]      E [eV]"
do i = 1, size(lam)
    print "(i4,f12.6,f12.6)", i, lam(i), lam(i) * Ha2eV
end do
print *, "HF ENERGIES (a.u.):"
print *, "electronic =", E0
print *, "nuclear    =", Enuc
print *, "total      =", Etot
end subroutine

end module


      double precision function xinbta(p,q,beta,alpha,ifault)
      implicit double precision (a-h,o-z)
c
c     algorithm as 109 appl. statist. (1977), vol.26, no.1
c     (replacing algorithm as 64  appl. statist. (1973),
c     vol.22, no.3)
c
c     Remark AS R83 and the correction in vol40(1) p.236 have been
c     incorporated in this version.
c
c     Computes inverse of the incomplete beta function
c     ratio for given positive values of the arguments
c     p and q, alpha between zero and one.
c     log of complete beta function, beta, is assumed to be known.
c
c     Auxiliary function required: BETAIN = algorithm AS63
c
      logical indx
c
c     Define accuracy and initialise.
c     SAE below is the most negative decimal exponent which does not
c     cause an underflow; a value of -308 or thereabouts will often be
c     OK in double precision.
c
c     data acu/1.0d-14/
c     data SAE/-37.D0/
      data SAE/-308.D0/
      data zero/0.0d0/, one/1.0d0/, two/2.0d0/
      data three/3.0d0/, four/4.0d0/, five/5.0d0/, six/6.0d0/
c
      fpu = 10.d0 ** sae
      xinbta = alpha
c
c     test for admissibility of parameters
c
      ifault = 1
      if (p.le.zero .or. q.le.zero) return
      ifault = 2
      if (alpha.lt.zero .or. alpha.gt.one) return
      ifault = 0
      if (alpha.eq.zero .or. alpha.eq.one) return
c
c     change tail if necessary
c
      if (alpha.le.0.5d0) goto 1
      a = one-alpha
      pp = q
      qq = p
      indx = .true.
      goto 2
    1 a = alpha
      pp = p
      qq = q
      indx = .false.
c
c     calculate the initial approximation
c
    2 r = dsqrt(-dlog(a*a))
      y = r-(2.30753d0+0.27061d0*r)/(one+(0.99229d0+0.04481d0*r)*r)
      if(pp.gt.one .and. qq.gt.one) goto 5
      r = qq+qq
      t = one/(9.0d0*qq)
      t = r*(one-t+y*dsqrt(t))**3
      if(t.le.zero) goto 3
      t = (four*pp+r-two)/t
      if(t.le.one) goto 4
      xinbta = one-two/(t+one)
      goto 6
    3 xinbta = one-dexp((dlog((one-a)*qq)+beta)/qq)
      goto 6
    4 xinbta = dexp((dlog(a*pp)+beta)/pp)
      goto 6
    5 r = (y*y-three)/six
      s = one/(pp+pp-one)
      t = one/(qq+qq-one)
      h = two/(s+t)
      w = y*dsqrt(h+r)/h-(t-s)*(r+five/six-two/(three*h))
      xinbta = pp/(pp+qq*dexp(w+w))
c
c     solve for x by a modified newton-raphson method,
c     using the function betain
c
    6 r = one-pp
      t = one-qq
      yprev = zero
      sq = one
      prev = one
      if(xinbta.lt.0.0001d0) xinbta = 0.0001d0
      if(xinbta.gt.0.9999d0) xinbta = 0.9999d0
      IEX = MAX(-5.D0/PP**2 - 1.D0/A**2 - 13.D0, SAE)
      ACU = 10.D0 ** IEX
    7 y = betain(xinbta,pp,qq,beta,ifault)
      if(ifault.eq.0) goto 8
      ifault = 3
      return
    8 continue
      xin = xinbta
      y = (y-a)*exp(beta+r*log(xin)+t*log(one-xin))
      if(y*yprev.le.zero) prev = max(sq, fpu)
      g = one
    9 adj = g*y
      sq = adj*adj
      if(sq.ge.prev) goto 10
      tx = xinbta-adj
      if(tx.ge.zero .and. tx.le.one) goto 11
   10 g = g/three
      goto 9
   11 if(prev.le.acu) goto 12
      if(y*y.le.acu) goto 12
      if(tx.eq.zero .or. tx.eq.one) goto 10
      if(tx.eq.xinbta) goto 12
      xinbta = tx
      yprev = y
      goto 7
   12 if (indx) xinbta = one-xinbta
      return
      end


      SUBROUTINE G0TICK
C
C          ------------------------------------------------
C          ROUTINE NO. ( 232)   VERSION (A7.3)    11:FEB:85
C          ------------------------------------------------
C
C          GIVEN THE AXIS AND ITS POSITION, THIS CALCULATES THE
C          END-POSITIONS OF THE TICK MARKS SUCH THAT THEY ALWAYS
C          APPEAR TO BE 8/1000 AND 5/1000 OF THE CURRENT WINDOW SIZE,
C          NO MATTER WHICH KIND OF MAPPING IS CURRENTLY BEING USED.
C
C
C          THE FOLLOWING ARGUMENTS ARE SUPPLIED THROUGH COMMON:
C
C          <KAXIS>  GIVES THE CURRENT AXIS BY ITS MODULUS:
C                   = 1 FOR THE X-AXIS, AND
C                   = 2 FOR THE Y-AXIS.
C          <AXPOSX> IS THE POSITION OF THE X-AXIS ALONG Y.
C          <AXPOSY> IS THE POSITION OF THE Y-AXIS ALONG X.
C
C
C          THE FOLLOWING ARGUMENTS ARE RETURNED THROUGH COMMON:
C
C          <TKEN1A> AND
C          <TKEN1B> ARE THE END-POINTS OF THE 5/1000TH.-SIZE TICK MARK.
C          <TKEN2A> AND
C          <TKEN2B> ARE THE END-POINTS OF THE 8/1000TH.-SIZE TICK MARK.
C
C
      COMMON /T0AARG/ KAXIS
      COMMON /T0APOS/ AXPOSX,AXPOSY
      COMMON /T0ATIK/ TKEN1A,TKEN1B,TKEN2A,TKEN2B
      COMMON /T0MAPT/ MAPNO0
      COMMON /T0WNDO/ X1WND0,X2WND0,Y1WND0,Y2WND0
C
      ENDTKX(DY,Y1WND0,Y2WND0)= AXPOSX*((Y1WND0/Y2WND0)**DY)
      ENDTKY(DX,X1WND0,X2WND0)= AXPOSY*((X1WND0/X2WND0)**DX)
C
C
      IF (IABS(KAXIS).NE.1) GO TO 2
C
C          THIS SECTION FINDS THE X-AXIS TICK MARKS
C          FOR EITHER LINEAR OR LOGARITHMIC Y-MAPPING.
C
      IF (MAPNO0.EQ.2.OR.MAPNO0.EQ.4) GO TO 1
C
      TIKL= 0.005*(Y2WND0-Y1WND0)
      TKEN1A= AXPOSX+TIKL
      TKEN1B= AXPOSX-TIKL
      TKEN2A= AXPOSX+1.6*TIKL
      TKEN2B= AXPOSX-1.6*TIKL
      RETURN
C
    1 TKEN1A= ENDTKX(0.005,Y2WND0,Y1WND0)
      TKEN1B= ENDTKX(0.005,Y1WND0,Y2WND0)
      TKEN2A= ENDTKX(0.008,Y2WND0,Y1WND0)
      TKEN2B= ENDTKX(0.008,Y1WND0,Y2WND0)
      RETURN
C
C          THIS SECTION FINDS THE Y-AXIS TICK MARKS
C          FOR EITHER LINEAR OR LOGARITHMIC X-MAPPING.
C
    2 IF (MAPNO0.EQ.3.OR.MAPNO0.EQ.4) GO TO 3
C
      TIKL= 0.005*(X2WND0-X1WND0)
      TKEN1A= AXPOSY+TIKL
      TKEN1B= AXPOSY-TIKL
      TKEN2A= AXPOSY+1.6*TIKL
      TKEN2B= AXPOSY-1.6*TIKL
      RETURN
C
    3 TKEN1A= ENDTKY(0.005,X2WND0,X1WND0)
      TKEN1B= ENDTKY(0.005,X1WND0,X2WND0)
      TKEN2A= ENDTKY(0.008,X2WND0,X1WND0)
      TKEN2B= ENDTKY(0.008,X1WND0,X2WND0)
      RETURN
      END


      SUBROUTINE DEFE4(COFX,IDMN,USOL,GRHS)
C
C     THIS SUBROUTINE FIRST APPROXIMATES THE TRUN1ATION ERROR GIVEN BY
C     TRUN1(X,Y)=DLX**2*TX+DLY**2*TY WHERE
C     TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 ON THE INTERIOR AND
C     AT THE BOUNDARIES IF PERIODIC(HERE UXXX,UXXXX ARE THE THIRD
C     AND FOURTH PARTIAL DERIVATIVES OF U WITH RESPECT TO X).
C     TX IS OF THE FORM AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX)
C     AT X=A OR X=B IF THE BOUNDARY CONDITION THERE IS MIXED.
C     TX=0.0 ALONG SPECIFIED BOUNDARIES.  TY HAS SYMMETRIC FORM
C     IN Y WITH X,AFUN(X),BFUN(X) REPLACED BY Y,DFUN(Y),EFUN(Y).
C     THE SECOND ORDER SOLUTION IN USOL IS USED TO APPROXIMATE
C     (VIA SECOND ORDER FINITE DIFFERENCING) THE TRUN1ATION ERROR
C     AND THE RESULT IS ADDED TO THE RIGHT HAND SIDE IN GRHS
C     AND THEN TRANSFERRED TO USOL TO BE USED AS A NEW RIGHT
C     HAND SIDE WHEN CALLING BLKTRI FOR A FOURTH ORDER SOLUTION.
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      EXTERNAL COFX
C
C
C     COMPUTE TRUN1ATION ERROR APPROXIMATION OVER THE ENTIRE MESH
C
         DO  30 I=IS,MS
            XI = AIT+FLOAT(I-1)*DLX
            CALL COFX (XI,AI,BI,CI)
         DO 30 J=JS,NS
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ)
C
            CALL DX4(USOL,IDMN,I,J,UXXX,UXXXX)
            CALL DY4(USOL,IDMN,I,J,UYYY,UYYYY)
            TX = AI*UXXXX/12.0+BI*UXXX/6.0
             TY=UYYYY/12.0
C
C     RESET FORM OF TRUN1ATION IF AT BOUNDARY WHICH IS NON-PERIODIC
C
            IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO  10
            TX = AI/3.0*(UXXXX/4.0+UXXX/DLX)
   10       IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO  20
            TY = (UYYYY/4.0+UYYY/DLY)/3.0
   20 GRHS(I,J)=GRHS(I,J)+DLY**2*(DLX**2*TX+DLY**2*TY)
   30    CONTINUE
C
C     RESET THE RIGHT HAND SIDE IN USOL
C
      DO  60 I=IS,MS
         DO  50 J=JS,NS
            USOL(I,J) = GRHS(I,J)
   50    CONTINUE
   60 CONTINUE
      RETURN
      END


PROGRAM evaluatePES

use dynamic_parameters
!-----------------------------------------------------------------------------------
implicit none
 character (len=40) :: NAME1
 real*8 :: xi(4),V,pii,th1,th2,phi,CONVE

 pii=acos(-1d0)
 CONVE=349.75d0 ! conversion factor: switch energies from kcal/mol to wave numbers

 ! name of the PES-file
 NAME1='PES-CO2dimer-1064'

 ! ---------------------------------------------------------------------------------
 ! ***  evaluate the PES  ***
 ! ---------------------------------------------------------------------------------
 !!  xi(1) is R, the distance between centers of mass (in Angstroms).             !!
 !!  xi(2) and xi(3) are cos(theta1) and cos(theta2) and range from (-1,1).       !!
 !!  xi(4) is the dihedral angle, in radians, with range: (0,2pi).                !!

 ! coordinate R
 xi(1)=5.64d0
 ! coordinate theta1
 th1=0.d0
 xi(2)=dcos(th1*pii/180.d0)
 ! coordinate theta2
 th2=180.d0
 xi(3)=dcos(th2*pii/180.d0)
 ! coordinate phi
 phi=0d0
 xi(4)=phi*pii/180.d0

 call PES(xi,V,NAME1)
 V=V*CONVE

 write(*,501)xi
 501 format(' coordinates [R;cos(th1);cos(th2);phi] -> ',4(F6.2))
 write(6,*) '                            potential -> ',V

end program evaluatePES


      SUBROUTINE modular_surface (u, v, x, y, z, nx, ny, nz)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE stel_constants
      USE modular_coils
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: k
      REAL(rprec) :: u, v
      REAL(rprec) :: x, y
      REAL(rprec) :: nx, ny, nz, nmag
      REAL(rprec) :: th0, th1, ph0, ph1
      REAL(rprec) :: r, ru, rv
      REAL(rprec) :: z, zu, zv
      REAL(rprec) :: ck, sk
!-----------------------------------------------

!     theta and derivative wrt u

      th0 = twopi*u
      th1 = twopi

!     phi and derivative wrt v

      ph0 = twopi*v/nfper
      ph1 = twopi/nfper

!     compute R, Z and derivatives wrt u and v

      r   = 0
      ru  = 0
      rv  = 0
      z   = 0
      zu  = 0
      zv  = 0
      DO k = 1, numsurf
         ck = COS(m_num(k)*th0 + nfper*n_num(k)*ph0)
         sk = SIN(m_num(k)*th0 + nfper*n_num(k)*ph0)
!     R ...
         r  = r  + rmn_sf(k)*ck
         ru = ru - rmn_sf(k)*m_num(k)*sk
         rv = rv - rmn_sf(k)*n_num(k)*sk
!     Z ...
         z  = z  + zmn_sf(k)*sk
         zu = zu + zmn_sf(k)*m_num(k)*ck
         zv = zv + zmn_sf(k)*n_num(k)*ck
      END DO
      ru = ru*th1
      zu = zu*th1
      rv = rv*ph1*nfper
      zv = zv*ph1*nfper

      sk = SIN(ph0)
      ck = COS(ph0)

!     RETURN X and Y

      x = r*ck
      y = r*sk

!     compute Nx, Ny, Nz

      nx = ru*zv*sk - zu*(rv*sk + r*ck)
      ny = zu*(rv*ck - r*sk) - ru*zv*ck
      nz = r*ru
      nmag = SQRT (nx**2 + ny**2 + nz**2)
      nx = -nx/nmag
      ny = -ny/nmag
      nz = -nz/nmag

      END SUBROUTINE modular_surface