!##############################################################################
!# ****************************************************************************
!# <name> user_flows </name>
!# ****************************************************************************
!#
!# <purpose>
!# Defines a couple of user-defined, analytically given flows and functions.
!# </purpose>
!##############################################################################

module user_flows

use fsystem

implicit none

contains

  ! ***************************************************************************
  ! Reference functions, Heat equation
  ! ***************************************************************************
  ! ***************************************************************************
  ! Heat equation, function set 1.
  !   y = t^2   x1
  ! ***************************************************************************

  elemental real(DP) function fct_heatY1 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatY1 = dtime**2 * dx
  end function

  elemental real(DP) function fct_heatLambda1 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatLambda1 = dalpha * (- 2.0_DP*dtime * dx) + 2*dalpha*dx
  end function

  elemental real(DP) function fct_heatF1 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatF1 = 2.0_DP*dtime*dx - 2.0_DP*dx*(dtime-1.0_DP)
  end function

  elemental real(DP) function fct_heatZ1 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatZ1 = -2.0_DP*dalpha*dx + dtime**2*dx
  end function

  ! ***************************************************************************
  ! Heat equation, function set 2
  !   y = t^2 (1-t)^2   x1
  !   l = a t (1-t) x1
  ! No factor 4 due to inconsistent terminal condition.
  ! ***************************************************************************

  elemental real(DP) function fct_heatY2 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatY2 = dtime**2 * (1.0_DP-dtime)**2 * dx
  end function

  elemental real(DP) function fct_heatLambda2 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatLambda2 = dalpha * dtime * (1.0_DP-dtime) * dx
  end function

  elemental real(DP) function fct_heatF2 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatF2 = 3.0_DP*dtime*dx-7.0_DP*dtime**2*dx+4*dtime**3*dx
  end function

  elemental real(DP) function fct_heatZ2 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatZ2 = (1.0_DP-dtime)*dx-dtime*dx+dtime**2*(1.0_DP-dtime)**2*dx
  end function

  ! ***************************************************************************
  ! Heat equation, function set 3
  !   y = t^2 (1-t)^2   x1
  !   l = a t (1-t)^2   x1
  ! Gives factor 4 with CN due to proper terminal condition.
  ! ***************************************************************************

  elemental real(DP) function fct_heatY3 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatY3 = dtime**2 * (1.0_DP-dtime)**2 * dx
  end function

  elemental real(DP) function fct_heatLambda3 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatLambda3 = dalpha * dtime * (1.0_DP-dtime)**2 * dx
  end function

  elemental real(DP) function fct_heatF3 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatF3 = &
      3.0_DP*dtime*dx-8.0_DP*dtime**2*dx+5*dtime**3*dx
  end function

  elemental real(DP) function fct_heatZ3 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatZ3 = &
         (1.0_DP-dtime)**2*dx-2.0_DP*dtime*(1.0_DP-dtime)*dx+&
          dtime**2*(1.0_DP-dtime)**2*dx
  end function

  ! ***************************************************************************
  ! Heat equation, function set 4
  !   y = t^2 (1-t)^2   x1
  ! ***************************************************************************

  elemental real(DP) function fct_heatY4 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatY4 = dtime**2 * (1.0_DP-dtime)**2 * dx
  end function

  elemental real(DP) function fct_heatLambda4 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatLambda4 = dalpha * (-2.0_DP*dtime*(1.0_DP-dtime)**2*dx + 2.0_DP*dtime**2*(1.0_DP-dtime)*dx)
  end function

  elemental real(DP) function fct_heatF4 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatF4 = 0.0_DP
  end function

  elemental real(DP) function fct_heatZ4 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatZ4 = &
        - dalpha*2.0_DP*(1-dtime)**2*dx + dalpha*8.0_DP*dtime*(1-dtime)*dx &
        - dalpha*2.0_DP*dtime**2*dx + dtime**2*(1.0_DP-dtime)**2*dx
  end function

  ! ***************************************************************************
  ! Heat equation, function set 5.
  !   y = t   x1
  !   l = (1-t) x1
  ! Does not produce error=0, only at the beginning.
  ! ***************************************************************************

  elemental real(DP) function fct_heatY5 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatY5 = dtime * dx
  end function

  elemental real(DP) function fct_heatLambda5 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatLambda5 = (1.0_DP-dtime)*dx
  end function

  elemental real(DP) function fct_heatF5 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatF5 = -(dtime-dalpha-1.0_DP)*dx/dalpha
  end function

  elemental real(DP) function fct_heatZ5 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatZ5 = (dtime-1.0_DP)*dx
  end function

  ! ***************************************************************************
  ! Heat equation, function set 6.
  !   y = t^2   x1
  !   l = (1-t)^2 x1
  ! ***************************************************************************

  elemental real(DP) function fct_heatY6 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatY6 = dtime**2 * dx
  end function

  elemental real(DP) function fct_heatLambda6 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatLambda6 = (1.0_DP-dtime)**2*dx
  end function

  elemental real(DP) function fct_heatF6 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatF6 = dx*(2.0_DP*dtime*dalpha+1.0_DP-2.0_DP*dtime+dtime**2)/dalpha
  end function

  elemental real(DP) function fct_heatZ6 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_heatZ6 = dtime**2*dx-2.0_DP*(1.0_DP-dtime)*dx
  end function

  ! ***************************************************************************
  ! Reference functions, Stokes equation
  ! ***************************************************************************
  ! ***************************************************************************
  ! Stokes, function set 1.
  !   y = t^2  ( x1 , -x2 , 0)
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY1_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY1_x = dtime**2 * dx
  end function

  elemental real(DP) function fct_stokesY1_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY1_y = - dtime**2 * dy
  end function

  elemental real(DP) function fct_stokesP1 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP1 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda1_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda1_x = dalpha * (-2.0_DP*dtime*dx)
  end function

  elemental real(DP) function fct_stokesLambda1_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda1_y = dalpha * (2.0_DP*dtime*dy)
  end function

  elemental real(DP) function fct_stokesXi1 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi1 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ1_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ1_x = -2.0_DP*dx + dtime**2*dx
  end function

  elemental real(DP) function fct_stokesZ1_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ1_y = 2.0_DP*dy - dtime**2*dy
  end function

  ! ***************************************************************************
  ! Stokes, function set 2.
  !   y = t^2 (1-t)^3  ( x2(1-x2) , 0 , 0 )
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY2_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY2_x = dy * (-1 + dy) * dtime ** 2 * (-1 + dtime) ** 3
  end function

  elemental real(DP) function fct_stokesY2_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY2_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesP2 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP2 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda2_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda2_x = &
        - dalpha * dtime * (-1 + dtime) ** 2 * (2 * dtime - 2 * dtime ** 2 &
        + 2 * dy - 5 * dy * dtime - 2 * dy ** 2 + 5 * dy ** 2 * dtime)
  end function

  elemental real(DP) function fct_stokesLambda2_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda2_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesXi2 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi2 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ2_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ2_x = &
          dy * dtime ** 2 - 3 * dy * dtime ** 3 + 3 * dy * dtime ** 4 &
        - dy * dtime ** 5 - dy ** 2 * dtime ** 2 + 3 * dy ** 2 * dtime ** 3 &
        - 3 * dy ** 2 * dtime ** 4 + dy ** 2 * dtime ** 5 - 2 * dalpha * dy &
        - 0.18D2 * dalpha * dy ** 2 * dtime + 2 * dalpha * dy ** 2 &
        + 0.18D2 * dalpha * dy * dtime - 0.36D2 * dalpha * dy * dtime ** 2 &
        + 0.20D2 * dalpha * dy * dtime ** 3 + 0.36D2 * dalpha * dy ** 2 * dtime ** 2 &
        - 0.20D2 * dalpha * dy ** 2 * dtime ** 3
  end function

  elemental real(DP) function fct_stokesZ2_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ2_y = 0.0_DP
  end function

  ! ***************************************************************************
  ! Stokes, function set 3.
  !   y = t^2 (x1^2 x2 , -x1 x2^2 , 0)
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY3_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY3_x = dtime**2 * dx**2 * dy
  end function

  elemental real(DP) function fct_stokesY3_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY3_y = - dtime**2 * dx**2 * dy
  end function

  elemental real(DP) function fct_stokesP3 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP3 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda3_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda3_x = -dalpha*(-2*dy*dtime**2*(1-dtime)**2 &
        +2*dx**2*dy*dtime*(1-dtime)**2 &
        -2*dx**2*dy*dtime**2*(1-dtime) )
  end function

  elemental real(DP) function fct_stokesLambda3_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda3_y = -dalpha*(-2*dx*dtime**2*(1-dtime)**2 &
        +2*dx*dy**2*dtime*(1-dtime)**2 &
        -2*dx*dy**2*dtime**2*(1-dtime) )
  end function

  elemental real(DP) function fct_stokesXi3 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi3 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ3_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ3_x = (dx**2*dy*dtime**2*(-1+dtime)**2) &
        - dalpha*(-4*dy*dtime+12*dy*dtime**2 &
                  -8*dy*dtime**3+2*dx**2*dy &
                  -12*dx**2*dy*dtime+12*dx**2*dy*dtime**2)
  end function

  elemental real(DP) function fct_stokesZ3_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ3_y = (dx*dy**2*dtime**2*(-1+dtime)**2) &
          - dalpha*(-4*dx*dtime+12*dx*dtime**2 &
                    -8*dx*dtime**3+2*dx*dy**2 &
                    -12*dx*dy**2*dtime+12*dx*dy**2*dtime**2)
  end function

  ! ***************************************************************************
  ! Stokes, function set 4.
  !   y = t^2 (1-t)^2  (x1^3 x2^2 , -x1^2 x2^3 , 0)
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY4_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY4_x = dx ** 3 * dy ** 2 * dtime ** 2 * (-1.0_DP + dtime) ** 2
  end function

  elemental real(DP) function fct_stokesY4_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY4_y = -dx ** 2 * dy ** 3 * dtime ** 2 * (-1.0_DP + dtime) ** 2
  end function

  elemental real(DP) function fct_stokesP4 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP4 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda4_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda4_x = -2 * dalpha * dx * dtime * (-1 + dtime) * &
              (3 * dy ** 2 * dtime - 3 * dy ** 2 * dtime ** 2 + dx ** 2 * dtime &
              - dx ** 2 * dtime ** 2 - dx ** 2 * dy ** 2 + 2 * dx ** 2 * dy ** 2 * dtime)
  end function

  elemental real(DP) function fct_stokesLambda4_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda4_y = 2 * dalpha * dy * dtime * (-1 + dtime) * &
              (dy ** 2 * dtime - dy ** 2 * dtime ** 2 + 3 * dx ** 2 * dtime &
               - 3 * dx ** 2 * dtime ** 2 - dx ** 2 * dy ** 2 &
               + 2 * dx ** 2 * dy ** 2 * dtime)
  end function

  elemental real(DP) function fct_stokesXi4 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi4 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ4_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ4_x = &
        -2*dalpha*dx**3*dy**2+12*dalpha*dx**3*dy**2*dtime-12*dalpha*dx**3*dy**2*dtime**2+dx**3*dy**2*dtime**2 &
        -2*dx**3*dy**2*dtime**3+dx**3*dy**2*dtime**4+24*dalpha*dx*dtime**2-48*dalpha*dx*dtime**3+24*dalpha*dx*dtime**4
!    fct_stokesZ4_x = 6 * dx * dy ** 2 * dtime ** 2 &
!        - 0.12D2 * dx * dy ** 2 * dtime ** 3 &
!        + 6 * dx * dy ** 2 * dtime ** 4 + 2 * dx ** 3 * dtime ** 2 &
!        - 4 * dx ** 3 * dtime ** 3 + 2 * dx ** 3 * dtime ** 4 &
!        + dx ** 3 * dy ** 2 * dtime ** 2 - 2 * dx ** 3 * dy ** 2 * dtime ** 3 &
!        + dx ** 3 * dy ** 2 * dtime ** 4 + 0.12D2 * dalpha * dx * dy ** 2 * dtime &
!        - 0.36D2 * dalpha * dx * dy ** 2 * dtime ** 2 &
!        + 0.24D2 * dalpha * dx * dy ** 2 * dtime ** 3 &
!        + 4 * dalpha * dx ** 3 * dtime &
!        - 0.12D2 * dalpha * dx ** 3 * dtime ** 2 &
!        + 8 * dalpha * dx ** 3 * dtime ** 3 &
!        - 2 * dalpha * dx ** 3 * dy ** 2 &
!        + 0.12D2 * dalpha * dx ** 3 * dy ** 2 * dtime &
!        - 0.12D2 * dalpha * dx ** 3 * dy ** 2 * dtime ** 2
  end function

  elemental real(DP) function fct_stokesZ4_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ4_y = &
        2*dalpha*dy**3*dx**2-12*dalpha*dy**3*dx**2*dtime+12*dalpha*dy**3*dx**2*dtime**2-dx**2*dy**3*dtime**2 &
        +2*dx**2*dy**3*dtime**3-dx**2*dy**3*dtime**4-24*dalpha*dy*dtime**2+48*dalpha*dy*dtime**3-24*dalpha*dy*dtime**4
!    fct_stokesZ4_y = -2 * dy ** 3 * dtime ** 2 + 4 * dy ** 3 * dtime ** 3 &
!        - 2 * dy ** 3 * dtime ** 4 - 6 * dx ** 2 * dy * dtime ** 2 &
!        + 0.12D2 * dx ** 2 * dy * dtime ** 3 - 6 * dx ** 2 * dy * dtime ** 4 &
!        - dx ** 2 * dy ** 3 * dtime ** 2 + 2 * dx ** 2 * dy ** 3 * dtime ** 3 &
!        - dx ** 2 * dy ** 3 * dtime ** 4 - 4 * dalpha * dy ** 3 * dtime &
!        + 0.12D2 * dalpha * dy ** 3 * dtime ** 2 &
!        - 8 * dalpha * dy ** 3 * dtime ** 3 &
!        - 0.12D2 * dalpha * dx ** 2 * dy * dtime &
!        + 0.36D2 * dalpha * dx ** 2 * dy * dtime ** 2 &
!        - 0.24D2 * dalpha * dx ** 2 * dy * dtime ** 3 &
!        + 2 * dalpha * dx ** 2 * dy ** 3 &
!        - 0.12D2 * dalpha * dx ** 2 * dy ** 3 * dtime &
!        + 0.12D2 * dalpha * dx ** 2 * dy ** 3 * dtime ** 2
  end function

  ! ***************************************************************************
  ! Stokes, function set 5.
  !   y = t  ( x2(1-x2) , 0 , 0 )
  ! No coupling between primal and dual!
  ! EXAMPLE DOES NOT WORK, NOT DIVERGENCE FREE WHEN BEING TIME DEPENDENT!
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY5_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY5_x = dtime * dy*(1.0_DP-dy)
  end function

  elemental real(DP) function fct_stokesY5_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY5_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesP5 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP5 = dtime*(1.0_DP-dx) !0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda5_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda5_x = 0.0_DP !-dalpha*( &
!                2.0_DP*dtime**2*(1.0_DP-dtime)**2 &
!              + 2.0_DP*dy*(1.0_DP-dy)*dtime*(1.0_DP-dtime)**2 &
!              - 2.0_DP*dy*(1.0_DP-dy)*dtime**2*(1.0_DP-dtime))
  end function

  elemental real(DP) function fct_stokesLambda5_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda5_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesXi5 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi5 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ5_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ5_x = 0.0_DP !- dy*(-1.0_DP+dy)*dtime**2*(-1.0_DP+dtime)**2 &
!            - dalpha*(4.0_DP*dtime-12.0_DP*dtime**2+8.0_DP*dtime**3+2.0_DP*dy &
!                      -12.0_DP*dy*dtime+12.0_DP*dy*dtime**2 &
!                      -2.0_DP*dy**2+12.0_DP*dy**2*dtime &
!                      -12.0_DP*dy**2*dtime**2)
  end function

  elemental real(DP) function fct_stokesZ5_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ5_y = 0.0_DP
  end function

  ! ***************************************************************************
  ! Stokes, function set 6.
  !   y      =     t ( x2(1-x2) , 0 , 0 )
  !   lambda = (1-t) ( x2(1-x2) , 0 , 0 )
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY6_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY6_x = dtime * dy*(1.0_DP-dy)
  end function

  elemental real(DP) function fct_stokesY6_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY6_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesP6 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP6 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda6_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda6_x = (1.0_DP-dtime) * dy*(1.0_DP-dy)
  end function

  elemental real(DP) function fct_stokesLambda6_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda6_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesXi6 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi6 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ6_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ6_x = -0.2D1 + 0.2D1 * dtime - dy + dy ** 2 + dy * dtime &
        - dy ** 2 * dtime
  end function

  elemental real(DP) function fct_stokesZ6_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ6_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesF6_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesF6_x = (0.2D1 * dtime * dalpha + dy * dalpha - dy ** 2 * dalpha + dy &
        - dy * dtime - dy ** 2 + dy ** 2 * dtime) / dalpha
  end function

  elemental real(DP) function fct_stokesF6_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesF6_y = 0.0_DP
  end function

  ! ***************************************************************************
  ! Stokes, function set 7.
  !   y      =     t^2 ( x2(1-x2) , 0 , 0 )
  !   lambda = (1-t)^2 ( x2(1-x2) , 0 , 0 )
  ! ***************************************************************************

  elemental real(DP) function fct_stokesY7_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY7_x = dtime**2 * dy*(1.0_DP-dy)
  end function

  elemental real(DP) function fct_stokesY7_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesY7_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesP7 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesP7 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda7_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda7_x = (1.0_DP-dtime)**2 * dy*(1.0_DP-dy)
  end function

  elemental real(DP) function fct_stokesLambda7_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesLambda7_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesXi7 (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesXi7 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ7_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ7_x = -0.2D1 + 0.4D1 * dtime - 0.2D1 * dtime ** 2 &
        - 0.2D1 * dy + 0.2D1 * dy * dtime + 0.2D1 * dy ** 2 &
        - 0.2D1 * dy ** 2 * dtime + dy * dtime ** 2 - dy ** 2 * dtime ** 2
  end function

  elemental real(DP) function fct_stokesZ7_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesZ7_y = 0.0_DP
  end function

  elemental real(DP) function fct_stokesF7_x (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesF7_x = -(-0.2D1 * dtime ** 2 * dalpha &
        - 0.2D1 * dy * dtime * dalpha + 0.2D1 * dy ** 2 * dtime * dalpha &
        - dy + 0.2D1 * dy * dtime - dy * dtime ** 2 + dy ** 2 &
        - 0.2D1 * dy ** 2 * dtime + dy ** 2 * dtime ** 2) / dalpha
  end function

  elemental real(DP) function fct_stokesF7_y (dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_stokesF7_y = 0.0_DP
  end function

  ! ***************************************************************************
  ! Stokes, function set 8
  !   w      = sin (Pi/2 x1) sin (Pi x2)
  !   y      = sin (Pi t ) w
  !   lambda = sin (Pi t ) w
  ! ***************************************************************************

  elemental real(DP) function fct_eigSt8(dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_eigSt8 = sin(0.5_DP*SYS_PI*dx) * sin(SYS_PI*dy)
  end function

  elemental real(DP) function fct_stokesY8_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesY8_x = fct_eigSt8(dx,dy,dtime,dalpha)*sin(0.5_DP*SYS_PI*dtime)
  end function

  elemental real(DP) function fct_stokesY8_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesY8_y = fct_eigSt8(dx,dy,dtime,dalpha)*sin(0.5_DP*SYS_PI*dtime)
  end function

  elemental real(DP) function fct_stokesP8 (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesP8 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesLambda8_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesLambda8_x = fct_eigSt8(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1.0_DP)
  end function

  elemental real(DP) function fct_stokesLambda8_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesLambda8_y = fct_eigSt8(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1.0_DP)
  end function

  elemental real(DP) function fct_stokesXi8 (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesXi8 = 0.0_DP
  end function

  elemental real(DP) function fct_stokesZ8_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesZ8_x = -0.25_DP*fct_eigSt8(dx,dy,dtime,dalpha)*(-4.0_DP*sin(0.5_DP*SYS_PI*dtime)+&
        5.0_DP*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)-5.0_DP*SYS_PI**2-2*cos(0.5_DP*SYS_PI*dtime)*SYS_PI)
  end function

  elemental real(DP) function fct_stokesZ8_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesZ8_y = -0.25_DP*fct_eigSt8(dx,dy,dtime,dalpha)*(-4.0_DP*sin(0.5_DP*SYS_PI*dtime)+&
        5.0_DP*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)-5.0_DP*SYS_PI**2-2*cos(0.5_DP*SYS_PI*dtime)*SYS_PI)
  end function

  elemental real(DP) function fct_stokesZ8_p (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesZ8_p = -0.5_DP*SYS_PI*(sin(0.5_DP*SYS_PI*dtime)*cos(0.5_DP*SYS_PI*dx)*sin(SYS_PI*dy)+&
        2.0_DP*sin(0.5_DP*SYS_PI*dtime)*sin(0.5_DP*SYS_PI*dx)*cos(SYS_PI*dy)-&
        cos(0.5_DP*SYS_PI*dx)*sin(SYS_PI*dy)-2*sin(0.5_DP*SYS_PI*dx)*cos(SYS_PI*dy))
  end function

  elemental real(DP) function fct_stokesF8_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesF8_x = 1.25_DP*fct_eigSt8(dx,dy,dtime,dalpha)*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)+&
        0.5_DP*fct_eigSt8(dx,dy,dtime,dalpha)*cos(0.5_DP*SYS_PI*dtime)*SYS_PI+&
        fct_eigSt8(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1)/dalpha
  end function

  elemental real(DP) function fct_stokesF8_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesF8_y = 1.25_DP*fct_eigSt8(dx,dy,dtime,dalpha)*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)+&
        0.5_DP*fct_eigSt8(dx,dy,dtime,dalpha)*cos(0.5_DP*SYS_PI*dtime)*SYS_PI+&
        fct_eigSt8(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1)/dalpha
  end function

  elemental real(DP) function fct_stokesF8_p (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesF8_p = -0.5_DP*SYS_PI*sin(0.5_DP*SYS_PI*dtime)*(cos(0.5_DP*SYS_PI*dx)*sin(SYS_PI*dy)+&
        2*sin(0.5_DP*SYS_PI*dx)*cos(SYS_PI*dy))
  end function

  ! ***************************************************************************
  ! Stokes, function set 9
  !   w      = sin (Pi/2 x1) sin (Pi x2)
  !   w_0    = sin (Pi x1) sin (Pi x2)
  !   y      = sin (Pi t ) ( w , w )
  !   lambda = sin (Pi t ) ( w , w )
  !   p      = sin (Pi t) w_0
  !   xi     = sin (Pi t) w_0
  ! ***************************************************************************

  elemental real(DP) function fct_eigSt9(dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    fct_eigSt9 = sin(0.5_DP*SYS_PI*dx) * sin(SYS_PI*dy)
  end function

  elemental real(DP) function fct_eigSt9_1(dx,dy,dtime,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dalpha
    ! No int-mean = 0 since there is a Neumann edge that forces p=0 on the edge.
    fct_eigSt9_1 = sin(SYS_PI*dx) * sin(SYS_PI*dy)
  end function

  elemental real(DP) function fct_stokesY9_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesY9_x = fct_eigSt9(dx,dy,dtime,dalpha)*sin(0.5_DP*SYS_PI*dtime)
  end function

  elemental real(DP) function fct_stokesY9_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesY9_y = fct_eigSt9(dx,dy,dtime,dalpha)*sin(0.5_DP*SYS_PI*dtime)
  end function

  elemental real(DP) function fct_stokesP9 (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesP9 = sin(SYS_PI*dtime)*fct_eigSt9_1(dx,dy,dtime,dalpha)
  end function

  elemental real(DP) function fct_stokesLambda9_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesLambda9_x = fct_eigSt9(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1.0_DP)
  end function

  elemental real(DP) function fct_stokesLambda9_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesLambda9_y = fct_eigSt9(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1.0_DP)
  end function

  elemental real(DP) function fct_stokesXi9 (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesXi9 = sin(SYS_PI*dtime)*fct_eigSt9_1(dx,dy,dtime,dalpha)
  end function

  elemental real(DP) function fct_stokesZ9_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesZ9_x = -0.25_DP*fct_eigSt9(dx,dy,dtime,dalpha)*(-4.0_DP*sin(0.5_DP*SYS_PI*dtime)+&
        5.0_DP*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)-5.0_DP*SYS_PI**2-2*cos(0.5_DP*SYS_PI*dtime)*SYS_PI) - &
        sin(SYS_PI*dtime)*SYS_PI*cos(SYS_PI*dx) * sin(SYS_PI*dy)
  end function

  elemental real(DP) function fct_stokesZ9_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesZ9_y = -0.25_DP*fct_eigSt9(dx,dy,dtime,dalpha)*(-4.0_DP*sin(0.5_DP*SYS_PI*dtime)+&
        5.0_DP*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)-5.0_DP*SYS_PI**2-2*cos(0.5_DP*SYS_PI*dtime)*SYS_PI) - &
        sin(SYS_PI*dtime)*SYS_PI*sin(SYS_PI*dx) * cos(SYS_PI*dy)
  end function

  elemental real(DP) function fct_stokesZ9_p (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesZ9_p = -0.5_DP*SYS_PI*(sin(0.5_DP*SYS_PI*dtime)*cos(0.5_DP*SYS_PI*dx)*sin(SYS_PI*dy)+&
        2.0_DP*sin(0.5_DP*SYS_PI*dtime)*sin(0.5_DP*SYS_PI*dx)*cos(SYS_PI*dy)-&
        cos(0.5_DP*SYS_PI*dx)*sin(SYS_PI*dy)-2*sin(0.5_DP*SYS_PI*dx)*cos(SYS_PI*dy))
  end function

  elemental real(DP) function fct_stokesF9_x (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesF9_x = 1.25_DP*fct_eigSt9(dx,dy,dtime,dalpha)*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)+&
        0.5_DP*fct_eigSt9(dx,dy,dtime,dalpha)*cos(0.5_DP*SYS_PI*dtime)*SYS_PI+&
        fct_eigSt9(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1)/dalpha + &
        sin(SYS_PI*dtime)*SYS_PI*cos(SYS_PI*dx) * sin(SYS_PI*dy)
  end function

  elemental real(DP) function fct_stokesF9_y (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesF9_y = 1.25_DP*fct_eigSt9(dx,dy,dtime,dalpha)*SYS_PI**2*sin(0.5_DP*SYS_PI*dtime)+&
        0.5_DP*fct_eigSt9(dx,dy,dtime,dalpha)*cos(0.5_DP*SYS_PI*dtime)*SYS_PI+&
        fct_eigSt9(dx,dy,dtime,dalpha)*(sin(0.5_DP*SYS_PI*dtime)-1)/dalpha + &
        sin(SYS_PI*dtime)*SYS_PI*sin(SYS_PI*dx) * cos(SYS_PI*dy)
  end function

  elemental real(DP) function fct_stokesF9_p (dx,dy,dtime,dtimeMin,dtimeMax,dalpha)
  real(DP), intent(in) :: dx,dy,dtime,dtimemin,dtimemax,dalpha
    fct_stokesF9_p = -0.5_DP*SYS_PI*sin(0.5_DP*SYS_PI*dtime)*(cos(0.5_DP*SYS_PI*dx)*sin(SYS_PI*dy)+&
        2*sin(0.5_DP*SYS_PI*dx)*cos(SYS_PI*dy))
  end function

end module


      function shape1(xlow,ylow,xhigh,yhigh,f,x,y)
c-----------------------------------------------------------------------
c       interpolates the function f(x,y) at the point (x,y) within the
c  interior of a rectangular region for which the value of f is known
c  at the corners.  interpolation is by linear serendipity shape
c  functions ala finite elements.  (see zienkiewicz, 'the finite element
c  method in engineering science', page 107 of the second edition)
c
c  arguments-
c
c     (xlow,ylow)-x,y coordinates of lower left corner of element
c     (xhigh,yhigh)-x,y coordinates of upper right hand corner of
c                   element.
c              (note this requires xhigh.gt.xlow and yhigh.gt.ylow)
c     f-four dimensional array of functional values at the corners
c         f(1)=f(xlow,ylow)
c         f(2)=f(xhigh,ylow)
c         f(3)=f(xlow,yhigh)
c         f(4)=f(xhigh,yhigh)
c
c     (x,y)-x,y coordinates at which f is to be evaluated.
c
c  alternate entry point-shape2
c     evaluates f(x,y) using interpolation coefficients calculated in
c     previous call to shape.
c-----------------------------------------------------------------------
      dimension f(4),shapefc(4)
      save shapefc
c--convert to local coordinates
      xzero=(xlow+xhigh)/2.
      yzero=(ylow+yhigh)/2.
      dx=xhigh-xzero
      dy=yhigh-yzero
      zeta=(x-xzero)/dx
      eta=(y-yzero)/dy
c--evaluate shape functions at (x,y) to obtain interpolation
c--coefficients
      shapefc(1)=(1.-zeta)*(1.-eta)/4.
      shapefc(2)=(1.+zeta)*(1.-eta)/4.
      shapefc(3)=(1.-zeta)*(1.+eta)/4.
      shapefc(4)=(1.+zeta)*(1.+eta)/4.
      entry shape2(xlow,ylow,xhigh,yhigh,f,x,y)
      sum=0.
      do 100 i=1,4
          sum=sum+shapefc(i)*f(i)
  100 continue
      shape=sum
      shape2=sum
      return
      end

c $Id$


program inv_test
  use m_util
  integer, dimension(3) :: piv
  real(dp), dimension(3,3) :: A, invA_expected
  real(dp), allocatable :: work(:)
  real(dp) :: invA(3,3), invA_lapack(3,3), lwork_real(1)
  integer lwork

  A = reshape((/ 1.0, 2.0, 3.0, 5.0, 7.0, 9.0, 11.0, -1.0, -0.5 /), shape(A))

  invA_expected(1,:) = (/ -11.0, -203.0, 164.0 /)
  invA_expected(2,:) = (/   4.0,   67.0, -46.0 /)
  invA_expected(3,:) = (/   6.0,  -12.0,   6.0 /)
  invA_expected = invA_expected / 75

  invA_lapack = A
  call dgetrf(3, 3, invA_lapack, 3, piv, info)

  call dgetri(3, invA_lapack, 3, piv, lwork_real, -1, info)
  lwork = nint(lwork_real(1))
  allocate(real(dp) :: work(lwork))
  call dgetri(3, invA_lapack, 3, piv, work, lwork, info)

  invA = A
  call ninv(invA)

  if (maxval(abs(invA - invA_lapack)) > 1D-10) stop 1
  if (maxval(abs(invA - invA_expected)) > 1D-10) stop 2
end program inv_test


      program matmul
      INTEGER SIZE
      PARAMETER (SIZE=100)
      real a(size,size), b(size,size), c(size,size)

      do 100 i = 1, size
         do 100 j = 1, size
            do 100 k = 1, size
               a(i,j) = a(i,j) + b(i,k)*c(k,j)
 100  continue

      end


c  intrinsic-vax-cd.f
c
c Test double complex intrinsics CD*.
c These functions are VAX extensions
c
c     David Billinghurst <David.Billinghurst@riotinto.com>
c
      double complex z, a
      double precision x
      logical fail
      intrinsic cdabs, cdcos, cdexp, cdlog, cdsin, cdsqrt
      common /flags/ fail
      fail = .false.

c     CDABS - Absolute value
      z = (3.0d0,-4.0d0)
      x = 5.0d0
      call c_d(CDABS(z),x,'CDABS(double complex)')
      call p_d_z(CDABS,z,x,'CDABS')

c     CDCOS - Cosine
      z = (3.0d0,1.0d0)
      a = (-1.52763825012d0,-0.165844401919)
      call c_z(CDCOS(z),a,'CDCOS(double complex)')
      call p_z_z(CDCOS,z,a,'CDCOS')

c     CDEXP - Exponential
      z = (3.0d0,1.0d0)
      a = (10.8522619142d0,16.9013965352)
      call c_z(CDEXP(z),a,'CDEXP(double complex)')
      call p_z_z(CDEXP,z,a,'CDEXP')

c     CDLOG - Natural logarithm
      call c_z(CDLOG(a),z,'CDLOG(double complex)')
      call p_z_z(CDLOG,a,z,'CDLOG')

c     CDSIN - Sine
      z = (3.0d0,1.0d0)
      a = (0.217759551622d0,-1.1634403637d0)
      call c_z(CDSIN(z),a,'CDSIN(double complex)')
      call p_z_z(CDSIN,z,a,'CDSIN')

c     CDSQRT - Square root
      z = (0.0d0,-4.0d0)
      a = sqrt(2.0d0)*(1.0d0,-1.0d0)
      call c_z(CDSQRT(z),a,'CDSQRT(double complex)')
      call p_z_z(CDSQRT,z,a,'CDSQRT')

      if ( fail ) call abort()
      end

      subroutine failure(label)
c     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end

      subroutine c_z(a,b,label)
c     Check if DOUBLE COMPLEX a equals b, and fail otherwise
      double complex a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_d(a,b,label)
c     Check if DOUBLE PRECISION a equals b, and fail otherwise
      double precision a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0d-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine p_z_z(f,x,a,label)
c     Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
      double complex f,x,a
      character*(*) label
      call c_z(f(x),a,label)
      end

      subroutine p_d_z(f,x,a,label)
c     Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
      double precision f,x
      double complex a
      character*(*) label
      call c_d(f(x),a,label)
      end


program cylinder

! Calculate the surface area of a cylinder.
!
! Declare variables and constants.
! constants=pi
! variables=radius squared and height

  implicit none    ! Require all variables to be explicitly declared

  integer :: ierr
  character(1) :: yn
  real :: radius, height, area
  real, parameter :: pi = 3.141592653589793

  interactive_loop: do

!   Prompt the user for radius and height
!   and read them.

    write (*,*) 'Enter radius and height.'
    read (*,*,iostat=ierr) radius,height

!   If radius and height could not be read from input,
!   then cycle through the loop.

    if (ierr /= 0) then
      write(*,*) 'Error, invalid input.'
      cycle interactive_loop
    end if

!   Compute area.  The ** means "raise to a power."

    area = 2*pi * (radius**2 + radius*height)

!   Write the input variables (radius, height)
!   and output (area) to the screen.

    write (*,'(1x,a7,f6.2,5x,a7,f6.2,5x,a5,f6.2)') &
      'radius=',radius,'height=',height,'area=',area

    yn = ' '
    yn_loop: do
      write(*,*) 'Perform another calculation? y[n]'
      read(*,'(a1)') yn
      if (yn=='y' .or. yn=='Y') exit yn_loop
      if (yn=='n' .or. yn=='N' .or. yn==' ') exit interactive_loop
    end do yn_loop

  end do interactive_loop

end program cylinder


program ch0706
    ! Voltage from -20 to +20 Volts
    implicit none

    real, dimension(-20:20) :: current
    real :: resistance
    integer :: voltage

    print *, ' type in the resistance'
    read *, resistance
    do voltage = -20, 20
        current(voltage) = voltage/resistance
        print *, voltage, ' ', current(voltage)
    end do
end program


module constants

! Contains the mathematical constant "pi".

use types, only: dp
implicit none
private
public pi

! Contain more digits than double precision, so that
! it is rounded correctly:
real(dp), parameter :: pi   = 3.1415926535897932384626433832795_dp

end module


program tarefa8

    real*16 :: Vd, VA, VB

    ! Definindo o valor de pi
    pi = 4e0*atan(1e0)

    ! Definindo unit para o arquivo de saida da tarefa 8
    open(unit=10, file='saida-8-10407962')

    ! Definindo unit para o arquivo de saida do item A
    open(unit=11, file='saida-8a-10407962')

    ! Definindo unit para o arquivo de saida do item B
    open(unit=12, file='saida-8b-10407962')

    ! Recebe o valor do raio
    print *, 'Digite o raio R:'
    read(*,*) R

    ! Recebe o valor da dimensão
    print *, 'Digite o número de dimensões d:'
    read(*,*) id

    ! loop que para mudar a dimensão de 2 até d
    do i = 2, id

        ! definindo arg e dgamma inicial
        ! aqui está sem as redundancia da tarefa-7
        arg = i/2e0
        dgamma = 1e0

        ! loop que calcula o dgamma
        do while (arg.gt.0e0)
            if (arg.ge.1e0) then
                dgamma = arg*dgamma
                arg = arg-1e0
            else
                dgamma = arg*sqrt(pi)*dgamma
                arg = 0e0
            end if
        end do

        ! calculo do volume d
        Vd = (pi**(i/2e0) * R**i) / dgamma

        ! escreve a dimensão e o volume no arquivo de saida
        write(10,'(I0,", ",F0.6)') i, Vd

        ! calcula e escreve a dimensão e a razão do volume do cudo raio 1 mili e esfera 1 mili
        VA = 1e0/Vd
        write(11, '(I0,", ",F0.6)') i, VA

        ! calcula e escreve a dimensão e a razão do volume do cubo raio 1 micro e esfera 1 angström
        VB = 1e0/(Vd*10e-4**i)
        write(12, '(I0,", ",F0.6)') i, VB

    end do

    ! fecha o arquivo de saida
    close(10)
    close(11)
    close(12)

end program tarefa8


subroutine bisect(fun,xl,xr,x,f,tol)

  implicit none

  ! arguments
  real(8),intent(inout) :: xl       ! left bound
  real(8),intent(inout) :: xr       ! right bound
  real(8),intent(inout) :: x        ! result
  real(8),intent(out)   :: f        ! residual
  real(8),intent(in)    :: tol      ! residual tolerance

  ! function argument
  real(8) :: fun
  external fun

  ! local varaibles
  real(8) :: fl     ! residual for left  bound
  real(8) :: fr     ! resdiual for right bound
  integer :: i      ! loop counter

  ! determine residual bounds
  fl = fun(xl)
  fr = fun(xr)

  ! begin loop
  do i = 1,100

    ! get midpoint
    x = 0.5_8*(xl + xr)

    ! evaluate resdiual at midpoint
    f = fun(x)

    ! check for convergence
    if (abs(f) < tol) exit

    ! reset the bounds
    if (f*fl < dble(0.0)) then

      ! move right bound info to mid
      xr = x
      fr = f

    else

      ! move left bound info to mid
      xl = x
      fl = f

    end if

  end do

end subroutine bisect


module types
  ! should replace .f2py_f2cmap

  implicit none

  ! fortran 2008 specific
  !use, intrinsic :: iso_fortran_env
  !integer, parameter :: sp = REAL32
  !integer, parameter :: dp = REAL64
  !integer, parameter :: qp = REAL128

  integer, parameter :: sp = selected_real_kind(6, 37) ! 32 single
  !integer, parameter :: dp = selected_real_kind(15, 307) ! 64 double
  integer, parameter :: qp = selected_real_kind(33, 4931) ! 128 quadruple

  !machine specific double precision
  integer, parameter :: dp = kind(1.d0)

  real(sp) :: r_sp = 1.0
  real(dp) :: r_dp = 1.0_dp
  real(qp) :: r_qp = 1.0_qp

end module

module precision

  use types ! set type precision

  contains

    subroutine get_integer_precision()
      !implicit none

      integer(sp) :: single
      integer(dp) :: double
      integer(qp) :: quadruple

      print *, "Huge Integer Single Precision"
      print *, huge(single)
      print *, "Huge Integer Double Precision"
      print *, huge(double)
      print *, "Huge Integer Quadruple Precision"
      print *, huge(quadruple)

    end subroutine get_integer_precision

    subroutine get_real_precision()
      !implicit none

      real(sp) :: single
      real(dp) :: double
      real(qp) :: quadruple

      print *, "Huge Real Single Precision"
      print *, huge(single)
      print *, "Huge Real Double Precision"
      print *, huge(double)
      print *, "Huge Real Quadruple Precision"
      print *, huge(quadruple)

      print *, "Tiny Real Single Precision"
      print *, tiny(single)
      print *, "Tiny Real Double Precision"
      print *, tiny(double)
      print *, "Tiny Real Quadruple Precision"
      print *, tiny(quadruple)

    end subroutine get_real_precision

end module


    Program dorgbr_example

!     DORGBR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dbdsqr, dgebrd, dlacpy, dorgbr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ic, ifail, info, lda, ldc, ldu, ldvt, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), c(:, :), d(:), e(:), taup(:), &
        tauq(:), u(:, :), vt(:, :), work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DORGBR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Do ic = 1, 2
        Read (nin, *) m, n
        lda = m
        ldc = n
        ldu = m
        ldvt = n
        lwork = 64*(m+n)
        Allocate (a(lda,n), c(ldc,n), d(n), e(n-1), taup(n), tauq(n), &
          u(ldu,n), vt(ldvt,n), work(lwork))

!       Read A from data file

        Read (nin, *)(a(i,1:n), i=1, m)

!       Reduce A to bidiagonal form
        Call dgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)

        If (m>=n) Then

!         Copy A to VT and U

          Call dlacpy('Upper', n, n, a, lda, vt, ldvt)
          Call dlacpy('Lower', m, n, a, lda, u, ldu)

!         Form P**T explicitly, storing the result in VT
          Call dorgbr('P', n, n, m, vt, ldvt, taup, work, lwork, info)

!         Form Q explicitly, storing the result in U
          Call dorgbr('Q', m, n, n, u, ldu, tauq, work, lwork, info)

!         Compute the SVD of A
          Call dbdsqr('Upper', n, n, m, 0, d, e, vt, ldvt, u, ldu, c, ldc, &
            work, info)

!         Print singular values, left & right singular vectors

          Write (nout, *)
          Write (nout, *) 'Example 1: singular values'
          Write (nout, 100) d(1:n)
          Write (nout, *)
          Flush (nout)

!         ifail: behaviour on error exit
!                =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
          ifail = 0
          Call nagf_file_print_matrix_real_gen('General', ' ', n, n, vt, ldvt, &
            'Example 1: right singular vectors, by row', ifail)

          Write (nout, *)
          Flush (nout)

          Call nagf_file_print_matrix_real_gen('General', ' ', m, n, u, ldu, &
            'Example 1: left singular vectors, by column', ifail)

        Else

!         Copy A to VT and U

          Call dlacpy('Upper', m, n, a, lda, vt, ldvt)
          Call dlacpy('Lower', m, m, a, lda, u, ldu)

!         Form P**T explicitly, storing the result in VT
          Call dorgbr('P', m, n, m, vt, ldvt, taup, work, lwork, info)

!         Form Q explicitly, storing the result in U
          Call dorgbr('Q', m, m, n, u, ldu, tauq, work, lwork, info)

!         Compute the SVD of A
          Call dbdsqr('Lower', m, n, m, 0, d, e, vt, ldvt, u, ldu, c, ldc, &
            work, info)

!         Print singular values, left & right singular vectors

          Write (nout, *)
          Write (nout, *) 'Example 2: singular values'
          Write (nout, 100) d(1:m)
          Write (nout, *)
          Flush (nout)

          ifail = 0
          Call nagf_file_print_matrix_real_gen('General', ' ', m, n, vt, ldvt, &
            'Example 2: right singular vectors, by row', ifail)

          Write (nout, *)
          Flush (nout)

          Call nagf_file_print_matrix_real_gen('General', ' ', m, m, u, ldu, &
            'Example 2: left singular vectors, by column', ifail)

        End If
        Deallocate (a, c, d, e, taup, tauq, u, vt, work)
      End Do

100   Format (3X, (8F8.4))
    End Program


PROGRAM F034

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, DIMENSION(10), PARAMETER :: FACTORIALS = &
    (/ 1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880 /)

    INTEGER :: SUM_VAL = 0

    INTEGER :: I, I_LEN, J, DIGITS_SUM

    CHARACTER (LEN=10) :: I_STR

    DO I = 100, 100000

        WRITE(I_STR, '(I10)') I
        I_STR = ADJUSTL(I_STR)

        I_LEN = LEN_TRIM(I_STR)

        DIGITS_SUM = 0

        DO J = 1, I_LEN
            DIGITS_SUM = DIGITS_SUM &
                       + FACTORIALS(IACHAR(I_STR(J:J))-IACHAR('0')+1)
        END DO

        IF (DIGITS_SUM == I) SUM_VAL = SUM_VAL + I

    END DO

    PRINT ('(I0)'), SUM_VAL

END PROGRAM F034