! =================================================================================================
! =================================================================================================
! ==========================                                           ============================
! ==========================      Zernike Polynomial Evaluation        ============================
! ==========================                                           ============================
! =================================================================================================
! =================================================================================================
!
! Author: Christopher A. Wong
! Date: 18 February 2016
! Source format: Fortran 2008
!
! This module contains procedures to evaluate the Zernike polynomials on the unit disk.
!
! Dependencies: LAPACK
!
! Externally called procedures:
!   zern_eval       --- Main Zernike polynomial evaluation routine. Call this externally.
!   zern_buildpars  --- Builds all parameters needed to call the main routine. Call first.
!   zern_bquad      --- Computes Zernike matrix for bilinear quadrature computations.
!
! Internal procedures:
!   getnumrad       --- Computes the number of radial polynomials.
!   Kconst          --- Computes recursive constants for q-recursive algorithm.
!   buildK          --- Builds all recursive constants.
!   idxwrap         --- Computes linear index of R(m,n)
!   idxwrap2        --- Computes linear index of Z(m,n)
!   shiftdown       --- Computes linear index of R(n,n+2)
!   cart_to_polar   --- Conversion from cartesian to polar.
!   Radial_eval     --- Evaluates radial polynomials.
!
! =================================================================================================
!
! Usage:
!
! To evaluate Zernike polynomials up to a maximum degree d, first use
!
!       call zern_buildpars(d)
!
! to precompute the recursion coefficients needed to compute the polynomials. Then, given any sets
! of points x, you can use
!
!       call zern_eval(x,numpt,d,output)
!
! where 'numpt' is the number of cartesian points in x, to calculate the output array of polynomial
! evaluations. If you wish to calculate the Zernike polynomials up to a new maximum degree, you must
! run zern_buildpars again with the new value of d before you start evaluating.
! =================================================================================================

module zernike

implicit none
private

integer,    parameter                       :: dp = kind(1.0d0)
real(dp),   parameter                       :: pi = 4*atan(1.0d0)
integer                                     :: numrad, numfunc, maxdeg
real(dp),   dimension(:), allocatable       :: K1, K2, K3
save

public  :: zern_eval, zern_buildpars, zern_bquad

contains

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

! This outer subroutine evaluates all Zernike polynomials up to a degree 'maxdeg' at a set of
! points x. This routine automatically evaluates the polynomials if the radial component is zero,
! and passes to the main subroutine Zern_eval for nonzero radial components.

subroutine zern_eval(x,numpt,func_out)

implicit none

! I/O Variables
real(dp),   dimension(:,:),             intent(in)      :: x
integer,                                intent(in)      :: numpt
real(dp),   dimension(:,:),             intent(out)     :: func_out

! Local variables
integer                                 :: m,n,p
real(dp),   dimension(1:numpt)          :: r, theta
real(dp),   dimension(1:numpt,1:numrad) :: Rad  ! Radial polynomial array
real(dp),   dimension(1:numpt,1:maxdeg) :: cosarray, sinarray ! Stores values of cos(m*theta), etc

! Convert to polar coordinates
call cart_to_polar(x,r,theta)

! Compute radial polynomials
Rad = 0.0d0
call Radial_eval(r,numpt,Rad)

! Precompute sin(m*theta), cos(m*theta) using elemental functions

do m = 1,maxdeg
    cosarray(:,m) = cos(m*theta)
    sinarray(:,m) = sin(m*theta)
end do

! Compute Zernike polynomials

do n = 0,maxdeg
    do p = 0,2*n,2
        m = p - n
        if (m < 0) then
            func_out(:,idxwrap2(m,n)) = Rad(:,idxwrap(-m,n)) * sinarray(:,-m)
        else if (m > 0) then
            func_out(:,idxwrap2(m,n)) = Rad(:,idxwrap(m,n)) * cosarray(:,m)
        else if (m == 0) then
            func_out(:,idxwrap2(m,n)) = Rad(:,idxwrap(m,n))
        end if
    end do
end do

end subroutine zern_eval

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

subroutine zern_buildpars(maxdeg_in)

! Computes and stores the following parameters within the modules scope:
! numrad, numfunc, maxdeg, K1, K2, K3
! This is used to rapidly evaluate at many different input points while under the same parameters

    implicit none

    integer,    intent(in)  :: maxdeg_in
    integer                 :: ksize

 ! Precompute parameters

    maxdeg = maxdeg_in
    numrad = getnumrad(maxdeg)
    numfunc = (maxdeg+1) * (maxdeg+2)/2

    if (mod(maxdeg,2) == 0) then
        ksize = (maxdeg/2 + 1)**2
    else
        ksize = (maxdeg+3) * (maxdeg+1) / 4
    end if

! Allocate q-recursive array

    if (allocated(K1) .eqv. .true.) then
        deallocate(K1, K2, K3)
    end if

    allocate(K1(1:ksize),K2(1:ksize),K3(1:ksize))

    call buildK(maxdeg)

end subroutine zern_buildpars

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

! This special routine is used only for computing bilinear quadratures. Given degree "maxdeg", this
! calculates a matrix A(x) = inv(F(x)) * G(x), where F(x) is the Zernike matrix up to degree
! 'maxdeg' - 1 and [F(x) G(x)] is the Zernike matrix up to degree 'maxdeg'.

subroutine zern_bquad(x,numpt,A_out)

    implicit none

    real(dp),   dimension(:),                   intent(in)  :: x        ! input array of points
    integer,                                    intent(in)  :: numpt    ! number of points
    real(dp),   dimension(:,:),                 intent(out) :: A_out    ! output matrix

    real(dp),   dimension(1:numpt,1:numfunc)                :: output
    real(dp),   dimension(1:numpt,1:(numfunc - maxdeg - 1)) :: F
    real(dp),   dimension(1:numpt,1:(maxdeg+1))             :: G
    integer,    dimension(1:numpt)                          :: IPIV     ! LAPACK pivot info
    integer                                                 :: INFO     ! LAPACK error value

! ---------

    ! Check that a symmetric bilinear quadrature has been requested
    if (numpt /= (numfunc - maxdeg - 1)) then
        print *, 'Error: Non-symmetric bilinear quadrature requested.'
        stop
    end if

    ! Evaluate matrix functions
    call zern_eval(reshape(x, (/ 2, numpt /) ),numpt,output)
    F = output(:,1:(numfunc - maxdeg -1))
    G = output(:,(numfunc - maxdeg):numfunc)

    ! Compute objective function A(x) = inv(F(x)) * G(x) using LAPACK routines
    call dgetrf(numpt,numpt,F,numpt,IPIV,INFO)
    call dgetrs('N',numpt,maxdeg+1,F,numpt,IPIV,G,numpt,INFO)

    A_out = G

end subroutine zern_bquad

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

pure integer function getnumrad(n)

! Computes the number of radial polynomials up to degree n

    implicit none

    integer, intent(in) :: n

    if (mod(n,2) == 1) then
        getnumrad = (n+3)*(n+1)/4
    else
        getnumrad = (n/2 + 1)**2
    end if

end function getnumrad

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

subroutine Kconst(K1i,K2i,K3i,m,n)

! Computes special constant parameters in recursive Zernike evaluation
! Inputs:
!   m,n         --- Integer, m < n, n - m even
! Outputs:
!   K1i,K2i,K3i    --- Double, special recursive constants in Q-Recursive Algorithm

implicit none

integer,    intent(in)  :: m,n              ! Input values
real(dp),   intent(out) :: K1i, K2i, K3i    ! Output coefficients

K3i = - 4 * real((m+2)*(m+1),dp) / real((n+m+2)*(n-m),dp)

K2i = K3i * real((n+m+4)*(n-m-2),dp) / real(4*(m+3),dp) + m + 2

K1i = real((m+4)*(m+3)/2,dp) - (m+4) * K2i + K3i/8 * real((n+m+6)*(n -m - 4),dp)

end subroutine Kconst
! =================================================================================================

subroutine buildK(maxdeg_in)

! Precomputes the matrix of special coefficients K(m,n) in the recursive Zernike evaluation
! If n is odd then each K has (n+3)(n+1)/4 elements
! If n is even then each K has (n/2 + 1)^2 elements

implicit none

integer,                        intent(in)  :: maxdeg_in       ! Input, highest order

! Local variables
integer                                     :: m,n,p,j

do n = 0,maxdeg_in
    do p = 2,n,2
        m = n - p
        j = idxwrap(m,n)
        call Kconst(K1(j),K2(j),K3(j),m,n)
    end do
end do

end subroutine

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

pure integer function idxwrap(m,n)

! Computes the linear index of R(m,n) and K(m,n)

implicit none

integer, intent(in) :: m,n

if (mod(n,2) == 1) then
    idxwrap = (n+3) * (n+1)/4 - (n-m)/2
else
    idxwrap = (n/2 + 1)**2 - (n-m)/2
end if

end function idxwrap

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

pure integer function idxwrap2(m,n)

! Computes the linear index of Z(m,n); n - m even

implicit none

integer, intent(in) :: m,n

idxwrap2 =  (n*(n+1) + (n + m + 2))/2

end function idxwrap2

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

pure integer function shiftdown(n)

! Computes the linear index of R(n,n+2)

implicit none

integer, intent(in) :: n

if (mod(n,2) == 1) then
    shiftdown = n + 2 + (n + 3)/2 * (n + 1)/2
else
    shiftdown = n + 2 + (n/2 + 1)**2
end if

end function shiftdown

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

subroutine cart_to_polar(x,r,theta)

implicit none

real(dp),   dimension(:,:), intent(in)  :: x        ! Input value in R^2 cartesian coordinates
real(dp),   dimension(:),   intent(out) :: r,theta  ! Output in polar coordinates

r = sqrt(x(1,:)**2 + x(2,:)**2)

theta = atan2(x(2,:),x(1,:))

end subroutine cart_to_polar

! =================================================================================================
! ================================== Radial Polynomial Subroutine =================================
! =================================================================================================

! This subroutine evaluates all radial polynomials up to degree 'maxdeg' at a specified point x.
! For n - m even, the Zernike polynomials are given by
!
!       Z(m,n,r,theta) = Rad(m,n,r) * cos(m * theta)    m >= 0
!       Z(m,n,r,theta) = Rad(m,n,r) * sin(m * theta)    m < 0
!
! The so-called "q-recursion" on Rad(m,n,r) is given by
!
!       Rad(n,n,r) = r^n
!       Rad(n-2,n,r) = n * Rad(n,n,r) + (n-1)* Rad(n-2,n-2,r)             n >= 2
!       Rad(m,n,r) = K_1 * Rad(m+4,n,r) + (K_2 + K_3/r^2) * Rad(m+2,n,r)  n - m > 2
!
! where the coefficients K_1, K_2, K_3 are given by
!
!       K_1 = (m+4)(m+3)/2 - (m+4) K_2 + K_3 (n + m + 6)(n - m - 4)/8
!       K_2 = K_3 (n + m + 4) (n - m - 2)/(4(m+3)) + m + 2
!       K_3 = - 4(m + 2)(m+1)/ ((n + m + 2)(n - m))

! This method *might* fail for extremely small r. Therefore for sufficiently small r we use the
! Prata recursive method to estimate the radial polynomial.

subroutine Radial_eval(r, numpt, Rad)

implicit none

! I/O Variables
integer,                                intent(in)      :: numpt        ! Number of input points
real(dp),   dimension(1:numpt),         intent(inout)   :: r            ! input radial values
real(dp),   dimension(:,:),             intent(out)     :: Rad          ! k x numrad output matrix

! Local Variables
real(dp),   dimension(1:numpt,1:numrad)             :: Radtemp      ! Sorted evaluation matrix
logical,    dimension(1:numpt)                      :: rnz          ! Is TRUE for a nonzero radius
real(dp)                                            :: tolr2        ! Tolerance for r^2
integer                                             :: j,n,m,p      ! loop variables
real(dp)                                            :: rtemp
integer                                             :: nnz          ! # of nonzero radial values

! Determine nonzero radial values and permute near-zero ones to the back
tolr2 = 10.0d-30
rnz = .true.
nnz = numpt

do j = numpt,1,-1 ! Permutes from back to front; this is optimal
    if (r(j)**2 <= tolr2) then
        rnz(j) = .false.
        nnz = nnz - 1
        rtemp = r(j)
        r(j:(numpt-1)) = r((j+1):numpt)
        r(numpt) = rtemp
    end if
end do

! Compute Rad(n,n,r)
do n = 0,maxdeg
    Radtemp(:,idxwrap(n,n)) = r**n
end do

! ------ Prata method for near-zero radial values ------

! Compute Rad(0,n,r) for n even, using a two-term expansion (since r << 1)
do n = 0,maxdeg,2
    j = n/2
    Radtemp(nnz+1:numpt,idxwrap(0,n)) = (-1)**(mod(j,2)) * &
                                    (1 - ((j+1)* r(nnz+1:numpt))*(j * r(nnz+1:numpt)))
end do

! Prata recursion for Rad(m,n,r), 0 < m < n
do n = 1,maxdeg
    do p = 2,n,2
        m = n - p
        j = idxwrap(m,n)
        Radtemp(nnz+1:numpt,j) = real(2*n,dp)/(n + m) * r(nnz+1:numpt) * &
                                Radtemp(nnz+1:numpt,idxwrap(m-1,n-1)) + &
                                real(m - n,dp)/(n + m) * Radtemp(nnz+1:numpt,j - n)
    end do
end do

! ------ Q-Recursive algorithm for nonzero radial values ------

! Compute Rad(n-2,n,r)
do n = 2,maxdeg
    j = shiftdown(n-2)
    Radtemp(1:nnz,j) = (1 - n) * Radtemp(1:nnz,j - n) + n * Radtemp(1:nnz,j+1)
    !print *, Radtemp(1:nnz,j - n)
    !print *, Radtemp(1:nnz,j+1)
end do

! Compute Rad(m,n,r) for n - m > 2
do n = 4, maxdeg
    do p = 4,n,2
        m = n - p
        j = idxwrap(m,n)
        Radtemp(1:nnz,j) = K1(idxwrap(m,n)) * Radtemp(1:nnz,j+2) + &
                        K2(idxwrap(m,n)) * Radtemp(1:nnz,j+1) + &
                        K3(idxwrap(m,n)) * Radtemp(1:nnz,j+1)/(r(1:nnz)**2)
    end do
end do

! ------ Re-sort output matrix ------
do j = 1,numpt
    if (rnz(j) .eqv. .false.) then
        Rad(j,:) = Radtemp(numpt,:)
        Radtemp((j+1):numpt,:) = Radtemp(j:(numpt-1),:)
    else
        Rad(j,:) = Radtemp(j,:)
    end if
end do

! ------ Normalize radial polynomials -------
! mathematically normalization should be done at the Zernike step,
! but it is cheaper to normalize at the radial step
do n = 0, maxdeg
    do m = n,0,-2
        if (m > 0) then
            Rad(:,idxwrap(m,n)) = sqrt((2*n+2)/pi) * Rad(:,idxwrap(m,n))
        else
            Rad(:,idxwrap(m,n)) = sqrt((n+1)/pi) * Rad(:,idxwrap(m,n))
        end if
    end do
end do

end subroutine Radial_eval

end module zernike


      real function tmpfun(tpshf)
c
c     + + + PURPOSE + + +
c
c     Function TMPFUN computes mean square error of the temperature for a given phase shift value.
c
c     Called from: SRS TMPCFT
c     Author(s): Shuhui Dun, WSU
c     Verified by: Joan Wu, WSU
c     Reference in User Guide:
c
c     Version:
c     Date recoded: January 07, 2008
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real tpshf
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     tpshf - phase shift in the sin curve, day
c
c     + + + COMMON BLOCKS + + +
c
      include 'ctcurv.inc'
c     Read: YavgT,YampT,obavgT
c
c     + + + LOCAL VARIABLES + + +
c
      integer i
      real tday, esavgT,sqer
c
c     + + + LOCAL DEFINITIONS + + +
c
c      tday - day in a year
c     esavgT - estimated monthly average temperature
c     sqer - total square error
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      sqer = 0.
c
      Do 10 i = 1, 12
         tday = 15 + (i-1)* 30.5
         esavgT = YavgT + YampT * sin(2*3.14/365. *(tday-tpshf))
c
         sqer = sqer + (esavgT - obavgt(i))**2
10    continue
c
      tmpfun = (sqer/12.)**0.5
c
      return
      end


MODULE Logistic_Regression
! A package for fitting linear logistic models by iteratively re-weighted
! least squares.

! The model fitted is that the probability of a `success' is:

!      p = 1 - 1/[1 + exp(b0 + b1.X1 + b2.X2 + ... + bk.Xk)]

! where X1, X2, ... , Xk are the predictor variables, and the coefficients
! b0, b1, b2, ..., bk are to be determined.

! N.B. The residual variance used here in estimating standard errors is the
!      larger of 1.0 and that from the weighted least squares calculations;
!      it is not the theoretical residual variance (1.0) assuming a binomial
!      distribution about the logistic curve.   If the fit of the logistic
!      is poor, the standard errors of the coefficients in the logistic will
!      be much larger.

! The calculation of chi-squared was corrected on 9 August 2003.
! My thanks to Zhang Guan

! By Alan Miller
! amiller @ bigpond.net.au
! users.bigpond.net.au/amiller/

! Latest revision - 9 August 2003

USE lsq
IMPLICIT NONE

PUBLIC  :: logistic

CONTAINS

SUBROUTINE logistic(ngroups, x, k, s, n, chisq, devnce, ndf, beta, se_beta,  &
                    ier, cov_beta, fit, stdres)

! Input arguments:

! ngroups     The number of groups of observations.

! x(:,:)      x(i,j) contains the value of the j-th predictor for group i.
!             The X-values are the same for all the n(i) trials in group i.

! k           The number of predictors.   N.B. A constant will be fitted in
!             the model; do not include it in the k predictor variables.

! s(:), n(:)  s(i) is the number of `successes' out of the n(i) `trials' in
!             the i-th group.   In many applications, each n(i) = 1, that is
!             each case will be treated individually, and then s(i) = 0 or 1
!             for each of the two possible outcomes.

INTEGER, INTENT(IN)    :: ngroups, k, s(:), n(:)
REAL (dp), INTENT(IN)  :: x(:,:)

! Output arguments:

! chisq       The value of chi-squared on exit, when a model has been fitted.

! devnce      The deviance on exit, when a model has been fitted.

! ndf         Number of degrees of freedom.

! beta(0:)    The fitted coefficients in the logistic model.

! se_beta(0:) Approximate standard errors of the beta coefficients.

! ier         Error indicator
!             = 0 successful termination
!             = 1 if ngroups < 2 or ndf < 0
!             = 2 if any n(i) < 0
!             = 3 if any r(i) < 0
!             = 4 if any r(i) > n(i)
!             = 5 if any X-variable is constant
!             = 6 if a singularity is detected
!             = 7 if any beta(i) is tending to +/- infinity
!             = 8 failure to converge in 20 iterations

REAL (dp), INTENT(OUT)  :: chisq, devnce, beta(0:), se_beta(0:)
INTEGER, INTENT(OUT)    :: ndf, ier

! Optional output arguments:

! cov_beta(0:,0:)     Approximate covariance matrix of the fitted coefficients.

! fit(:)      The fitted probabilities of a success for each group.

! stdres(:)   Vector of standardized residuals.

REAL (dp), INTENT(OUT), OPTIONAL  :: cov_beta(0:,0:), fit(:), stdres(:)

! Local variables

INTEGER    :: i, iter, j, ncov, pos
REAL (dp)  :: propn(ngroups), p(ngroups), wt(ngroups), xrow(0:k), db(0:k), &
              bnew(0:k), dev_new, xb, pnew(ngroups), wnew(ngroups), a, b,  &
              range(k), var, e(ngroups), hii
LOGICAL    :: lindep(0:k)
REAL (dp), ALLOCATABLE  :: covmat(:)

! Initial checks

ier = 0
ndf = ngroups - k - 1
IF (ngroups < 2 .OR. ndf < 0) THEN
  ier = 1
  RETURN
END IF
IF (ANY(n(1:ngroups) < 0)) THEN
  ier = 2
  RETURN
END IF
IF (ANY(s(1:ngroups) < 0)) THEN
  ier = 3
  RETURN
END IF
IF (ANY(s(1:ngroups) > n(1:ngroups))) THEN
  ier = 4
  RETURN
END IF

! Calculate ranges of the X-variables to use in testing whether any beta
! is tending to +/- infinity.  Also test that no variable is constant.

DO i = 1, k
  a = MAXVAL(x(1:ngroups,i))
  b = MINVAL(x(1:ngroups,i))
  range(i) = a - b
  IF (range(i) < EPSILON(0.0_dp) * (ABS(a) + ABS(b))) THEN
    ier = 5
    RETURN
  END IF
END DO

! Start with all beta's = 0 and weights = 1.

beta(0:k) = 0.0_dp
wt(1:ngroups) = 1.0_dp
p(1:ngroups) = 0.5_dp

! propn stores the sample proportions, i.e. s(i) / n(i)
propn(1:ngroups) = REAL(s(1:ngroups), KIND=dp) / n(1:ngroups)
iter = 1

! Start of iterative cycle

DO
  CALL startup(k, .TRUE.)
  DO i = 1, ngroups
    IF (iter == 1) THEN
      xrow(0) = 0.25_dp
      xrow(1:k) = 0.25_dp*x(i, 1:k)
    ELSE
      xrow(0) = p(i)*(1.0_dp - p(i))
      xrow(1:k) = p(i)*(1.0_dp - p(i))*x(i, 1:k)
    END IF
    CALL includ(wt(i), xrow, propn(i)-p(i))
  END DO

! Test for a singularity

  CALL sing(lindep, ier)
  IF (ier /= 0) THEN
    DO i = 1, k
      IF (lindep(i)) THEN
        WRITE(*, '(a, i6, a)') ' Variable number ', i,  &
                               ' is linearly dependent upon earlier variables'
      END IF
    END DO
    ier = 6
    RETURN
  END IF

  CALL regcf(db, k+1, ier)
  10 bnew = beta(0:k) + db

! Calculate new p(i)'s, weights & deviance

  dev_new = 0.0_dp
  DO i = 1, ngroups
    xb = DOT_PRODUCT( x(i,1:k), bnew(1:k) ) + bnew(0)
    xb = EXP(xb)
    pnew(i) = xb / (1.0_dp + xb)
    wnew(i) = REAL(n(i), KIND=dp) / (pnew(i)*(1.0_dp - pnew(i)))
    IF (iter == 1) wnew(i) = SQRT(wnew(i))
    IF (s(i) > 0) dev_new = dev_new + s(i)*LOG(propn(i)/pnew(i))
    IF (s(i) < n(i)) dev_new = dev_new +   &
                           (n(i)-s(i))*LOG((1.0_dp-propn(i))/(1.0_dp-pnew(i)))
  END DO
  dev_new = 2 * dev_new

! If deviance has increased, reduce the step size.

  IF (iter > 2) THEN
    IF (dev_new > devnce*1.0001_dp) THEN
      db = 0.5_dp * db
      GO TO 10
    END IF
  END IF

! Replace betas, weights & p's with new values

  beta(0:k) = bnew(0:k)
  wt = wnew
  p(1:ngroups) = pnew

! Test for convergence

  IF (iter > 2 .AND. devnce - dev_new < 0.0001_dp) EXIT
  devnce = dev_new
  iter = iter + 1
  IF (iter > 20) THEN
    ier = 8
    RETURN
  END IF

! Test for a very large beta

  DO i = 1, k
    IF (ABS(beta(i))*range(i) > 30.0_dp) THEN
      WRITE(*, '(a, i4, a)') ' Coefficient for variable no.', i,  &
                             ' tending to infinity'
      ier = 7
      RETURN
    END IF
  END DO

END DO

e = n(1:ngroups)*p(1:ngroups)
chisq = SUM( (s(1:ngroups) - e)**2 / (e * (1.0_dp - p(1:ngroups))) )
devnce = dev_new

! Calculate the approximate covariance matrix for the beta's, if ndf > 0.

IF (ndf > 0) THEN
  ncov = (k+1)*(k+2)/2
  ALLOCATE( covmat(ncov) )
  CALL cov(k+1, var, covmat, ncov, se_beta, ier)
  IF (var < 1.0_dp) THEN
    covmat = covmat / var
    se_beta = se_beta / SQRT(var)
  END IF

  IF(PRESENT(cov_beta)) THEN
    pos = 1
    DO i = 0, k
      cov_beta(i,i) = covmat(pos)
      pos = pos + 1
      DO j = i+1, k
        cov_beta(i,j) = covmat(pos)
        cov_beta(j,i) = covmat(pos)
        pos = pos + 1
      END DO
    END DO
  END IF
END IF

IF(PRESENT(fit)) fit(1:ngroups) = p

IF (PRESENT(stdres)) THEN
  DO i = 1, ngroups
    xrow(0) = p(i)*(1.0_dp - p(i))
    xrow(1:k) = p(i)*(1.0_dp - p(i))*x(i, 1:k)
    CALL hdiag(xrow, k+1, hii, ier)
    stdres(i) = (s(i) - n(i)*p(i)) /   &
                SQRT(n(i)*p(i)*(1.0_dp - p(i))*(1.0_dp - hii))
  END DO
END IF

IF (ALLOCATED(covmat)) DEALLOCATE( covmat )

RETURN
END SUBROUTINE logistic

FUNCTION chi_squared(ndf, chi2) RESULT(prob)
! Calculate the chi-squared distribution function
! ndf  = number of degrees of freedom
! chi2 = chi-squared value
! prob = probability of a chi-squared value <= chi2 (i.e. the left-hand
!        tail area)

INTEGER, INTENT(IN)    :: ndf
REAL (dp), INTENT(IN)  :: chi2
REAL (dp)              :: prob

! Local variables
REAL (dp) :: half = 0.5_dp, x, p

x = half * chi2
p = half * REAL(ndf)
prob = gammad(x, p)
RETURN

END FUNCTION chi_squared

FUNCTION gammad(x, p) RESULT(gamma_prob)

!  ALGORITHM AS239  APPL. STATIST. (1988) VOL. 37, NO. 3

!  Computation of the Incomplete Gamma Integral

!  Auxiliary functions required: ALNORM = algorithm AS66 (included) & LNGAMMA

!  Converted to be compatible with ELF90 by Alan Miller
!  N.B. The return parameter IFAULT has been removed as ELF90 allows only
!  one output parameter from functions.   An error message is issued instead.

! This revision - 15 October 1996

REAL (dp), INTENT(IN) :: x, p
REAL (dp)             :: gamma_prob

!     Local variables

REAL (dp) :: pn1, pn2, pn3, pn4, pn5, pn6, tol = 1.d-14, oflo = 1.d+37,  &
             xbig = 1.d+8, arg, c, rn, a, b, one = 1._dp, zero = 0._dp, an, &
             two = 2._dp, elimit = -88._dp, plimit = 1000._dp, three = 3._dp, &
             nine = 9._dp

gamma_prob = zero

!      Check that we have valid values for X and P

IF (p <= zero .OR. x < zero) THEN
  WRITE(*, *)'Error: Function gammad.  1st argument < 0 or 2nd argument <= 0'
  RETURN
END IF
IF (x == zero) RETURN

!      Use a normal approximation if P > PLIMIT

IF (p > plimit) THEN
  pn1 = three * SQRT(p) * ((x / p) ** (one / three) + one / (nine * p) - one)
  gamma_prob = alnorm(pn1, .false.)
  RETURN
END IF

!      If X is extremely large compared to P then set gamma_prob = 1

IF (x > xbig) THEN
  gamma_prob = one
  RETURN
END IF

IF (x <= one .OR. x < p) THEN

!      Use Pearson's series expansion.
!      (Note that P is not large enough to force overflow in LNGAMMA)

  arg = p * LOG(x) - x - lngamma(p + one)
  c = one
  gamma_prob = one
  a = p
  DO
    a = a + one
    c = c * x / a
    gamma_prob = gamma_prob + c
    IF (c < tol) EXIT
  END DO
  arg = arg + LOG(gamma_prob)
  gamma_prob = zero
  IF (arg >= elimit) gamma_prob = EXP(arg)

ELSE

!      Use a continued fraction expansion

  arg = p * LOG(x) - x - lngamma(p)
  a = one - p
  b = a + x + one
  c = zero
  pn1 = one
  pn2 = x
  pn3 = x + one
  pn4 = x * b
  gamma_prob = pn3 / pn4
  DO
    a = a + one
    b = b + two
    c = c + one
    an = a * c
    pn5 = b * pn3 - an * pn1
    pn6 = b * pn4 - an * pn2
    IF (ABS(pn6) > zero) THEN
      rn = pn5 / pn6
      IF (ABS(gamma_prob - rn) <= MIN(tol, tol * rn)) EXIT
      gamma_prob = rn
    END IF

    pn1 = pn3
    pn2 = pn4
    pn3 = pn5
    pn4 = pn6
    IF (ABS(pn5) >= oflo) THEN

  !      Re-scale terms in continued fraction if terms are large

      pn1 = pn1 / oflo
      pn2 = pn2 / oflo
      pn3 = pn3 / oflo
      pn4 = pn4 / oflo
    END IF
  END DO
  arg = arg + LOG(gamma_prob)
  gamma_prob = one
  IF (arg >= elimit) gamma_prob = one - EXP(arg)
END IF

RETURN
END FUNCTION gammad

FUNCTION alnorm(x, upper) RESULT(norm_prob)

!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

REAL (dp), INTENT(IN)  :: x
LOGICAL, INTENT(IN)    :: upper
REAL (dp)              :: norm_prob

! Local variables
REAL (dp) :: zero = 0.0_dp, one = 1.0_dp, half = 0.5_dp
REAL (dp) :: con = 1.28_dp, z, y, ltone = 7.0_dp, utzero = 18.66_dp
REAL (dp) :: p = 0.398942280444_dp, q = 0.39990348504_dp,   &
             r = 0.398942280385_dp, a1 = 5.75885480458_dp,  &
             a2 = 2.62433121679_dp, a3 = 5.92885724438_dp,  &
             b1 = -29.8213557807_dp, b2 = 48.6959930692_dp, &
             c1 = -3.8052D-8, c2 = 3.98064794D-4,         &
             c3 = -0.151679116635_dp, c4 = 4.8385912808_dp, &
             c5 = 0.742380924027_dp, c6 = 3.99019417011_dp, &
             d1 = 1.00000615302_dp, d2 = 1.98615381364_dp,  &
             d3 = 5.29330324926_dp, d4 = -15.1508972451_dp, &
             d5 = 30.789933034_dp
LOGICAL   :: up

up = upper
z = x
IF(z >=  zero) GO TO 10
up = .NOT. up
z = -z
10 IF(z <= ltone .OR. up .AND. z <= utzero) GO TO 20
norm_prob = zero
GO TO 40
20 y = half*z*z
IF(z > con) GO TO 30

norm_prob = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
GO TO 40
30 norm_prob = r*EXP(-y)/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
40 IF(.NOT. up) norm_prob = one - norm_prob
RETURN

END FUNCTION alnorm

FUNCTION lngamma(z) RESULT(lanczos)

!  Uses Lanczos-type approximation to ln(gamma) for z > 0.
!  Reference:
!       Lanczos, C. 'A precision approximation of the gamma
!               function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!  Accuracy: About 14 significant digits except for small regions
!            in the vicinity of 1 and 2.

!  Programmer: Alan Miller
!              1 Creswick Street, Brighton, Vic. 3187, Australia
!  Latest revision - 14 October 1996

REAL(dp), INTENT(IN) :: z
REAL(dp)             :: lanczos

! Local variables

REAL(dp)  :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
                      -1259.139216722289_dp, 771.3234287757674_dp, &
                      -176.6150291498386_dp, 12.50734324009056_dp, &
                      -0.1385710331296526_dp, 0.9934937113930748D-05, &
                       0.1659470187408462D-06 /), zero = 0._dp,   &
                       one = 1._dp, lnsqrt2pi = 0.9189385332046727_dp, &
                       half = 0.5_dp, sixpt5 = 6.5_dp, seven = 7._dp, tmp
INTEGER   :: j

IF (z <= zero) THEN
  WRITE(*, *)'Error: zero or -ve argument for lngamma'
  RETURN
END IF

lanczos = zero
tmp = z + seven
DO j = 9, 2, -1
  lanczos = lanczos + a(j)/tmp
  tmp = tmp - one
END DO
lanczos = lanczos + a(1)
lanczos = LOG(lanczos) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
RETURN

END FUNCTION lngamma

END MODULE Logistic_Regression


PROGRAM day_of_year
IMPLICIT NONE
  INTEGER :: year, month, day ! User inputs
  INTEGER :: index
  INTEGER :: month_lengths(12)
  LOGICAL :: is_leap
  INTEGER :: result = 0

  WRITE(*, *) "Enter today's numerical date using format YYYY M D"
  READ(*, *) year, month, day
  IF (MOD(year, 400) .eq. 0) THEN
    is_leap = .true.
  ELSE IF (MOD(year, 100) .eq. 0) THEN
    is_leap = .false.
  ELSE IF (MOD(year, 4) .eq. 0) THEN
    is_leap = .true.
  ELSE
    is_leap = .false.
  END IF

  IF (is_leap) THEN
    month_lengths = (/ 31,29,31,30,31,30,31,31,30,31,30,31 /)
  ELSE
    month_lengths = (/ 31,28,31,30,31,30,31,31,30,31,30,31 /)
  END IF

  result = day
  DO index = 1, month - 1
      result = result + month_lengths(index)
  END DO
  WRITE(*, *) result
END PROGRAM day_of_year


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_bbt2eig( n, B,  U, lam )

!  The n x n PSD matrix A is given by A = B * B^T.
!  The SVD of B is:  B = U * S * V^T, so that the
!  eigendecomposition of A is: A = U * S^2 * U^T.
!  Given B, return U and lam=diag(S).

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: B(n,n)
real(k_dp), intent(out) :: U(n,n), lam(n)

real(k_dp) :: vt(n,n), work(5*n*n+20*n)
integer    :: lwork, info

lwork = 5*n*n+20*n

vt = B
call dgesvd( 'A', 'N', n, n, vt, n, lam, u, n, vt, n, work, lwork, info)

if( info /= 0 ) then
   write(0,*)'ell_bbt2eig: info, lwork, work(1) = ', info, lwork, work(1)
   stop
endif

return
end subroutine ell_bbt2eig


!--------------------------------------------------
!PHY2063 Task 2
!URN 6309823 - Penguin Lab Group 1B
!October 29th 2015
!--------------------------------------------------
!
PROGRAM Task2
  IMPLICIT NONE
!
  REAL          ::  ran,r,l,x,y,z,ratio,error
  REAL          ::  v_box_exact,n_torus,v_torus_exact,v_torus_est
  INTEGER       ::  i,iseed,first,n
  real,external ::  rand
!
  first=0
  iseed=971739
  ran=rand(iseed,first)
  write(6,*)'This is the random number the pseudo-random number generator'
  write(6,*)'gives me',ran
  write(6,*)' '
  write(6,*)'The radius of the ring is "r"'
  write(6,*)' '
  write(6,*)'The radius of the circle that runs'
  write(6,*)'along the middle of ring "r" is "l"'
  write(6,*)' '
  write(6,*)'What is the value of "l"?'
  read (5,*)l
  write(6,*)' '
  write(6,*)'What is the value of "r"?'
  read (5,*)r
  write(6,*)' '
  write(6,*)'How many points "n" should be calculated?'
  read (5,*)n
  write(6,*)' '
  write(6,'(a,i9)')'seed value that generates this sequence is ',iseed
!
! v_torus is the volume of the torus
!
  v_torus_exact=((4.0*atan(1.0))*r**2)*(2*(4.0*atan(1.0))*l)
  v_box_exact=2*r*(2*(r+l))**2
  n_torus=0
!
  do i=1,n
    x=2.0*(r+l)*(rand(iseed,first)-(0.5))
    y=2.0*(r+l)*(rand(iseed,first)-(0.5))
    z=2.0*r*(rand(iseed,first)-(0.5))
    if((l-(x**2+y**2)**0.5)**2+z**2-r**2<0.0)n_torus=n_torus+1.0
  end do
!
  ratio=n_torus/n
  v_torus_est=v_box_exact*ratio
  error=v_torus_exact-v_torus_est
  write(6,*)'This is the estimate for the volume of the torus',v_torus_est
  write(6,*)'This is the actual volume of the torus          ',v_torus_exact
  write(6,*)'This is the error in the volume of the torus    ',error
end program Task2
!
!
real function rand(iseed,first)
!
! This function returns a pseudo-random number for each invocation.
! It is an f90 adaptation of an
! FORTRAN 77 adaptation
! by Dick Valent and Fred Clare
! http://www.cisl.ucar.edu/zine/96/spring/articles/3.random-6.html
! of the "Integer Version 2" minimal
! standard number generator whose Pascal code appears in the article:
!
!     Park, Steven K. and Miller, Keith W., "Random Number Generators:
!     Good Ones are Hard to Find", Communications of the ACM,
!     October, 1988.
!
  implicit none
  integer, parameter :: MPLIER=16807
  integer, parameter :: MODLUS=2147483647
  integer, parameter :: MOBYMP=127773
  integer, parameter :: MOMDMP=2836
  integer :: hvlue,lvlue,testv,nextn,first,iseed
  save nextn
!
  if(first == 0) THEN
    nextn=iseed
    first=1
  endif
!
  hvlue=nextn/mobymp
  lvlue=mod(nextn,mobymp)
  testv=mplier*lvlue-momdmp*hvlue
  if(testv > 0)then
    nextn=testv
  else
    nextn=testv+modlus
  endif
  rand = real(nextn)/real(modlus)
!
end function rand


      module ex17_mod
!
!     This is the module supporting program ex17.
!
      type myComplex
        real::realPart,imaginaryPart
      end type myComplex
!
!     Operator Interfaces...
!
      interface operator (+)
        module procedure do_myComplex_add
      end interface
!
!     Module Procedures...
!
      Contains
!
!
      subroutine print_myComplex(val)
!
!     This subroutine prints a myComplex type variable.
!
      implicit none
      type(myComplex),intent(in)::val
!
 1000 Format(1x,'Real Part:',f10.5,'  Imaginary Part:',f10.5)
!
      write(*,1000) val%realPart,val%imaginaryPart
!
      return
      end subroutine print_myComplex

      subroutine myComplex_add(val1,val2,mySum)
!
!     This subroutine forms the sum of two arguments, val1 and val2, which are
!     of type myComplex.
!
      implicit none
      type(myComplex),intent(in)::val1,val2
      type(myComplex),intent(out)::mySum
!
      mySum%realPart      = val1%realPart + val2%realPart
      mySum%imaginaryPart = val1%imaginaryPart + val2%imaginaryPart
!
      return
      end subroutine myComplex_add

      function do_myComplex_add(val1,val2) result(mySum)
!
!     This function forms the sum of two arguments, val1 and val2, which are
!     of type myComplex.
!
      implicit none
      type(myComplex),intent(in)::val1,val2
      type(myComplex)::mySum
!
      mySum%realPart      = val1%realPart + val2%realPart
      mySum%imaginaryPart = val1%imaginaryPart + val2%imaginaryPart
!
      return
      end function do_myComplex_add

      end module ex17_mod

      program ex17
      use ex17_mod
!
!     This program asks a user for two complex numbers, loads those into my
!     derived data type called myComplex, echos the numbers back to the user,
!     and then adds the numbers and reports the result to the user.
!
!
!     Variable Declarations
      implicit none
      type(myComplex)::user1,user2,sum12
!
!     Begin by asking the user for the two input complex numbers.
!
      write(*,*)' Please enter the FIRST complex number giving the ',  &
        'real part followed by the imaginary part.'
      read(*,*) user1%realPart,user1%imaginaryPart
      write(*,*)' Please enter the SECOND complex number giving the ',  &
        'real part followed by the imaginary part.'
      read(*,*) user2%realPart,user2%imaginaryPart
      write(*,*)' Here are the values you have given as input...'
      write(*,*)' user1:'
      call print_myComplex(user1)
      write(*,*)' user2:'
      call print_myComplex(user2)
!
!     Form the sum of user1 and user2. Then, print the result.
!
      call myComplex_add(user1,user2,sum12)
      write(*,*)' The sum of your two complex numbers is:'
      call print_myComplex(sum12)
!
!     Form the sum of user1 and user2 again; this time let's use the new
!     function do_myComplex_add.
!
      sum12 = do_myComplex_add(user1,user2)
      write(*,*)' The sum of your two complex numbers using the function, is:'
      call print_myComplex(sum12)
      write(*,*)' ...and again...'
      call print_myComplex(do_myComplex_add(user1,user2))
!
!     Take the sum user1 and sum12.
!
      write(*,*)' The sum of user1 and sum12 = user1 + user1 + user2...'
      sum12 = user1 + sum12
      call print_myComplex(sum12)
      write(*,*)' ...and again...'
      sum12 = user1 + user1 + user2
      call print_myComplex(sum12)
!
      end program ex17


! Copyright (c) 2017-2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_binomial
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_beta_dist
  IMPLICIT NONE
  PRIVATE

  Public :: BinomialCumulative, BinomialLikelyhood
Contains
  Real(c_double) Function BinomialCumulative(p, n, k) Result(val)
    real(c_double), intent(in) :: p
    integer(8) :: n, k
    val = IncompleteBeta(REAL(n-k,8), REAL(k+1,8), 1-p)
  End Function BinomialCumulative

  Real(c_double) Function BinomialLikelyhood(p, n, k) Result(val)
    real(c_double), intent(in) :: p
    integer(8) :: n, k
    real(c_double) :: vEq, vSup, vInf
    vEq = EXP(LOG_GAMMA(REAL(n+1,8)) - LOG_GAMMA(REAL(n-k+1,8)) &
             - LOG_GAMMA(REAL(k+1,8)))*p**k*(1-p)**(n-k)
    vInf = BinomialCumulative(p, n, k)
    vSup = 1d0 - vInf + vEq
    val = MIN(vInf, vSup)
  End Function BinomialLikelyhood
End Module mlf_binomial


************************************************************************
*                        SUBROUTINE BERNOULLI                          *
*                                                                      *
* Purpose:                                                             *
* It computes Bernoulli numbers for dilog (Spence) function evaluation.*
*                                                                      *
* A call to this subroutine (call Bernoulli(n) must be made before     *
* using the function rli2(x,n).  n must be the sambe in both case and  *
* not greater than 20. It is the order at which the series is truncated*
*                                                                      *
*                                                                      *
************************************************************************

      Subroutine Bernoulli(n)
      implicit real*8(a-h,o-z)
      dimension Be(0:20),B(0:20)
      parameter (Zeta2=1.64493406684823d0)
      common/coeff/B

* This routine computes the Bernoulli numbers for rli2
* B(n)= Bernoulli_numbers(2*n)

      Be(0)=1.d0
      Be(1)=1.d0/6.d0
      Be(2)=-1.d0/30.d0
      Be(3)=1.d0/42.d0
      Be(4)=Be(2)
      Be(5)=5.d0/66.d0
      Be(6)=-691.d0/2730.d0
      Be(7)=7.d0*Be(1)
      Be(8)=-3617.d0/510.d0
      Be(9)=43867.d0/798.d0
      Be(10)=-174611.d0/330.d0
      Be(11)=854513.d0/138.d0
      Be(12)=-236364091.d0/2730.d0
      Be(13)=8553103.d0/6.d0
      Be(14)=-23749461029.d0/870.d0
      Be(15)=8615841276005.d0/14322.d0
      Be(16)=-7709321041217.d0/510.d0
      Be(17)=2577687858367.d0/6.d0
      Be(18)=-26315271553053477373.d0/1919190.d0
      Be(19)=2929993913841559.d0/6.d0
      Be(20)=-261082718496449122051.d0/13530.d0

* Divido per (2n+1)!
      fn1=1.d0
      fn2=1.d0
      do i=1,n
        fn1=fn1*(2.d0*i+1)
        fn2=fn2*2.d0*i
        B(i)=Be(i)/fn1
        B(i)=B(i)/fn2
      enddo
        B(0)=1.d0
      return
      end

      function rli2(x,n)
*n is the order to which it is computed the series. Must be at most 20
* with the above Bernoulli numbers, and not greater that the one used
* for the call to Bernoulli subroutine.
      implicit real*8(a-h,o-z)
      dimension B(0:20)
      parameter (Zeta2=1.64493406684823d0)
      common/coeff/B

      if(x.gt.1.d0) then
        print*,'Variable out of range'
        stop
      endif

      if(abs(x).le.0.5d0) then
        t=-log(1.d0-x)
        rli2= -t/4.d0
        f=1.d0
        do i=0,n
          rli2=rli2+B(i)*f
          f=f*t*t
        enddo
        rli2=rli2*t
      elseif(x.gt.0.5d0) then
        q=1.d0-x
        t=-log(1.d0-q)
        rli2= -t/4.d0
        f=1.d0
        do i=0,n
          rli2=rli2+B(i)*f
          f=f*t*t
        enddo
        rli2=-rli2*t+Zeta2
        if (x.ne.1.d0) then
          rli2=rli2-log(x)*log(q)
        endif
      elseif(x.ge.-1.d0) then
        q=-x/(1.d0-x)
        t=-log(1.d0-q)
        rli2= -t/4.d0
        f=1.d0
        do i=0,n
          rli2=rli2+B(i)*f
          f=f*t*t
        enddo
        rli2=-rli2*t-log(1-x)**2/2.d0
      elseif(x.ge.-2.d0) then
        q=1.d0/(1.d0-x)
        t=-log(1.d0-q)
        rli2= -t/4.d0
        f=1.d0
        do i=0,n
          rli2=rli2+B(i)*f
          f=f*t*t
        enddo
        rli2=rli2*t-log(-x)*log(1-x)+log(1-x)**2/2.d0-Zeta2
      else
        q=1.d0/x
        t=-log(1.d0-q)
        rli2= -t/4.d0
        f=1.d0
        do i=0,n
          rli2=rli2+B(i)*f
          f=f*t*t
        enddo
        rli2=-rli2*t-log(-x)**2/2.d0-Zeta2
      endif
      return
      end


c     program SRDGE2
c>> 2001-05-22 SRDGE2 Krogh Minor change for making .f90 version.
c>> 1994-10-19 SRDGE2 Krogh  Changes to use M77CON
c>> 1992-03-10 SRDGE2 Lawson
c
c     Demo driver for SGED, SGEFS, SGEI, SGESLT
c     ------------------------------------------------------------------
c--S replaces "?": ?RDGE2, ?GED, ?GEFS, ?GEI, ?GESLT, ?MATP
c     ------------------------------------------------------------------
      integer NMAX, INFO
      parameter (NMAX = 3)
      real             A(3,3), B(3,1), C(3,1), DET(2), WORK(NMAX)
      integer I, J, IPVT(NMAX)
c
      data (A(1,J),J=1,3) / 0.579E0, -.394E0, 0.915E0 /
      data (A(2,J),J=1,3) / -0.795E0, 0.226E0, -0.868E0 /
      data (A(3,J),J=1,3) / 0.141E0, -0.329E0, -0.286E0 /
c
      data (B(I,1),I=1,3) / 5.873E0, -5.324E0, 1.069E0 /
      data (C(I,1),I=1,3) / -6.267e0, 4.951e0, -5.177e0 /
c     ------------------------------------------------------------------
      call SMATP(A,NMAX,NMAX,NMAX,' A(,) =')
      print*,' '
      call SMATP(B,NMAX,NMAX,1,' B(,) =')
      call SGEFS(A,NMAX,NMAX,B,NMAX,1,IPVT,INFO)
      print*,' '
      call SMATP(B,NMAX,NMAX,1,' Solution of A*x = b is:')
c
      print*,' '
      call SMATP(C,NMAX,NMAX,1,' C(,) =')
      call SGESLT(A, NMAX, NMAX, IPVT, C)
      print*,' '
      call SMATP(C,NMAX,NMAX,1,' Solution of (A**t)*x = c is:')
c
      call SGED(A, NMAX, NMAX, IPVT, DET)
      print'(/a,f10.6,a,f5.2,a/)',
     *   ' Determinant of A is:',DET(1),' * 10**(',DET(2),')'
c
      call SGEI(A, NMAX, NMAX, IPVT, WORK)
      call SMATP(A,NMAX,NMAX,NMAX,' Inverse of A =')
      end


    Program zgelqf_example

!     ZGELQF 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 blas_interfaces, Only: ztrsm
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zgelqf, zunmlq
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: one = (1.0_dp, 0.0_dp)
      Complex (Kind=dp), Parameter :: zero = (0.0_dp, 0.0_dp)
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, ldb, lwork, m, n, nrhs
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), tau(:), work(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZGELQF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, nrhs
      lda = m
      ldb = n
      lwork = 64*n
      Allocate (a(lda,n), b(ldb,nrhs), tau(n), work(lwork))

!     Read A and B from data file

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

!     Compute the LQ factorization of A
      Call zgelqf(m, n, a, lda, tau, work, lwork, info)

!     Solve L*Y = B, storing the result in B
      Call ztrsm('Left', 'Lower', 'No transpose', 'Non-Unit', m, nrhs, one, a, &
        lda, b, ldb)

!     Set rows (M+1) to N of B to zero

      If (m<n) Then
        b(m+1:n, 1:nrhs) = zero
      End If

!     Compute minimum-norm solution X = (Q**H)*B in B
      Call zunmlq('Left', 'Conjugate transpose', n, nrhs, m, a, lda, tau, b, &
        ldb, work, lwork, info)

!     Print minimum-norm solution(s)

      Write (nout, *)
      Flush (nout)

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, nrhs, b, &
        ldb, 'Bracketed', 'F7.4', 'Minimum-norm solution(s)', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

    End Program


!
!     Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! NVIDIA CORPORATION and its licensors retain all intellectual property
! and proprietary rights in and to this software, related documentation
! and any modifications thereto.  Any use, reproduction, disclosure or
! distribution of this software and related documentation without an express
! license agreement from NVIDIA CORPORATION is strictly prohibited.
!

program test_matmul
real*8, dimension(2000,2000) :: a, b, c, c_expd
integer*4 :: n = 2000, m = 2000, l = 2000
real*8 :: t1, t2, t3, t4
integer*4 :: i, j, niters, nerrors

call random_number(a)
call random_number(b)
c = 0.0d0
c_expd = 0.0d0
nerrors = 0
niters = 1   ! was 10000

call cpu_time(t1)
do i = 1, niters
  call matmul_s(a,b,c_expd,n,m,l)
enddo
call cpu_time(t2)

call cpu_time(t3)
do i = 1, niters
  call matmul_p(a,b,c,n,m,l)
enddo
call cpu_time(t4)

do j = 1, m
  do i = 1, n
    if (c(i,j) .ne. c_expd(i,j)) then
       nerrors = nerrors + 1
    endif
  enddo
enddo

print *, "Serial Time(seconds): ",t2-t1
print *, "Parallel Time(seconds): ",t4-t3

if (nerrors .ne. 0) then
  print *, "Test FAILED"
else
  print *, "Test PASSED"
endif
end

subroutine matmul_p(a,b,c,n,m,l)
integer*4 :: n, m, l
real*8, dimension(n,l) :: a
real*8, dimension(l,m) :: b
real*8, dimension(n,m) :: c

integer*4 :: i, j, k

do i = 1, n
  do j = 1, m
    do k = 1, l
       c(i,j) = c(i,j) + (a(i,k) * b(k,m))
    enddo
  enddo
enddo

end

!pgi$r noconcur
subroutine matmul_s(a,b,c,n,m,l)
integer*4 :: n, m, l
real*8, dimension(n,l) :: a
real*8, dimension(l,m) :: b
real*8, dimension(n,m) :: c

integer*4 :: i, j, k

do i = 1, n
  do j = 1, m
    do k = 1, l
       c(i,j) = c(i,j) + (a(i,k) * b(k,m))
    enddo
  enddo
enddo

end


      PROGRAM xwtn
C     driver for routine wtn
      INTEGER NCMAX,NX,NY
      REAL EPS
      PARAMETER(NCMAX=50,NX=128,NY=256,EPS=1.e-06)
      INTEGER ncof,ioff,joff,i,j,nerror,ntot
      REAL a(NX,NY),aorg(NX,NY),cc,cr
      COMMON /pwtcom/ cc(NCMAX),cr(NCMAX),ncof,ioff,joff
      INTEGER ndim(2)
      EXTERNAL pwt
      DATA ndim /NX,NY/
      nerror=0
      ntot=NX*NY
      do 12 i=1,NX
        do 11 j=1,NY
          if (i.eq.j) then
            a(i,j)=-1.
          else
            a(i,j)=1./sqrt(abs(float(i-j)))
          endif
          aorg(i,j)=a(i,j)
11      continue
12    continue
      call pwtset(12)
      call wtn(a,ndim,2,1,pwt)
C     here, one might set the smallest components to zero, encode and transmit
C     the remaining components as a compressed form of the "image"
      call wtn(a,ndim,2,-1,pwt)
      do 14 i=1,NX
        do 13 j=1,NY
          if (abs(aorg(i,j)-aorg(i,j)).ge.EPS) then
            write(*,*) 'Compare Error at element ',i,j
            nerror=nerror+1
          endif
13      continue
14    continue
      if (nerror.ne.0) then
        write(*,*) 'Number of comparision errors: ',nerror
      else
        write(*,*) 'Transform-inverse transform check OK'
      endif
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xwtn.for


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED 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
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes Legendre polynomial and its first
!! and second derivative on a given point x.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] n  degree of the polynomial
!> @param[in] x point
!> @param[out] p2  Legendre polynomial of degree n evaluated in x
!> @param[out] p2der  derivative of p2 evaluated in x
!> @param[out] p2der2  second derivative of p2 evaluated in x
!> @param[out] p1  Legendre polynomial of degree n-1 evaluated in x
!> @param[out] p1der  derivative of p1 evaluated in x

     subroutine GET_LEGENDRE_VALUE_2DER(p2der2,p2,p2der,p1,p1der,n,x)

      implicit real*8 (a-h,o-z)

      p2=1.d0
      p2der=0.d0
      p2der2=0.d0
      if (n.eq.0) return
      p1=p2
      p2=x
      p1der=p2der
      p2der=1.d0
      p2der2=0.d0
      p1der2=0.d0
      p0der2=0.d0
      if (n.eq.1) return
      k=1
      p0=p1
      p1=p2
      p0der=p1der
      p1der=p2der
      p0der2 = p1der2
      p1der2 = p2der2
      dk=dfloat(k)
      a1=(2.d0*dk+1.d0)/(dk+1.d0)
      a2=-dk/(dk+1.d0)
      p2=a1*p1*x+a2*p0
      p2der=a1*p1+a1*p1der*x+a2*p0der
      p2der2=a1*p1der2*x+2.d0*a1*p1der+a2*p0der2
      if (n.eq.2) return
      do k=2,n-1
        p0=p1
        p1=p2
        p0der=p1der
        p1der=p2der
        p0der2=p1der2
        p1der2=p2der2
        dk=dfloat(k)
        a1=(2.d0*dk+1.d0)/(dk+1.d0)
        a2=-dk/(dk+1.d0)
        p2=a1*p1*x+a2*p0
        p2der=a1*p1+a1*p1der*x+a2*p0der
        p2der2=a1*p1der2*x+2.d0*a1*p1der+a2*p0der2
      enddo
      return
      end subroutine GET_LEGENDRE_VALUE_2DER


!     ------------------------------------------------------------------
Subroutine Jacobian (Jac,Det,NDim,NodG,XL,dF)
    !     ------------------------------------------------------------------
    Implicit real*8 (a-h,o-z)
    Dimension dF(NDim,NodG),XL(1)
    !     ojo que en algun lugar dF(NDimE,NodEL)
    !     Hay que hacer compatible esta cuestion de diemensionamientos
    !
    Real*8 JacInv(NDim,NDim)
    Real*8 Jac(NDim,NDim)
    !
    !     Do iGC=1,NDim
    !     Do iLC=1,NDim
    !     JacInv(iGC,iLC)= 0.0d0
    !     Enddo
    !     Enddo
    JacInv = 0.0d0
    !
    Do Nod=1,NodG
        iPNod = (Nod-1)*NDim
        Do iGC=1,NDim
            Do iLC=1,NDim
                JacInv(iLC,iGC) = JacInv(iLC,iGC) + &
                    &              XL( iPNod + iGC ) * dF(iLC,Nod)
            Enddo
        Enddo
    Enddo
    !     Ya no (Uso de rutina IMSL para invertir JacInv y obtener Jac)
    !
    Select Case (NDim)
        Case (1)
            Determinant = JacInv(1,1)
            if (Determinant .NE.0.0d0 ) then
                Jac(1,1)    = 1.0d0 / Determinant
            else
                Write (*,*)'WARNING, Element Jacobian = 0'
                Write (*,*)'WARNING, Element Jacobian = 0'
                Write (*,*)'WARNING, Element Jacobian = 0'
                Stop
            endif
        !
        Case (2)
            Determinant = JacInv(1,1)*JacInv(2,2)-JacInv(1,2)*JacInv(2,1)
            if (Determinant .NE.0.0d0 ) then
                Jac(1,1)    = JacInv(2,2) / Determinant
                Jac(1,2)    =-JacInv(1,2) / Determinant
                Jac(2,1)    =-JacInv(2,1) / Determinant
                Jac(2,2)    = JacInv(1,1) / Determinant
            else
                Write (*,*)'WARNING, Element Jacobian = 0 , dim 2'
                Write (*,*)'WARNING, Element Jacobian = 0 , dim 2'
                Write (*,*)'WARNING, Element Jacobian = 0 , dim 2'
                Stop
            endif
        !
        Case (3)
            A1 = JacInv(3,3)*JacInv(2,2) - JacInv(3,2)*JacInv(2,3)
            B1 = JacInv(3,3)*JacInv(2,1) - JacInv(3,1)*JacInv(2,3)
            C1 = JacInv(3,2)*JacInv(2,1) - JacInv(3,1)*JacInv(2,2)
            !
            A2 = JacInv(3,3)*JacInv(1,2) - JacInv(3,2)*JacInv(1,3)
            B2 = JacInv(3,3)*JacInv(1,1) - JacInv(3,1)*JacInv(1,3)
            C2 = JacInv(3,2)*JacInv(1,1) - JacInv(3,1)*JacInv(1,2)
            !
            A3 = JacInv(2,3)*JacInv(1,2) - JacInv(2,2)*JacInv(1,3)
            B3 = JacInv(2,3)*JacInv(1,1) - JacInv(2,1)*JacInv(1,3)
            C3 = JacInv(2,2)*JacInv(1,1) - JacInv(2,1)*JacInv(1,2)
            !
            Determinant= JacInv(1,1)*A1 - JacInv(1,2)*B1 + JacInv(1,3)*C1
            !
            if (Determinant .NE.0.0d0 ) then
                Jac(1,1)    = A1 / Determinant
                Jac(1,2)    =-A2 / Determinant
                Jac(1,3)    = A3 / Determinant
                !
                Jac(2,1)    =-B1 / Determinant
                Jac(2,2)    = B2 / Determinant
                Jac(2,3)    =-B3 / Determinant
                !
                Jac(3,1)    = C1 / Determinant
                Jac(3,2)    =-C2 / Determinant
                Jac(3,3)    = C3 / Determinant
            else
                Write (*,*)'WARNING, Element Jacobian = 0 , dim 3' , Determinant
                Write (*,*)'WARNING, Element Jacobian = 0 , dim 3' , Determinant
                Write (*,*)'WARNING, Element Jacobian = 0 , dim 3' , Determinant
                Stop
            endif
        !
        Case default
            Write (*,*)'Invalid Case for Determinant of element"s Jacobian'
            Write (*,*)'Dimension of Simplex not contained in 1-3',NDim
            Write (*,*)'WARNING, Jacobian of an element = 0'
            Stop
    !     Determinant=0.0d0
    End Select
    !
    !     Det = Determinant(NDim,JacInv)
    Det = Determinant
    !
    if (Det < 0.0d0) then
        Write (*,*)'!!!!! WARNING, Jacobian of an element < 0'
    End if
    !
    !     CALL DLINRG (NDim, JacInv, NDim, Jac, NDim)
    !
    Return
End Subroutine Jacobian
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Real*8 function Determinant(NDim,Jac)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit real*8 (a-h,o-z)
    Real*8 Jac(NDim,NDim)
    !
    Select Case (NDim)
        Case (1)
            Determinant = Jac(1,1)
        Case (2)
            Determinant = Jac(1,1)*Jac(2,2)-Jac(1,2)*Jac(2,1)
        Case (3)
            Determinant = Jac(1,1)*(Jac(3,3)*Jac(2,2)-Jac(3,2)*Jac(2,3)) &
                &        - Jac(1,2)*(Jac(3,3)*Jac(2,1)-Jac(3,1)*Jac(2,3)) &
                &        + Jac(1,3)*(Jac(3,2)*Jac(2,1)-Jac(3,1)*Jac(2,2))
        Case default
            !     Write (*,*)'Invalid Case for Determinant of element"s Jacobian'
            !     Write (*,*)'Dimension of Simplex not contained in 1-3',NDim
            Determinant=0.0d0
    !
    End Select
    !
    Return
End
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine LocalShapeDer (NodEL,NDim,dF,GaussPoint,Iorder,iBu)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit real*8 (a-h,o-z)
    Dimension dF(NDim,NodEL),GaussPoint(NDim)
    Integer d(NDim)
    !     Ejemplo: ndim=3, d(3) vector indicador
    !     de la derivada de primer orden = d/dy-> [0,1,0]
    !     iBu = 1 Bubble element, iBu=0 Linear_Element
    !     NLSF=NDim+1+iBu : Number of Linear Shape Functions
    !     Deriv=1
    NLSF=NDim+1+iBu
    d=0
    !
    Do Nod=1,NodEL
        Do iLC=1,NDim
            !
            d(iLC)=1
            if (Iorder .eq. 1 .and. Nod .GT. NLSF) then
                dF(iLC,Nod)= 0.0d0
            else
                dF(iLC,Nod)= SFSimplex(GaussPoint,d,Iorder,Nod,NDim)
            endif
            d(iLC)=0
        !
        Enddo
    Enddo
    !
    Return
End Subroutine LocalShapeDer
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine GlobalShapeDer (NodEL,NDim,dF_L,dF_G,Jac)
    Implicit real*8 (a-h,o-z)
    Dimension dF_L(NDim,NodEL),dF_G(NDim,NodEL)
    Real*8 Jac(NDim,NDim)
    !
    !     Do Nod=1,NodEL
    !     Do iGC=1,NDim
    !     dF_G(iGC,Nod)=0.0d0
    !     Enddo
    !     Enddo
    dF_G = 0.0d0
    !    C
    Do Nod=1,NodEL
        Do iLC=1,NDim
            Do iGC=1,NDim
                dF_G(iGC,Nod)= dF_G (iGC,Nod)+ dF_L(iLC,Nod)*Jac(iGC,iLC)
            Enddo
        Enddo
    Enddo
    !
    Return
End Subroutine GlobalShapeDer
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine ShapeF (NodEL,NDim,F,GaussPoint,iOrder,iBu)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit real*8 (a-h,o-z)
    Dimension F(NodEL),GaussPoint(NDim)
    !     iBu = 1 Bubble element, iBu=0 Linear_Element
    !     NLSF=NDim+1+iBu : Number of Linear Shape Functions
    !     iOrder = Interpolation order: 1=Linear; 2=Cuadratic
    Integer d(NDim)
    !
    d=0
    NLSF=NDim+1+iBu
    !
    Do Nod=1,NodEL
        if (Iorder .eq. 1 .and. Nod .GT. NLSF) then
            F(Nod)= 0.0d0
        else
            F(Nod)= SFSimplex(GaussPoint,d,iOrder,Nod,NDim)
        endif
    Enddo
    !
    Return
End Subroutine ShapeF
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine GaussRule (Psi,W,NDim,NGP,iSimplex)
    Implicit real*8 (a-h,o-z)
    Dimension PSI(NDim,NGP),W(NGP)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !
    CaseSimplex: Select case (iSimplex)
        !     iSimplex = 0 -> The element is a Simplex
        !     iSimplex = 1 -> The element is a HiperCube
        !
        Case (0)
            !     The element is a simplex
            !
            CaseNDimSimplex: Select case (NDim)
                !
                !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                !     gauss points for  tetrahedral elements
                !     last modifief 19/9/01
                !
                Case (3)
                    !
                    CaseNGP3d: Select case (NGP)
                        !
                        Case (1)
                                         !     tetrahedral 1-points formula, degree of precision 1
                                         !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.25D0
                            PSI(2,1) = 0.25D0
                            PSI(3,1) = 0.25D0
                                         !  Weights/6
                            W(1) = 1.0D0*0.166666666666667D0
                        !
                        Case (4)
                            !     tetrahedral 4-points formula, degree of precision 2
                            !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.1381966011250105D0
                            PSI(2,1) = 0.1381966011250105D0
                            PSI(3,1) = 0.1381966011250105D0
                            PSI(1,2) = 0.5854101966249685D0
                            PSI(2,2) = 0.1381966011250105D0
                            PSI(3,2) = 0.1381966011250105D0
                            PSI(1,3) = 0.1381966011250105D0
                            PSI(2,3) = 0.5854101966249685D0
                            PSI(3,3) = 0.1381966011250105D0
                            PSI(1,4) = 0.1381966011250105D0
                            PSI(2,4) = 0.1381966011250105D0
                            PSI(3,4) = 0.5854101966249685D0

                                         !     Weights/6
                            WT   = 0.25D0*0.1666666666666667D0
                            W(1) = WT
                            W(2) = WT
                            W(3) = WT
                            W(4) = WT
                        !
                        Case (5)
                                         !     tetrahedral 5-points formula, degree of precision 3
                                         !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.25D0
                            PSI(2,1) = 0.25D0
                            PSI(3,1) = 0.25D0
                            PSI(1,2) = 0.1666666666666667D0
                            PSI(2,2) = 0.1666666666666667D0
                            PSI(3,2) = 0.1666666666666667D0
                            PSI(1,3) = 0.3333333333333333D0
                            PSI(2,3) = 0.1666666666666667D0
                            PSI(3,3) = 0.1666666666666667D0
                            PSI(1,4) = 0.1666666666666667D0
                            PSI(2,4) = 0.3333333333333333D0
                            PSI(3,4) = 0.1666666666666667D0
                            PSI(1,5) = 0.1666666666666667D0
                            PSI(2,5) = 0.1666666666666667D0
                            PSI(3,5) = 0.3333333333333333D0
                                         !     Weights/6
                            W(1) = - 0.80D0*0.1666666666666667D0
                            WT   =   0.45D0*0.1666666666666667D0
                            W(2) = WT
                            W(3) = WT
                            W(4) = WT
                            W(5) = WT
                        !
                        Case (11)
                              !    Tetrahedral 11-points formula, degree of precision 4
                              !    Gauss Points Intrinsic Coordinates
                              ! See reference: Yen Liu and Marcel Vinokur,
                              !   "Exact Integrations of Polynomials and
                              !    Symmetric Quadrature Formulas over Arbitrary Polyhedral Grids",
                              !    NASA Report > NASA TM-112202; Ames Research Center A-976805
                            PSI(1,1) = 0.25D0
                            PSI(2,1) = 0.25D0
                            PSI(3,1) = 0.25D0
                            !
                                                   ! Vertex based points
                            Alpha = 5.0d0/7.0d0
                            Psi1  = 0.25d0 + 0.75d0 * Alpha
                            Psi2  = 0.25d0 * ( 1.0d0 - Alpha )
                            PSI(1,2) = Psi2
                            PSI(2,2) = Psi2
                            PSI(3,2) = Psi2
                            !
                            PSI(1,3) = Psi1
                            PSI(2,3) = Psi2
                            PSI(3,3) = Psi2
                            !
                            PSI(1,4) = Psi2
                            PSI(2,4) = Psi1
                            PSI(3,4) = Psi2
                            !
                            PSI(1,5) = Psi2
                            PSI(2,5) = Psi2
                            PSI(3,5) = Psi1
                            !
                                                   ! Side based points
                            Beta  = Dsqrt( 70.0d0 ) / 28.0d0
                            Psi1  = 0.25d0 + 0.5d0 * Beta
                            Psi2  = 0.25d0 - 0.5d0 * Beta
                            PSI(1,6) = Psi1
                            PSI(2,6) = Psi1
                            PSI(3,6) = Psi2
                            !
                            PSI(1,7) = Psi1
                            PSI(2,7) = Psi2
                            PSI(3,7) = Psi1
                            !
                            PSI(1,8) = Psi2
                            PSI(2,8) = Psi1
                            PSI(3,8) = Psi1
                            !
                            PSI(1,9) = Psi2
                            PSI(2,9) = Psi2
                            PSI(3,9) = Psi1
                            !
                            PSI(1,10)= Psi2
                            PSI(2,10)= Psi1
                            PSI(3,10)= Psi2
                            !
                            PSI(1,11)= Psi1
                            PSI(2,11)= Psi2
                            PSI(3,11)= Psi2
                            !
                                                   !     Weights/6
                            W(1) = - ( 1.48D2 / 1.875D3 ) * 0.1666666666666667D0
                            WT   =   ( 3.43D2 / 7.5D3   ) * 0.1666666666666667D0
                            W(2) = WT
                            W(3) = WT
                            W(4) = WT
                            W(5) = WT
                            !
                            WTB   =   ( 5.6D1 / 3.75D2   ) * 0.1666666666666667D0
                            W(6 ) = WTB
                            W(7 ) = WTB
                            W(8 ) = WTB
                            W(9 ) = WTB
                            W(10) = WTB
                            W(11) = WTB
                    !
                    EndSelect CaseNGP3d
                !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                !     gauss points for triangular elements
                Case (2)
                    !
                    CaseNGP2d: Select case (NGP)
                        !
                        Case (1)
                            !     triangle 1-points formula, degree of precision 1
                            !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.333333333333333D0
                            PSI(2,1) = 0.333333333333333D0
                            !     Weights/2
                            W(1) = 1.0D0 *0.5d0
                        !
                        Case (3)
                            !     triangle 3-points formula, degree of precision 2
                            !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.166666666666667D0
                            PSI(2,1) = 0.166666666666667D0
                            PSI(1,2) = 0.666666666666667D0
                            PSI(2,2) = 0.166666666666667D0
                            PSI(1,3) = 0.166666666666667D0
                            PSI(2,3) = 0.666666666666667D0
                            !     Weights/2
                            WT   = 0.333333333333333D0 *0.5d0
                            W(1) = WT
                            W(2) = WT
                            W(3) = WT
                        !
                        Case (4)
                            !     triangle 4-points formula, degree of precision 3
                            !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.2D0
                            PSI(2,1) = 0.2D0
                            PSI(1,2) = 0.6D0
                            PSI(2,2) = 0.2D0
                            PSI(1,3) = 0.2D0
                            PSI(2,3) = 0.6D0
                            PSI(1,4) = 0.333333333333333D0
                            PSI(2,4) = 0.333333333333333D0
                            !     Weights/2
                            WT   = 0.520833333333333D0 *0.5d0
                            W(1) = WT
                            W(2) = WT
                            W(3) = WT
                            W(4) = - 0.56250D0 *0.5d0
                        !
                        Case (6)
                            !     triangle 6-points formula, degree of precision 4
                            !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.091576213509771D0
                            PSI(2,1) = 0.091576213509771D0
                            PSI(1,2) = 0.445948490915965D0
                            PSI(2,2) = 0.445948490915965D0
                            PSI(1,3) = 0.816847572980459D0
                            PSI(2,3) = 0.091576213509771D0
                            PSI(1,4) = 0.108103018168070D0
                            PSI(2,4) = 0.445948490915965D0
                            PSI(1,5) = 0.091576213509771D0
                            PSI(2,5) = 0.816847572980459D0
                            PSI(1,6) = 0.445948490915965D0
                            PSI(2,6) = 0.108103018168070D0
                            !     Weights/2
                            WT1  = 0.109951743655322D0 *0.5d0
                            WT2  = 0.223381589678011D0 *0.5d0
                            W(1) = WT1
                            W(2) = WT2
                            W(3) = WT1
                            W(4) = WT2
                            W(5) = WT1
                            W(6) = WT2
                        !
                        Case (7)
                            !     triangle 7-points formula, degree of precision 5
                            !     Gauss Points Intrinsic Coordinates
                            PSI(1,1) = 0.333333333333333D0
                            PSI(2,1) = 0.333333333333333D0
                            PSI(1,2) = 0.101286507323456D0
                            PSI(2,2) = 0.101286507323456D0
                            PSI(1,3) = 0.470142064105115D0
                            PSI(2,3) = 0.470142064105115D0
                            PSI(1,4) = 0.797426985353087D0
                            PSI(2,4) = 0.101286507323456D0
                            PSI(1,5) = 0.059715871789770D0
                            PSI(2,5) = 0.470142064105115D0
                            PSI(1,6) = 0.101286507323456D0
                            PSI(2,6) = 0.797426985353087D0
                            PSI(1,7) = 0.470142064105115D0
                            PSI(2,7) = 0.059715871789770D0
                            !     Weights/2
                            W(1) = 0.225000000000000d0 *0.5d0
                            WT1  = 0.125939180544827d0 *0.5d0
                            WT2  = 0.132394152788506d0 *0.5d0
                            W(2) = WT1
                            W(3) = WT2
                            W(4) = WT1
                            W(5) = WT2
                            W(6) = WT1
                            W(7) = WT2
                    !
                    EndSelect CaseNGP2d
                !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                !Gauss Points for 1D segments as simplexs(gauss coordinates between[0-1])
                !
                Case (1)
                    !     NDim=1
                    !     integrates exactly a polynomial of order 2*NGP-1
                    CaseNGP1D: Select case (NGP)
                        Case (1)
                            PSI(1,1) = 0.5D0
                            W(1) = 1.0d0
                        !
                        Case (2)
                            GaussPoint1 = 1.0d0/Dsqrt(3.0d0)
                            PSI(1,1) = 0.5d0*( 1.0d0 - GaussPoint1 )
                            PSI(1,2) = 0.5d0*( 1.0d0 + GaussPoint1 )
                            W(1) = 0.5d0
                            W(2) = 0.5d0
                        !
                        Case (3)
                            GaussPoint1 = Dsqrt(0.6d0)
                            PSI(1,1) = 0.5d0*( 1.0d0 - GaussPoint1 )
                            PSI(1,2) = 0.5d0*( 1.0d0 + GaussPoint1 )
                            PSI(1,3) = 0.5d0
                            W1 = 2.5d0/9.0d0
                            W(1) = W1
                            W(2) = W1
                            W(3) = 4.0d0/9.0d0
                        !
                        Case (4)
                            R = Dsqrt(1.2d0)
                            GaussPoint1 = Dsqrt( (3.0d0+2.0d0*R) / 7.0d0 )
                            GaussPoint2 = Dsqrt( (3.0d0-2.0d0*R) / 7.0d0 )
                            PSI(1,1) = 0.5d0*( 1.0d0 - GaussPoint1 )
                            PSI(1,2) = 0.5d0*( 1.0d0 + GaussPoint1 )
                            PSI(1,3) = 0.5d0*( 1.0d0 - GaussPoint2 )
                            PSI(1,4) = 0.5d0*( 1.0d0 + GaussPoint2 )
                            W1 = 1.0d0 / (12.0d0*R)
                            W(1) = (0.25d0-W1)
                            W(2) = (0.25d0-W1)
                            W(3) = (0.25d0+W1)
                            W(4) = (0.25d0+W1)
                    !
                    EndSelect CaseNGP1D
            !
            EndSelect CaseNDimSimplex
        !
        !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        Case (1)
            !     The element is a Hipercube
            !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
            !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
            !
            CaseNDimCube: Select case (NDim)
                Case (1)
                    CaseNGPCube: Select case (NGP)
                        !     integrates exactly a polynomial of order 2*NGP-1
                        Case (1)
                            PSI(1,1) = 0.0D0
                            !     Weights
                            W(1) = 2.0d0
                        !
                        Case (2)
                            GaussPoint1 = 1.0d0/Dsqrt(3.0d0)
                            PSI(1,1) = -GaussPoint1
                            PSI(1,2) =  GaussPoint1
                            !     Weights
                            W(1) = 1.0d0
                            W(2) = 1.0d0
                        !
                        Case (3)
                            GaussPoint1 = Dsqrt(0.6d0)
                            PSI(1,1) = -GaussPoint1
                            PSI(1,2) =  GaussPoint1
                            PSI(1,3) =  0.0d0
                            !     Weights
                            W1 = 5.0d0/9.0d0
                            W(1) = W1
                            W(2) = W1
                            W(3) = 8.0d0/9.0d0
                        !
                        Case (4)
                            R = Dsqrt(1.2d0)
                            GaussPoint1 = Dsqrt( (3.0d0+2.0d0*R) / 7.0d0 )
                            GaussPoint2 = Dsqrt( (3.0d0-2.0d0*R) / 7.0d0 )
                            PSI(1,1) = -GaussPoint1
                            PSI(1,2) =  GaussPoint1
                            PSI(1,3) = -GaussPoint2
                            PSI(1,4) =  GaussPoint2
                            !     Weights
                            W1 = 1.0d0 / (6.0d0*R)
                            W(1) = (0.5d0-W1)
                            W(2) = (0.5d0-W1)
                            W(3) = (0.5d0+W1)
                            W(4) = (0.5d0+W1)
                    !
                    EndSelect CaseNGPCube

                case (2)
                    CaseNGPCubeDim2: Select case (NGP)

                        case (1)

                            PSI(1,1) = 0.0d0
                            PSI(2,1) = 0.0d0

                            W(1) = 4.0d0

                        case (4)

                            PSI(1,1) =    5.773502691896257d-01
                            PSI(1,2) =    5.773502691896257d-01
                            PSI(1,3) =   -5.773502691896257d-01
                            PSI(1,4) =   -5.773502691896257d-01
                            PSI(2,1) =    5.773502691896257d-01
                            PSI(2,2) =   -5.773502691896257d-01
                            PSI(2,3) =    5.773502691896257d-01
                            PSI(2,4) =   -5.773502691896257d-01
                            W(1) =    1.0d0
                            W(2) =    1.0d0
                            W(3) =    1.0d0
                            W(4) =    1.0d0

                        case (9)

                            PSI(1,1) =    7.745966692414834d-01
                            PSI(1,2) =    7.745966692414834d-01
                            PSI(1,3) =    7.745966692414834d-01
                            PSI(1,4) =    0.000000000000000d+00
                            PSI(1,5) =    0.000000000000000d+00
                            PSI(1,6) =    0.000000000000000d+00
                            PSI(1,7) =   -7.745966692414834d-01
                            PSI(1,8) =   -7.745966692414834d-01
                            PSI(1,9) =   -7.745966692414834d-01
                            PSI(2,1) =    7.745966692414834d-01
                            PSI(2,2) =    0.000000000000000d+00
                            PSI(2,3) =   -7.745966692414834d-01
                            PSI(2,4) =    7.745966692414834d-01
                            PSI(2,5) =    0.000000000000000d+00
                            PSI(2,6) =   -7.745966692414834d-01
                            PSI(2,7) =    7.745966692414834d-01
                            PSI(2,8) =    0.000000000000000d+00
                            PSI(2,9) =   -7.745966692414834d-01
                            W(1) =    3.086419753086406d-01
                            W(2) =    4.938271604938261d-01
                            W(3) =    3.086419753086406d-01
                            W(4) =    4.938271604938261d-01
                            W(5) =    7.901234567901234d-01
                            W(6) =    4.938271604938261d-01
                            W(7) =    3.086419753086406d-01
                            W(8) =    4.938271604938261d-01
                            W(9) =    3.086419753086406d-01

                    EndSelect CaseNGPCubeDim2

                case (3)
                    CaseNGPCubeDim3: Select case (NGP)

                        case (1)

                            PSI(1,1) = 0.0d0
                            PSI(2,1) = 0.0d0
                            PSI(3,1) = 0.0d0
                            W(1) = 8.0d0

                        case (8)
                            PSI(1,1) =    5.773502691896257d-01
                            PSI(1,2) =    5.773502691896257d-01
                            PSI(1,3) =    5.773502691896257d-01
                            PSI(1,4) =    5.773502691896257d-01
                            PSI(1,5) =   -5.773502691896257d-01
                            PSI(1,6) =   -5.773502691896257d-01
                            PSI(1,7) =   -5.773502691896257d-01
                            PSI(1,8) =   -5.773502691896257d-01
                            PSI(2,1) =    5.773502691896257d-01
                            PSI(2,2) =    5.773502691896257d-01
                            PSI(2,3) =   -5.773502691896257d-01
                            PSI(2,4) =   -5.773502691896257d-01
                            PSI(2,5) =    5.773502691896257d-01
                            PSI(2,6) =    5.773502691896257d-01
                            PSI(2,7) =   -5.773502691896257d-01
                            PSI(2,8) =   -5.773502691896257d-01
                            PSI(3,1) =    5.773502691896257d-01
                            PSI(3,2) =   -5.773502691896257d-01
                            PSI(3,3) =    5.773502691896257d-01
                            PSI(3,4) =   -5.773502691896257d-01
                            PSI(3,5) =    5.773502691896257d-01
                            PSI(3,6) =   -5.773502691896257d-01
                            PSI(3,7) =    5.773502691896257d-01
                            PSI(3,8) =   -5.773502691896257d-01
                            W(1) =    1.0d0
                            W(2) =    1.0d0
                            W(3) =    1.0d0
                            W(4) =    1.0d0
                            W(5) =    1.0d0
                            W(6) =    1.0d0
                            W(7) =    1.0d0
                            W(8) =    1.0d0

                        case (27)

                            PSI(1,1) =    7.745966692414834d-01
                            PSI(1,2) =    7.745966692414834d-01
                            PSI(1,3) =    7.745966692414834d-01
                            PSI(1,4) =    7.745966692414834d-01
                            PSI(1,5) =    7.745966692414834d-01
                            PSI(1,6) =    7.745966692414834d-01
                            PSI(1,7) =    7.745966692414834d-01
                            PSI(1,8) =    7.745966692414834d-01
                            PSI(1,9) =    7.745966692414834d-01
                            PSI(1,10) =    0.000000000000000d+00
                            PSI(1,11) =    0.000000000000000d+00
                            PSI(1,12) =    0.000000000000000d+00
                            PSI(1,13) =    0.000000000000000d+00
                            PSI(1,14) =    0.000000000000000d+00
                            PSI(1,15) =    0.000000000000000d+00
                            PSI(1,16) =    0.000000000000000d+00
                            PSI(1,17) =    0.000000000000000d+00
                            PSI(1,18) =    0.000000000000000d+00
                            PSI(1,19) =   -7.745966692414834d-01
                            PSI(1,20) =   -7.745966692414834d-01
                            PSI(1,21) =   -7.745966692414834d-01
                            PSI(1,22) =   -7.745966692414834d-01
                            PSI(1,23) =   -7.745966692414834d-01
                            PSI(1,24) =   -7.745966692414834d-01
                            PSI(1,25) =   -7.745966692414834d-01
                            PSI(1,26) =   -7.745966692414834d-01
                            PSI(1,27) =   -7.745966692414834d-01
                            PSI(2,1) =    7.745966692414834d-01
                            PSI(2,2) =    7.745966692414834d-01
                            PSI(2,3) =    7.745966692414834d-01
                            PSI(2,4) =    0.000000000000000d+00
                            PSI(2,5) =    0.000000000000000d+00
                            PSI(2,6) =    0.000000000000000d+00
                            PSI(2,7) =   -7.745966692414834d-01
                            PSI(2,8) =   -7.745966692414834d-01
                            PSI(2,9) =   -7.745966692414834d-01
                            PSI(2,10) =    7.745966692414834d-01
                            PSI(2,11) =    7.745966692414834d-01
                            PSI(2,12) =    7.745966692414834d-01
                            PSI(2,13) =    0.000000000000000d+00
                            PSI(2,14) =    0.000000000000000d+00
                            PSI(2,15) =    0.000000000000000d+00
                            PSI(2,16) =   -7.745966692414834d-01
                            PSI(2,17) =   -7.745966692414834d-01
                            PSI(2,18) =   -7.745966692414834d-01
                            PSI(2,19) =    7.745966692414834d-01
                            PSI(2,20) =    7.745966692414834d-01
                            PSI(2,21) =    7.745966692414834d-01
                            PSI(2,22) =    0.000000000000000d+00
                            PSI(2,23) =    0.000000000000000d+00
                            PSI(2,24) =    0.000000000000000d+00
                            PSI(2,25) =   -7.745966692414834d-01
                            PSI(2,26) =   -7.745966692414834d-01
                            PSI(2,27) =   -7.745966692414834d-01
                            PSI(3,1) =    7.745966692414834d-01
                            PSI(3,2) =    0.000000000000000d+00
                            PSI(3,3) =   -7.745966692414834d-01
                            PSI(3,4) =    7.745966692414834d-01
                            PSI(3,5) =    0.000000000000000d+00
                            PSI(3,6) =   -7.745966692414834d-01
                            PSI(3,7) =    7.745966692414834d-01
                            PSI(3,8) =    0.000000000000000d+00
                            PSI(3,9) =   -7.745966692414834d-01
                            PSI(3,10) =    7.745966692414834d-01
                            PSI(3,11) =    0.000000000000000d+00
                            PSI(3,12) =   -7.745966692414834d-01
                            PSI(3,13) =    7.745966692414834d-01
                            PSI(3,14) =    0.000000000000000d+00
                            PSI(3,15) =   -7.745966692414834d-01
                            PSI(3,16) =    7.745966692414834d-01
                            PSI(3,17) =    0.000000000000000d+00
                            PSI(3,18) =   -7.745966692414834d-01
                            PSI(3,19) =    7.745966692414834d-01
                            PSI(3,20) =    0.000000000000000d+00
                            PSI(3,21) =   -7.745966692414834d-01
                            PSI(3,22) =    7.745966692414834d-01
                            PSI(3,23) =    0.000000000000000d+00
                            PSI(3,24) =   -7.745966692414834d-01
                            PSI(3,25) =    7.745966692414834d-01
                            PSI(3,26) =    0.000000000000000d+00
                            PSI(3,27) =   -7.745966692414834d-01
                            W(1) =    1.714677640603555d-01
                            W(2) =    2.743484224965694d-01
                            W(3) =    1.714677640603555d-01
                            W(4) =    2.743484224965694d-01
                            W(5) =    4.389574759945121d-01
                            W(6) =    2.743484224965694d-01
                            W(7) =    1.714677640603555d-01
                            W(8) =    2.743484224965694d-01
                            W(9) =    1.714677640603555d-01
                            W(10) =    2.743484224965694d-01
                            W(11) =    4.389574759945121d-01
                            W(12) =    2.743484224965694d-01
                            W(13) =    4.389574759945121d-01
                            W(14) =    7.023319615912208d-01
                            W(15) =    4.389574759945121d-01
                            W(16) =    2.743484224965694d-01
                            W(17) =    4.389574759945121d-01
                            W(18) =    2.743484224965694d-01
                            W(19) =    1.714677640603555d-01
                            W(20) =    2.743484224965694d-01
                            W(21) =    1.714677640603555d-01
                            W(22) =    2.743484224965694d-01
                            W(23) =    4.389574759945121d-01
                            W(24) =    2.743484224965694d-01
                            W(25) =    1.714677640603555d-01
                            W(26) =    2.743484224965694d-01
                            W(27) =    1.714677640603555d-01

                    EndSelect CaseNGPCubeDim3

            !
            EndSelect CaseNDimCube
    !
    EndSelect CaseSimplex
    !
    Return
end Subroutine GaussRule

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine LocalShapeDerQ (NodEL,NDim,dF,GaussPoint,Iorder,iS)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit real*8 (a-h,o-z)
    Dimension dF(NDim,NodEL),GaussPoint(NDim)
    Integer d(NDim)
    ! Ejemplo: ndim=3, d(3) vector indicador de la derivada de primer orden = d/dy-> [0,1,0]
    !    iS = 1 Serendipity element, iS=0 Lagrangian element
    d=0

    Do Nod=1,NodEL
        Do iLC=1,NDim
            d(iLC)=1
            dF(iLC,Nod)= &
                &            SFQuadrilateral(GaussPoint,d,Iorder,Nod,NDim,iS)
            d(iLC)=0
        Enddo
    Enddo

    Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine ShapeFQ (NodEL,NDim,F,GaussPoint,iOrder,iS)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit real*8 (a-h,o-z)
    Dimension F(NodEL),GaussPoint(NDim)
    !    iS = 1 Serendipity element, iS=0 Lagrangian element
    !    iOrder = Interpolation order: 1=Linear; 2=Cuadratic
    Integer d(NDim)

    d=0
    Do Nod=1,NodEL
        F(Nod)= SFQuadrilateral(GaussPoint,d,iOrder,Nod,NDim,iS)
    Enddo

    Return
End
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c *** Example of the Arnoldi iteration
c *** Copyright (c) 2020, Ioannis Nompelis
c *** See "LICENSE" for terms of use.
c *** Ioannis Nompelis <nompelis@nobelware.com>
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       Program main
       Implicit none
       Real*8,allocatable,dimension(:,:) :: amat
       Real*8,allocatable,dimension(:) :: bvec
       Real*8,allocatable,dimension(:,:) :: q,h
       Integer*4 :: size, num, i,k

       size = 10
       num = 4

       allocate( amat(size,size), bvec(size), q(size,num), h(num,num) )
       amat(:,:) = 0.0d0
       bvec(:) = 0.0d0

       call setup( size, amat, bvec )

       call arnoldi_basis( size, amat, bvec, num, q, h )

       PRINT*,'Vectors'
       do k = 1,num
          PRINT*,'k=',k
          do i = 1,size
             PRINT*,'i=',i,'   q=',q(i,k)
          enddo
       enddo

       call check_orthogonality ( size, num, q )

       End

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       Subroutine arnoldi_basis( size, amat, bvec, num, qvecs, hmat )
       Implicit none
       Integer*4, intent(IN) :: size, num
       Real*8,dimension( size, size ), intent(IN) :: amat
       Real*8,dimension( size ), intent(IN) :: bvec
       Real*8,dimension( size, num ), intent(OUT) :: qvecs
       Real*8,dimension( num, num ), intent(OUT) :: hmat
       Integer*4 :: i,j,k,kk
       Real*8 :: r

       !--- form the first vector assuming it is not normalized
       r = 0.0d0
       do i = 1,size
          r = r + bvec(i)*bvec(i)
       enddo
       r = sqrt(r)
       !--- magnitude of the initial vector; assume it is not a unit vector
       hmat(1,1) = r
       !--- store the first vector normalized
       r = 1.0d0/r
       do i = 1,size
          qvecs(i,1) = bvec(i) * r
       enddo

       !--- form the subsequent vectors (so that there are "num" in total)
       do k = 2,num
          !--- map to a new vector using the matrix
          do i = 1,size
             r = 0.0d0
             do j = 1,size
                r = r + amat(i,j) * qvecs(j,k-1)
             enddo
             qvecs(i,k) = r
          enddo

          !--- make orthogonal to all previous vectors (up to k-1)
          do kk = 1,k-1
             r = 0.0d0
             do i = 1,size
                r = r + qvecs(i,k) * qvecs(i,kk)
             enddo
             !--- store projetion to the Hezenberg matrix
             hmat(k,kk) = r
             !--- subtract the projection vectorwise
             do i = 1,size
                qvecs(i,k) = qvecs(i,k) - r * qvecs(i,kk)
             enddo
          enddo
          !--- calculate the magnitude
          r = 0.0d0
          do i = 1,size
             r = r + qvecs(i,k) * qvecs(i,k)
          enddo
          r = sqrt(r)
          hmat(k,k) = r
          r = 1.0d0/r
          do i = 1,size
             qvecs(i,k) = qvecs(i,k) * r
          enddo
       enddo

       End

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       Subroutine setup( size, amat, bvec )
       Implicit none
       Integer*4, intent(IN) :: size
       Real*8,dimension( size, size ), intent(INOUT) :: amat
       Real*8,dimension( size ), intent(INOUT) :: bvec
       Integer*4 :: i,j

       do i = 1,size
       do j = 1,size
          if( i.eq.j ) amat(i,j) = -2.0d0
          if( i.eq.j-1) amat(i,j) = 1.0d0
          if( i.eq.j+1) amat(i,j) = 1.0d0
       enddo
       enddo
       amat(1,:) = 0.0d0
       amat(1,1) = 1.0d0
       amat(size,:) = 0.0d0
       amat(size,size) = 1.0d0

       PRINT*,'Matrix'
       do i = 1,size
          PRINT*,'Row',i
       do j = 1,size
          PRINT*,amat(i,j)
       enddo
       enddo

       do i = 1,size
          bvec(i) = 1.0d0
       enddo

       PRINT*,'Vector'
       do i = 1,size
          PRINT*,'Row',i, bvec(i)
       enddo

       End

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       Subroutine check_orthogonality ( size, num, q )
       Implicit none
       Integer*4, intent(IN) :: size, num
       Real*8,dimension( size, num ), intent(INOUT) :: q
       Integer*4 :: m,n,i
       Real*8 :: r

       do m = 1,num
       do n = 1,num
          r = 0.0d0
          do i = 1,size
             r = r + q(i,m) * q(i,n)
          enddo
          PRINT*,'Test ortho: ',m,n,r
       enddo
       enddo

       End


! ==========================================================================
!
! Basic VMC/DMC code for educational purposes.
! This file: estimation of error bars from correlated data.
!
! Copyright (C) 2012 Jindrich Kolorenc
!
! The software is released under MIT/X11 license.
!
! ==========================================================================

! The error bars are estimated with the blocking method [Flyvbjerg &
! Petersen, J. Chem. Phys. 91, 461-6 (1989)].
! The subroutines assume that we start with 2^N data points (the reblocking
! is done by pairing the points/blocks).

module reblocking
  use types_const, only: dp
  implicit none
  private

  public :: errorbar

contains

  subroutine reblock(A)
    ! {{{ reblocking by pairing
    real(dp), dimension(:), intent(inout) :: A
    integer :: i
    do i=1, size(A), 2
       A(i/2+1)=(A(i)+A(i+1))*0.5_dp
    end do
    ! }}}
  end subroutine reblock

  function varmean(A,mean) result(s)
    ! {{{ variance of the mean
    real(dp), dimension(:), intent(in) :: A
    real(dp), intent(in) :: mean
    real(dp) :: s
    integer :: dim
    dim=size(A)
    s=sum((A-mean)**2)/(dim-1)/dim
    ! }}}
  end function varmean

  function errorbar(A,mean,filename,corrlen,finalNblock) result(s)
    ! {{{ NB: on output, the array A is modified, since reblocking is
    !     called directly on it
    real(dp), dimension(:), intent(inout) :: A
    real(dp), intent(in) :: mean
    character(*), intent(in), optional :: filename
    real(dp), intent(out), optional :: corrlen
    integer, intent(out), optional :: finalNblock
    real(dp) :: s0, s, s1
    integer :: dim
    logical :: writeout
    writeout=present(filename)
    if ( writeout ) then
       open(unit=99,file=filename,action="write")
       write(unit=99,fmt=*) "# number of blocks    variance    errorbar"
    end if
    dim=size(A)
    s0=varmean(A,mean)
    s=s0
    do while ( dim > 2 )
       call reblock(A(1:dim))
       dim=dim/2
       s1=varmean(A(1:dim),mean)
       if ( writeout ) write(unit=99,fmt=*) dim, s1, sqrt(s1)
       if ( s1 <= s ) exit
       s=s1
    end do
    if ( writeout ) close(unit=99)
    if ( present(corrlen) ) corrlen=s/s0
    if ( present(finalNBlock) ) finalNblock=dim
    s=sqrt(s)
    ! }}}
  end function errorbar

end module reblocking

! Local variables:
! folded-file: t
! End: