program main

!*****************************************************************************80
!
!! MAIN is the main program for RANDOM_MPI.
!
!  Discussion:
!
!    This program demonstrates how P processors can generate the same
!    sequence of random numbers as 1 processor.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 May 2008
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    William Gropp, Ewing Lusk, Anthony Skjellum,
!    Using MPI: Portable Parallel Programming with the
!    Message-Passing Interface,
!    Second Edition,
!    MIT Press, 1999,
!    ISBN: 0262571323.
!
  use mpi

  integer ( kind = 4 ) a
  integer ( kind = 4 ) an
  integer ( kind = 4 ) b
  integer ( kind = 4 ) bn
  integer ( kind = 4 ) c
  integer ( kind = 4 ) error
  integer ( kind = 4 ) id
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) p
  integer ( kind = 4 ) u
  integer ( kind = 4 ) v
!
!  Initialize MPI.
!
  call MPI_Init ( error )
!
!  Get the number of processes.
!
  call MPI_Comm_size ( MPI_COMM_WORLD, p, error )
!
!  Get the rank of this processor.
!
  call MPI_Comm_rank ( MPI_COMM_WORLD, id, error )
!
!  Print a message.
!
  if ( id == 0 ) then
    call timestamp ( )
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'RANDOM_MPI - Master process:'
    write ( *, '(a)' ) '  FORTRAN90 version'
    write ( *, '(a,i8)' ) '  The number of processors is P = ', p
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  This program shows how a stream of random numbers'
    write ( *, '(a)' ) '  can be computed "in parallel" in an MPI program.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  We assume we are using a linear congruential'
    write ( *, '(a)' ) '  random number generator or "LCRG", which takes'
    write ( *, '(a)' ) '  an integer input and returns a new integer output:'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '    U = ( A * V + B ) mod C'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  We assume that we want the MPI program to produce'
    write ( *, '(a)' ) '  the same sequence of random values as a sequential'
    write ( *, '(a)' ) '  program would - but we want each processor to compute'
    write ( *, '(a)' ) '  one part of that sequence.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  We do this by computing a new LCRG which can compute'
    write ( *, '(a)' ) '  every P''th entry of the original one.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Our LCRG works with integers, but it is easy to'
    write ( *, '(a)' ) '  turn each integer into a real number between [0,1].'
  end if
!
!  A, B and C define the linear congruential random number generator.
!
  a = 16807
  b = 0
  c = 2147483647

  if ( id == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  LCRG parameters:'
    write ( *, '(a)' ) ' '
    write ( *, '(a,i12)' ) '  A  = ', a
    write ( *, '(a,i12)' ) '  B  = ', b
    write ( *, '(a,i12)' ) '  C  = ', c
  end if

  k_hi = p * 10
!
!  Processor 0 generates 10 * P random values.
!
  if ( id == 0 ) then

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Let processor 0 generate the entire random number sequence.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '     K    ID         Input        Output'
    write ( *, '(a)' ) ' '

    k = 0
    v = 12345
    write ( *, '(2x,i4,2x,i4,2x,12x,2x,i12)' ) k, id, v

    do k = 1, k_hi
      u = v
      call lcrg_evaluate ( a, b, c, u, v )
      write ( *, '(2x,i4,2x,i4,2x,i12,2x,i12)' ) k, id, u, v
    end do

  end if
!
!  Processor P now participates by computing the P-th part of the sequence.
!
  call lcrg_anbn ( a, b, c, p, an, bn )

  if ( id == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  LCRG parameters for P processors:'
    write ( *, '(a)' ) ' '
    write ( *, '(a,i12)' ) '  AN = ', an
    write ( *, '(a,i12)' ) '  BN = ', bn
    write ( *, '(a,i12)' ) '  C  = ', c
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Have ALL the processors participate in computing'
    write ( *, '(a)' ) '  the same random number sequence.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '     K    ID         Input        Output'
    write ( *, '(a)' ) ' '
  end if
!
!  Use the basis LCRG to get the ID-th value in the sequence.
!
  v = 12345
  do j = 1, id
    u = v
    call lcrg_evaluate ( a, b, c, u, v )
  end do
  k = id

  write ( *, '(2x,i4,2x,i4,2x,12x,2x,i12)' ) k, id, v
!
!  Now use the "skipping" LCRG to compute the values with indices
!  ID, ID+P, ID+2P, ...,
!
  do k = id + p, k_hi, p
    u = v
    call lcrg_evaluate ( an, bn, c, u, v )
    write ( *, '(2x,i4,2x,i4,2x,i12,2x,i12)' ) k, id, u, v
  end do
!
!  Terminate MPI.
!
  call MPI_Finalize ( error )
!
!  Terminate.
!
  if ( id == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'RANDOM_MPI - Master process:'
    write ( *, '(a)' ) '  Normal end of execution.'
    write ( *, '(a)' ) ' '
    call timestamp ( )
  end if

  stop
end
subroutine congruence ( a, b, c, ierror, x )

!*****************************************************************************80
!
!! CONGRUENCE solves a congruence of the form ( A * X = C ) mod B.
!
!  Discussion:
!
!    A, B and C are given integers.  The equation is solvable if and only
!    if the greatest common divisor of A and B also divides C.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Eric Weisstein,
!    CRC Concise Encyclopedia of Mathematics,
!    CRC Press, 2002,
!    Second edition,
!    ISBN: 1584883472,
!    LC: QA5.W45.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, B, C, the coefficients of the
!    Diophantine equation.
!
!    Output, integer ( kind = 4 ) IERROR, error flag.
!    0, no error, X was computed.
!    1, A = B = 0, C is nonzero.
!    2, A = 0, B and C nonzero, but C is not a multiple of B.
!    3, A nonzero, B zero, C nonzero, but C is not a multiple of A.
!    4, A, B, C nonzero, but GCD of A and B does not divide C.
!    5, algorithm ran out of internal space.
!
!    Output, integer ( kind = 4 ) X, the solution of the Diophantine equation.
!    X will be between 0 and B-1.
!
  implicit none

  integer ( kind = 4 ), parameter :: nmax = 100

  integer ( kind = 4 ) a
  integer ( kind = 4 ) a_copy
  integer ( kind = 4 ) a_mag
  integer ( kind = 4 ) a_sign
  integer ( kind = 4 ) b
  integer ( kind = 4 ) b_copy
  integer ( kind = 4 ) b_mag
  integer ( kind = 4 ) b_sign
  integer ( kind = 4 ) c
  integer ( kind = 4 ) c_copy
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i4_gcd
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) k
  integer ( kind = 4 ) n
  integer ( kind = 4 ), parameter :: one = 1
  integer ( kind = 4 ) q(nmax)
  logical swap
  integer ( kind = 4 ) x
  integer ( kind = 4 ) y
  integer ( kind = 4 ) z
!
!  Defaults for output parameters.
!
  ierror = 0
  x = 0
  y = 0
!
!  Special cases.
!
  if ( a == 0 .and. b == 0 .and. c == 0 ) then
    x = 0
    return
  else if ( a == 0 .and. b == 0 .and. c /= 0 ) then
    ierror = 1
    x = 0
    return
  else if ( a == 0 .and. b /= 0 .and. c == 0 ) then
    x = 0
    return
  else if ( a == 0 .and. b /= 0 .and. c /= 0 ) then
    x = 0
    if ( mod ( c, b ) /= 0 ) then
      ierror = 2
    end if
    return
  else if ( a /= 0 .and. b == 0 .and. c == 0 ) then
    x = 0
    return
  else if ( a /= 0 .and. b == 0 .and. c /= 0 ) then
    x = c / a
    if ( mod ( c, a ) /= 0 ) then
      ierror = 3
    end if
    return
  else if ( a /= 0 .and. b /= 0 .and. c == 0 ) then
!   g = i4_gcd ( a, b )
!   x = b / g
    x = 0
    return
  end if
!
!  Handle the "general" case: A, B and C are nonzero.
!
!  Step 1: Compute the GCD of A and B, which must also divide C.
!
  g = i4_gcd ( a, b )

  if ( mod ( c, g ) /= 0 ) then
    ierror = 4
    return
  end if

  a_copy = a / g
  b_copy = b / g
  c_copy = c / g
!
!  Step 2: Split A and B into sign and magnitude.
!
  a_mag = abs ( a_copy )
  a_sign = sign ( one, a_copy )
  b_mag = abs ( b_copy )
  b_sign = sign ( one, b_copy )
!
!  Another special case, A_MAG = 1 or B_MAG = 1.
!
  if ( a_mag == 1 ) then
    x = a_sign * c_copy
    return
  else if ( b_mag == 1 ) then
    x = 0
    return
  end if
!
!  Step 3: Produce the Euclidean remainder sequence.
!
  if ( b_mag <= a_mag ) then

    swap = .false.
    q(1) = a_mag
    q(2) = b_mag

  else

    swap = .true.
    q(1) = b_mag
    q(2) = a_mag

  end if

  n = 3

  do

    q(n) = mod ( q(n-2), q(n-1) )

    if ( q(n) == 1 ) then
      exit
    end if

    n = n + 1

    if ( nmax < n ) then
      ierror = 5
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CONGRUENCE - Fatal error!'
      write ( *, '(a)' ) '  Exceeded number of iterations.'
      stop
    end if

  end do
!
!  Step 4: Go backwards to solve X * A_MAG + Y * B_MAG = 1.
!
  y = 0
  do k = n, 2, -1
    x = y
    y = ( 1 - x * q(k-1) ) / q(k)
  end do
!
!  Step 5: Undo the swapping.
!
  if ( swap ) then
    z = x
    x = y
    y = z
  end if
!
!  Step 6: Apply signs to X and Y so that X * A + Y * B = 1.
!
  x = x * a_sign
!
!  Step 7: Multiply by C, so that X * A + Y * B = C.
!
  x = x * c_copy
!
!  Step 8: Force 0 <= X < B.
!
  x = mod ( x, b )
!
!  Step 9: Force positivity.
!
  if ( x < 0 ) then
    x = x + b
  end if

  return
end
function i4_gcd ( i, j )

!*****************************************************************************80
!
!! I4_GCD finds the greatest common divisor of I and J.
!
!  Discussion:
!
!    Only the absolute values of I and J are
!    considered, so that the result is always nonnegative.
!
!    If I or J is 0, I4_GCD is returned as max ( 1, abs ( I ), abs ( J ) ).
!
!    If I and J have no common factor, I4_GCD is returned as 1.
!
!    Otherwise, using the Euclidean algorithm, I4_GCD is the
!    largest common factor of I and J.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer  ( kind = 4 )I, J, two numbers whose greatest common
!    divisor is desired.
!
!    Output, integer  ( kind = 4 )I4_GCD, the greatest common divisor
!    of I and J.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) i4_gcd
  integer ( kind = 4 ) ip
  integer ( kind = 4 ) iq
  integer ( kind = 4 ) ir
  integer ( kind = 4 ) j

  i4_gcd = 1
!
!  Return immediately if either I or J is zero.
!
  if ( i == 0 ) then
    i4_gcd = max ( 1, abs ( j ) )
    return
  else if ( j == 0 ) then
    i4_gcd = max ( 1, abs ( i ) )
    return
  end if
!
!  Set IP to the larger of I and J, IQ to the smaller.
!  This way, we can alter IP and IQ as we go.
!
  ip = max ( abs ( i ), abs ( j ) )
  iq = min ( abs ( i ), abs ( j ) )
!
!  Carry out the Euclidean algorithm.
!
  do

    ir = mod ( ip, iq )

    if ( ir == 0 ) then
      exit
    end if

    ip = iq
    iq = ir

  end do

  i4_gcd = iq

  return
end
subroutine lcrg_anbn ( a, b, c, n, an, bn )

!*****************************************************************************80
!
!! LCRG_ANBN computes the "N-th power" of a linear congruential generator.
!
!  Discussion:
!
!    We are considering a linear congruential random number generator.
!    The LCRG takes as input an integer value called SEED, and returns
!    an updated value of SEED,
!
!      SEED(out) = ( a * SEED(in) + b ) mod c.
!
!    and an associated pseudorandom real value
!
!      U = SEED(out) / c.
!
!    In most cases, a user is content to call the LCRG repeatedly, with
!    the updating of SEED being taken care of automatically.
!
!    The purpose of this routine is to determine the values of AN and BN
!    that describe the LCRG that is equivalent to N applications of the
!    original LCRG.
!
!    One use for such a facility would be to do random number computations
!    in parallel.  If each of N processors is to compute many random values,
!    you can guarantee that they work with distinct random values
!    by starting with a single value of SEED, using the original LCRG to
!    generate the first N-1 "iterates" of SEED, so that you now have N "seed"
!    values, and from now on, applying the N-th power of the LCRG to the seeds.
!
!    If the K-th processor starts from the K-th seed, it will essentially
!    be computing every N-th entry of the original random number sequence,
!    offset by K.  Thus the individual processors will be using a random
!    number stream as good as the original one, and without repeating, and
!    without having to communicate.
!
!    To evaluate the N-th value of SEED directly, we start by ignoring
!    the modular arithmetic, and working out the sequence of calculations
!    as follows:
!
!      SEED(0)   =     SEED.
!      SEED(1)   = a * SEED      + b
!      SEED(2)   = a * SEED(1)   + b = a^2 * SEED           + a * b + b
!      SEED(3)   = a * SEED(2)   + b = a^3 * SEED + a^2 * b + a * b + b
!      ...
!      SEED(N-1) = a * SEED(N-2) + b
!
!      SEED(N) = a * SEED(N-1) + b = a^N * SEED
!                                    + ( a^(n-1) + a^(n-2) + ... + a + 1 ) * b
!
!    or, using the geometric series,
!
!      SEED(N) = a^N * SEED + ( a^N - 1) / ( a - 1 ) * b
!              = AN * SEED + BN
!
!    Thus, from any SEED, we can determine the result of N applications of the
!    original LCRG directly if we can solve
!
!      ( a - 1 ) * BN = ( a^N - 1 ) * b in modular arithmetic,
!
!    and evaluate:
!
!      AN = a^N
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 April 2008
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Barry Wilkinson, Michael Allen,
!    Parallel Programming:
!    Techniques and Applications Using Networked Workstations
!    and Parallel Computers,
!    Prentice Hall,
!    ISBN: 0-13-140563-2,
!    LC: QA76.642.W54.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, the multiplier for the LCRG.
!
!    Input, integer ( kind = 4 ) B, the added value for the LCRG.
!
!    Input, integer ( kind = 4 ) C, the base for the modular arithmetic.
!    For 32 bit arithmetic, this is often 2^31 - 1, or 2147483647.  It is
!    required that 0 < C.
!
!    Input, integer ( kind = 4 ) N, the "index", or number of times that the
!    LCRG is to be applied.  It is required that 0 <= N.
!
!    Output, integer ( kind = 4 ) AN, BN, the multiplier and added value for
!    the LCRG that represent N applications of the original LCRG.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ) am1
  integer ( kind = 4 ) an
  integer ( kind = 4 ) anm1tb
  integer ( kind = 4 ) b
  integer ( kind = 4 ) bn
  integer ( kind = 4 ) c
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) n

  if ( n < 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'LCRG_ANBN - Fatal error!'
    write ( *, '(a,i12)' ) '  Illegal input value of N = ', n
    stop
  end if

  if ( c <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'LCRG_ANBN - Fatal error!'
    write ( *, '(a,i12)' ) '  Illegal input value of C = ', c
    stop
  end if

  if ( n == 0 ) then
    an = 1
    bn = 0
  else if ( n == 1 ) then
    an = a
    bn = b
  else
!
!  Compute A^N.
!
    call power_mod ( a, n, c, an )
!
!  Solve
!    ( a - 1 ) * BN = ( a^N - 1 ) mod B
!  for BN.
!
    am1 = a - 1
    anm1tb = ( an - 1 ) * b

    call congruence ( am1, c, anm1tb, ierror, bn )

    if ( ierror /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'LCRG_ANBN - Fatal error!'
      write ( *, '(a)' ) '  An error occurred in the CONGRUENCE routine.'
      write ( *, '(a,i8)' ) '  The error code was IERROR = ', ierror
      stop
    end if

  end if

  return
end
subroutine lcrg_evaluate ( a, b, c, x, y )

!*****************************************************************************80
!
!! LCRG_EVALUATE evaluates an LCRG, y = ( A * x + B ) mod C.
!
!  Discussion:
!
!    This routine cannot be recommended for production use.  Because we want
!    to do modular arithmetic, but the base is not a power of 2, we need to
!    use "double precision" integers to keep accuracy.
!
!    If we knew the base C, we could try to avoid overflow while not changing
!    precision.
!
!    If the base C was a power of 2, we could rely on the usual properties of
!    integer arithmetic on computers, in which overflow bits, which are always
!    ignored, don't actually matter.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 April 2008
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, the multiplier for the LCRG.
!
!    Input, integer ( kind = 4 ) B, the added value for the LCRG.
!
!    Input, integer ( kind = 4 ) C, the base for the modular arithmetic.
!    For 32 bit arithmetic, this is often 2^31 - 1, or 2147483647.  It is
!    required that 0 < C.
!
!    Input, integer ( kind = 4 ) X, the value to be processed.
!
!    Output, integer ( kind = 4 ) Y, the processed value.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 8 ) a8
  integer ( kind = 4 ) b
  integer ( kind = 8 ) b8
  integer ( kind = 4 ) c
  integer ( kind = 8 ) c8
  integer ( kind = 4 ) x
  integer ( kind = 8 ) x8
  integer ( kind = 4 ) y
  integer ( kind = 8 ) y8
!
!  To avoid roundoff issues, we need to go to "double precision" integers.
!  (Not available on all planets.)
!
  a8 = a
  b8 = b
  c8 = c
  x8 = x

  y8 = mod ( a8 * x8 + b8, c8 )

  y = int ( y8, kind = 4 )

  if ( y < 0 ) then
    y = y + c
  end if

  return
end
subroutine power_mod ( a, n, m, x )

!*****************************************************************************80
!
!! POWER_MOD computes ( A^N ) mod M.
!
!  Discussion:
!
!    Some programming tricks are used to speed up the computation, and to
!    allow computations in which the value A**N is much too large to
!    store in an integer word.
!
!    First, for efficiency, the power A**N is computed by determining
!    the binary expansion of N, then computing A, A**2, A**4, and so on
!    by repeated squaring, and multiplying only those factors that
!    contribute to A**N.
!
!    Secondly, the intermediate products are immediately "mod'ed", which
!    keeps them small.
!
!    For instance, to compute ( A^13 ) mod 11, we essentially compute
!
!       13 = 1 + 4 + 8
!
!       A^13 = A * A^4 * A^8
!
!       A^13 ( mod 11 ) = A ( mod 11 ) * A^4 ( mod 11 ) * A^8 ( mod 11 ).
!
!    Fermat's little theorem says that if P is prime, and A is not divisible
!    by P, then ( A^(P-1) - 1 ) is divisible by P.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 May 2008
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, the base of the expression to be tested.
!    0 <= A is required.
!
!    Input, integer ( kind = 4 ) N, the power to which the base is raised.
!    0 <= N is required.
!
!    Input, integer ( kind = 4 ) M, the divisor against which the expression
!    is tested.  0 < M is required.
!
!    Output, integer ( kind = 4 ) X, the remainder when A^N is divided by M.
!    If any input quantity is unacceptable, then the nonsensical value
!    X = -1 is returned.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 8 ) a_square2
  integer ( kind = 4 ) d
  integer ( kind = 4 ) m
  integer ( kind = 8 ) m2
  integer ( kind = 4 ) n
  integer ( kind = 4 ) ncopy
  integer ( kind = 4 ), parameter :: two = 2
  integer ( kind = 4 ) x
  integer ( kind = 8 ) x2

  if ( a < 0 ) then
    x = -1
    return
  end if

  if ( m <= 0 ) then
    x = -1
    return
  end if

  if ( n < 0 ) then
    x = -1
    return
  end if
!
!  A_SQUARE contains the successive squares of A.
!
  a_square2 =  int ( a, kind = 8 )
  x2 = int ( 1, kind = 8 )
  m2 = int ( m, kind = 8 )

  ncopy = n

  do while ( 0 < ncopy )

    d = mod ( ncopy, two )

    if ( d == 1 ) then
      x2 = mod ( x2 * a_square2, m2 )
    end if

    a_square2 = mod ( a_square2 * a_square2, m2 )
    ncopy = ( ncopy - d ) / 2

  end do
!
!  Fix up X so that it is nonnegative.
!
  do while ( x2 < 0 )
    x2 = x2 + m2
  end do

  x = int ( x2 )

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


      DOUBLE PRECISION FUNCTION DT_SAMPLW(Xmin,Xmax,B)

C***********************************************************************
C Sampling from f(x)=1/x^b between x_min and x_max.                    *
C S. Roesler, 18.4.98                                                  *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION B , DT_RNDM , ONE , onemb , r , Xmax , Xmin
      SAVE
      PARAMETER (ONE=1.0D0)

      r = DT_RNDM(B)
      IF ( B.EQ.ONE ) THEN
         DT_SAMPLW = EXP(r*LOG(Xmax)+(ONE-r)*LOG(Xmin))
      ELSE
         onemb = ONE - B
         DT_SAMPLW = (r*Xmax**onemb+(ONE-r)*Xmin**onemb)**(ONE/onemb)
      END IF

      END FUNCTION


module window_statistics
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    private
    type, public :: window_stats_type
        private
        real(kind=dp), dimension(:), allocatable :: window
        integer :: nr_value = 0
        integer :: curr_pos = 1
    contains
        procedure, public :: init
        procedure, public :: add_data
        procedure, public :: mean
        procedure, public :: stddev
    end type window_stats_type

contains

    subroutine init(window_stats, n)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(window_stats_type), intent(inout) :: window_stats
        integer, value :: n
        integer :: istat
        allocate(window_stats%window(n), stat=istat)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(A)') &
                '# error: can not allocate memory'
            stop 1
        end if
        window_stats%window = 0.0_dp
    end subroutine init

    subroutine add_data(window_stats, value)
        implicit none
        class(window_stats_type), intent(inout) :: window_stats
        real(kind=dp), value :: value
        window_stats%window(window_stats%curr_pos) = value
        if (window_stats%nr_value < size(window_stats%window)) &
            window_stats%nr_value = window_stats%nr_value + 1
        if (window_stats%curr_pos < size(window_stats%window)) then
            window_stats%curr_pos = window_stats%curr_pos + 1
        else
            window_stats%curr_pos = 1
        end if
    end subroutine add_data

    function mean(window_stats) result(mean_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(window_stats_type), intent(in) :: window_stats
        real(kind=dp) :: mean_value
        if (window_stats%nr_value == 0) then
            write (unit=error_unit, fmt='(A)') '# error: no data'
            stop 2
        else
            mean_value = sum(window_stats%window)/window_stats%nr_value
        end if
    end function mean

    function stddev(window_stats) result(stddev_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(window_stats_type), intent(in) :: window_stats
        real(kind=dp) :: stddev_value
        real(kind=dp) :: mean_value
        if (window_stats%nr_value < 2) then
            write (unit=error_unit, fmt='(A)') '# error: not enough data'
            stop 2
        else
            mean_value = window_stats%mean()
            stddev_value = sqrt(sum(window_stats%window**2)/window_stats%nr_value - &
                                mean_value**2)
        end if
    end function stddev

end module window_statistics


C$Procedure      NPLNPT ( Nearest point on line to point )

      SUBROUTINE NPLNPT ( LINPT, LINDIR, POINT, PNEAR, DIST )

C$ Abstract
C
C     Find the nearest point on a line to a specified point, and find
C     the distance between the two points.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      LINPT  ( 3 )
      DOUBLE PRECISION      LINDIR ( 3 )
      DOUBLE PRECISION      POINT  ( 3 )

      DOUBLE PRECISION      PNEAR  ( 3 )
      DOUBLE PRECISION      DIST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     LINPT,
C     LINDIR     I   Point on a line and the line's direction vector.
C     POINT      I   A second point.
C     PNEAR      O   Nearest point on the line to POINT.
C     DIST       O   Distance between POINT and PNEAR.
C
C$ Detailed_Input
C
C     LINPT
C     LINDIR         are, respectively, a point and a direction vector
C                    that define a line in 3-dimensional space.  The
C                    line is the set of points
C
C                       LINPT   +   t * LINDIR
C
C                    where t is any real number.
C
C     POINT          is a point in 3-dimensional space.
C
C$ Detailed_Output
C
C     PNEAR          is the nearest point on the input line to the input
C                    point.
C
C     DIST           is the distance between the input line and input
C                    point.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the line direction vector LINDIR is the zero vector, the
C         error SPICE(ZEROVECTOR) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     For every line L and point P, there is a unique closest point
C     on L to P.  Call this closest point C.  It is always true that
C     P - C  is perpendicular to L, and the length of P - C is called
C     the `distance' between P and L.
C
C$ Examples
C
C     1)  Suppose a line passes through the point ( 1, 2, 3 ) and
C         has direction vector ( 0, 1, 1 ).  We wish to find the
C         closest point on the line to the point ( -6, 9, 10 ).  We
C         can use the code fragment
C
C            LINPT(1)   =  1.D0
C            LINPT(2)   =  2.D0
C            LINPT(3)   =  3.D0
C
C            LINDIR(1)  =  0.D0
C            LINDIR(2)  =  1.D0
C            LINDIR(3)  =  1.D0
C
C            POINT(1)   = -6.D0
C            POINT(2)   =  9.D0
C            POINT(3)   = 10.D0
C
C            CALL NPLNPT ( LINPT, LINDIR, POINT, PNEAR, DIST )
C
C         After the call, PNEAR will take the value
C
C            ( 1.D0, 9.D0, 10.D0 );
C
C         DIST will be 7.0.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 17-SEP-2014 (NJB)
C
C        Now uses discovery check-in.
C
C-    SPICELIB Version 1.1.0, 09-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VADD call.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     distance between point and line
C     nearest point on line to point
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 09-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VADD call.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDIST

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local variables
C
      DOUBLE PRECISION      PROJ  ( 3 )
      DOUBLE PRECISION      TRANS ( 3 )

C
C     Use discovery check-in.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

C
C     We need a real direction vector to work with.
C
      IF (  VZERO (LINDIR)  )  THEN

         CALL CHKIN  ( 'NPLNPT'                             )
         CALL SETMSG ( 'Direction vector must be non-zero.' )
         CALL SIGERR ( 'SPICE(ZEROVECTOR)'                  )
         CALL CHKOUT ( 'NPLNPT'                             )
         RETURN

      END IF

C
C     We translate line and input point so as to put the line through
C     the origin.  Then the nearest point on the translated line to the
C     translated point TRANS is the projection of TRANS onto the line.
C
      CALL VSUB  ( POINT,  LINPT,  TRANS )
      CALL VPROJ ( TRANS,  LINDIR, PROJ  )
      CALL VADD  ( PROJ,   LINPT,  PNEAR )

      DIST = VDIST ( PNEAR,  POINT )

      RETURN
      END


module mod_average

  implicit none

  private
  public :: average

contains

  pure real function average(x) result(res)
   real, intent(in) :: x(:)
   res = sum(x) / size(x)
  end function average

end module mod_average

program test_average
  use mod_average, only: average
  print *, average([1, 6, 4])
end program test_average


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program uses MPI to do a parallel monte carlo calculation of pi
	!
	! .. Parameters ..
	!  npts				= total number of Monte Carlo points
	!  xmin				= lower bound for integration region
	!  xmax             = upper bound for integration region
	! .. Scalars ..
	!  mynpts			= this processes number of Monte Carlo points
	!  myid				= process id
	!  nprocs			= total number of MPI processes
	!  ierr				= error code
	!  i                = loop counter
	!  f				= average value from summation
	!  sum              = total sum
	!  mysum            = sum on this process
	!  randnum          = random number generated from (0,1) uniform
	!                     distribution
	!  x                = current Monte Carlo location
	!  start			= simulation start time
	!  finish			= simulation end time
	! .. Arrays ..
	!
	! .. Vectors ..
	!
	! REFERENCES
	! http://chpc.wustl.edu/mpi-fortran.html
	! Gropp, Lusk and Skjellum, "Using MPI" MIT press (1999)
	!
	! ACKNOWLEDGEMENTS
	! The program below was modified from one available at the internet
	! address in the references. This internet address was last checked
	! on 30 March 2012
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	!
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! MPI library
    PROGRAM monte_carlo_mpi
    USE MPI
    IMPLICIT NONE

    INTEGER(kind=8), PARAMETER 	:: npts = 1e10
    REAL(kind=8), PARAMETER 	:: xmin=0.0d0,xmax=1.0d0
    INTEGER(kind=8) 			:: mynpts
    INTEGER(kind=4) 	        :: ierr, myid, nprocs
    INTEGER(kind=8) 	        :: i
    REAL(kind=8) 		        :: f,sum,mysum,randnum
    REAL(kind=8) 		        :: x, start, finish

    ! Initialize MPI
    CALL MPI_INIT(ierr)
    CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
    CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
    start=MPI_WTIME()

	! Calculate the number of points each MPI process needs to generate
    IF (myid .eq. 0) THEN
      mynpts = npts - (nprocs-1)*(npts/nprocs)
    ELSE
      mynpts = npts/nprocs
    ENDIF

    ! set initial sum to zero
    mysum = 0.0d0
	! use loop on local process to generate portion of Monte Carlo integral
    DO i=1,mynpts
      CALL random_number(randnum)
      x = (xmax-xmin)*randnum + xmin
      mysum = mysum + 4.0d0/(1.0d0 + x**2)
    ENDDO

	! Do a reduction and sum the results from all processes
    CALL MPI_REDUCE(mysum,sum,1,MPI_DOUBLE_PRECISION,MPI_SUM,&
          0,MPI_COMM_WORLD,ierr)
    finish=MPI_WTIME()

    ! Get one process to output the result and running time
    IF (myid .eq. 0) THEN
         f = sum/npts
         PRINT*,'PI calculated with ',npts,' points = ',f
         PRINT*,'Program took ', finish-start, ' for Time stepping'
    ENDIF

    CALL MPI_FINALIZE(ierr)

    STOP
    END PROGRAM


! { dg-do run }
! PR 25806: Functions returning pointers to arrays
program a
    integer, target :: storage(5)
    integer :: s(3)

    print *, x(3)  ! { dg-output " *1  *2  *3" }

    if (ssum(x(3)) /= 6) call abort()

    s = 0
    s = x(3)
    if (any(s /= (/1, 2, 3/))) call abort()

contains

    function x(n) result(t)
        integer, intent(in) :: n
        integer, pointer :: t(:)
        integer :: i

        t => storage(1:n)
        t = (/ (i, i = 1, n) /)

    end function x

    integer function ssum(a)
        integer, intent(in) :: a(:)

        ssum = sum(a)

    end function ssum

end program a


! Program to test passing intrinsic functions as actual arguments for
! dummy procedures.
subroutine test (proc)
   implicit none
   real proc
   real a, b, c

   a = 1.0
   b = sin (a)
   c = proc (a)

   if (abs (b - c) .gt. 0.001) call abort

end subroutine

program dummy
   implicit none
   external test
   intrinsic sin

   call test (sin)
end program


program tsunami

  ! Tsunami simulator.
  !
  ! Solves the non-linear 2-d shallow water equation system:
  !
  !     du/dt + u du/dx + v du/dy + g dh/dx = 0
  !     dv/dt + u dv/dx + v dv/dy + g dh/dy = 0
  !     dh/dt + d(hu)/dx + d(hv)/dy = 0
  !
  ! This version is parallelized, and uses derived types.

  use iso_fortran_env, only: int32, real32
  use mod_field, only: Field, diffx, diffy

  implicit none

  integer(int32) :: n

  integer(int32), parameter :: im = 101 ! grid size in x
  integer(int32), parameter :: jm = 101 ! grid size in y
  integer(int32), parameter :: num_time_steps = 1000 ! number of time steps

  real(real32), parameter :: dt = 0.02 ! time step [s]
  real(real32), parameter :: dx = 1 ! grid spacing [m]
  real(real32), parameter :: dy = 1 ! grid spacing [m]
  real(real32), parameter :: g = 9.8 ! gravitational acceleration [m/s]

  integer(int32), parameter :: ic = 51, jc = 51
  real(real32), parameter :: decay = 0.02

  type(Field) :: h, u, v, hm

  if (this_image() == 1) print *, 'Tsunami started'

  u = Field('u', [im, jm])
  v = Field('v', [im, jm])
  h = Field('h', [im, jm])
  hm = Field('hm', [im, jm])

  ! initialize a gaussian blob in the center
  call h % set_gaussian(decay, ic, jc)
  call h % sync_edges()

  ! set mean water depth
  hm = 10.

  call h % write(0)

  time_loop: do n = 1, num_time_steps

    if (this_image() == 1) then
      print *, 'Computing time step', n, '/', num_time_steps
    end if

    ! compute u at next time step
    u = u - (u * diffx(u) / dx + v * diffy(u) / dy &
      + g * diffx(h) / dx) * dt
    call u % sync_edges()

    ! compute v at next time step
    v = v - (u * diffx(v) / dx + v * diffy(v) / dy &
      + g * diffy(h) / dy) * dt
    call v % sync_edges()

    ! compute h at next time step
    h = h - (diffx(u * (hm + h)) / dx + diffy(v * (hm + h)) / dy) * dt
    call h % sync_edges()

    call h % write(n)

  end do time_loop

end program tsunami


! (D) LEAST-DISTANCE QUADRATIC PROGRAMMING
!
! (SUBPROGRAMS INVOLVED:  WOLFE, ILOC, CONENR, HOUSE, DOTPRD,
! REFWL)
!
! GIVEN POSITIVE INTEGERS M AND N, AND A MATRIX PMAT, THIS PROGRAM WILL
! ATTEMPT TO LOCATE AN N-DIMENSIONAL POINT WPT IN THE POLYHEDRON
! DETERMINED BY THE INEQUALITIES
! PMAT(1,J)*WPT(1)+...+PMAT(N,J)*WPT(N)+PMAT(N+1,J) .LE. 0.0 FOR J=1,...,M
! WHOSE DISTANCE WDIST FROM THE ORIGIN IS MINIMIZED.  ON OUTPUT, JFLAG
! WILL BE AN ERROR FLAG WHOSE VALUE WILL BE 0 FOR A NORMAL SOLUTION AND
! POSITIVE FOR A LIKELY FAILURE.  THE METHOD IS AN ENHANCED VERSION OF
! THAT IN
! WOLFE, PHILIP, FINDING THE NEAREST POINT IN A POLYTOPE, MATHEMATICAL
! PROGRAMMING 11 (1976), 128-149.
! THE FOLLOWING SAMPLE DRIVER IS SET UP TO FIND THE NEAREST POINT TO
! THE ORIGIN IN THE POLYHEDRON DEFINED BY X + Y + Z .GE. 2.0D0 (I.E.
! -X - Y - Z + 2.0D0 .LE. 0.0D0) AND Z .GE. 1.0D0 (I.E. -Z + 1.0D0 .LE.
! 0.0D0).  (THE EXACT SOLUTION IS (X,Y,Z) = (0.5D0,0.5D0,1.0D0) WITH
! DISTANCE SQRT(1.5D0) FROM THE ORIGIN.)
!
! SAMPLE DRIVER FOR (D) LEAST-DISTANCE QUADRATIC PROGRAMMING
!
! THE MINIMUM DIMENSIONS ARE PMAT(NPARM+1,NUMGR), PMAT1(NPARM+1,NUMGR),
! WPT(NPARM), ICOR(NPARM+1), R(NPARM+1), PTNR(NPARM+1), COEF(NUMGR),
! WCOEF(NUMGR), IWORK(4*NUMGR+5*NPARM+3), WORK(2*NPARM**2+4*NUMGR*NPARM
! +9*NUMGR+22*NPARM+10), WHERE NPARM .GE. N AND NUMGR .GE. M.  THE FIRST
! DIMENSIONS OF PMAT AND PMAT1 MUST BE EXACTLY NPARM+1.

program main

    use conmax_module
    use iso_fortran_env, only: wp => real64

    IMPLICIT NONE

    real(wp) :: coef(2), pmat(4, 2), pmat1(4, 2), ptnr(4), r(4), s, &
                wcoef(2), wdist, work(136), wpt(3)
    INTEGER :: i, icor(4), iwork(26), j, jflag, liwrk, lwrk, m, mp1, &
               n, ncor, nmaj, nmin, np1, nparm, numgr

    n = 3
    m = 2
    pmat(1, 1) = -1.0_wp
    pmat(2, 1) = -1.0_wp
    pmat(3, 1) = -1.0_wp
    pmat(4, 1) = 2.0_wp
    pmat(1, 2) = 0.0_wp
    pmat(2, 2) = 0.0_wp
    pmat(3, 2) = -1.0_wp
    pmat(4, 2) = 1.0_wp
    nparm = n
    numgr = m
    liwrk = 4*numgr + 5*nparm + 3
    lwrk = 2*nparm**2 + 4*numgr*nparm + 9*numgr + 22*nparm + 10
    mp1 = m + 1
    np1 = n + 1

    !OPEN (6,FILE='QPOUT')
    WRITE (6, 99001) m, n
99001 FORMAT(/' THERE ARE', I5, '  BOUNDARIES AND', I5, '  DIMENSIONS'// &
              ' THE BOUNDARY COEFFICIENTS ARE')
    DO j = 1, m
        WRITE (6, 99002) (pmat(i, j), i=1, np1)
99002   FORMAT(/(3E22.13))
    END DO
    CALL WOLFE(n, m, pmat, 0, s, ncor, icor, iwork, liwrk, work, lwrk, r, coef, &
               ptnr, pmat1, nparm, numgr, wcoef, wpt, wdist, nmaj, nmin, jflag)
    WRITE (6, 99003) jflag, wdist, (wpt(i), i=1, n)
99003 FORMAT(/' AFTER WOLFE THE ERROR FLAG IS', &
         &I4//' THE DISTANCE FROM THE ORIGIN IS', &
         &E22.13//' THE POINT HAS COORDINATES'//(3E22.13))

END

! OUTPUT FOR (D) LEAST-DISTANCE QUADRATIC PROGRAMMING
!
! THERE ARE    2  BOUNDARIES AND    3  DIMENSIONS
!
! THE BOUNDARY COEFFICIENTS ARE
!
!  -0.1000000000000E+01  -0.1000000000000E+01  -0.1000000000000E+01
!   0.2000000000000E+01
!
!   0.0000000000000E+00   0.0000000000000E+00  -0.1000000000000E+01
!   0.1000000000000E+01
!
! AFTER WOLFE THE ERROR FLAG IS   0
!
! THE DISTANCE FROM THE ORIGIN IS   0.1224744871392E+01
!
! THE POINT HAS COORDINATES
!
!   0.5000000000000E+00   0.5000000000000E+00   0.1000000000000E+01
!


      SUBROUTINE SB08MY( DA, A, B, EPSB )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients of B(s) = A(s) * A(-s) and a norm
C     for the accuracy of the computed coefficients.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DA      (input) INTEGER
C             The degree of the polynomials A(s) and B(s).  DA >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (DA+1)
C             This array must contain the coefficients of the polynomial
C             A(s) in increasing powers of s.
C
C     B       (output) DOUBLE PRECISION array, dimension (DA+1)
C             This array contains the coefficients of the polynomial
C             B(s) in increasing powers of s**2.
C
C     EPSB    (input/output) DOUBLE PRECISION
C             On entry, EPSB must contain the machine precision (see
C             LAPACK Library routine DLAMCH).
C             On exit, EPSB contains an updated value, using a norm
C             for the accuracy of the computed coefficients.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB08AZ by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Laplace transform, polynomial operations, spectral factorization.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, THREE
      PARAMETER         ( ZERO  = 0.0D0, ONE = 1.0D0, TWO=2.0D0,
     $                    THREE = 3.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DA
      DOUBLE PRECISION  EPSB
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
C     .. Local Scalars ..
      INTEGER           I, K
      DOUBLE PRECISION  MAXSA, SA, SABS, SIGNI, SIGNK, TERM
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN
C     .. Executable Statements ..
C
      SIGNI = ONE
      MAXSA = ZERO
C
      DO 40 I = 0, DA
         SABS = A(I+1)**2
         SA = SIGNI*SABS
         SIGNK = -TWO*SIGNI
C
         DO 20 K = 1, MIN( I, DA - I )
            TERM = SIGNK*A(I-K+1)*A(I+K+1)
            SA = SA + TERM
            SABS = SABS + ABS( TERM )
            SIGNK = -SIGNK
   20    CONTINUE
C
         B(I+1) = SA
         MAXSA = MAX( MAXSA, SABS )
         SIGNI = -SIGNI
   40 CONTINUE
C
      EPSB = THREE*MAXSA*EPSB
C
      RETURN
C *** Last line of SB08MY ***
      END


!
!
!
!
 SUBROUTINE HARMO_Y_TT (LMAX, LON, LAT, Y_TT)
 USE SHTOOLS
 IMPLICIT NONE
 INTEGER, PARAMETER :: LLMAX=512, JJMAX=(LLMAX+1)*(LLMAX+2)/2
 INTEGER J, MJ, LJ, J_INDEX, LMAX
 COMPLEX*16 Y_TT(*)
 REAL*8 LON, LAT
 REAL*8, ALLOCATABLE :: DPLM(:)
 REAL*8, ALLOCATABLE :: PLM(:)
 REAL*8 COSDD, SINDD
 INTEGER :: JMAX
!
!
! Given longitude LON and latitude LAT  - in degrees - this routine computes
! the theta-component of the gradient of *all* the 4-pi normalized complex
! harmonics $\cal Y_{lm}(\theta,\lambda)$, with \theta=colatitude and \lambda=
! longitude, to degree LMAX. This subroutine uses the (modified) SHTOOLS Legendre
! functions by PlmBar (see Sbr PLMBAR_MOD). - Created by GS August 8, 2008 -
!
! CREATED by GS on MAY 1, 2020. The program computes y_tt
!
! - Modified by GS Apr 2020 -- dynamically allocate DPLM
!
!**********************************************************
!   Modified GS on MAy 1, 2020
!
!   The routine computes "y_tt = d/dtheta d/dtheta y"
!**********************************************************
!
!
! ---- Tests the longitude and latitude bounds
  If(abs(lat)>90.) then
 	        Write(* ,*) "Error in Sbr. GRAD_THETA_HARMO: Latitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 1
  elseif (lon<0.or.lon>360.) then
 	        Write(* ,*) "Error in Sbr. GRAD_THETA_HARMO: Longitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 2
  Endif
!
!
!
! ---- Allocate temporary arrays
!
   JMAX=(LMAX+1)*(LMAX+2)/2
   ALLOCATE( DPLM(JMAX) )
   ALLOCATE( PLM (JMAX) )
!
! ---- Builds the SHTOOLS Legendre functions, with Condon-Shortley phase
!
   CALL PLMBAR_MOD    (LMAX, LAT,  PLM)
   CALL PLMBAR_MOD_D1 (LMAX, LAT, DPLM)
!
!
! ---- Computes the 4-pi normalized Spherical Harmonics up to degree LMAX
!
    		do j=1, j_index(lmax,lmax)
!
       			y_tt(j) = &
!
                        (         &
			- (cosdd(90.-LAT)/sindd(90.-LAT))*dplm(j) &
			+ (float(mj(j)**2)/sindd(90.-LAT)/sindd(90.-LAT) - lj(j)*(lj(j)+1))*plm(j) &
			) * &
			cmplx(cosdd(float(mj(j))*lon),sindd(float(mj(j))*lon))
!
    		enddo
!
!
! ---- Release memory
!
    DEALLOCATE( DPLM )
    DEALLOCATE(  PLM )
!
END SUBROUTINE HARMO_Y_TT
!
!
!
!
!


!/////////////////////////////////////////////////////////////////////////
!//
!// MPI example program in FORTRAN 90
!//
!/////////////////////////////////////////////////////////////////////////

PROGRAM pi
   IMPLICIT NONE
   INCLUDE "mpif.h"

   INTEGER                                  :: psize    ! Number of procs
   INTEGER                                  :: my_rank  ! This process
   INTEGER                                  :: i        ! Index
   INTEGER                                  :: n = 1000 ! Used as constant
   INTEGER                                  :: rstat    ! Status variable
   INTEGER,DIMENSION(MPI_STATUS_SIZE)       :: status   ! MPI status

   DOUBLE PRECISION                         :: l_sum
   DOUBLE PRECISION                         :: g_sum
   DOUBLE PRECISION                         :: x
   DOUBLE PRECISION                         :: h

   CHARACTER (LEN=80)                       :: str      ! Text string

   !// Initialize MPI
   CALL MPI_Init(rstat)

   !// Get number of procs
   CALL MPI_Comm_size(MPI_COMM_WORLD, psize, rstat)

   !// Get process number for this process
   CALL MPI_Comm_rank(MPI_COMM_WORLD, my_rank, rstat)

   !// Fortran has no default command line args into
   !// a process. Using fixed size of n

   CALL MPI_Bcast(n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, rstat)

   h = 1.0/n
   l_sum = 0.

   DO i = my_rank, n
      x = (i+0.5)*h
      l_sum = l_sum + 4.0/(1.0+x*x)
   END DO

   l_sum = l_sum + h

   IF (my_rank == 0) THEN
      g_sum = l_sum
      DO i = 1, psize - 1
         CALL MPI_Recv(l_sum, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE, 500, &
                       MPI_COMM_WORLD, status, rstat)
         g_sum = g_sum + l_sum
      END DO
      PRINT *, 'Result = ', g_sum
   ELSE
      CALL MPI_Send(l_sum, 1, MPI_DOUBLE_PRECISION, 0, 500, MPI_COMM_WORLD)
   END IF

   CALL MPI_Finalize(rstat)

END PROGRAM pi


program test
  integer :: a(10, 10), b(10,10), c(10, 10)
  integer:: i = 1,j =1

  do i = 1,10
    do j = 1,10
      a(j,i) = i
      b(j,i) = j
    end do
  end do

  do i = 1,10
    do j = 1,10,1
      c(j,i) = a(j,i) + b(j,i)
    end do
  end do

  print *, c
end program test


module m_util
  contains

  function circle_area(radius)
    implicit none

    real(8) :: radius
    real(8) :: circle_area

    circle_area = PI * radius * radius

  end function circle_area
end module m_util


! $UWHPSC/codes/fortran/builtinfcns2.f90

program builtinfcns

    implicit none
    real :: pi, x, y    ! note kind is not specified

    ! compute pi as arc-cosine of -1:
    pi = acos(-1.0)

    x = cos(pi)
    y = sqrt(exp(log(pi)))**2

    print *, "pi = ", pi
    print *, "x = ", x
    print *, "y = ", y

end program builtinfcns


FUNCTION studnt (t, doff) RESULT(fn_val)

! N.B. Argument IFAULT has been removed.

! Code converted using TO_F90 by Alan Miller
! Date: 2002-01-02  Time: 21:19:45

!     ALGORITHM AS 27  APPL. STATIST. VOL.19, NO.1

!     Calculate the upper tail area under Student's t-distribution

!     Translated from Algol by Alan Miller

IMPLICIT NONE
REAL, INTENT(IN)      :: t
REAL, INTENT(IN)      :: doff
REAL                  :: fn_val

!     Local variables

REAL     :: v, x, tt
LOGICAL  :: pos
REAL, PARAMETER  :: four = 4.0, one = 1.0, zero = 0.0, half = 0.5
REAL, PARAMETER  :: a1 = 0.09979441, a2 = -0.581821, a3 = 1.390993,  &
                    a4 = -1.222452, a5 = 2.151185
REAL, PARAMETER  :: b1 = 5.537409, b2 = 11.42343
REAL, PARAMETER  :: c1 = 0.04431742, c2 = -0.2206018, c3 = -0.03317253,  &
                    c4 = 5.679969, c5 = -12.96519
REAL, PARAMETER  :: d1 = 5.166733, d2 = 13.49862
REAL, PARAMETER  :: e1 = 0.009694901, e2 = -0.1408854, e3 = 1.88993,  &
                    e4 = -12.75532, e5 = 25.77532
REAL, PARAMETER  :: f1 = 4.233736, f2 = 14.3963
REAL, PARAMETER  :: g1 = -9.187228E-5, g2 = 0.03789901, g3 = -1.280346,  &
                    g4 = 9.249528, g5 = -19.08115
REAL, PARAMETER  :: h1 = 2.777816, h2 = 16.46132
REAL, PARAMETER  :: i1 = 5.79602E-4, i2 = -0.02763334, i3 = 0.4517029,  &
                    i4 = -2.657697, i5 = 5.127212
REAL, PARAMETER  :: j1 = 0.5657187, j2 = 21.83269

!     Check that number of degrees of freedom > 4.

IF (doff <= four) THEN
  WRITE(*, *) '** Error in AS27 - degrees of freedom <= 4  **'
  RETURN
END IF

!     Evaluate series.

v = one / doff
pos = (t >= zero)
tt = ABS(t)
x = half*(one +   &
    tt*(((a1 + v*(a2 + v*(a3 + v*(a4 + v*a5)))) / (one - v*(b1 - v*b2))) +  &
    tt*(((c1 + v*(c2 + v*(c3 + v*(c4 + v*c5)))) / (one - v*(d1 - v*d2))) +  &
    tt*(((e1 + v*(e2 + v*(e3 + v*(e4 + v*e5)))) / (one - v*(f1 - v*f2))) +  &
    tt*(((g1 + v*(g2 + v*(g3 + v*(g4 + v*g5)))) / (one - v*(h1 - v*h2))) +  &
    tt*((i1 + v*(i2 + v*(i3 + v*(i4 + v*i5)))) / (one - v*(j1 - v*j2))) ))))) ** (-8)
IF (pos) THEN
  fn_val = x
ELSE
  fn_val = one - x
END IF

RETURN
END FUNCTION studnt


!->Module LIB_FEM. Rafa Palacios. Last Update 15Jul2008.
!
!->Description.-
!
!    This module includes specific subroutines for Finite Element solution
!    with banded matrices.
!
!->Subroutines.-
!
!  fem_bandmat:         Multiply a banded matrix by a full matrix.
!  fem_bandvec:         Multiply a banded matrix by a vector.
!  fem_choleski_dcmp:   Choleski decomposition of a symmetric banded matrix.
!  fem_choleski_solv:   Solution of linear system with Choleski decomposition.
!  fem_1d_gauss_val:    Database of 1-D Gauss point coordinates and weights.
!  fem_2d_gauss_num:    Determines the number of gaussian Points in a 2-D element.
!  fem_2d_gauss_val:    Database of 2-D Gauss point coordinates and weights.
!  fem_1d_shapefun:     1-D isoparametric shape functions.
!  fem_2d_shapefun:     2-D isoparametric Shape Functions.
!  fem_elmdof:          Get index of element d.o.f. in the model.
!  fem_glob2loc_map:    Get dof data from global to local matrix.
!  fem_glob2loc_extract: Get data from global vector into element grids.
!  fem_v2m:             Convert vector to matrix.
!  fem_m2v:             Convert matrix to vector array
!
!->Remarks.-
!
!  1) Compact storage of (anti)symmetric banded matrices:
!
!       Actual matrix:
!
!        -------------------------
!        |a11  a12  a13  0   0   |
!        |a12  a22  a23  a24 0   |
!        |a13  a23  a33  a34 a35 |
!        |0    a24  a34  a44 a45 |
!        |0    0    a35  a45 a55 |
!        -------------------------
!
!      Stored matrix:
!
!        ----------------
!        |a11  a12  a13 |
!        |a22  a23  a24 |
!        |a33  a34  a35 |
!        |a44  a45  0   |
!        |a55  0    0   |
!        ----------------
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module lib_fem
 implicit none
!
! (This module does not contain Public Variables).
!

!-> Private variables.
!
! This parameter to simulate the machine epsilon for
! a very small number which will cause singularity
 real(8), private, parameter:: Epsilon = 1.0d-13

 contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Function FEM_BANDMAT
!
!-> Description.-
!
!   Multiply a banded matrix by a full matrix.
!
!->Remarks:
!
!   1) The banded matrix is defined by its upper triangular submatrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function fem_bandmat (Symmetry,A,B)
!
!-> I/O Variables.
!
  character(len=1),intent(in) :: Symmetry               ! Symmetry properties.
  real(8),intent(in) :: A(:,:)                          ! Banded Matrix, A.
  real(8),intent(in) :: B(:,:)                          ! Regular Matrix,B.
  real(8) :: fem_bandmat(size(A,DIM=1), size(B,DIM=2))  ! A�B
!
!-> Local Variables.
!
  integer :: iCol       ! Counters on columns of matrix B.
!
! Multiply each column of B using the vector multiplication.
!
  do iCol=1, size(B,DIM=2)
    fem_bandmat(:,iCol)= fem_bandvec (Symmetry,A,B(:,iCol))
  end do
!
  return
 end function fem_bandmat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Function FEM_BANDVEC
!
!-> Description.-
!
!   Multiply a banded matrix by a vector.
!
!->Remarks:
!
!   1) The banded matrix is defined by its upper triangular submatrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function fem_bandvec (Symmetry,A,b)
!
!-> I/O Variables.
!
  character(len=1), intent(in) :: Symmetry    ! =S or A: sym or ant matrix.
  real(8),intent(in) :: A(:,:)                ! Banded Matrix, A.
  real(8),intent(in) :: b(:)                  ! Regular vector,b.
  real(8)            :: fem_bandvec(size(b))  ! A�b
!
!-> Local Variables.
!
  real(8) :: Delta      ! +1 or -1 depending of symmetry properties.
  integer :: DimBand    ! Length of the band for the current row.
  integer :: iRow       ! Counter on rows.
  integer :: iCol       ! Counters on columns.
  integer :: NumRows    ! Number of rows.
  integer :: NumCols    ! Number of columns in the matrix.
!
! Initialization of variables.
!
  fem_bandvec=0.d0
  if (Symmetry.eq.'S') Delta= 1.d0
  if (Symmetry.eq.'A') Delta=-1.d0
  NumRows= size(b)
  NumCols= size(A,DIM=2)
!
! Multiply the upper triangular matrix by the vector.
!
  DimBand=NumCols
  do iRow=1,NumRows
    if (iRow.gt.NumRows-NumCols+1) DimBand=DimBand-1
    do iCol=1,DimBand
      fem_bandvec(iRow)= fem_bandvec(iRow) + A(iRow,iCol)*b(iRow+iCol-1)
    end do
  end do
!
! Multiply the lower triangular matrix by the vector.
!
  DimBand=NumCols
  do iRow=1,NumRows-1
    if (iRow.gt.NumRows-NumCols+1) DimBand=DimBand-1
    do iCol=2,DimBand
      fem_bandvec(iRow+iCol-1)= fem_bandvec(iRow+iCol-1) + Delta*A(iRow,iCol)*b(iRow)
    end do
  end do
!
  return
 end function fem_bandvec

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_CHOLESKI_DCMP.
!
!->Description.-
!
!    Cholesky decomposition for a banded symmetric positive definite
!    coefficient matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fem_choleski_dcmp (A,Error)
!
!-> I/O Variables.
!
  real(8), intent(inout)::A (:,:)  ! Input and output matrices.
  integer, intent(out) :: Error    ! Error code.
!
!-> Local variables.
!
  integer :: i, j, k    ! Counters.
  integer :: NumBand    ! Half-Bandwidth of the problem.
  real(8) :: Sum        ! Partial sum of coefficient rates.
!
! Initialize variables.
!
  Error=0
  NumBand= size(A,DIM=2)
!
! Loop in the coefficients of the matrix.
!
  do i=1,size(A,DIM=1)
    do j=1,NumBand-1
!
! For each element, get the corresponding numerator in the decomposition
! and store in the original matrix..
!
      Sum=0.0d0
      do k= max(i+j - NumBand,1) , i-1
        Sum= Sum + A(k,1) * A(k,i+1-k) * A(k,i+j-k)
      enddo
      A(i,j)= A(i,j) - Sum
    enddo
!
! Update the element value in the decomposition and give an error if
! the matrix is ill-conditioned.
!
    if(abs(A(i,1)).le.Epsilon) then
      Error=-1
      return
    else
      do j = 2, NumBand
        A(i,j)= A(i,j) / A(i,1)
      enddo
    end if
  enddo
!
  return
 end subroutine fem_choleski_dcmp

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_CHOLESKI_SOLV
!
!->Description.-
!
!    Solve a linear system Ax=b, where A is given in its Choleski
!    factorization. The solution is performed through forward and
!    back substitution.
!
!->Remarks.-
!
!   1) Algorithms can be found in Belengundu & Chandrupatla's book
!      "Finite Elements in Engineering".
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fem_choleski_solv (A,b)
!
!-> I/O Variables.
!
  real(8), intent(in)::     A(:,:)  ! Matrix in Choleski form.
  real(8), intent(inout) :: b(:)    ! Right Hand Side.
!
!-> Local variables.
!
  integer :: i, j      ! Counters on rows and columns.
  integer :: NumCols   ! Half-Bandwidth of the matrix.
  integer :: NumRows   ! Number of equations in the system.
  real(8) :: Sum       ! Value to store sums.

  NumRows= size(A,DIM=1)
  NumCols= size(A,DIM=2)

! Forward Substitution.
  do i=2,NumRows
    Sum= 0.0d0
    do j= max(1,i+1-NumCols), i-1
      Sum= Sum + A(j,i-j+1) * b(j)
    enddo
    b(i)= b(i)-Sum
  enddo

! Backwards Substitution.
  b(NumRows) = b(NumRows)/A(NumRows,1)

  do i = NumRows-1, 1, -1
    Sum = 0.0d0
    do j= 2, min(NumCols, NumRows - i + 1)
      Sum = Sum + A(i,j) * b(j + i - 1)
    enddo
    b(i) = b(i)/A(i,1)- Sum
  enddo

  return
 end subroutine fem_choleski_solv

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Subroutine FEM_1D_GAUSS_VAL
!
!-> Description.-
!
!   Database of Weights and Coordinates for Gaussian Quadrature for 1-D
!   integration.
!
!->Remarks:
!
!   1) Coefficients from Abramowitz and Stegun.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_1d_gauss_val (NumGauss,Coords,Weight)

!-> I/O Variables.

  integer,intent(in) :: NumGauss        ! Number of Gaussian points.
  real(8),intent(out):: Coords(NumGauss)       ! Local Coordinates of the Points.
  real(8),intent(out):: Weight(NumGauss)       ! Weights of the Gaussian Points.

! Default output values.
  Coords=0.d0
  Weight=0.d0

! Database of weights and location of gaussian points.
  select case(NumGauss)
  case(1)
    Coords(1)= 0.d0
    Weight(1)= 2.d0
  case(2)
    Coords(1)=-0.577350269189626d0
    Coords(2)= 0.577350269189626d0
    Weight(1)= 1.d0
    Weight(2)= 1.d0
  case(3)
    Coords(1)=-0.774596669241483d0
    Coords(2)= 0.d0
    Coords(3)= 0.774596669241483d0
    Weight(1)= 0.555555555555556d0
    Weight(2)= 0.888888888888889d0
    Weight(3)= 0.555555555555556d0
  case(4)
    Coords(1)=-0.861136311594053d0
    Coords(2)=-0.339981043584856d0
    Coords(3)= 0.339981043584856d0
    Coords(4)= 0.861136311594053d0
    Weight(1)= 0.347854845137454d0
    Weight(2)= 0.652145154862546d0
    Weight(3)= 0.652145154862546d0
    Weight(4)= 0.347854845137454d0
  case(5)
    Coords(1)=-0.906179845938664d0
    Coords(2)=-0.538469310105683d0
    Coords(3)= 0.d0
    Coords(4)= 0.538469310105683d0
    Coords(5)= 0.906179845938664d0
    Weight(1)= 0.236926885056189d0
    Weight(2)= 0.478628670499366d0
    Weight(3)= 0.568888888888889d0
    Weight(4)= 0.478628670499366d0
    Weight(5)= 0.236926885056189d0
  case(6)
    Coords(1)=-0.932469514203152d0
    Coords(2)=-0.661209386466265d0
    Coords(3)=-0.238619186083197d0
    Coords(4)= 0.238619186083197d0
    Coords(5)= 0.661209386466265d0
    Coords(6)= 0.932469514203152d0
    Weight(1)= 0.171324492379170d0
    Weight(2)= 0.360761573048139d0
    Weight(3)= 0.467913934572691d0
    Weight(4)= 0.467913934572691d0
    Weight(5)= 0.360761573048139d0
    Weight(6)= 0.171324492379170d0

  case default
    STOP 'Error: Number of Gauss points in 1-D elements larger than 6.'
  end select

  return
 end subroutine fem_1d_gauss_val

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Subroutine FEM_1D_SHAPEFUN
!
!-> Description.-
!
!   Calculate the value of 1-D isoparametric shape function and its
!   derivative at a inner point in the element defined by local coordinates.
!
!->Remarks:
!
!   1) The isoparametric shape functions were extracted from Chandrupatla and
!      Belengundu's book "Finite Elements in Engineering". All conventions in
!      the book are used here.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_1d_shapefun (NumNodeElem, z, Fun, Der)
!
!-> I/O Variables.
  integer,intent(in) :: NumNodeElem   ! Number of nodes in the element.
  real(8),intent(in) :: z             ! Local Coordinate of the point.
  real(8),intent(out):: Fun(:)        ! Shape Function.
  real(8),intent(out):: Der(:)        ! Derivative of the Shape Function.

! Initialization.
  Fun=0.d0
  Der=0.d0

  select case (NumNodeElem)

! Three-noded beam:
  case (3)
    Fun(1)=-0.5d0*z*(1.d0-z)
    Fun(2)= 0.5d0*z*(1.d0+z)
    Fun(3)= 1.0d0-z*z
    Der(1)=-0.5d0*(1.d0-2.d0*z)
    Der(2)= 0.5d0*(1.d0+2.d0*z)
    Der(3)=-2.0d0*z

! Two-noded beam:
  case (2)
    Fun(1)= 0.5d0*(1.d0-z)
    Fun(2)= 0.5d0*(1.d0+z)
    Der(1)=-0.5d0
    Der(2)= 0.5d0

  case default
    STOP 'Error: 1-D elements must have either 2 or 3 nodes'
  end select

  return
 end subroutine fem_1d_shapefun

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Subroutine FEM_2D_GAUSS_NUM
!
!-> Description.-
!
!   Determine the number of gauss points for the current type of element.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_2d_gauss_num (Flag, NumNode_Elem, NumGauss)
!
!-> I/O Variables
!
  integer,intent(in) :: NumNode_Elem  ! # nodes in the element.
  integer,intent(out):: NumGauss      ! # Gaussian points.
  integer,intent(in) :: Flag          ! =0 for CTRIA, /=0 for CQUAD.
!
! Set the number of Gauss points depending of the type of element (CTRIA or
! CQUAD) and the number of nodes of the element.
!
  if (Flag.eq.0) then
    if (NumNode_Elem.gt.3) then
      NumGauss=7
    else
      NumGauss=3
    end if
  else
    if (NumNode_Elem.gt.4) then
      NumGauss=9
    else
      NumGauss=4
    end if
  endif
!
  return
 end subroutine fem_2d_gauss_num

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Subroutine FEM_2D_GAUSS_VAL
!
!-> Description.-
!
!   Database of Weights and Coordinates for Gaussian Quadrature.
!
!->Remarks:
!
!   1) Coefficients are extracted from Zienkiewitz' book "The Finite
!      Element Method".
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_2d_gauss_val (Flag, NumGauss, Coords, Weight, iErr)
!
!-> I/O Variables.
!
  integer,intent(in) :: Flag              ! =0 for CTRIA, /=0 for CQUAD.
  integer,intent(in) :: NumGauss          ! Number of Gaussian points.
  real(8),intent(out):: Coords(:,:)       ! Local Coordinates of the Points.
  real(8),intent(out):: Weight(:)         ! Weights of the Gaussian Points.
  integer,intent(out):: iErr              ! Error Code.
!
!-> Local variables.
!
  integer, parameter:: MaxPoints=10 ! Maximum # of linear points.
  integer :: iGauss                 ! Counter in the Gaussian points.
  integer :: i1,i2                  ! Counters in the linear points.
  integer :: NumPoints              ! Number of linear points.
  real(8) :: CoordsLin(MaxPoints)   ! Local Coordinates for [-1,1] integration.
  real(8) :: WeightLin(MaxPoints)   ! Local Coordinates for [-1,1] integration.

! Default output values.
  iErr=0
  Coords=0.d0
  Weight=0.d0

! Quadrilateral Elements.
  if (Flag.ne.0) then
    NumPoints=nint(sqrt(float(NumGauss)))
    if ((NumGauss-NumPoints*NumPoints).ne.0) NumPoints=0

    select case(NumPoints)
    case(1)
      CoordsLin(1)=0.d0
      WeightLin(1)=0.d0
    case(2)
      CoordsLin(1)=-1.d0/dsqrt(3.d0)
      CoordsLin(2)= 1.d0/dsqrt(3.d0)
      WeightLin(1)= 1.d0
      WeightLin(2)= 1.d0
    case(3)
      CoordsLin(1)=-dsqrt(.6d0)
      CoordsLin(2)= 0.d0
      CoordsLin(3)= dsqrt(.6d0)
      WeightLin(1)= 5.d0/9.d0
      WeightLin(2)= 8.d0/9.d0
      WeightLin(3)= 5.d0/9.d0
    case(4)
      CoordsLin(1)=-0.861136311594053d0
      CoordsLin(2)=-0.339981043584856d0
      CoordsLin(3)= 0.339981043584856d0
      CoordsLin(4)= 0.861136311594053d0
      WeightLin(1)= 0.347854845137454d0
      WeightLin(2)= 0.652145154862546d0
      WeightLin(3)= 0.652145154862546d0
      WeightLin(4)= 0.347854845137454d0
    case(5)
      CoordsLin(1)=-0.906179845938664d0
      CoordsLin(2)=-0.538469310105683d0
      CoordsLin(3)= 0.d0
      CoordsLin(4)= 0.538469310105683d0
      CoordsLin(5)= 0.906179845938664d0
      WeightLin(1)= 0.236926885056189d0
      WeightLin(2)= 0.478628670499366d0
      WeightLin(3)= 0.568888888888889d0
      WeightLin(4)= 0.478628670499366d0
      WeightLin(5)= 0.236926885056189d0
    case default
      iErr=-1
    end select

    iGauss=0
    do i1=1,NumPoints
      do i2=1,NumPoints
        iGauss= iGauss+1
        Coords(iGauss,1)= CoordsLin(i1)
        Coords(iGauss,2)= CoordsLin(i2)
        Weight(iGauss)  = WeightLin(i1)*WeightLin(i2)
      end do
    end do

! Triangular elements.
  else if (Flag.eq.0) then
    NumPoints=NumGauss
    select case(NumPoints)
    case(3)
      Coords(1,1)=1.d0/6.d0
      Coords(1,2)=1.d0/6.d0
      Coords(2,1)=2.d0/3.d0
      Coords(2,2)=1.d0/6.d0
      Coords(3,1)=1.d0/6.d0
      Coords(3,2)=2.d0/3.d0
      Weight(1:3)=1.d0/6.d0
    case(7)
      Coords(1,1)= 0.101286507323456d0
      Coords(1,2)= 0.101286507323456d0
      Weight(1)  = 0.0629695902724d0
      Coords(2,1)= 0.797426985353087d0
      Coords(2,2)= 0.101286507323456d0
      Weight(2)  = 0.0629695902724d0
      Coords(3,1)= 0.101286507323456d0
      Coords(3,2)= 0.797426985353087d0
      Weight(3)  = 0.0629695902724d0
      Coords(4,1)= 0.470142064105115d0
      Coords(4,2)= 0.059715871789770d0
      Weight(4)  = 0.0661970763943d0
      Coords(5,1)= 0.470142064105115d0
      Coords(5,2)= 0.470142064105115d0
      Weight(5)  = 0.0661970763943d0
      Coords(6,1)= 0.059715871789770d0
      Coords(6,2)= 0.470142064105115d0
      Weight(6)  = 0.0661970763943d0
      Coords(7,1)= 0.333333333333333d0
      Coords(7,2)= 0.333333333333333d0
      Weight(7)  = 0.1125d0
    case default
      iErr=-1
    end select
  end if

  return
 end subroutine fem_2d_gauss_val

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!-> Subroutine FEM_2D_SHAPEFUN
!
!-> Description.-
!
!   Calculate the value of the 2-D isoparametric shape function and its
!   derivatives at a inner point in the element defined by local coordinates.
!
!->Remarks:
!
!   1) The isoparametric shape functions were extracted from Chandrupatla and
!      Belengundu's book "Finite Elements in Engineering". All conventions in
!      the book are used here.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_2d_shapefun (Flag, Node, z1, z2, Fun, Der)
!
!-> I/O Variables.
!
  integer,intent(in) :: Flag                   ! =0: for CTRIA, /=0: for CQUAD.
  integer,intent(in) :: Node(:)                ! Array on nodes (=0: node not present).
  real(8),intent(in) :: z1,z2         ! Local Coordinates of the Points.
  real(8),intent(out):: Fun(:)        ! Shape Function.
  real(8),intent(out):: Der(:,:)      ! Derivative of the Shape Function.
!
!-> Local variables.
!
  real(8) :: z3                       ! Third variable for triangular elements.
!
! Initialization.
!
  Fun=0.d0
  Der=0.d0
!
!
!-> Quadrilateral Elements:
!   ----------------------
!
  if (Flag.ne.0) then
!
! Shape Functions.
!
    if (Node(9).ne.0) Fun(9)=        (1.d0-z1*z1)*(1.d0-z2*z2)
    if (Node(5).ne.0) Fun(5)=.5d0 * ((1.d0-z1*z1)*(1.d0-z2)-Fun(9))
    if (Node(7).ne.0) Fun(7)=.5d0 * ((1.d0-z1*z1)*(1.d0+z2)-Fun(9))
    if (Node(6).ne.0) Fun(6)=.5d0 * ((1.d0-z2*z2)*(1.d0+z1)-Fun(9))
    if (Node(8).ne.0) Fun(8)=.5d0 * ((1.d0-z2*z2)*(1.d0-z1)-Fun(9))
!
    Fun(1)=.25d0 * ((1.d0-z1)*(1.d0-z2)-Fun(9)) - .5d0*(Fun(8)+Fun(5))
    Fun(2)=.25d0 * ((1.d0+z1)*(1.d0-z2)-Fun(9)) - .5d0*(Fun(5)+Fun(6))
    Fun(3)=.25d0 * ((1.d0+z1)*(1.d0+z2)-Fun(9)) - .5d0*(Fun(6)+Fun(7))
    Fun(4)=.25d0 * ((1.d0-z1)*(1.d0+z2)-Fun(9)) - .5d0*(Fun(7)+Fun(8))
!
! Derivatives with z1.
!
    if (Node(9).ne.0) Der(9,1)=-2.d0*z1*(1.d0-z2*z2)
    if (Node(5).ne.0) Der(5,1)=-z1*(1.d0-z2) -.5d0*Der(9,1)
    if (Node(7).ne.0) Der(7,1)=-z1*(1.d0+z2) -.5d0*Der(9,1)
    if (Node(6).ne.0) Der(6,1)=.5d0*( (1.d0-z2*z2)-Der(9,1))
    if (Node(8).ne.0) Der(8,1)=.5d0*(-(1.d0-z2*z2)-Der(9,1))
!
    Der(1,1)=.25d0*(-(1.d0-z2)-Der(9,1)) - .5d0*(Der(8,1)+Der(5,1))
    Der(2,1)=.25d0*( (1.d0-z2)-Der(9,1)) - .5d0*(Der(5,1)+Der(6,1))
    Der(3,1)=.25d0*( (1.d0+z2)-Der(9,1)) - .5d0*(Der(6,1)+Der(7,1))
    Der(4,1)=.25d0*(-(1.d0+z2)-Der(9,1)) - .5d0*(Der(7,1)+Der(8,1))
!
! Derivatives with z2.
!
    if (Node(9).ne.0) Der(9,2)=-2.d0*z2*(1.d0-z1*z1)
    if (Node(5).ne.0) Der(5,2)=.5d0*(-(1.d0-z1*z1)-Der(9,2))
    if (Node(7).ne.0) Der(7,2)=.5d0*( (1.d0-z1*z1)-Der(9,2))
    if (Node(6).ne.0) Der(6,2)=-z2*(1.d0+z1) -.5d0*Der(9,2)
    if (Node(8).ne.0) Der(8,2)=-z2*(1.d0-z1) -.5d0*Der(9,2)
!
    Der(1,2)=.25d0*(-(1.d0-z1)-Der(9,2)) - .5d0*(Der(8,2)+Der(5,2))
    Der(2,2)=.25d0*(-(1.d0+z1)-Der(9,2)) - .5d0*(Der(5,2)+Der(6,2))
    Der(3,2)=.25d0*( (1.d0+z1)-Der(9,2)) - .5d0*(Der(6,2)+Der(7,2))
    Der(4,2)=.25d0*( (1.d0-z1)-Der(9,2)) - .5d0*(Der(7,2)+Der(8,2))
!
!
!-> Triangular Elements:
!   -------------------
!
  else
    z3=1.d0-z1-z2
!
! Shape Functions.
!
    if (Node(5).ne.0) Fun(5)= 4.d0*z3*z1
    if (Node(6).ne.0) Fun(6)= 4.d0*z1*z2
    if (Node(7).ne.0) Fun(7)= 4.d0*z2*z3
!
    Fun(1)= z3 - .5d0*(Fun(5)+Fun(7))
    Fun(2)= z1 - .5d0*(Fun(6)+Fun(5))
    Fun(3)= z2 - .5d0*(Fun(7)+Fun(6))
!
! Derivatives with z1.
!
    if (Node(5).ne.0) Der(5,1)= 4.d0*(z3-z1)
    if (Node(6).ne.0) Der(6,1)= 4.d0*z2
    if (Node(7).ne.0) Der(7,1)=-4.d0*z2
!
    Der(1,1)=-1.d0 - .5d0*(Der(5,1)+Der(7,1))
    Der(2,1)= 1.d0 - .5d0*(Der(6,1)+Der(5,1))
    Der(3,1)=      - .5d0*(Der(7,1)+Der(6,1))
!
! Derivatives with z2.
!
    if (Node(5).ne.0) Der(5,2)=-4.d0*z1
    if (Node(6).ne.0) Der(6,2)= 4.d0*z1
    if (Node(7).ne.0) Der(7,2)= 4.d0*(z3-z2)
!
    Der(1,2)=-1.d0 - .5d0*(Der(5,2)+Der(7,2))
    Der(2,2)=      - .5d0*(Der(6,2)+Der(5,2))
    Der(3,2)= 1.d0 - .5d0*(Der(7,2)+Der(6,2))
!
  end if
!
  return
 end subroutine fem_2d_shapefun

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_ELMDOF.
!
!->Description.-
!
!   Find the corresponding d.o.f's for an element and store them in
!   a steering vector.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_elmdof(NumDofNode,NodeList,g)
!
!-> I/O Variables.
!
  integer,intent(in) :: NumDofNode    ! Number of d.o.f.'s in each node.
  integer,intent(in) :: NodeList(:)   ! List of nodes in the element.
  integer,intent(out):: g(:)          ! Global d.o.f's in the element.
!
!-> Local variables.
!
  integer::i,j,m
!
! Initialize.
  g= 0;
  m= 0;
!
! Loop in the nodes.
  do i=1,size(NodeList)
    if(NodeList(i).ne.0) then
      do j=1,NumDofNode
        m= m+1
        g(m)= NumDofNode*(NodeList(i)-1)+j
      end do
   end if
  end do
!
  return
 end subroutine fem_elmdof

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_GLOB2LOC_MAP.
!
!->Description.-
!
!    Extract the elements corresponding to a given dof from a global
!    matrix and add them to a given local matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_glob2loc_map (global,local,g)

  ! I/O Variables.
  real(8),intent(in) :: global(:,:)
  real(8),intent(out) :: local(:,:)
  integer, intent(in) :: g(:)
!
!-> Local Variables.
!
  integer:: i
!
  do i=1,size(local,1)
    local(i,:)=local(i,:)+global(g(i),:)
  end do
!
  return
 end subroutine fem_glob2loc_map

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_GLOB2LOC_EXTRACT.
!
!->Description.-
!
!    Extract the values corresponding to given nodes from a vector of global
!    data.
!
! -> sm: Input/Output description:
!
! - ElemNodes(ii) = nn, where ii is the ii-th node according to the local elem.
!               ... ordering and nn is the nn-th element in the global ordering
! - GlobVector(nn,:): array associated to the nn-th node (in the global ordering)
!               ... the quantities here stored are not associated to any
!               ... frame of reference
! - LocVector(ii,:): array associated to the ii-th node (local), i.e. to the
!              ... nn-th node (global). The association is extablished through
!              ... ElemNodes. No change of frame of reference is performed
!
! e.g.: sample call from input_xxx.f90 (output_elems)
! fem_glob2loc_extract (Elem(iElem)%Conn,Coords,PosElem,NumNE)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine fem_glob2loc_extract (ElemNodes,GlobVector,LocVector,NumNodeElem)

! I/O variables.
  integer,intent(in) :: ElemNodes (:)      ! Nodes in the current element.
  real(8),intent(in) :: GlobVector(:,:)    ! Vector of global values.
  real(8),intent(inout):: LocVector (:,:)    ! Vector of local values.
  integer,intent(out):: NumNodeElem        ! Actual number of nodes in the element.

! Local variables.
  integer:: i

! Compute number of non-zero connectivies in the element.
  NumNodeElem=0
  do i=1,size(ElemNodes)
    if (ElemNodes(i).gt.0) NumNodeElem=NumNodeElem+1
  end do

! Extract data from global vector.
  LocVector=0.d0
  LocVector(1:NumNodeElem,:)=GlobVector(ElemNodes(1:NumNodeElem),:)
  return
 end subroutine fem_glob2loc_extract

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_V2M.
!
!->Description.-
!
!    Convert array of degrees of freedom to matrix form.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function fem_v2m (Vector,Nrow,Ncol)

! I/O variables.
  real(8),intent(in) :: Vector(:)          ! Vector.
  integer,intent(in) :: Nrow               ! Number of rows in the matrix.
  integer,intent(in) :: Ncol               ! Number of columns in the matrix.
  real(8)            :: fem_v2m(Nrow,Ncol) ! Matrix.

! Local variables.
  integer:: i,iCol,iRow    ! Counters.

  iRow=1
  iCol=1
  do i=1,size(Vector)

    fem_v2m(iRow,iCol)=Vector(i)

    if (iCol.eq.NCol) then
      iRow=iRow+1
      iCol=1
    else
      iCol=iCol+1
    end if
  end do

  return
 end function fem_v2m

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_M2V.
!
!->Description.-
!
!    Convert matrix to vector array.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function fem_m2v (Matrix,N,Filter)

! I/O variables.
  real(8),intent(in)         :: Matrix(:,:)      ! Matrix.
  integer,intent(in)         :: N                ! Size of the vector.
  integer,optional,intent(in):: Filter(:)        ! Filter on rows of the matrix.
  real(8)                    :: fem_m2v(N)       ! Vector.

! Local variables.
  integer:: i,j,k      ! Counters.

! Initialize
  k=0
  fem_m2v=0.d0

  do i=1,size(Matrix,DIM=1)
    do j=1,size(Matrix,DIM=2)

      if (present(Filter)) then
        if (Filter(i).ne.0) then
          k=k+1
          fem_m2v(k)=Matrix(i,j)
        end if

      else
        k=k+1
        fem_m2v(k)=Matrix(i,j)
      end if
    end do
  end do

  return
 end function fem_m2v

 function fem_v2m_filter(vector, nrows, ncols, listin)
    real(8), intent(IN)             :: vector(:)
    integer, intent(IN)             :: nrows
    integer, intent(IN)             :: ncols
    integer, intent(IN)             :: listin(:)

    real(8)                         :: fem_v2m_filter(nrows, ncols)

    integer                         :: i_node
    integer                         :: ii

    fem_v2m_filter = 0.0d0
    ii = 0
    do i_node=1, nrows
        if (listin(i_node) <= 0) then
            cycle
        end if
        ii = (listin(i_node) - 1)*ncols

        fem_v2m_filter(i_node, :) = vector(ii+1:ii+6)
    end do
end function fem_v2m_filter

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine FEM_N2D.
!
!->Description.-
!
!    Convert node array to degrees of freedom.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 function fem_n2d (NumNodes,NumDofNode,NodeList)

! I/O variables.
   integer,intent(in):: NumNodes        ! Number of degrees of freedom in the model.
   integer,intent(in):: NumDofNode      ! Number of degrees of freedom on each node.
   integer,intent(in):: NodeList(:)     ! Nodes in the global array.
   integer           :: fem_n2d(NumNodes*NumDofNode) ! Vector.

! Local variables.
  integer:: i,j,k      ! Counters.

! Initialize
  k=0
  fem_n2d=0

  do i=1,size(NodeList)
    do j=1,NumDofNode
      k=k+1
      if (NodeList(i).ne.0) fem_n2d(k)= NumDofNode*(NodeList(i)-1)+j
    end do
  end do

  return
 end function fem_n2d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module lib_fem