module simplex
    use nrtype
    implicit none
contains
    function r8_factorial ( n )

        !*****************************************************************************80
        !
        !! R8_FACTORIAL computes the factorial of N.
        !
        !  Discussion:
        !
        !    factorial ( N ) = product ( 1 <= I <= N ) I
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    16 January 1999
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) N, the argument of the factorial function.
        !    If N is less than 1, the function value is returned as 1.
        !
        !    Output, REAL(DP) R8_FACTORIAL, the factorial of N.
        !
        implicit none

        REAL(DP) r8_factorial
        INTEGER(I4B) i
        INTEGER(I4B) n

        r8_factorial = 1.0D+00

        do i = 1, n
            r8_factorial = r8_factorial * DBLE ( i )
        end do

        return
    end function r8_factorial

    subroutine r8mat_det ( n, a, det )

        !*****************************************************************************80
        !
        !! R8MAT_DET computes the determinant of an R8MAT.
        !
        !  Discussion:
        !
        !    An R8MAT is an array of R8 values.
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    07 December 2004
        !
        !  Author:
        !
        !    Original FORTRAN77 version by Helmut Spaeth.
        !    FORTRAN90 version by John Burkardt.
        !
        !  Reference:
        !
        !    Helmut Spaeth,
        !    Cluster Analysis Algorithms
        !    for Data Reduction and Classification of Objects,
        !    Ellis Horwood, 1980, page 125-127.
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) N, the order of the matrix.
        !
        !    Input, REAL(DP) A(N,N), the matrix whose determinant is desired.
        !
        !    Output, REAL(DP) DET, the determinant of the matrix.
        !
        implicit none

        INTEGER(I4B) n

        REAL(DP) a(n,n)
        REAL(DP) b(n,n)
        REAL(DP) det
        INTEGER(I4B) j
        INTEGER(I4B) k
        INTEGER(I4B) m
        INTEGER(I4B) piv(1)
        REAL(DP) t

        b(1:n,1:n) = a(1:n,1:n)

        det = 1.0D+00

        do k = 1, n

            piv = maxloc ( abs ( b(k:n,k) ) )

            m = piv(1) + k - 1

            if ( m /= k ) then
                det = - det
                t      = b(m,k)
                b(m,k) = b(k,k)
                b(k,k) = t
            end if

            det = det * b(k,k)

            if ( b(k,k) /= 0.0D+00 ) then

                b(k+1:n,k) = -b(k+1:n,k) / b(k,k)

                do j = k + 1, n
                    if ( m /= k ) then
                        t      = b(m,j)
                        b(m,j) = b(k,j)
                        b(k,j) = t
                    end if
                    b(k+1:n,j) = b(k+1:n,j) + b(k+1:n,k) * b(k,j)
                end do

            end if

        end do

        return
    end subroutine r8mat_det

    subroutine r8mat_transpose_print ( m, n, a, title )

        !*****************************************************************************80
        !
        !! R8MAT_TRANSPOSE_PRINT prints an R8MAT, transposed.
        !
        !  Discussion:
        !
        !    An R8MAT is an array of R8 values.
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    14 June 2004
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) M, N, the number of rows and columns.
        !
        !    Input, REAL(DP) A(M,N), an M by N matrix to be printed.
        !
        !    Input, character ( len = * ) TITLE, a title.
        !
        implicit none

        INTEGER(I4B) m
        INTEGER(I4B) n

        REAL(DP) a(m,n)
        character ( len = * ) title

        call r8mat_transpose_print_some ( m, n, a, 1, 1, m, n, title )

        return
    end subroutine r8mat_transpose_print

    subroutine r8mat_transpose_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

        !*****************************************************************************80
        !
        !! R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT, transposed.
        !
        !  Discussion:
        !
        !    An R8MAT is an array of R8 values.
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    10 September 2009
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) M, N, the number of rows and columns.
        !
        !    Input, REAL(DP) A(M,N), an M by N matrix to be printed.
        !
        !    Input, INTEGER(I4B) ILO, JLO, the first row and column to print.
        !
        !    Input, INTEGER(I4B) IHI, JHI, the last row and column to print.
        !
        !    Input, character ( len = * ) TITLE, a title.
        !
        implicit none

        INTEGER(I4B), parameter :: incx = 5
        INTEGER(I4B) m
        INTEGER(I4B) n

        REAL(DP) a(m,n)
        character ( len = 14 ) ctemp(incx)
        INTEGER(I4B) i
        INTEGER(I4B) i2
        INTEGER(I4B) i2hi
        INTEGER(I4B) i2lo
        INTEGER(I4B) ihi
        INTEGER(I4B) ilo
        INTEGER(I4B) inc
        INTEGER(I4B) j
        INTEGER(I4B) j2hi
        INTEGER(I4B) j2lo
        INTEGER(I4B) jhi
        INTEGER(I4B) jlo
        character ( len = * ) title

        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) trim ( title )

        do i2lo = max ( ilo, 1 ), min ( ihi, m ), incx

            i2hi = i2lo + incx - 1
            i2hi = min ( i2hi, m )
            i2hi = min ( i2hi, ihi )

            inc = i2hi + 1 - i2lo

            write ( *, '(a)' ) ' '

            do i = i2lo, i2hi
                i2 = i + 1 - i2lo
                write ( ctemp(i2), '(i8,6x)' ) i
            end do

            write ( *, '(''  Row   '',5a14)' ) ctemp(1:inc)
            write ( *, '(a)' ) '  Col'
            write ( *, '(a)' ) ' '

            j2lo = max ( jlo, 1 )
            j2hi = min ( jhi, n )

            do j = j2lo, j2hi

                do i2 = 1, inc
                    i = i2lo - 1 + i2
                    write ( ctemp(i2), '(g14.6)' ) a(i,j)
                end do

                write ( *, '(i5,a,5a14)' ) j, ':', ( ctemp(i), i = 1, inc )

            end do

        end do

        return
    end subroutine r8mat_transpose_print_some

    subroutine simplex_coordinates1 ( n, x )

        !*****************************************************************************80
        !
        !! SIMPLEX_COORDINATES1 computes the Cartesian coordinates of simplex vertices.
        !
        !  Discussion:
        !
        !    The simplex will have its centroid at 0;
        !
        !    The sum of the vertices will be zero.
        !
        !    The distance of each vertex from the origin will be 1.
        !
        !    The length of each edge will be constant.
        !
        !    The dot product of the vectors defining any two vertices will be - 1 / N.
        !    This also means the angle subtended by the vectors from the origin
        !    to any two distinct vertices will be arccos ( - 1 / N ).
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    19 September 2010
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) N, the spatial dimension.
        !
        !    Output, REAL(DP) X(N,N+1), the coordinates of the vertices
        !    of a simplex in N dimensions.
        !
        implicit none

        INTEGER(I4B) n

        INTEGER(I4B) i
        INTEGER(I4B) j
        REAL(DP) x(n,n+1)

        x(1:n,1:n+1) = 0.0D+00

        do i = 1, n
            !
            !  Set X(I,I) so that sum ( X(1:I,I)**2 ) = 1.
            !
            x(i,i) = sqrt ( 1.0D+00 - sum ( x(1:i-1,i)**2 ) )
            !
            !  Set X(I,J) for J = I+1 to N+1 by using the fact that XI dot XJ = - 1 / N
            !
            do j = i + 1, n + 1
                x(i,j) = ( - 1.0D+00 / real ( n, kind = 8 ) &
                    - dot_product ( x(1:i-1,i), x(1:i-1,j) ) ) / x(i,i)
            end do

        end do

        return
    end subroutine simplex_coordinates1

    subroutine simplex_coordinates2 ( n, x )

        !*****************************************************************************80
        !
        !! SIMPLEX_COORDINATES2 computes the Cartesian coordinates of simplex vertices.
        !
        !  Discussion:
        !
        !    This routine uses a simple approach to determining the coordinates of
        !    the vertices of a regular simplex in n dimensions.
        !
        !    We want the vertices of the simplex to satisfy the following conditions:
        !
        !    1) The centroid, or average of the vertices, is 0.
        !    2) The distance of each vertex from the centroid is 1.
        !       By 1), this is equivalent to requiring that the sum of the squares
        !       of the coordinates of any vertex be 1.
        !    3) The distance between any pair of vertices is equal (and is not zero.)
        !    4) The dot product of any two coordinate vectors for distinct vertices
        !       is -1/N; equivalently, the angle subtended by two distinct vertices
        !       from the centroid is arccos ( -1/N).
        !
        !    Note that if we choose the first N vertices to be the columns of the
        !    NxN identity matrix, we are almost there.  By symmetry, the last column
        !    must have all entries equal to some value A.  Because the square of the
        !    distance between the last column and any other column must be 2 (because
        !    that's the distance between any pair of columns), we deduce that
        !    (A-1)^2 + (N-1)*A^2 = 2, hence A = (1-sqrt(1+N))/N.  Now compute the
        !    centroid C of the vertices, and subtract that, to center the simplex
        !    around the origin.  Finally, compute the norm of one column, and rescale
        !    the matrix of coordinates so each vertex has unit distance from the origin.
        !
        !    This approach devised by John Burkardt, 19 September 2010.  What,
        !    I'm not the first?
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    19 September 2010
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) N, the spatial dimension.
        !
        !    Output, REAL(DP) X(N,N+1), the coordinates of the vertices
        !    of a simplex in N dimensions.
        !

        use nrtype
        implicit none

        integer (I4B), INTENT(IN) :: n

        real (DP) :: a
        real (DP ) :: c(n)
        integer ( I4B ) :: j
        real ( DP ) :: s
        real ( DP ), DIMENSION(n,n+1), INTENT(OUT) :: x

        x(1:n,1:n+1) = 0.0D+00

        do j = 1, n
            x(j,j) = 1.0D+00
        end do

        a = ( 1.0D+00 - sqrt ( 1.0D+00 + DBLE ( n ) ) ) &
            / DBLE ( n )

        x(1:n,n+1) = a
        !
        !  Now adjust coordinates so the centroid is at zero.
        !
        c(1:n) = sum ( x(1:n,1:n+1), dim = 2 ) / DBLE ( n + 1 )

        do j = 1, n + 1
            x(1:n,j) = x(1:n,j) - c(1:n)
        end do
        !
        !  Now scale so each column has norm 1.
        !
        s = sqrt ( sum ( x(1:n,1)**2 ) )

        x(1:n,1:n+1) = x(1:n,1:n+1) / s

        return
    end subroutine simplex_coordinates2

    subroutine simplex_volume ( n, x, volume )

        !*****************************************************************************80
        !
        !! SIMPLEX_VOLUME computes the volume of a simplex.
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    19 September 2010
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, INTEGER(I4B) N, the spatial dimension.
        !
        !    Input, REAL(DP) X(N,N+1), the coordinates of the vertices
        !    of a simplex in N dimensions.
        !
        !    Output, REAL(DP) VOLUME, the volume of the simplex.
        !
        implicit none

        INTEGER(I4B) n

        REAL(DP) a(n,n)
        REAL(DP) det
        INTEGER(I4B) i
        INTEGER(I4B) j
        REAL(DP) volume
        REAL(DP) x(n,n+1)

        a(1:n,1:n) = x(1:n,1:n)
        do j = 1, n
            a(1:n,j) = a(1:n,j) - x(1:n,n+1)
        end do

        call r8mat_det ( n, a, det )

        volume = abs ( det )
        do i = 1, n
            volume = volume / real ( i, kind = 8 )
        end do

        return
    end subroutine simplex_volume

    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:
        !
        !    18 May 2013
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    None
        !
        implicit none

        character ( len = 8 ) ampm
        INTEGER(I4B) d
        INTEGER(I4B) h
        INTEGER(I4B) m
        INTEGER(I4B) mm
        character ( len = 9 ), parameter, dimension(12) :: month = (/ &
            'January  ', 'February ', 'March    ', 'April    ', &
            'May      ', 'June     ', 'July     ', 'August   ', &
            'September', 'October  ', 'November ', 'December ' /)
        INTEGER(I4B) n
        INTEGER(I4B) s
        INTEGER(I4B) values(8)
        INTEGER(I4B) 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 subroutine timestamp
end module simplex


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  double precision function hgll(I,Z,ZGLL,NZ)

!-------------------------------------------------------------
!
!  Compute the value of the Lagrangian interpolant L through
!  the NZ Gauss-Lobatto Legendre points ZGLL at point Z
!
!-------------------------------------------------------------

  implicit none

  integer i,nz
  double precision z
  double precision ZGLL(0:nz-1)

  integer n
  double precision EPS,DZ,ALFAN
  double precision, external :: PNLEG,PNDLEG

  EPS = 1.d-5
  DZ = Z - ZGLL(I)
  if(abs(DZ) < EPS) then
   HGLL = 1.d0
   return
  endif
  N = NZ - 1
  ALFAN = dble(N)*(dble(N)+1.d0)
  HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))

  end function hgll

!
!=====================================================================
!

  double precision function hglj(I,Z,ZGLJ,NZ)

!-------------------------------------------------------------
!
!  Compute the value of the Lagrangian interpolant L through
!  the NZ Gauss-Lobatto Jacobi points ZGLJ at point Z
!
!-------------------------------------------------------------

  implicit none

  integer i,nz
  double precision z
  double precision ZGLJ(0:nz-1)

  integer n
  double precision EPS,DZ,ALFAN
  double precision, external :: PNGLJ,PNDGLJ

  EPS = 1.d-5
  DZ = Z - ZGLJ(I)
  if(abs(DZ) < EPS) then
   HGLJ = 1.d0
   return
  endif
  N = NZ - 1
  ALFAN = dble(N)*(dble(N)+2.d0)
  HGLJ = - (1.d0-Z*Z)*PNDGLJ(Z,N)/ (ALFAN*PNGLJ(ZGLJ(I),N)*(Z-ZGLJ(I)))

  end function hglj

!
!=====================================================================
!

  subroutine lagrange_any(xi,NGLL,xigll,h,hprime)

! subroutine to compute the Lagrange interpolants based upon the GLL points
! and their first derivatives at any point xi in [-1,1]

  implicit none

  integer NGLL
  double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)

  integer dgr,i,j
  double precision prod1,prod2

  do dgr=1,NGLL

    prod1 = 1.0d0
    prod2 = 1.0d0
    do i=1,NGLL
      if(i /= dgr) then
        prod1 = prod1*(xi-xigll(i))
        prod2 = prod2*(xigll(dgr)-xigll(i))
      endif
    enddo
    h(dgr)=prod1/prod2

    hprime(dgr)=0.0d0
    do i=1,NGLL
      if(i /= dgr) then
        prod1=1.0d0
        do j=1,NGLL
          if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
        enddo
        hprime(dgr) = hprime(dgr)+prod1
      endif
    enddo
    hprime(dgr) = hprime(dgr)/prod2

  enddo

  end subroutine lagrange_any

!
!=====================================================================
!

! subroutine to compute the derivative of the Lagrange interpolants
! at the GLL points at any given GLL point

  double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)

!------------------------------------------------------------------------
!
!     Compute the value of the derivative of the I-th
!     Lagrange interpolant through the
!     NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
!
!------------------------------------------------------------------------

  implicit none

  integer i,j,nz
  double precision zgll(0:nz-1)

  integer degpoly

  double precision, external :: pnleg,pndleg

  degpoly = nz - 1
  if (i == 0 .and. j == 0) then
    lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
  else if (i == degpoly .and. j == degpoly) then
    lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
  else if (i == j) then
    lagrange_deriv_GLL = 0.d0
  else
    lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
      (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
      + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
      (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
  endif

  end function lagrange_deriv_GLL

!
!=======================================================================
!

! subroutine to compute the derivative of the interpolants of the GLJ
! quadrature at the GLJ points at any given GLJ point

  double precision function poly_deriv_GLJ(I,j,ZGLJ,NZ)

!------------------------------------------------------------------------
!
!     Compute the value of the derivative of the I-th
!     polynomial interpolant of the GLJ quadrature through the
!     NZ Gauss-Lobatto-Jacobi (0,1) points ZGLJ at point ZGLJ(j)
!
!------------------------------------------------------------------------

  implicit none

  integer i,j,nz
  double precision zglj(0:nz-1)

  integer degpoly

  double precision, external :: pnglj

  degpoly = nz - 1

  if (i == 0 .and. j == 0) then ! Case 1
    poly_deriv_GLJ = -dble(degpoly)*(dble(degpoly)+2.d0)/6.d0
  else if (i == 0 .and. 0 < j .and. j < degpoly) then ! Case 2
    poly_deriv_GLJ = 2.d0*(-1)**degpoly*pnglj(zglj(j),degpoly)/((1.d0+zglj(j))*(dble(degpoly)+1.d0))
  else if (i == 0 .and. j == degpoly) then ! Case 3
    poly_deriv_GLJ = (-1)**degpoly/(dble(degpoly)+1.d0)
  else if (0 < i .and. i < degpoly .and. j == 0) then ! Case 4
    poly_deriv_GLJ = (-1)**(degpoly+1)*(dble(degpoly)+1.d0)/(2.d0*pnglj(zglj(i),degpoly)*(1.d0+zglj(i)))
  else if (0 < i .and. i < degpoly .and. 0 < j .and. j < degpoly .and. i /= j) then ! Case 5
    poly_deriv_GLJ = 1.d0/(zglj(j)-zglj(i))*pnglj(zglj(j),degpoly)/pnglj(zglj(i),degpoly)
  else if (0 < i .and. i < degpoly .and. i == j) then  ! Case 6
    poly_deriv_GLJ = -1.d0/(2.d0*(1.d0+zglj(i)))
  else if (0 < i .and. i < degpoly .and. j == degpoly) then ! Case 7
    poly_deriv_GLJ = 1.d0/(pnglj(zglj(i),degpoly)*(1.d0-zglj(i)))
  else if (i == degpoly .and. j == 0) then ! Case 8
    poly_deriv_GLJ = (-1)**(degpoly+1)*(dble(degpoly)+1.d0)/4.d0
  else if (i == degpoly .and. 0 < j .and. j < degpoly) then ! Case 9
    poly_deriv_GLJ = -1.d0/(1.d0-zglj(j))*pnglj(zglj(j),degpoly)
  else if (i == degpoly .and. j == degpoly) then ! Case 10
    poly_deriv_GLJ = (dble(degpoly)*(dble(degpoly)+2.d0)-1.d0)/4.d0
  else
    call exit_MPI('Problem in poly_deriv_GLJ: in a perfect world this would NEVER appear')
  endif

  end function poly_deriv_GLJ


!
! ej3b.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program MCImpSampling
use precision, pr => dp
use ran2mod

implicit none
integer                     :: i, j, k, seed=102012
real(pr), parameter         :: exact=0.25_pr
real(pr)                    :: x, y2, Imc2, error2, cum2
real(pr)                    ::    y3, Imc3, error3, cum3

open(unit=10, file='ej3b.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#   n   Imc2  err2   Imc3   err3"

cum2 = 0._pr
cum3 = 0._pr
do i = 1, 100000
    x = ran2(seed)
    y2 = phi_inv(x, 2)
    y3 = phi_inv(x, 3)
    cum2 = cum2 + f(y2)/p(y2, 2)
    cum3 = cum3 + f(y3)/p(y3, 3)
    if (mod(i, 10)==0) then
        Imc2 = cum2/real(i, pr)
        Imc3 = cum3/real(i, pr)
        error2 = abs(exact - Imc2)
        error3 = abs(exact - Imc3)
        write(10, *) i, Imc2, error2, Imc3, error3
    end if
end do
close(10)

contains

function p(x, k)
implicit none
integer                     :: k
real(pr)                    :: p, x

p = (k + 1) * x**k

end function p

function phi_inv(x, k)
implicit none
integer                     :: k
real(pr)                    :: phi_inv, x

phi_inv = x**(1._pr/(real(k, pr)+1._pr))

end function phi_inv

function f(x)
implicit none
real(pr)                    :: f, x

f = x**3.

end function f

end program


C
C     MATRIX MULTIPLICATION - VERSION WITH CALL TO SAXPY
C
C     DATA FLOW INTERPROCEDURAL ANALYSIS
C     SUMMARY OF EFFECTS ON A PROCEDURE
C     PARALLELIZATION OF LOOPS INCLUDING CALLS TO PROCEDURE
C
      SUBROUTINE MM03(N, A, B, C)
C
      REAL*8 A(N,N), B(N,N), C(N,N), XAUX(0:127)
C
      DO I = 1,N
         DO J = 1,N
            C(I,J) = 0.0
         ENDDO
      ENDDO
C
      DO J = 1,N
         DO K = 1,N
            CALL SAXPY(N, C(1,J), A(1,K), B(K,J))
         ENDDO
      ENDDO
C
      RETURN
      END
C
C     COMPUTATION OF X = X + S*Y
C
C     SUMMARY OF EFFECTS ON A PROCEDURE
C
      SUBROUTINE SAXPY(N, X, Y, S)
C
      INTEGER N
      REAL*8 X(N), Y(N), S
C
      M = MOD(N,4)
      DO I = 1, M
         X(I) = X(I) + S*Y(I)
      ENDDO
C
      DO I = M+1, N, 4
         X(I) = X(I) + S*Y(I)
         X(I+1) = X(I+1) + S*Y(I+1)
         X(I+2) = X(I+2) + S*Y(I+2)
         X(I+3) = X(I+3) + S*Y(I+3)
      ENDDO
C
      RETURN
      END


!	Means of products.  meanth contains means.
!	covth contains covariances.
!	quadpoint contains points.  density contains weights.
function mprodth(covth,meanth)
implicit none
real(kind=8),intent(in)::covth(:,:),meanth(:)
real(kind=8)::mprodth(size(meanth),size(meanth))
!	col for column number.
!	row for row number.
integer::col,row
do row=1,size(meanth)
	do col=1,row
		mprodth(row,col)=covth(row,col)+meanth(row)*meanth(col)
	end do
end do
return
end function mprodth


    Program dptcon_example

!     DPTCON 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_interfaces, Only: dlanst, dptcon, dpttrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, rcond
      Integer :: info, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), work(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DPTCON Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (d(n), e(n-1), work(n))

!     Read the lower bidiagonal part of the tridiagonal matrix A from
!     data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Compute the 1-norm of A
      anorm = dlanst('1-norm', n, d, e)

!     Factorize the tridiagonal matrix A
      Call dpttrf(n, d, e, info)

      If (info==0) Then

!       Estimate the condition number of A
        Call dptcon(n, d, e, anorm, rcond, work, info)

!       Print the estimated condition number

        If (rcond>=epsilon(1.0E0_dp)) Then
          Write (nout, 100) 'Estimate of condition number = ', 1.0_dp/rcond
        Else
          Write (nout, 100) 'A is singular to working precision. RCOND = ', &
            rcond
        End If

      Else
        Write (nout, 110) 'The leading minor of order ', info, &
          ' is not positive definite'
      End If

100   Format (1X, A, 1P, E10.2)
110   Format (1X, A, I3, A)
    End Program


      FUNCTION FSBDLD(DIASED,GPDIASED,D50,DEP,PEXP,PHID,CSHIELDS,
     &    SBDLDP,ISOPT)
C
C CHANGE RECORD
C  MODIFED TO INCLUDE ALTERNATE FORMULAS FOR BED LOAD PHI
C
C
C **  CALCULATES DIMNSIONLESS BED LOAD TRANSPORT COEFFICIENT
C **  ISOPT=0  USE CONSTANT VALUE
C
      IF(ISOPT.EQ.0) FSBDLD=SBDLDP
C
C **  ISOPT=1  BASED ON
C **
C **  VAN RIJN, L. C., 1984: SEDIMENT TRANSPORT, PART I: BED
C **  LOAD TRANSPORT, J. HYDRAULIC ENGINEERING, 110, 1431-1455.
C
      IF(ISOPT.EQ.1)THEN
        RD=DIASED*SQRT(GPDIASED)*1.E6
        RD=(1./RD)**0.2
        TMP=CSHIELDS**2.1
        FSBDLD=0.053*RD/TMP
      ENDIF
C
C **  ISOPT=2  BASED ON MODIFIED ENGULAND-HANSEN FORMULA
C **  REFERENCE TO BE ADDED
C
      IF(ISOPT.EQ.2)THEN
        TMP1=(DEP/D50)**0.33333
        TMP2=(PEXP/PHID)**1.125
        FSBDLD=2.0367*TMP1*TMP2
      ENDIF
C
C **  ISOPT=3  BASED ON WU, WANG AND JIA, J. HYDR. RES. V38, 2000
C
      IF(ISOPT.EQ.3)THEN
        TMP1=0.03*((PHID/PEXP)**0.6)
        TMP2=TMP1**2.2
        FSBDLD=0.0053/TMP2
      ENDIF
      RETURN
      END


!======================================================================
! SUBRUTINA GENERADORA DE VALORES ALEATORIOS CON UNA DISTRIBUCION
! GAUSSIANA.
!
! AUTOR: MARTIN ALEJANDRO PAREDES SOSA
! MODIFICACION DEL DE GABY
!======================================================================

Subroutine RanGauss(Gauss)
  Use cte
  Implicit None

  Real :: Rand1, Rand2 !VALORES ALEATORIOS CON DISTRIBUCION UNIFORME
  Real :: Gauss        !VALORES ALEATORIOS CON DISTRIBUCION GAUSSIANA

  !generando números aleatorios uniformes
12 call random_number(Rand1)
  call random_number(Rand2)

  !para evitar que diverja el logaritmo al evaluarlo en rand1
  if (rand1.le.1E-8) then
     go to 12
  end if

  !generando un número aleatorios con distribución gaussiana
  Gauss = Sqrt ( -2.0 * log(Rand1) ) * cos(2.0 * pi * Rand2)

end subroutine RanGauss


!     Last change:  MBP  20 Jun 1999    7:24 am
      SUBROUTINE RFT(A, B, N, ISN)
!    C, 10 / 11 / 80.V1 RTD <PN> :FFT LIBRARY
!    IF ISN = 1, THIS SUBROUTINE COMPLETES THE FOURIER TRANSFORM
!     OF 2 * N REAL DATA VALUES, WHERE THE ORIGINAL DATA VALUES ARE
!    STORED ALTERNATELY IN ARRAYS A AND B, AND ARE FIRST
!    TRANSFORMED BY A COMPLEX FOURIER TRANSFORM OF DIMENSION N.
!    THE COSINE COEFFICIENTS ARE IN A(1), A(2), ...A(N + 1) AND
!     THE SINE COEFFICIENTS ARE IN B(1), B(2), ...B(N + 1).
!    A TYPICAL CALLING SEQUENCE IS
!         CALL FFT(A, B, N, N, N, 1)
!         CALL RFT(A, B, N, 1)
!    THE RESULTS SHOULD BE MULTIPLIED BY 0.5  / N TO GIVE THE
!    USUAL SCALING OF COEFFICIENTS.
!    IF ISN = -1, THE INVERSE TRANSFORMATION IS DONE, THE FIRST
!    STEP IN EVALUATING A REAL FOURIER SERIES.
!    A TYPICAL CALLING SEQUENCE IS
!         CALL RFT(A, B, N,  - 1)
!         CALL FFT(A, B, N, N, N,  - 1)
!    THE RESULTS SHOULD BE MULTIPLIED BY 0.5 TO GIVE THE USUAL
!    SCALING , AND THE TIME DOMAIN RESULTS ALTERNATE IN ARRAYS
!     A AND B, I.E., A(1), B(1), A(2), B(2), ...A(N), B(N).
!    THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX
!     ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO
!    GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO PASS
!    THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY
!    VALUES, E.G.
!          CALL FFT(A, A(2), N, N, N, 2)
!          CALL RFT(A, A(2), N, 2)
!    IN THIS CASE, THE COSINE AND SINE COEFFICIENTS ALTERNATE IN
!    A,  BY R.C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968
!
! NOTE FROM THE USERS:
!
!     BUGS WERE FOUND IN THIS VERSION OF RFT, WHICH HAS BEEN USED IN
!    BASIC I, II, AND III.   THESE ARE:
!
!      1)  TWO VALUES OUTSIDE THE USER'S BUFFER, X(N + 1) AND X(N + 2) FOR
!     A TRANSFORM OF N DATA POINTS, ARE CLOBBERED IN AN ATTEMPT AT
!     SCRATCH STORAGE.  THIS HAS BEEN CORRECTED IN THE LATER VERSION, AN
!     THE OLD PROGRAM, IDENTICAL IN EXECUTION, BUT WHICH DID NOT CONTAIN
!     CORREKT THINKING IN ITS NONUSE OF COMMENTS, HAS BEEN DESTROYED.
!
!     2)  THE INVERSE TRANSFORM STATEMENTS SHOULD BE CHANGED, SO THAT
!     A(K), A(K + 1) (BETWEEN STATEMENTS 5 & 10) IS DEFINED.
!
!     3)   ROUNDED ARITHMETIC SHOULD BE USED.
!
      DIMENSION A(1), B(1)
      INC = IABS(ISN)
      NK = N * INC + 2
      NH = NK / 2
      SD = -2.0 * ATAN(1.0) / FLOAT(N)
      CD = 2.0 * SIN(SD) **2
      SD = SIN(SD + SD)
      IF ( ISN .LT. 0 ) GOTO 30
      CN = 1.
!     DO FIRST LOOP
!     STORING NYQUIST REAL IN IMAGINARY 0 SAMPLE & VICEVERSA
      AA   = 2. * (A(1) + B(1))
      B(1) = 2. * (A(1) - B(1))
!
12    A(1) = AA
! INCREMENT SIN & COSINE
      SN = SD * CN
      CN = CN * (1. - CD)
      L = 1 + INC

!     *** MAIN LOOP ***

      DO J = L, NH, INC
!        OK, FROM HERE ON IT'S ALMOST THE SAME.
         K = NK - J
         AA = A(J) + A(K)
         AB = A(J) - A(K)
         BA = B(J) + B(K)
         BB = B(J) - B(K)
         RE = CN * BA + SN * AB
         FIM = SN * BA - CN * AB
         B(K) = FIM - BB
         B(J) = FIM + BB
         A(K) = AA - RE
         A(J) = AA + RE
         AA = CN - (CD * CN + SD * SN)
         SN = (SD * CN - CD * SN) + SN
!        THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION
!        ERROR.  IF ROUNDED ARITHMETIC IS USED, SUBSTITUTE
         CN = AA
       END DO
!      CN = 0.5 / (AA**2 + SN**2) + 0.5
!      SN = CN * SN
!      CN = CN * AA

       RETURN

!      *** INVERSE TRANSFORM ***
 30    CN = -1.0
       SD = -SD
       AA   = A(1) + B(1)
       B(1) = A(1) - B(1)
       GO TO 12

       END
!**********************************************************************C
      SUBROUTINE RFFT(A, NX, IFORW)
      DIMENSION A(NX)
      IF (IFORW.GT.0) THEN
         CALL CFFT(A, NX / 2, 1)
         CALL RFT(A(1), A(2), NX / 2, 2)
      ELSE
         CALL RFT(A(1), A(2), NX / 2,  - 2)
         CALL CFFT(A, NX / 2,  - 1)
      END IF
      RETURN
      END
!**********************************************************************C
      SUBROUTINE RFFTSC(A, NX, IPACK, IFAC)
      DIMENSION A(*)

      IF (IFAC == 1) THEN
         FAC = .5 / NX
      ELSE IF (IFAC == - 1) THEN
         FAC = 0.25 / NX
      ELSE
         FAC = 1E0
      END IF

      IF (IPACK == 2) THEN
         A(2) = 0E0
      ELSE IF (IPACK == 3) THEN
         A(NX + 1) = A(2)
         A(NX + 2) = 0E0
         A(2) = 0E0
      ELSE IF (IPACK == - 3) THEN
         A(2) = A(NX + 1)
      ELSE IF (IPACK == - 2) THEN
         A(2) = 0E0
      END IF

      IF (IFAC /= 0) THEN
        DO I = 1, NX
           A(I) = A(I) * FAC
        END DO
      END IF

      RETURN
      END


double precision function true_solution(x, t)

! True solution for the thin film equation,
!     q_t + (qq_xxx)_x = 0.

    implicit none
    double precision, intent(in) :: x, t

    double precision :: t0 = .3d0, tau, ell, eta
    parameter(ell = 2.d0)

    tau = (5.d0 * (t + t0))**.2d0
    eta = x / tau

    if (eta < ell) then
        true_solution = 1.d0/(24.d0 * tau) * (ell**2 - eta**2)**2
    else
        true_solution = 0.d0
    end if

end function true_solution


MODULE gridmod
  !-------------------------------------------------------------------
  !  Created     : Mateo Duque Villegas
  !  Last updated: 2-Feb-2018
  !-------------------------------------------------------------------
  IMPLICIT NONE

CONTAINS

    SUBROUTINE latlon(blat,blon,ydegr,xdegr,nlat,mlon,ylat,xlon)

    IMPLICIT NONE

    !! Global namespace
    INTEGER(KIND=4), INTENT(in) :: nlat
    INTEGER(KIND=4), INTENT(in) :: mlon
    REAL(KIND=4),    INTENT(in) :: ydegr
    REAL(KIND=4),    INTENT(in) :: xdegr
    REAL(KIND=4),    INTENT(in) :: blat
    REAL(KIND=4),    INTENT(in) :: blon
    REAL(KIND=8),    DIMENSION(nlat), INTENT(out)  :: ylat
    REAL(KIND=8),    DIMENSION(mlon), INTENT(out)  :: xlon

    !! Local namespace
    INTEGER(KIND=4)                                :: ilon
    INTEGER(KIND=4)                                :: ilat

    !! Longitudes going from -180 to 180
    DO ilon = 1,mlon
       xlon(ilon) = -blon + (ilon-1)*xdegr
    END DO

    !! Latitudes going from 90 to -90
    DO ilat = 1,nlat
       ylat(ilat) = blat - ilat*ydegr
    END DO

    RETURN

  END SUBROUTINE latlon

END MODULE gridmod


! Program to test the PACK intrinsic
program intrinsic_pack
   integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/)
   integer, dimension(3, 3) :: a
   integer, dimension(6) :: b

   a = reshape (val, (/3, 3/))
   b = 0
   b(1:6:3) = pack (a, a .ne. 0);
   if (any (b(1:6:3) .ne. (/9, 7/))) call abort
   b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/));
   if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort

   call tests_with_temp()
contains
  subroutine tests_with_temp
    ! A few tests which involve a temporary
    if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort
    if (any (pack(a, .true.) .ne. val)) call abort
    if (size(pack (a, .false.)) .ne. 0) call abort
    if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort

  end subroutine tests_with_temp
end program


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief Jacobian calculation

module hecmw_Jacob231
contains

  subroutine hecmw_Jacob_231 ( hecMESH, iElem, DET, W, N, NX, NY )
    use hecmw_util
    implicit none

    type(hecmwST_local_mesh):: hecMESH
    integer(kind=kint)::       iElem
    real(kind=kreal)::         DET
    real(kind=kreal)::         W(3),N(3,3),NX(3,3),NY(3,3)

    integer(kind=kint):: i, ii, j, iLocal
    real(kind=kreal):: DUM
    real(kind=kreal):: XX(3), YY(3)
    real(kind=kreal):: NR(3), NS(3)
    real(kind=kreal):: Jacob(2,2), Jinv(2,2)

    !!
    !! ******** Set values of coordinates********
    !!
    do i = 1, 3
      ii = 3 - i
      iLocal = hecMESH%elem_node_item( 3*iElem -ii )
      XX(i) = hecMESH%node( iLocal*3 -1 )
      YY(i) = hecMESH%node( iLocal*3    )
      W(i)  = 1.0 / 3.0D0
    end do

    !!
    !! ******** Set values to shape functions ********
    !!
    N(1,1) = 0.5D0
    N(2,1) = 0.5D0
    N(3,1) = 0.0D0

    N(1,2) = 0.0D0
    N(2,2) = 0.5D0
    N(3,2) = 0.5D0

    N(1,3) = 0.5D0
    N(2,3) = 0.0D0
    N(3,3) = 0.5D0
    !!
    !! ******** Derivative of shape functions ********
    !!
    !! ----------- For R-Coordinate -------------
    NR(1) = 1.0D0
    NR(2) = 0.0D0
    NR(3) =-1.0D0
    !! ----------- For S-Coordinate -------------
    NS(1) = 0.0D0
    NS(2) = 1.0D0
    NS(3) =-1.0D0
    !!
    !! ******** Jacobi matrix calculation********
    !!
    Jacob(1,1) = NR(1)*XX(1)+NR(2)*XX(2)+NR(3)*XX(3)
    Jacob(2,1) = NS(1)*XX(1)+NS(2)*XX(2)+NS(3)*XX(3)
    Jacob(1,2) = NR(1)*YY(1)+NR(2)*YY(2)+NR(3)*YY(3)
    Jacob(2,2) = NS(1)*YY(1)+NS(2)*YY(2)+NS(3)*YY(3)

    DET = Jacob(1,1)*Jacob(2,2) - Jacob(1,2)*Jacob(2,1)
    !!
    !! ******** Inverse Jacobi matrix calculation ********
    !!
    DUM = 1.0 / DET
    Jinv(1,1) =  DUM * Jacob(2,2)
    Jinv(2,1) = -DUM * Jacob(1,2)
    Jinv(1,2) = -DUM * Jacob(2,1)
    Jinv(2,2) =  DUM * Jacob(1,1)

    do i = 1, 3
      do j = 1, 3

        NX(i,j) = Jinv(1,1)*NR(i) + Jinv(1,2)*NS(i)
        NY(i,j) = Jinv(2,1)*NR(i) + Jinv(2,2)*NS(i)

      end do
    end do

  end subroutine hecmw_Jacob_231
end module hecmw_Jacob231


	FUNCTION PR_ALTM  ( alti )
C************************************************************************
C* PR_ALTM								*
C*									*
C* This function computes ALTM from ALTI.  The following equation is	*
C* used:								*
C*									*
C*              ALTM = ALTI * 1013.25 / 29.921				*
C*									*
C* REAL PR_ALTM  ( ALTI )						*
C*									*
C* Input parameters:							*
C*	ALTI		REAL	 	Altimeter in inches		*
C*									*
C* Output parameters:							*
C*	PR_ALTM		REAL		Altimeter in millibars		*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84						*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC       7/88	Modify documentation			*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for bad data.
C
	IF  ( ERMISS ( alti ) )  THEN
	    PR_ALTM = RMISSD
	    RETURN
	END IF
C
C*	Calculate.
C
	PR_ALTM = alti * 1013.25 / 29.921
C*
	RETURN
	END


*       This an example of finding roots ofth function
*       f(x)=x^2-5
*       page 11

        func(x)=x*x-5
        TOLX=1.E-06
        x=1
        Fold=func(x)
        Dx=0.5
        Iter=0
10      continue
        Iter=Iter+1
        x=x+Dx
        Print*,Iter,x,sqrt(5.)-x
        If((fold*func(x)).LT.0)then
        x=x-Dx
        Dx=Dx/2
        End If
        If(Abs(Dx).GT.TOLX) goto 10
        stop
        end

last28-52009/Example/finding roots of function/finding roots of function.f


program main
    implicit none
    integer :: limit, i
    integer, dimension(:), allocatable :: numbers

    limit = 100
    numbers = (/ (i, i = 1, limit) /)
    print *, sum(numbers) ** 2 - sum(numbers ** 2)

end program main


program problem3
  use euler
  implicit none
  integer, parameter :: i16 = selected_int_kind(16)
  integer*8          :: n = 600851475143_i16
  integer            :: i

  do i=int(sqrt(dble(n)))+1,2,-1
     if (is_factor(i,n) .and. is_prime(int8(i))) then
        print *, i
        exit
     end if
  end do

end program problem3


      FUNCTION erfcc(x)
      REAL erfcc,x
      REAL t,z
      z=abs(x)
      t=1./(1.+0.5*z)
      erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t*
     *(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t*
     *(1.48851587+t*(-.82215223+t*.17087277)))))))))
      if (x.lt.0.) erfcc=2.-erfcc
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/erfcc.for


!
!  Find covariance matrix components for linear and quadratic parts of beta.
!	covbeta is the estimated covariance matrix of beta.
!	thpr is a collection of predictor vectors.
!   covlin is the estimated covariance matrix of linear part.
!	covlinquad is the estimated compact covariance matrix of linear and quadratic parts.
!	covquad is the estimated compact covariance matrix of quadratic parts.

subroutine covarlinquad(covbeta,thpr,covlin,covlinquad,covquad)
implicit none

real(kind=8),intent(in)::covbeta(:,:),thpr(:)
real(kind=8),intent(out)::covlin(:,:),covlinquad(:,:),covquad(:,:)
!   dimcovlat is the number of possibly distinct elements in a dimlatin by dimlatin covariance matrix.
!   dimlatin is the dimension of the underlying covariance matrix.
!   nlin points to linear components.
!   npred is the number of predictors.
!	nquadratic points to quadratic components.
!   position, position1, position2, and position3 point to elements of the parameter vector.
!   position1 points to elements of the parameter vector.
!   pred counts predictors.
!   pred1 counts predictors.

integer::dimcovlat,dimlatin,nlin,npred,nquadratic,position,position1,position2,position3,pred,pred1

!   Find sizes.
dimlatin=size(covlin,1)
dimcovlat=dimlatin*(dimlatin+1)/2
npred=size(thpr)
nquadratic=size(covbeta,1)-npred*dimcovlat+1
nlin=nquadratic-npred*dimlatin
!	Covariance matrix of linear part.
position=nlin

covlin=0.0_8
do pred=1,npred
	position1=position+dimlatin-1
	position2=nlin

	do pred1=1,npred
		position3=position2+dimlatin-1
		covlin=covlin+covbeta(position:position1,position2:position3)*thpr(pred)*thpr(pred1)
		position2=position3+1
	end do
	position=position1+1

end do

!	Covariance matrix of quadratic part.
position=nquadratic

covquad=0.0_8
do pred=1,npred
	position1=position+dimcovlat-1
	position2=nquadratic
	do pred1=1,npred
		position3=position2+dimcovlat-1
		covquad=covquad+covbeta(position:position1,position2:position3)*thpr(pred)*thpr(pred1)
		position2=position3+1
	end do
	position=position1+1
end do
!	Covariance matrix of linear and quadratic part.
covlinquad=0.0_8
position=nlin
do pred=1,npred
	position1=position+dimlatin-1
	position2=nquadratic
	do pred1=1,npred
		position3=position2+dimcovlat-1
		covlinquad=covlinquad+covbeta(position:position1,position2:position3)*thpr(pred)*thpr(pred1)
		position2=position3+1
	end do

	position=position1+1
end do
return

end subroutine covarlinquad


C
C     file sepeli.f
C
      SUBROUTINE SEPELI (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,
     1                   D,N,NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,GRHS,
     2                   USOL,IDMN,W,PERTRB,IERROR)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1),
C ARGUMENTS              USOL(IDMN,N+1),GRHS(IDMN,N+1),
C                        W (SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SEPELI SOLVES FOR EITHER THE SECOND-ORDER
C                        FINITE DIFFERENCE APPROXIMATION OR A
C                        FOURTH-ORDER APPROXIMATION TO A SEPARABLE
C                        ELLIPTIC EQUATION
C
C                          2    2
C                          AF(X)*D U/DX + BF(X)*DU/DX  + CF(X)*U +
C                          2    2
C                          DF(Y)*D U/DY  + EF(Y)*DU/DY + FF(Y)*U
C
C                          = G(X,Y)
C
C                        ON A RECTANGLE (X GREATER THAN OR EQUAL TO A
C                        AND LESS THAN OR EQUAL TO B; Y GREATER THAN
C                        OR EQUAL TO C AND LESS THAN OR EQUAL TO D).
C                        ANY COMBINATION OF PERIODIC OR MIXED BOUNDARY
C                        CONDITIONS IS ALLOWED.
C
C                        THE POSSIBLE BOUNDARY CONDITIONS ARE:
C                        IN THE X-DIRECTION:
C                        (0) PERIODIC, U(X+B-A,Y)=U(X,Y) FOR ALL
C                            Y,X (1) U(A,Y), U(B,Y) ARE SPECIFIED FOR
C                            ALL Y
C                        (2) U(A,Y), DU(B,Y)/DX+BETA*U(B,Y) ARE
C                            SPECIFIED FOR ALL Y
C                        (3) DU(A,Y)/DX+ALPHA*U(A,Y),DU(B,Y)/DX+
C                            BETA*U(B,Y) ARE SPECIFIED FOR ALL Y
C                        (4) DU(A,Y)/DX+ALPHA*U(A,Y),U(B,Y) ARE
C                            SPECIFIED FOR ALL Y
C
C                        IN THE Y-DIRECTION:
C                        (0) PERIODIC, U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                        (1) U(X,C),U(X,D) ARE SPECIFIED FOR ALL X
C                        (2) U(X,C),DU(X,D)/DY+XNU*U(X,D) ARE
C                            SPECIFIED FOR ALL X
C                        (3) DU(X,C)/DY+GAMA*U(X,C),DU(X,D)/DY+
C                            XNU*U(X,D) ARE SPECIFIED FOR ALL X
C                        (4) DU(X,C)/DY+GAMA*U(X,C),U(X,D) ARE
C                            SPECIFIED FOR ALL X
C
C USAGE                  CALL SEPELI (INTL,IORDER,A,B,M,MBDCND,BDA,
C                                     ALPHA,BDB,BETA,C,D,N,NBDCND,BDC,
C                                     GAMA,BDD,XNU,COFX,COFY,GRHS,USOL,
C                                     IDMN,W,PERTRB,IERROR)
C
C ARGUMENTS
C ON INPUT               INTL
C                          = 0 ON INITIAL ENTRY TO SEPELI OR IF ANY
C                              OF THE ARGUMENTS C,D, N, NBDCND, COFY
C                              ARE CHANGED FROM A PREVIOUS CALL
C                          = 1 IF C, D, N, NBDCND, COFY ARE UNCHANGED
C                              FROM THE PREVIOUS CALL.
C
C                        IORDER
C                          = 2 IF A SECOND-ORDER APPROXIMATION
C                              IS SOUGHT
C                          = 4 IF A FOURTH-ORDER APPROXIMATION
C                              IS SOUGHT
C
C                        A,B
C                          THE RANGE OF THE X-INDEPENDENT VARIABLE,
C                          I.E., X IS GREATER THAN OR EQUAL TO A
C                          AND LESS THAN OR EQUAL TO B.  A MUST BE
C                          LESS THAN B.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL [A,B] IS SUBDIVIDED. HENCE,
C                          THERE WILL BE M+1 GRID POINTS IN THE X-
C                          DIRECTION GIVEN BY XI=A+(I-1)*DLX
C                          FOR I=1,2,...,M+1 WHERE DLX=(B-A)/M IS
C                          THE PANEL WIDTH.  M MUST BE LESS THAN
C                          IDMN AND GREATER THAN 5.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT X=A AND X=B
C
C                          = 0 IF THE SOLUTION IS PERIODIC IN X, I.E.,
C                              U(X+B-A,Y)=U(X,Y)  FOR ALL Y,X
C                          = 1 IF THE SOLUTION IS SPECIFIED AT X=A
C                              AND X=B, I.E., U(A,Y) AND U(B,Y) ARE
C                              SPECIFIED FOR ALL Y
C                          = 2 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              THE BOUNDARY CONDITION IS MIXED AT X=B,
C                              I.E., U(A,Y) AND DU(B,Y)/DX+BETA*U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C                          = 3 IF THE BOUNDARY CONDITIONS AT X=A AND
C                              X=B ARE MIXED, I.E.,
C                              DU(A,Y)/DX+ALPHA*U(A,Y) AND
C                              DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED
C                              FOR ALL Y
C                          = 4 IF THE BOUNDARY CONDITION AT X=A IS
C                              MIXED AND THE SOLUTION IS SPECIFIED
C                              AT X=B, I.E., DU(A,Y)/DX+ALPHA*U(A,Y)
C                              AND U(B,Y) ARE SPECIFIED FOR ALL Y
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1
C                          THAT SPECIFIES THE VALUES OF
C                          DU(A,Y)/DX+ ALPHA*U(A,Y) AT X=A, WHEN
C                          MBDCND=3 OR 4.
C                          BDA(J) = DU(A,YJ)/DX+ALPHA*U(A,YJ),
C                          J=1,2,...,N+1. WHEN MBDCND HAS ANY OTHER
C                          OTHER VALUE, BDA IS A DUMMY PARAMETER.
C
C                        ALPHA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN
C                          CASE OF A MIXED BOUNDARY CONDITION AT X=A
C                          (SEE ARGUMENT BDA).  IF MBDCND IS NOT
C                          EQUAL TO 3 OR 4 THEN ALPHA IS A DUMMY
C                          PARAMETER.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1
C                          THAT SPECIFIES THE VALUES OF
C                          DU(B,Y)/DX+ BETA*U(B,Y) AT X=B.
C                          WHEN MBDCND=2 OR 3
C                          BDB(J) = DU(B,YJ)/DX+BETA*U(B,YJ),
C                          J=1,2,...,N+1. WHEN MBDCND HAS ANY OTHER
C                          OTHER VALUE, BDB IS A DUMMY PARAMETER.
C
C                        BETA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN
C                          CASE OF A MIXED BOUNDARY CONDITION AT
C                          X=B (SEE ARGUMENT BDB).  IF MBDCND IS
C                          NOT EQUAL TO 2 OR 3 THEN BETA IS A DUMMY
C                          PARAMETER.
C
C                        C,D
C                          THE RANGE OF THE Y-INDEPENDENT VARIABLE,
C                          I.E., Y IS GREATER THAN OR EQUAL TO C
C                          AND LESS THAN OR EQUAL TO D.  C MUST BE
C                          LESS THAN D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL [C,D] IS SUBDIVIDED.
C                          HENCE, THERE WILL BE N+1 GRID POINTS
C                          IN THE Y-DIRECTION GIVEN BY
C                          YJ=C+(J-1)*DLY FOR J=1,2,...,N+1 WHERE
C                          DLY=(D-C)/N IS THE PANEL WIDTH.
C                          IN ADDITION, N MUST BE GREATER THAN 4.
C
C                        NBDCND
C                          INDICATES THE TYPES OF BOUNDARY CONDITIONS
C                          AT Y=C AND Y=D
C
C                          = 0 IF THE SOLUTION IS PERIODIC IN Y,
C                              I.E., U(X,Y+D-C)=U(X,Y)  FOR ALL X,Y
C                          = 1 IF THE SOLUTION IS SPECIFIED AT Y=C
C                              AND Y = D, I.E., U(X,C) AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C                          = 2 IF THE SOLUTION IS SPECIFIED AT Y=C
C                              AND THE BOUNDARY CONDITION IS MIXED
C                              AT Y=D, I.E., U(X,C) AND
C                              DU(X,D)/DY+XNU*U(X,D) ARE SPECIFIED
C                              FOR ALL X
C                          = 3 IF THE BOUNDARY CONDITIONS ARE MIXED
C                              AT Y=C AND Y=D, I.E.,
C                              DU(X,D)/DY+GAMA*U(X,C) AND
C                              DU(X,D)/DY+XNU*U(X,D) ARE SPECIFIED
C                              FOR ALL X
C                          = 4 IF THE BOUNDARY CONDITION IS MIXED
C                              AT Y=C AND THE SOLUTION IS SPECIFIED
C                              AT Y=D, I.E. DU(X,C)/DY+GAMA*U(X,C)
C                              AND U(X,D) ARE SPECIFIED FOR ALL X
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1
C                          THAT SPECIFIES THE VALUE OF
C                          DU(X,C)/DY+GAMA*U(X,C) AT Y=C.
C                          WHEN NBDCND=3 OR 4 BDC(I) = DU(XI,C)/DY +
C                          GAMA*U(XI,C), I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC
C                          IS A DUMMY PARAMETER.
C
C                        GAMA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN
C                          CASE OF A MIXED BOUNDARY CONDITION AT
C                          Y=C (SEE ARGUMENT BDC).  IF NBDCND IS
C                          NOT EQUAL TO 3 OR 4 THEN GAMA IS A DUMMY
C                          PARAMETER.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1
C                          THAT SPECIFIES THE VALUE OF
C                          DU(X,D)/DY + XNU*U(X,D) AT Y=C.
C                          WHEN NBDCND=2 OR 3 BDD(I) = DU(XI,D)/DY +
C                          XNU*U(XI,D), I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD
C                          IS A DUMMY PARAMETER.
C
C                        XNU
C                          THE SCALAR MULTIPLYING THE SOLUTION IN
C                          CASE OF A MIXED BOUNDARY CONDITION AT
C                          Y=D (SEE ARGUMENT BDD).  IF NBDCND IS
C                          NOT EQUAL TO 2 OR 3 THEN XNU IS A
C                          DUMMY PARAMETER.
C
C                        COFX
C                          A USER-SUPPLIED SUBPROGRAM WITH
C                          PARAMETERS X, AFUN, BFUN, CFUN WHICH
C                          RETURNS THE VALUES OF THE X-DEPENDENT
C                          COEFFICIENTS AF(X), BF(X), CF(X) IN THE
C                          ELLIPTIC EQUATION AT X.
C
C                        COFY
C                          A USER-SUPPLIED SUBPROGRAM WITH PARAMETERS
C                          Y, DFUN, EFUN, FFUN WHICH RETURNS THE
C                          VALUES OF THE Y-DEPENDENT COEFFICIENTS
C                          DF(Y), EF(Y), FF(Y) IN THE ELLIPTIC
C                          EQUATION AT Y.
C
C                          NOTE:  COFX AND COFY MUST BE DECLARED
C                          EXTERNAL IN THE CALLING ROUTINE.
C                          THE VALUES RETURNED IN AFUN AND DFUN
C                          MUST SATISFY AFUN*DFUN GREATER THAN 0
C                          FOR A LESS THAN X LESS THAN B, C LESS
C                          THAN Y LESS THAN D (SEE IERROR=10).
C                          THE COEFFICIENTS PROVIDED MAY LEAD TO A
C                          MATRIX EQUATION WHICH IS NOT DIAGONALLY
C                          DOMINANT IN WHICH CASE SOLUTION MAY FAIL
C                          (SEE IERROR=4).
C
C                        GRHS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT-HAND SIDE OF THE
C                          ELLIPTIC EQUATION, I.E.,
C                          GRHS(I,J)=G(XI,YI), FOR I=2,...,M,
C                          J=2,...,N.  AT THE BOUNDARIES, GRHS IS
C                          DEFINED BY
C
C                          MBDCND   GRHS(1,J)   GRHS(M+1,J)
C                          ------   ---------   -----------
C                            0      G(A,YJ)     G(B,YJ)
C                            1         *           *
C                            2         *        G(B,YJ)  J=1,2,...,N+1
C                            3      G(A,YJ)     G(B,YJ)
C                            4      G(A,YJ)        *
C
C                          NBDCND   GRHS(I,1)   GRHS(I,N+1)
C                          ------   ---------   -----------
C                            0      G(XI,C)     G(XI,D)
C                            1         *           *
C                            2         *        G(XI,D)  I=1,2,...,M+1
C                            3      G(XI,C)     G(XI,D)
C                            4      G(XI,C)        *
C
C                          WHERE * MEANS THESE QUANTITIES ARE NOT USED.
C                          GRHS SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        USOL
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE SOLUTION ALONG THE BOUNDARIES.
C                          AT THE BOUNDARIES, USOL IS DEFINED BY
C
C                          MBDCND   USOL(1,J)   USOL(M+1,J)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(A,YJ)     U(B,YJ)
C                            2      U(A,YJ)        *     J=1,2,...,N+1
C                            3         *           *
C                            4         *        U(B,YJ)
C
C                          NBDCND   USOL(I,1)   USOL(I,N+1)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(XI,C)     U(XI,D)
C                            2      U(XI,C)        *     I=1,2,...,M+1
C                            3         *           *
C                            4         *        U(XI,D)
C
C                          WHERE * MEANS THE QUANTITIES ARE NOT USED
C                          IN THE SOLUTION.
C
C                          IF IORDER=2, THE USER MAY EQUIVALENCE GRHS
C                          AND USOL TO SAVE SPACE.  NOTE THAT IN THIS
C                          CASE THE TABLES SPECIFYING THE BOUNDARIES
C                          OF THE GRHS AND USOL ARRAYS DETERMINE THE
C                          BOUNDARIES UNIQUELY EXCEPT AT THE CORNERS.
C                          IF THE TABLES CALL FOR BOTH G(X,Y) AND
C                          U(X,Y) AT A CORNER THEN THE SOLUTION MUST
C                          BE CHOSEN.  FOR EXAMPLE, IF MBDCND=2 AND
C                          NBDCND=4, THEN U(A,C), U(A,D), U(B,D) MUST
C                          BE CHOSEN AT THE CORNERS IN ADDITION
C                          TO G(B,C).
C
C                          IF IORDER=4, THEN THE TWO ARRAYS, USOL AND
C                          GRHS, MUST BE DISTINCT.
C
C                          USOL SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        IDMN
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAYS
C                          GRHS AND USOL AS IT APPEARS IN THE PROGRAM
C                          CALLING SEPELI.  THIS PARAMETER IS USED
C                          TO SPECIFY THE VARIABLE DIMENSION OF GRHS
C                          AND USOL.  IDMN MUST BE AT LEAST 7 AND
C                          GREATER THAN OR EQUAL TO M+1.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          LET K=INT(LOG2(N+1))+1 AND SET L=2**(K+1).
C                          THEN (K-2)*L+K+10*N+12*M+27 WILL SUFFICE
C                          AS A LENGTH OF W.  THE ACTUAL LENGTH OF W
C                          IN THE CALLING ROUTINE MUST BE SET IN W(1)
C                          (SEE IERROR=11).
C
C ON OUTPUT              USOL
C                          CONTAINS THE APPROXIMATE SOLUTION TO THE
C                          ELLIPTIC EQUATION.
C                          USOL(I,J) IS THE APPROXIMATION TO U(XI,YJ)
C                          FOR I=1,2...,M+1 AND J=1,2,...,N+1.
C                          THE APPROXIMATION HAS ERROR
C                          O(DLX**2+DLY**2) IF CALLED WITH IORDER=2
C                          AND O(DLX**4+DLY**4) IF CALLED WITH
C                          IORDER=4.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT
C                          BE DESTROYED IF SEPELI IS CALLED AGAIN WITH
C                          INTL=1.  IN ADDITION W(1) CONTAINS THE
C                          EXACT MINIMAL LENGTH (IN FLOATING POINT)
C                          REQUIRED FOR THE WORK SPACE (SEE IERROR=11).
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                          BOUNDARY CONDITIONS
C                          (I.E., ALPHA=BETA=0 IF MBDCND=3;
C                          GAMA=XNU=0 IF NBDCND=3) IS SPECIFIED
C                          AND IF THE COEFFICIENTS OF U(X,Y) IN THE
C                          SEPARABLE ELLIPTIC EQUATION ARE ZERO
C                          (I.E., CF(X)=0 FOR X GREATER THAN OR EQUAL
C                          TO A AND LESS THAN OR EQUAL TO B;
C                          FF(Y)=0 FOR Y GREATER THAN OR EQUAL TO C
C                          AND LESS THAN OR EQUAL TO D) THEN A
C                          SOLUTION MAY NOT EXIST.  PERTRB IS A
C                          CONSTANT CALCULATED AND SUBTRACTED FROM
C                          THE RIGHT-HAND SIDE OF THE MATRIX EQUATIONS
C                          GENERATED BY SEPELI WHICH INSURES THAT A
C                          SOLUTION EXISTS. SEPELI THEN COMPUTES THIS
C                          SOLUTION WHICH IS A WEIGHTED MINIMAL LEAST
C                          SQUARES SOLUTION TO THE ORIGINAL PROBLEM.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS OR FAILURE TO FIND A SOLUTION
C                          = 0 NO ERROR
C                          = 1 IF A GREATER THAN B OR C GREATER THAN D
C                          = 2 IF MBDCND LESS THAN 0 OR MBDCND GREATER
C                              THAN 4
C                          = 3 IF NBDCND LESS THAN 0 OR NBDCND GREATER
C                              THAN 4
C                          = 4 IF ATTEMPT TO FIND A SOLUTION FAILS.
C                              (THE LINEAR SYSTEM GENERATED IS NOT
C                              DIAGONALLY DOMINANT.)
C                          = 5 IF IDMN IS TOO SMALL
C                              (SEE DISCUSSION OF IDMN)
C                          = 6 IF M IS TOO SMALL OR TOO LARGE
C                              (SEE DISCUSSION OF M)
C                          = 7 IF N IS TOO SMALL (SEE DISCUSSION OF N)
C                          = 8 IF IORDER IS NOT 2 OR 4
C                          = 9 IF INTL IS NOT 0 OR 1
C                          = 10 IF AFUN*DFUN LESS THAN OR EQUAL TO 0
C                               FOR SOME INTERIOR MESH POINT (XI,YJ)
C                          = 11 IF THE WORK SPACE LENGTH INPUT IN W(1)
C                               IS LESS THAN THE EXACT MINIMAL WORK
C                               SPACE LENGTH REQUIRED OUTPUT IN W(1).
C
C                          NOTE (CONCERNING IERROR=4):  FOR THE
C                          COEFFICIENTS INPUT THROUGH COFX, COFY,
C                          THE DISCRETIZATION MAY LEAD TO A BLOCK
C                          TRIDIAGONAL LINEAR SYSTEM WHICH IS NOT
C                          DIAGONALLY DOMINANT (FOR EXAMPLE, THIS
C                          HAPPENS IF CFUN=0 AND BFUN/(2.*DLX) GREATER
C                          THAN AFUN/DLX**2).  IN THIS CASE SOLUTION
C                          MAY FAIL.  THIS CANNOT HAPPEN IN THE LIMIT
C                          AS DLX, DLY APPROACH ZERO.  HENCE, THE
C                          CONDITION MAY BE REMEDIED BY TAKING LARGER
C                          VALUES FOR M OR N.
C
C SPECIAL CONDITIONS     SEE COFX, COFY ARGUMENT DESCRIPTIONS ABOVE.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       BLKTRI, COMF, AND SEPAUX
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                DEVELOPED AT NCAR DURING 1975-76 BY
C                        JOHN C. ADAMS OF THE SCIENTIFIC COMPUTING
C                        DIVISION.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              SEPELI AUTOMATICALLY DISCRETIZES THE
C                        SEPARABLE ELLIPTIC EQUATION WHICH IS THEN
C                        SOLVED BY A GENERALIZED CYCLIC REDUCTION
C                        ALGORITHM IN THE SUBROUTINE, BLKTRI.  THE
C                        FOURTH-ORDER SOLUTION IS OBTAINED USING
C                        'DEFERRED CORRECTIONS' WHICH IS DESCRIBED
C                        AND REFERENCED IN SECTIONS, REFERENCES AND
C                        METHOD.
C
C TIMING                 THE OPERATIONAL COUNT IS PROPORTIONAL TO
C                        M*N*LOG2(N).
C
C ACCURACY               THE FOLLOWING ACCURACY RESULTS WERE OBTAINED
C                        ON A CDC 7600.  NOTE THAT THE FOURTH-ORDER
C                        ACCURACY IS NOT REALIZED UNTIL THE MESH IS
C                        SUFFICIENTLY REFINED.
C
C                                     SECOND-ORDER  FOURTH-ORDER
C                            M    N     ERROR         ERROR
C
C                             6    6    6.8E-1        1.2E0
C                            14   14    1.4E-1        1.8E-1
C                            30   30    3.2E-2        9.7E-3
C                            62   62    7.5E-3        3.0E-4
C                           126  126    1.8E-3        3.5E-6
C
C
C REFERENCES             KELLER, H.B., NUMERICAL METHODS FOR TWO-POINT
C                        BOUNDARY-VALUE PROBLEMS, BLAISDEL (1968),
C                        WALTHAM, MASS.
C
C                        SWARZTRAUBER, P., AND R. SWEET (1975):
C                        EFFICIENT FORTRAN SUBPROGRAMS FOR THE
C                        SOLUTION OF ELLIPTIC PARTIAL DIFFERENTIAL
C                        EQUATIONS.  NCAR TECHNICAL NOTE
C                        NCAR-TN/IA-109, PP. 135-137.
C***********************************************************************
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
      EXTERNAL        COFX       ,COFY
C
C     CHECK INPUT PARAMETERS
C
      CALL CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,COFY,
     1             IDMN,IERROR)
      IF (IERROR .NE. 0) RETURN
C
C     COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT
C
      L = N+1
      IF (NBDCND .EQ. 0) L = N
      LOGB2N = INT(ALOG(FLOAT(L)+0.5)/ALOG(2.0))+1
      LL = 2**(LOGB2N+1)
      K = M+1
      L = N+1
      LENGTH = (LOGB2N-2)*LL+LOGB2N+MAX0(2*L,6*K)+5
      IF (NBDCND .EQ. 0) LENGTH = LENGTH+2*L
      IERROR = 11
      LINPUT = INT(W(1)+0.5)
      LOUTPT = LENGTH+6*(K+L)+1
      W(1) = FLOAT(LOUTPT)
      IF (LOUTPT .GT. LINPUT) RETURN
      IERROR = 0
C
C     SET WORK SPACE INDICES
C
      I1 = LENGTH+2
      I2 = I1+L
      I3 = I2+L
      I4 = I3+L
      I5 = I4+L
      I6 = I5+L
      I7 = I6+L
      I8 = I7+K
      I9 = I8+K
      I10 = I9+K
      I11 = I10+K
      I12 = I11+K
      I13 = 2
      CALL SPELIP (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1             NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),
     3             W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR)
      RETURN
      END
      SUBROUTINE SPELIP (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,
     1                   D,N,NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,AN,BN,
     2                   CN,DN,UN,ZN,AM,BM,CM,DM,UM,ZM,GRHS,USOL,IDMN,
     3                   W,PERTRB,IERROR)
C
C     SPELIP SETS UP VECTORS AND ARRAYS FOR INPUT TO BLKTRI
C     AND COMPUTES A SECOND ORDER SOLUTION IN USOL.  A RETURN JUMP TO
C     SEPELI OCCURRS IF IORDER=2.  IF IORDER=4 A FOURTH ORDER
C     SOLUTION IS GENERATED IN USOL.
C
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,DN(*)      ,
     1                UN(*)      ,ZN(*)
      DIMENSION       AM(*)      ,BM(*)      ,CM(*)      ,DM(*)      ,
     1                UM(*)      ,ZM(*)
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      LOGICAL         SINGLR
      EXTERNAL        COFX       ,COFY
C
C     SET PARAMETERS INTERNALLY
C
      KSWX = MBDCND+1
      KSWY = NBDCND+1
      K = M+1
      L = N+1
      AIT = A
      BIT = B
      CIT = C
      DIT = D
C
C     SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR
C     AND NON-SPECIFIED BOUNDARIES.
C
      DO  20 I=2,M
         DO  10 J=2,N
            USOL(I,J) = GRHS(I,J)
   10    CONTINUE
   20 CONTINUE
      IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO  40
      DO  30 J=2,N
         USOL(1,J) = GRHS(1,J)
   30 CONTINUE
   40 CONTINUE
      IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO  60
      DO  50 J=2,N
         USOL(K,J) = GRHS(K,J)
   50 CONTINUE
   60 CONTINUE
      IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO  80
      DO  70 I=2,M
         USOL(I,1) = GRHS(I,1)
   70 CONTINUE
   80 CONTINUE
      IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100
      DO  90 I=2,M
         USOL(I,L) = GRHS(I,L)
   90 CONTINUE
  100 CONTINUE
      IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3)
     1    USOL(1,1) = GRHS(1,1)
      IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3)
     1    USOL(K,1) = GRHS(K,1)
      IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5)
     1    USOL(1,L) = GRHS(1,L)
      IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5)
     1    USOL(K,L) = GRHS(K,L)
      I1 = 1
C
C     SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES
C
      MP = 1
      NP = 1
      IF (KSWX .EQ. 1) MP = 0
      IF (KSWY .EQ. 1) NP = 0
C
C     SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED
C     IN NINT,MINT
C
      DLX = (BIT-AIT)/FLOAT(M)
      MIT = K-1
      IF (KSWX .EQ. 2) MIT = K-2
      IF (KSWX .EQ. 4) MIT = K
      DLY = (DIT-CIT)/FLOAT(N)
      NIT = L-1
      IF (KSWY .EQ. 2) NIT = L-2
      IF (KSWY .EQ. 4) NIT = L
      TDLX3 = 2.0*DLX**3
      DLX4 = DLX**4
      TDLY3 = 2.0*DLY**3
      DLY4 = DLY**4
C
C     SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI
C
      IS = 1
      JS = 1
      IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2
      IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2
      NS = NIT+JS-1
      MS = MIT+IS-1
C
C     SET X - DIRECTION
C
      DO 110 I=1,MIT
         XI = AIT+FLOAT(IS+I-2)*DLX
         CALL COFX (XI,AI,BI,CI)
         AXI = (AI/DLX-0.5*BI)/DLX
         BXI = -2.*AI/DLX**2+CI
         CXI = (AI/DLX+0.5*BI)/DLX
         AM(I) = AXI
         BM(I) = BXI
         CM(I) = CXI
  110 CONTINUE
C
C     SET Y DIRECTION
C
      DO 120 J=1,NIT
         YJ = CIT+FLOAT(JS+J-2)*DLY
         CALL COFY (YJ,DJ,EJ,FJ)
         DYJ = (DJ/DLY-0.5*EJ)/DLY
         EYJ = (-2.*DJ/DLY**2+FJ)
         FYJ = (DJ/DLY+0.5*EJ)/DLY
         AN(J) = DYJ
         BN(J) = EYJ
         CN(J) = FYJ
  120 CONTINUE
C
C     ADJUST EDGES IN X DIRECTION UNLESS PERIODIC
C
      AX1 = AM(1)
      CXM = CM(MIT)
      GO TO (170,130,150,160,140),KSWX
C
C     DIRICHLET-DIRICHLET IN X DIRECTION
C
  130 AM(1) = 0.0
      CM(MIT) = 0.0
      GO TO 170
C
C     MIXED-DIRICHLET IN X DIRECTION
C
  140 AM(1) = 0.0
      BM(1) = BM(1)+2.*ALPHA*DLX*AX1
      CM(1) = CM(1)+AX1
      CM(MIT) = 0.0
      GO TO 170
C
C     DIRICHLET-MIXED IN X DIRECTION
C
  150 AM(1) = 0.0
      AM(MIT) = AM(MIT)+CXM
      BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM

      CM(MIT) = 0.0
      GO TO 170
C
C     MIXED - MIXED IN X DIRECTION
C
  160 CONTINUE
      AM(1) = 0.0
      BM(1) = BM(1)+2.*DLX*ALPHA*AX1
      CM(1) = CM(1)+AX1
      AM(MIT) = AM(MIT)+CXM
      BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM
      CM(MIT) = 0.0
  170 CONTINUE
C
C     ADJUST IN Y DIRECTION UNLESS PERIODIC
C
      DY1 = AN(1)
      FYN = CN(NIT)
      GO TO (220,180,200,210,190),KSWY
C
C     DIRICHLET-DIRICHLET IN Y DIRECTION
C
  180 CONTINUE
      AN(1) = 0.0
      CN(NIT) = 0.0
      GO TO 220
C
C     MIXED-DIRICHLET IN Y DIRECTION
C
  190 CONTINUE
      AN(1) = 0.0
      BN(1) = BN(1)+2.*DLY*GAMA*DY1
      CN(1) = CN(1)+DY1
      CN(NIT) = 0.0
      GO TO 220
C
C     DIRICHLET-MIXED IN Y DIRECTION
C
  200 AN(1) = 0.0
      AN(NIT) = AN(NIT)+FYN
      BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN
      CN(NIT) = 0.0
      GO TO 220
C
C     MIXED - MIXED DIRECTION IN Y DIRECTION
C
  210 CONTINUE
      AN(1) = 0.0
      BN(1) = BN(1)+2.*DLY*GAMA*DY1
      CN(1) = CN(1)+DY1
      AN(NIT) = AN(NIT)+FYN
      BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN
      CN(NIT) = 0.0
  220 IF (KSWX .EQ. 1) GO TO 270
C
C     ADJUST USOL ALONG X EDGE
C
      DO 260 J=JS,NS
         IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230
         USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J)
         GO TO 240
  230    USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J)
  240    IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250
         USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J)
         GO TO 260
  250    USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J)
  260 CONTINUE
  270 IF (KSWY .EQ. 1) GO TO 320
C
C     ADJUST USOL ALONG Y EDGE
C
      DO 310 I=IS,MS
         IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280
         USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1)
         GO TO 290
  280    USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I)
  290    IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300
         USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L)
         GO TO 310
  300    USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I)
  310 CONTINUE
  320 CONTINUE
C
C     SAVE ADJUSTED EDGES IN GRHS IF IORDER=4
C
      IF (IORDER .NE. 4) GO TO 350
      DO 330 J=JS,NS
         GRHS(IS,J) = USOL(IS,J)
         GRHS(MS,J) = USOL(MS,J)
  330 CONTINUE
      DO 340 I=IS,MS
         GRHS(I,JS) = USOL(I,JS)
         GRHS(I,NS) = USOL(I,NS)
  340 CONTINUE
  350 CONTINUE
      IORD = IORDER
      PERTRB = 0.0
C
C     CHECK IF OPERATOR IS SINGULAR
C
      CALL CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,SINGLR)
C
C     COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE
C     IF SINGULAR
C
      IF (SINGLR) CALL SEPTRI (MIT,AM,BM,CM,DM,UM,ZM)
      IF (SINGLR) CALL SEPTRI (NIT,AN,BN,CN,DN,UN,ZN)
C
C     MAKE INITIALIZATION CALL TO BLKTRI
C
      IF (INTL .EQ. 0)
     1    CALL BLKTRI (INTL,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,
     2                 USOL(IS,JS),IERROR,W)
      IF (IERROR .NE. 0) RETURN
C
C     ADJUST RIGHT HAND SIDE IF NECESSARY
C
  360 CONTINUE
      IF (SINGLR) CALL SEPORT (USOL,IDMN,ZN,ZM,PERTRB)
C
C     COMPUTE SOLUTION
C
      CALL BLKTRI (I1,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS),
     1             IERROR,W)
      IF (IERROR .NE. 0) RETURN
C
C     SET PERIODIC BOUNDARIES IF NECESSARY
C
      IF (KSWX .NE. 1) GO TO 380
      DO 370 J=1,L
         USOL(K,J) = USOL(1,J)
  370 CONTINUE
  380 IF (KSWY .NE. 1) GO TO 400
      DO 390 I=1,K
         USOL(I,L) = USOL(I,1)
  390 CONTINUE
  400 CONTINUE
C
C     MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES
C     NORM IF OPERATOR IS SINGULAR
C
      IF (SINGLR) CALL SEPMIN (USOL,IDMN,ZN,ZM,PRTRB)
C
C     RETURN IF DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE
C     NOT FLAGGED
C
      IF (IORD .EQ. 2) RETURN
      IORD = 2
C
C     COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION
C
      CALL DEFER (COFX,COFY,IDMN,USOL,GRHS)
      GO TO 360
      END
      SUBROUTINE CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,
     1                   COFY,IDMN,IERROR)
C
C     THIS PROGRAM CHECKS THE INPUT PARAMETERS FOR ERRORS
C
      EXTERNAL        COFX       ,COFY
C
C     CHECK DEFINITION OF SOLUTION REGION
C
      IERROR = 1
      IF (A.GE.B .OR. C.GE.D) RETURN
C
C     CHECK BOUNDARY SWITCHES
C
      IERROR = 2
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN
      IERROR = 3
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN
C
C     CHECK FIRST DIMENSION IN CALLING ROUTINE
C
      IERROR = 5
      IF (IDMN .LT. 7) RETURN
C
C     CHECK M
C
      IERROR = 6
      IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN
C
C     CHECK N
C
      IERROR = 7
      IF (N .LT. 5) RETURN
C
C     CHECK IORDER
C
      IERROR = 8
      IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN
C
C     CHECK INTL
C
      IERROR = 9
      IF (INTL.NE.0 .AND. INTL.NE.1) RETURN
C
C     CHECK THAT EQUATION IS ELLIPTIC
C
      DLX = (B-A)/FLOAT(M)
      DLY = (D-C)/FLOAT(N)
      DO  30 I=2,M
         XI = A+FLOAT(I-1)*DLX
         CALL COFX (XI,AI,BI,CI)
         DO  20 J=2,N
            YJ = C+FLOAT(J-1)*DLY
            CALL COFY (YJ,DJ,EJ,FJ)
            IF (AI*DJ .GT. 0.0) GO TO  10
            IERROR = 10
            RETURN
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
C
C     NO ERROR FOUND
C
      IERROR = 0
      RETURN
      END
      SUBROUTINE CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,
     1                   SINGLR)
C
C     THIS SUBROUTINE CHECKS IF THE PDE   SEPELI
C     MUST SOLVE IS A SINGULAR OPERATOR
C
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      LOGICAL         SINGLR
      SINGLR = .FALSE.
C
C     CHECK IF THE BOUNDARY CONDITIONS ARE
C     ENTIRELY PERIODIC AND/OR MIXED
C
      IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR.
     1    (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN
C
C     CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN
C
      IF (MBDCND .NE. 3) GO TO  10
      IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN
   10 IF (NBDCND .NE. 3) GO TO  20
      IF (GAMA.NE.0.0 .OR. XNU.NE.0.0) RETURN
   20 CONTINUE
C
C     CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS
C     ARE ZERO
C
      DO  30 I=IS,MS
         XI = AIT+FLOAT(I-1)*DLX
         CALL COFX (XI,AI,BI,CI)
         IF (CI .NE. 0.0) RETURN
   30 CONTINUE
      DO  40 J=JS,NS
         YJ = CIT+FLOAT(J-1)*DLY
         CALL COFY (YJ,DJ,EJ,FJ)
         IF (FJ .NE. 0.0) RETURN
   40 CONTINUE
C
C     THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED
C
      SINGLR = .TRUE.
      RETURN
      END
      SUBROUTINE DEFER (COFX,COFY,IDMN,USOL,GRHS)
C
C     THIS SUBROUTINE FIRST APPROXIMATES THE TRUNCATION ERROR GIVEN BY
C     TRUN1(X,Y)=DLX**2*TX+DLY**2*TY WHERE
C     TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 ON THE INTERIOR AND
C     AT THE BOUNDARIES IF PERIODIC(HERE UXXX,UXXXX ARE THE THIRD
C     AND FOURTH PARTIAL DERIVATIVES OF U WITH RESPECT TO X).
C     TX IS OF THE FORM AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX)
C     AT X=A OR X=B IF THE BOUNDARY CONDITION THERE IS MIXED.
C     TX=0.0 ALONG SPECIFIED BOUNDARIES.  TY HAS SYMMETRIC FORM
C     IN Y WITH X,AFUN(X),BFUN(X) REPLACED BY Y,DFUN(Y),EFUN(Y).
C     THE SECOND ORDER SOLUTION IN USOL IS USED TO APPROXIMATE
C     (VIA SECOND ORDER FINITE DIFFERENCING) THE TRUNCATION ERROR
C     AND THE RESULT IS ADDED TO THE RIGHT HAND SIDE IN GRHS
C     AND THEN TRANSFERRED TO USOL TO BE USED AS A NEW RIGHT
C     HAND SIDE WHEN CALLING BLKTRI FOR A FOURTH ORDER SOLUTION.
C
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      EXTERNAL        COFX       ,COFY
C
C     COMPUTE TRUNCATION ERROR APPROXIMATION OVER THE ENTIRE MESH
C
      DO  40 J=JS,NS
         YJ = CIT+FLOAT(J-1)*DLY
         CALL COFY (YJ,DJ,EJ,FJ)
         DO  30 I=IS,MS
            XI = AIT+FLOAT(I-1)*DLX
            CALL COFX (XI,AI,BI,CI)
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ)
C
            CALL SEPDX (USOL,IDMN,I,J,UXXX,UXXXX)
            CALL SEPDY (USOL,IDMN,I,J,UYYY,UYYYY)
            TX = AI*UXXXX/12.0+BI*UXXX/6.0
            TY = DJ*UYYYY/12.0+EJ*UYYY/6.0
C
C     RESET FORM OF TRUNCATION IF AT BOUNDARY WHICH IS NON-PERIODIC
C
            IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO  10
            TX = AI/3.0*(UXXXX/4.0+UXXX/DLX)
   10       IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO  20
            TY = DJ/3.0*(UYYYY/4.0+UYYY/DLY)
   20       GRHS(I,J) = GRHS(I,J)+DLX**2*TX+DLY**2*TY
   30    CONTINUE
   40 CONTINUE
C
C     RESET THE RIGHT HAND SIDE IN USOL
C
      DO  60 I=IS,MS
         DO  50 J=JS,NS
            USOL(I,J) = GRHS(I,J)
   50    CONTINUE
   60 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


C=======================================================================
C  SOLAR.for contains:
C     SOLAR  - Computes declination, solar time of sunrise and sunset,
C                daily solar constant and cloudiness factor.
C     DAYLEN - Computes solar day length
C     DECL   - Computes solar declination from day length
C=======================================================================

C=======================================================================
C  SOLAR, Subroutine, N.B. Pickering
C  Computes daily solar constant (Spitters, 1986) and cloudiness factor.
C-----------------------------------------------------------------------
C  REVISION HISTORY
C  12/02/1990 NBP Written
C  09/23/1993 NBP Separated DAYLEN function and created DECL to compute
C                  declination from DAYL.  Removed DOY effect on S0N.
C  03/15/2000 GH  Incorporated into modular CROPGRO
C-----------------------------------------------------------------------
C  Called by: WEATHR
C  Calls:     None
C=======================================================================

      SUBROUTINE SOLAR(
     &    DAYL, DEC, SRAD, XLAT,                          !Input
     &    CLOUDS, ISINB, S0N)                             !Output

!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL AMTRCS,AMTRD,CCOS,CLOUDS,DAYL,DEC,DSINB,ISINB,
     &  PI,RAD,SCLEAR,S0D,S0N,SC,SOC,SRAD,SRADJ,SSIN,XLAT
      PARAMETER (AMTRCS=0.77, PI = 3.14159, RAD = PI/180.0, SC=1368.0)

!-----------------------------------------------------------------------
C     Initialization
      SRADJ = SRAD * 1.0E6

C     Sun angles.  SOC limited for latitudes above polar circles.
      SSIN = SIN(RAD*DEC) * SIN(RAD*XLAT)
      CCOS = COS(RAD*DEC) * COS(RAD*XLAT)
      SOC = SSIN / CCOS
      SOC = MIN(MAX(SOC,-1.0),1.0)

C     Integral of SINB over day (sec) (Eqn. 18).
      DSINB = 3600.0 * (DAYL*SSIN + 24.0/PI*CCOS*SQRT(1.0-SOC**2))

C     Set normal (perp.) extra-terrestial radiation equal to
C     average solar constant (elliptical orbit ignored).
      S0N = SC

C     Calculate daily atmospheric transmission from global
C     and normal extra-terrestial radiation.
      S0D = S0N * DSINB
      AMTRD = SRADJ / S0D

C     Calculate clear sky radiation (0.77*S0D) in MJ.
      SCLEAR = AMTRCS * S0D * 1.E-6

C     Calculate daily cloudiness factor (range = 0-1).
      CLOUDS = MIN(MAX(1.0-SRAD/SCLEAR,0.0),1.0)

C     Integral in Eqn. 6 (used in HMET)
      ISINB = 3600.0 * (DAYL*(SSIN+0.4*(SSIN**2+0.5*CCOS**2)) +
     &  24.0/PI*CCOS*(1.0+1.5*0.4*SSIN)*SQRT(1.0-SOC**2))

      RETURN
      END SUBROUTINE SOLAR
C=======================================================================
!   SOLAR Variables
!-----------------------------------------------------------------------
! AMTRCS Fraction of radiation which reaches surface under clear sky
!          conditions
! AMTRD  Actual fraction of radiation which reaches surface
! CCOS   Product of cosines of declination and latitude
! CLOUDS Relative cloudiness factor (0-1)
! DAYL   Day length on day of simulation (from sunrise to sunset) (hr)
! DEC    Solar declination or (90o - solar elevation at noon). Amplitude =
!          +/- 23.45. Min = Dec. 21, Max = Jun 21/22 (deg.)
! DSINB  Integral of SINB over day (s)
! ISINB  Integral in Spitter's Equation 6
! PI     PI=3.14159 (rad)
! RAD    RAD=PI/180. (rad./deg.)
! S0D    Daily extraterrestrial irradiance (MJ/m2-d)
! S0N    Normal extraterrestrial radiation (set equal to average solar
!          constant; elliptical orbit ignored) (J/m2-s)
! SC     Solar constant (J / m2 - s)
! SCLEAR Clear sky radiation (MJ / m2 - d)
! SOC    Sine over cosine (intermediate calculation)
! SRAD   Solar radiation (MJ/m2-d)
! SRADJ  Solar Radiation (J/m2-d)
! SSIN   Product of sines of declination and latitude
! XLAT   Latitude (deg.)
C=======================================================================

C=======================================================================
C  DAYLEN, Real Function, N.B. Pickering, 09/23/1993
C  Computes solar day length (Spitters, 1986).
!-----------------------------------------------------------------------
!  Called by: WEATHR
!  Calls:     None
C=======================================================================

      SUBROUTINE DAYLEN(
     &    DOY, XLAT,                                      !Input
     &    DAYL, DEC, SNDN, SNUP)                          !Output

!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER DOY
      REAL DEC,DAYL,PI,RAD,SOC,SNDN,SNUP,XLAT
      PARAMETER (PI=3.14159, RAD=PI/180.0)

!-----------------------------------------------------------------------
C     Calculation of declination of sun (Eqn. 16). Amplitude= +/-23.45
C     deg. Minimum = DOY 355 (DEC 21), maximum = DOY 172.5 (JUN 21/22).
      DEC = -23.45 * COS(2.0*PI*(DOY+10.0)/365.0)

C     Sun angles.  SOC limited for latitudes above polar circles.
      SOC = TAN(RAD*DEC) * TAN(RAD*XLAT)
      SOC = MIN(MAX(SOC,-1.0),1.0)

C     Calculate daylength, sunrise and sunset (Eqn. 17)
      DAYL = 12.0 + 24.0*ASIN(SOC)/PI
      SNUP = 12.0 - DAYL/2.0
      SNDN = 12.0 + DAYL/2.0

      RETURN
      END SUBROUTINE DAYLEN

C=======================================================================
! DAYLEN Variables
!-----------------------------------------------------------------------
! DAYL  Day length on day of simulation (from sunrise to sunset)  (hr)
! DEC   Solar declination or (90o - solar elevation at noon) (deg.)
! DOY   Day of year (d)
! PI    PI=3.14159 (rad)
! RAD   RAD=PI/180. (rad./deg.)
! SNDN  Time of sunset (hr)
! SNUP  Time of sunrise (hr)
! SOC   Sine over cosine (intermediate calculation)
! XLAT  Latitude (deg.)
C=======================================================================

C=======================================================================
C  DECL, Real Function, N.B. Pickering, 09/23/1993
C  Computes solar declination from day length (Spitters, 1986).
!-----------------------------------------------------------------------
!  Called by: WTHMOD
!  Calls:     None
!-----------------------------------------------------------------------
C  Input : DAYL,XLAT
C  Output: DECL
C  Local : DL,PI,RAD,SC,XLAT1
C=======================================================================

      REAL FUNCTION DECL(DAYL,XLAT)

!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL DAYL,DL,PI,RAD,SC,XLAT1,XLAT
      PARAMETER (PI=3.14159, RAD=PI/180.0)

!-----------------------------------------------------------------------
C     Limit value of XLAT and DL to prevent zeros.

      IF (XLAT .GE. 0.0 .AND. XLAT .LT. 0.1) THEN
        XLAT1 = 0.1
        DL = 12.00573
      ELSE IF (XLAT .LT. 0.0 .AND. XLAT .GT. -0.1) THEN
        XLAT1 = -0.1
        DL = 11.99427
      ELSE
        DL = DAYL
        XLAT1 = XLAT
      ENDIF

C     Calculation of declination of sun.

      SC = SIN((DL-12.0)/24.0*PI)
      XLAT1 = TAN(RAD*XLAT1)
      DECL = ATAN(SC/XLAT1) / RAD

      RETURN
      END FUNCTION DECL

C=======================================================================
! DECL Variables
!-----------------------------------------------------------------------
! DAYL   Day length (from sunrise to sunset) (hr)
! DECL   Solar declination function subroutine (deg.)
! DL     Day length (hr)
! PI    PI=3.14159 (rad)
! RAD   RAD=PI/180. (rad./deg.)
! SC     Solar constant (J / m2 - s)
! XLAT1  Latitude (deg.)
! XLAT   Latitude (deg.)
C=======================================================================

C=======================================================================
C  TWILIGHT, Subroutine - from daylength calculations used in Maize and
C     Rice routines.
C  Computes twilight to twilight day length
C  Civil twilight: the geometric centre of the sun is relative to the horizon, -6 degrees
!-----------------------------------------------------------------------
!  Called by: WEATHR
!  Calls:     None
C=======================================================================

      SUBROUTINE TWILIGHT(DOY, XLAT, TWILEN)

!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER DOY
      REAL C1, DEC, DLV, PI, RAD, S1, TWILEN, XLAT
      PARAMETER (PI=3.14159, RAD=PI/180.0)

!-----------------------------------------------------------------------
      !TWILEN is Twilight to Twilight daylength

      S1 = SIN(XLAT*0.01745)
      C1 = COS(XLAT*0.01745)
      DEC    = 0.4093*SIN(0.0172*(DOY-82.2))
      DLV    = ((-S1*SIN(DEC)-0.1047)/(C1*COS(DEC)))
      DLV    = AMAX1 (DLV,-0.87)
      TWILEN = 7.639*ACOS(DLV)

      RETURN
      END SUBROUTINE TWILIGHT
C=======================================================================


module constants
  real(kind=8), parameter :: pi=3.14159
  real(kind=8), parameter :: Mpc_in_m=3.086d22
  real(kind=8), parameter :: Msol_in_kg=1.989d30
  real(kind=8), parameter :: kms_in_ms=1000.
  real(kind=8), parameter :: lunit=1d-3,vunit=1,munit=1.d10
  real(kind=8), parameter :: gmks=6.67d-11
  !  real(kind=8), parameter ::
  real(kind=8), parameter :: ggdt=gmks*(munit*Msol_in_kg)/(lunit*Mpc_in_m)/(vunit*kms_in_ms)/(vunit*kms_in_ms)
  real(kind=8), parameter :: kb=1.38d-23  ! Boltzmann constant in MKS
  real(kind=8), parameter :: mp=1.67d-27  ! Proton mass in kg
  real(kind=8), parameter :: gamma=5./3.
  real(kind=8), parameter :: u_to_temp=((gamma-1)*mp/kb)*(kms_in_ms)**2
  real(kind=8), parameter :: joules_to_ergs=1d7
  real(kind=8), parameter :: rhocrit0=27.755d-9 ! Critical density at z=0
  real(kind=8) :: molecular_weight
  real(kind=8), parameter :: deltavir=200.!101.14
end module constants


program calc
use calculates
implicit none

real(kind=8) :: x, fx, error, true
integer:: n

x = -2.0d0
n = 8
call taylor (x,n,fx)

write(*,*) "done: ", fx

true = 0.135335283236613
true = rounded(true)

error = rounded((true - fx) / true)
error = dabs(error)

write(*,*) "error: ", error

end program calc