! Test that IOLENGTH works for derived types containing arrays
module iolength_2_mod
  integer, parameter ::  &
       ! 32 bit, i.e. 4 byte integer (every gcc architecture should have this?)
       int32 = selected_int_kind(9), &
       ! IEEE double precision, i.e. 8 bytes
       dp = selected_real_kind(15, 307)
  type foo
     ! This type should take up 5*4+4+8=32 bytes
     integer(int32) :: a(5), b
     real(dp) :: c
  end type foo
end module iolength_2_mod

program iolength_2
  use iolength_2_mod
  implicit none
  integer :: iol
  type(foo) :: d
  inquire (iolength = iol) d
  if ( 32 /= iol) then
     call abort
  end if
end program iolength_2


program logistic_map_2
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, error_unit
    use meshgrid_mod, only : meshgrid
    implicit none
    integer :: nr_x_values = 100, nr_r_values = 100, nr_iterations = 100
    real, parameter :: x_min = 0.0_DP, x_max = 1.0_DP, &
                       r_min = 0.5_DP, r_max = 4.0_DP
    real(kind=DP), dimension(:), allocatable :: x_vals, r_vals
    real(kind=DP), dimension(:, :), allocatable :: X, R, result
    real :: delta_x, delta_r
    integer :: i, j, status

    call get_parameters(nr_x_values, nr_r_values, nr_iterations)

    ! initialize X
    allocate (x_vals(nr_x_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate array'
        stop 1
    end if
    delta_x = (x_max - x_min)/nr_x_values
    x_vals = [ (x_min + i*delta_x, i=1, nr_x_values) ]

    ! initialize R
    allocate (r_vals(nr_r_values), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate array'
        stop 1
    end if
    delta_r = (r_max - r_min)/nr_r_values
    r_vals = [ (r_min + i*delta_r, i=1, nr_r_values) ]

    ! compute meshgrid
    call meshgrid(x_vals, r_vals, X, R)

    ! allocate result matrix
    allocate (result, source=X, stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate array'
        stop 1
    end if

    ! compute result
    result = iterate_map(X, R, nr_iterations)
    do j = 1, nr_x_values
        do i = 1, nr_r_values
            print *, R(i, j), result(i, j)
        end do
    end do

    ! deallocate the lot
    deallocate(X, R, result, x_vals, r_vals)

contains

    subroutine get_parameters(nr_x_values, nr_r_values, nr_iterations)
        implicit none
        integer, intent(out) :: nr_x_values, nr_r_values, nr_iterations
        integer, parameter :: default_nr_x_vals = 100, default_nr_r_vals = 100, &
                              default_nr_iterations = 100
        character(len=1024) :: buffer, msg
        integer :: status

        if (command_argument_count() == 3) then
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) nr_x_values
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 2
            end if
            call get_command_argument(2, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) nr_r_values
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 2
            end if
            call get_command_argument(3, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) nr_iterations
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 2
            end if
        else
            nr_x_values = default_nr_x_vals
            nr_r_values = default_nr_r_vals
            nr_iterations = default_nr_iterations
        end if
    end subroutine get_parameters

    elemental function iterate_map(x0, r, nr_steps) result(xn)
        implicit none
        real(kind=DP), value :: x0, r
        integer, value :: nr_steps
        real(kind=DP) :: xn
        integer :: i

        xn = x0
        do i = 1, nr_steps
            xn = r*xn*(1.0_DP - xn)
        end do
    end function iterate_map

end program logistic_map_2


      SUBROUTINE CSCAL(N,CA,CX,INCX)
*     .. Scalar Arguments ..
      COMPLEX CA
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      COMPLEX CX(*)
*     ..
*
*  Purpose
*  =======
*
*     CSCAL scales a vector by a constant.
*
*  Further Details
*  ===============
*
*     jack dongarra, linpack,  3/11/78.
*     modified 3/93 to return if incx .le. 0.
*     modified 12/3/93, array(1) declarations changed to array(*)
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER I,NINCX
*     ..
      IF (N.LE.0 .OR. INCX.LE.0) RETURN
      IF (INCX.EQ.1) THEN
*
*        code for increment equal to 1
*
         DO I = 1,N
            CX(I) = CA*CX(I)
         END DO
      ELSE
*
*        code for increment not equal to 1
*
         NINCX = N*INCX
         DO I = 1,NINCX,INCX
            CX(I) = CA*CX(I)
         END DO
      END IF
      RETURN
      END


	INTEGER FUNCTION INTDLM  ( x, ix1, ix2 )
C************************************************************************
C* INTDLM								*
C* 									*
C* This function rounds first argument, X, in the direction of the 	*
C* vector IX1 - IX2.  For values between IX1 and IX2, this means that 	*
C* the value returned will be the integer closest to IX1.  If the 	*
C* resulting value would be outside the range IX1 to IX2, the nearest 	*
C* boundary, IX1 or IX2, is returned.					*
C* 									*
C* INTEGER INTDLM  ( X, IX1, IX2 )					*
C* 									*
C* Input parameters:							*
C* 	X		REAL		Data value			*
C* 	IX1		INTEGER		First point			*
C* 	IX2		INTEGER		Second point			*
C* 									*
C* Output parameters:							*
C* 	INTDLM		INTEGER		Value of X rounded towards IX1	*
C**									*
C* Log:									*
C* G. Chatters/RDS	8/84						*
C* M. desJardins/GSFC	5/85						*
C************************************************************************
C------------------------------------------------------------------------
C*	Round X in the direction of IX2 to IX1.
C*	Formula used depends on sign of X and sign of IX2 - IX1.
C
	IF  ( x .lt. 0.0  .and.  ( ix2 - ix1 ) .ge. 0.0 )  THEN
	   IF  ( x .eq. REAL ( INT ( x ) ) ) THEN
	      ix = INT ( x )
	   ELSE
	      ix = INT ( x ) - 1
	   END IF
	ELSE IF ( x .ge. 0.0  .and.  ( ix2 - ix1 ) .lt. 0.0 ) THEN
	   IF ( x .eq. REAL ( INT ( x ) ) ) THEN
	      ix = INT ( x )
	   ELSE
	      ix = INT ( x ) + 1
	   END IF
	ELSE
	   ix = INT ( x )
	END IF
C
C*	If resulting value is outside range, limit it to boundary value.
C
	IF ( ( ix2 - ix1 ) .ge. 0 ) THEN
	   intdlm = MAX0 ( ix1, MIN0 ( ix, ix2 ) )
	ELSE
	   intdlm = MAX0 ( ix2, MIN0 ( ix, ix1 ) )
	END IF
C*
	RETURN
	END


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------
subroutine locate(xx,n,is,ie,x,j)
    ! -----------------------------------------------------------------------
    !
    ! Given an array "xx" of length "n", and given a value "x", this routine
    ! returns a value "j" such that "x" is between xx(j) and xx(j+1).  xx
    ! must be monotonic, either increasing or decreasing.  j=is-1 or j=ie is
    ! returned to indicate that x is out of range.
    !
    ! Bisection Concept From "Numerical Recipes", Press et. al. 1986  pp 90.
    ! -----------------------------------------------------------------------

    real, intent(in), dimension(n) :: xx
    real :: x
    integer, intent (out) :: j
    !f2py intent(out) j

    ! Initialize lower and upper methods:

    if(is.le.0) is = 1
    jl = is-1
    ju = ie
    if(xx(n).le.x) then
        j = ie
        return
    end if

    ! If we are not done then compute a midpoint:
    10 if(ju-jl.gt.1) then
        jm = (ju+jl)/2

        ! Replace the lower or upper limit with the midpoint:
        if((xx(ie).gt.xx(is)).eqv.(x.gt.xx(jm))) then
              jl = jm
        else
              ju = jm
        endif
        go to 10
    endif

    ! Return with the array index:

    j = jl

    return

end subroutine locate

subroutine dlocate(xx,n,is,ie,x,j)
    !-----------------------------------------------------------------------

    ! Given an array "xx" of length "n", and given a value "x", this routine
    ! returns a value "j" such that "x" is between xx(j) and xx(j+1).  xx
    ! must be monotonic, either increasing or decreasing.  j=0 or j=n is
    ! returned to indicate that x is out of range.

    ! Modified to set the start and end points by "is" and "ie"

    ! Bisection Concept From "Numerical Recipes", Press et. al. 1986  pp 90.
    !-----------------------------------------------------------------------

    real*8, intent (in) :: x
    real*8, intent (in), dimension(n) :: xx
    integer, intent (in) :: n,is,ie

    integer, intent (out) :: j
    !f2py intent(out) j

    integer :: jl,ju,jm, iss

    iss = is

    ! Initialize lower and upper methods:
    if(iss.le.0) iss = 1
    jl = iss-1
    ju = ie
    if(xx(n).le.x) then
        j = ie
        return
    end if

    ! If we are not done then compute a midpoint:

    10 if(ju-jl > 1) then

        jm = (ju+jl)/2

        ! Replace the lower or upper limit with the midpoint:

        if((xx(ie) > xx(iss)).eqv.(x > xx(jm))) then
            jl = jm
        else
            ju = jm
        endif
        go to 10
    endif

    ! Return with the array index:

    j = jl

    return
end subroutine dlocate


!*==sgbtrf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SGBTRF
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGBTRF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, KL, KU, LDAB, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       REAL               AB( LDAB, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGBTRF computes an LU factorization of a real m-by-n band matrix A
!> using partial pivoting with row interchanges.
!>
!> This is the blocked version of the algorithm, calling Level 3 BLAS.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KL
!> \verbatim
!>          KL is INTEGER
!>          The number of subdiagonals within the band of A.  KL >= 0.
!> \endverbatim
!>
!> \param[in] KU
!> \verbatim
!>          KU is INTEGER
!>          The number of superdiagonals within the band of A.  KU >= 0.
!> \endverbatim
!>
!> \param[in,out] AB
!> \verbatim
!>          AB is REAL array, dimension (LDAB,N)
!>          On entry, the matrix A in band storage, in rows KL+1 to
!>          2*KL+KU+1; rows 1 to KL of the array need not be set.
!>          The j-th column of A is stored in the j-th column of the
!>          array AB as follows:
!>          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!>
!>          On exit, details of the factorization: U is stored as an
!>          upper triangular band matrix with KL+KU superdiagonals in
!>          rows 1 to KL+KU+1, and the multipliers used during the
!>          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!>          See below for further details.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!> \endverbatim
!>
!> \param[out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!>               has been completed, but the factor U is exactly
!>               singular, and division by zero will occur if it is used
!>               to solve a system of equations.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realGBcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The band storage scheme is illustrated by the following example, when
!>  M = N = 6, KL = 2, KU = 1:
!>
!>  On entry:                       On exit:
!>
!>      *    *    *    +    +    +       *    *    *   u14  u25  u36
!>      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!>     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!>     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!>
!>  Array elements marked * are not used by the routine; elements marked
!>  + need not be set on entry, but are required by the routine to store
!>  elements of U because of fill-in resulting from the row interchanges.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SGBTRF(M,N,Kl,Ku,Ab,Ldab,Ipiv,Info)
      IMPLICIT NONE
!*--SGBTRF148
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Kl , Ku , Ldab , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      REAL Ab(Ldab,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
      INTEGER NBMAX , LDWORK
      PARAMETER (NBMAX=64,LDWORK=NBMAX+1)
!     ..
!     .. Local Scalars ..
      INTEGER i , i2 , i3 , ii , ip , j , j2 , j3 , jb , jj , jm , jp , &
     &        ju , k2 , km , kv , nb , nw
      REAL temp
!     ..
!     .. Local Arrays ..
      REAL work13(LDWORK,NBMAX) , work31(LDWORK,NBMAX)
!     ..
!     .. External Functions ..
      INTEGER ILAENV , ISAMAX
      EXTERNAL ILAENV , ISAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL SCOPY , SGBTF2 , SGEMM , SGER , SLASWP , SSCAL , SSWAP , &
     &         STRSM , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in
!
      kv = Ku + Kl
!
!     Test the input parameters.
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Kl<0 ) THEN
         Info = -3
      ELSEIF ( Ku<0 ) THEN
         Info = -4
      ELSEIF ( Ldab<Kl+kv+1 ) THEN
         Info = -6
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGBTRF',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Determine the block size for this environment
!
      nb = ILAENV(1,'SGBTRF',' ',M,N,Kl,Ku)
!
!     The block size must not exceed the limit set by the size of the
!     local arrays WORK13 and WORK31.
!
      nb = MIN(nb,NBMAX)
!
      IF ( nb<=1 .OR. nb>Kl ) THEN
!
!        Use unblocked code
!
         CALL SGBTF2(M,N,Kl,Ku,Ab,Ldab,Ipiv,Info)
      ELSE
!
!        Use blocked code
!
!        Zero the superdiagonal elements of the work array WORK13
!
         DO j = 1 , nb
            DO i = 1 , j - 1
               work13(i,j) = ZERO
            ENDDO
         ENDDO
!
!        Zero the subdiagonal elements of the work array WORK31
!
         DO j = 1 , nb
            DO i = j + 1 , nb
               work31(i,j) = ZERO
            ENDDO
         ENDDO
!
!        Gaussian elimination with partial pivoting
!
!        Set fill-in elements in columns KU+2 to KV to zero
!
         DO j = Ku + 2 , MIN(kv,N)
            DO i = kv - j + 2 , Kl
               Ab(i,j) = ZERO
            ENDDO
         ENDDO
!
!        JU is the index of the last column affected by the current
!        stage of the factorization
!
         ju = 1
!
         DO j = 1 , MIN(M,N) , nb
            jb = MIN(nb,MIN(M,N)-j+1)
!
!           The active part of the matrix is partitioned
!
!              A11   A12   A13
!              A21   A22   A23
!              A31   A32   A33
!
!           Here A11, A21 and A31 denote the current block of JB columns
!           which is about to be factorized. The number of rows in the
!           partitioning are JB, I2, I3 respectively, and the numbers
!           of columns are JB, J2, J3. The superdiagonal elements of A13
!           and the subdiagonal elements of A31 lie outside the band.
!
            i2 = MIN(Kl-jb,M-j-jb+1)
            i3 = MIN(jb,M-j-Kl+1)
!
!           J2 and J3 are computed after JU has been updated.
!
!           Factorize the current block of JB columns
!
            DO jj = j , j + jb - 1
!
!              Set fill-in elements in column JJ+KV to zero
!
               IF ( jj+kv<=N ) THEN
                  DO i = 1 , Kl
                     Ab(i,jj+kv) = ZERO
                  ENDDO
               ENDIF
!
!              Find pivot and test for singularity. KM is the number of
!              subdiagonal elements in the current column.
!
               km = MIN(Kl,M-jj)
               jp = ISAMAX(km+1,Ab(kv+1,jj),1)
               Ipiv(jj) = jp + jj - j
               IF ( Ab(kv+jp,jj)/=ZERO ) THEN
                  ju = MAX(ju,MIN(jj+Ku+jp-1,N))
                  IF ( jp/=1 ) THEN
!
!                    Apply interchange to columns J to J+JB-1
!
                     IF ( jp+jj-1<j+Kl ) THEN
!
                        CALL SSWAP(jb,Ab(kv+1+jj-j,j),Ldab-1,           &
     &                             Ab(kv+jp+jj-j,j),Ldab-1)
                     ELSE
!
!                       The interchange affects columns J to JJ-1 of A31
!                       which are stored in the work array WORK31
!
                        CALL SSWAP(jj-j,Ab(kv+1+jj-j,j),Ldab-1,         &
     &                             work31(jp+jj-j-Kl,1),LDWORK)
                        CALL SSWAP(j+jb-jj,Ab(kv+1,jj),Ldab-1,          &
     &                             Ab(kv+jp,jj),Ldab-1)
                     ENDIF
                  ENDIF
!
!                 Compute multipliers
!
                  CALL SSCAL(km,ONE/Ab(kv+1,jj),Ab(kv+2,jj),1)
!
!                 Update trailing submatrix within the band and within
!                 the current block. JM is the index of the last column
!                 which needs to be updated.
!
                  jm = MIN(ju,j+jb-1)
                  IF ( jm>jj ) CALL SGER(km,jm-jj,-ONE,Ab(kv+2,jj),1,   &
     &                 Ab(kv,jj+1),Ldab-1,Ab(kv+1,jj+1),Ldab-1)
               ELSE
!
!                 If pivot is zero, set INFO to the index of the pivot
!                 unless a zero pivot has already been found.
!
                  IF ( Info==0 ) Info = jj
               ENDIF
!
!              Copy current column of A31 into the work array WORK31
!
               nw = MIN(jj-j+1,i3)
               IF ( nw>0 ) CALL SCOPY(nw,Ab(kv+Kl+1-jj+j,jj),1,         &
     &                                work31(1,jj-j+1),1)
            ENDDO
            IF ( j+jb<=N ) THEN
!
!              Apply the row interchanges to the other blocks.
!
               j2 = MIN(ju-j+1,kv) - jb
               j3 = MAX(0,ju-j-kv+1)
!
!              Use SLASWP to apply the row interchanges to A12, A22, and
!              A32.
!
               CALL SLASWP(j2,Ab(kv+1-jb,j+jb),Ldab-1,1,jb,Ipiv(j),1)
!
!              Adjust the pivot indices.
!
               DO i = j , j + jb - 1
                  Ipiv(i) = Ipiv(i) + j - 1
               ENDDO
!
!              Apply the row interchanges to A13, A23, and A33
!              columnwise.
!
               k2 = j - 1 + jb + j2
               DO i = 1 , j3
                  jj = k2 + i
                  DO ii = j + i - 1 , j + jb - 1
                     ip = Ipiv(ii)
                     IF ( ip/=ii ) THEN
                        temp = Ab(kv+1+ii-jj,jj)
                        Ab(kv+1+ii-jj,jj) = Ab(kv+1+ip-jj,jj)
                        Ab(kv+1+ip-jj,jj) = temp
                     ENDIF
                  ENDDO
               ENDDO
!
!              Update the relevant part of the trailing submatrix
!
               IF ( j2>0 ) THEN
!
!                 Update A12
!
                  CALL STRSM('Left','Lower','No transpose','Unit',jb,j2,&
     &                       ONE,Ab(kv+1,j),Ldab-1,Ab(kv+1-jb,j+jb),    &
     &                       Ldab-1)
!
!
!                    Update A22
!
                  IF ( i2>0 ) CALL SGEMM('No transpose','No transpose', &
     &                 i2,j2,jb,-ONE,Ab(kv+1+jb,j),Ldab-1,              &
     &                 Ab(kv+1-jb,j+jb),Ldab-1,ONE,Ab(kv+1,j+jb),Ldab-1)
!
!
!                    Update A32
!
                  IF ( i3>0 ) CALL SGEMM('No transpose','No transpose', &
     &                 i3,j2,jb,-ONE,work31,LDWORK,Ab(kv+1-jb,j+jb),    &
     &                 Ldab-1,ONE,Ab(kv+Kl+1-jb,j+jb),Ldab-1)
               ENDIF
!
               IF ( j3>0 ) THEN
!
!                 Copy the lower triangle of A13 into the work array
!                 WORK13
!
                  DO jj = 1 , j3
                     DO ii = jj , jb
                        work13(ii,jj) = Ab(ii-jj+1,jj+j+kv-1)
                     ENDDO
                  ENDDO
!
!                 Update A13 in the work array
!
                  CALL STRSM('Left','Lower','No transpose','Unit',jb,j3,&
     &                       ONE,Ab(kv+1,j),Ldab-1,work13,LDWORK)
!
!
!                    Update A23
!
                  IF ( i2>0 ) CALL SGEMM('No transpose','No transpose', &
     &                 i2,j3,jb,-ONE,Ab(kv+1+jb,j),Ldab-1,work13,LDWORK,&
     &                 ONE,Ab(1+jb,j+kv),Ldab-1)
!
!
!                    Update A33
!
                  IF ( i3>0 ) CALL SGEMM('No transpose','No transpose', &
     &                 i3,j3,jb,-ONE,work31,LDWORK,work13,LDWORK,ONE,   &
     &                 Ab(1+Kl,j+kv),Ldab-1)
!
!                 Copy the lower triangle of A13 back into place
!
                  DO jj = 1 , j3
                     DO ii = jj , jb
                        Ab(ii-jj+1,jj+j+kv-1) = work13(ii,jj)
                     ENDDO
                  ENDDO
               ENDIF
            ELSE
!
!              Adjust the pivot indices.
!
               DO i = j , j + jb - 1
                  Ipiv(i) = Ipiv(i) + j - 1
               ENDDO
            ENDIF
!
!           Partially undo the interchanges in the current block to
!           restore the upper triangular form of A31 and copy the upper
!           triangle of A31 back into place
!
            DO jj = j + jb - 1 , j , -1
               jp = Ipiv(jj) - jj + 1
               IF ( jp/=1 ) THEN
!
!                 Apply interchange to columns J to JJ-1
!
                  IF ( jp+jj-1<j+Kl ) THEN
!
!                    The interchange does not affect A31
!
                     CALL SSWAP(jj-j,Ab(kv+1+jj-j,j),Ldab-1,            &
     &                          Ab(kv+jp+jj-j,j),Ldab-1)
                  ELSE
!
!                    The interchange does affect A31
!
                     CALL SSWAP(jj-j,Ab(kv+1+jj-j,j),Ldab-1,            &
     &                          work31(jp+jj-j-Kl,1),LDWORK)
                  ENDIF
               ENDIF
!
!              Copy the current column of A31 back into place
!
               nw = MIN(i3,jj-j+1)
               IF ( nw>0 ) CALL SCOPY(nw,work31(1,jj-j+1),1,Ab(kv+Kl+1- &
     &                                jj+j,jj),1)
            ENDDO
         ENDDO
      ENDIF
!
!
!     End of SGBTRF
!
      END SUBROUTINE SGBTRF


!                                                                     8.07.2009
!------------------------------------------------------------------------------
module my_init

   integer, parameter :: lgt= kind(.true.), i4b= selected_int_kind(9),        &
                         i16b= selected_int_kind(38), sp=kind(1.0), wp=kind(1.0d0), &
                         dp=kind(1.0d0)

   real(wp), parameter :: rero= 0.0_wp, one= 1.0_wp, two= 2.0_wp,             &
                          three= 3.0_wp, four= 4.0_wp, five= 5.0_wp,          &
                          six= 6.0_wp

   real(wp), parameter :: pi= two*two*atan(one)
   real(wp), parameter :: twopi= two*pi, pio2= pi/two
   real(wp), parameter :: sq2= sqrt(two)

   complex(wp), parameter :: zero= (rero,rero), zone= (one,rero),             &
                             zi= (rero,one)

end module my_init


! Covariance matrix, diagonalization

module utils1
  !$ use omp_lib
  use RandomNS
  implicit none

  	integer lwork,liwork
  	data lwork,liwork /1,1/
      logical setBlk
      data setBlk /.false./

    integer, parameter :: root_max_len = 512

contains

!----------------------------------------------------------------------

 subroutine Diagonalize(a,diag,n,switch)
	!Does m = U diag U^T, returning U in m
	integer n,id
	double precision a(n,n),diag(n)
	logical switch
	integer i,j,ierr,il,iu,m,isuppz(2*n)
	double precision vl,vu,abstol,z(n,n)
	double precision, dimension(:), allocatable :: work
	integer, dimension(:), allocatable :: iwork

	diag=0.
      abstol=0.

      id=0
      !$ id=omp_get_thread_num()

      if(.not.setBlk .or. switch) then
      	if(id==0) then
      		!find optimal block sizes
      		allocate(work(1))
            	allocate(iwork(1))
            	lwork=-1
            	liwork=-1

            	call DSYEVR( 'V', 'A', 'U', n, a, n, vl, vu, il, iu, &
      		abstol, m, diag, Z, n, isuppz, work, lwork, iwork, liwork, ierr )

            	lwork=int(work(1))
            	liwork=iwork(1)
            	deallocate(work,iwork)
            	setBlk=.true.
	else
            	do
                  	!$OMP FLUSH(setBlk)
                  	if(setBlk) exit
		enddo
	end if
      endif

      allocate(work(lwork),iwork(liwork))
      call DSYEVR( 'V', 'A', 'U', n, a, n, vl, vu, il, iu, &
      abstol, m, diag, Z, n, isuppz, work, lwork, iwork, liwork, ierr )
      a=z
      deallocate(work,iwork)

      !check for inf & nan
      do i=1,n
    	if(diag(i)/=diag(i) .or. diag(i)>huge(1d0)) then
		diag=1d0
		a=0d0
		do j=1,n
			a(j,j)=1d0
		enddo
		exit
	endif
      enddo

 end subroutine Diagonalize

!----------------------------------------------------------------------

! LogSumExp(x,y)=log(exp(x)+exp(y))
  double precision function LogSumExp(x,y)
    double precision x,y

    if (x.gt.y) then
       LogSumExp=x+log(1+exp(y-x))
    else
       LogSumExp=y+log(1+exp(x-y))
    end if
    return

  end function LogSumExp

!----------------------------------------------------------------------

  subroutine calc_covmat(npt,np,p,mean,covmat)
    implicit none
    integer np,npt
    double precision p(:,:)
    double precision covmat(:,:)
    double precision mean(:)
    integer i,j,ip

    covmat=0.
    do i=1,np
       do j=i,np
          do ip=1,npt
             covmat(i,j)=covmat(i,j)+((p(i,ip)-mean(i))*(p(j,ip)-mean(j)))
          end do
          if(j/=i) covmat(j,i)=covmat(i,j)
       end do
       covmat(i,1:np)=covmat(i,1:np)/dble(npt-1)
    end do

    return

  end subroutine calc_covmat

!----------------------------------------------------------------------

  subroutine calc_covmat_wt(npt,np,p,wt,mean,covmat)
    implicit none
    integer np,npt
    double precision p(:,:),wt(:)
    double precision covmat(:,:)
    double precision mean(:)
    integer i,j,ip

    covmat=0.
    do i=1,np
       do j=i,np
          do ip=1,npt
             covmat(i,j)=covmat(i,j)+((p(i,ip)-mean(i))*(p(j,ip)-mean(j)))*wt(ip)
          end do
          if(j/=i) covmat(j,i)=covmat(i,j)
       end do
    end do

    return

  end subroutine calc_covmat_wt

!----------------------------------------------------------------------

  !inv_cov=(evec).(inv_eval).Transpose(evec)
  subroutine calc_invcovmat(numdim,evec,eval,invcov)
    implicit none
    integer numdim !num of dimensions & points
    double precision evec(:,:),eval(:) !eigenvectors & eigenvalues
    double precision invcov(:,:)
    integer i,j,k

    invcov=0d0
    do i=1,numdim
       do j=i,numdim
          do k=1,numdim
             invcov(i,j)=invcov(i,j)+(evec(i,k)*evec(j,k)/eval(k))
          end do
          if(i/=j) invcov(j,i)=invcov(i,j)
       end do
    end do

    return

  end subroutine calc_invcovmat

!----------------------------------------------------------------------

  subroutine ScaleFactor(npt,ndim,pt,mean,inv_cov,kmax)
    implicit none

    double precision kmax
    integer npt,ndim
    double precision pt(ndim,npt),ptM(1,ndim),sf(1,1)
    integer i,k
    double precision inv_cov(ndim,ndim)
    double precision mean(ndim)
    double precision temp_p(ndim,npt)

    do i=1,ndim
	temp_p(i,1:npt)=pt(i,1:npt)-mean(i)
    enddo

    kmax=0d0
    do k=1,npt
    	ptM(1,:)=temp_p(:,k)
    	sf=MatMul(MatMul(ptM,inv_cov),Transpose(ptM))
        if(sf(1,1)>kmax) kmax=sf(1,1)
    enddo

    !kmax=sqrt(kmax)

  end subroutine ScaleFactor

!----------------------------------------------------------------------

 double precision function ptScaleFac(ndim,pt,meanx,invcovx)

	implicit none

	integer ndim!dimensionality
      	double precision pt(ndim),point(1,ndim)!point to be checked
      	double precision meanx(ndim),invcovx(ndim,ndim)!cluster attributes
      	double precision kfac(1,1)!k factor of present point

      	point(1,:)=pt(:)-meanx(:)
	kfac=MATMUL(MATMUL(point,invcovx),Transpose(point))
	ptScaleFac=kfac(1,1)

 end function ptScaleFac

!----------------------------------------------------------------------

   subroutine getTMatrix(ndim,evec,eval,TMatrix)

    implicit none

    double precision TMatrix(ndim,ndim),evec(ndim,ndim),eval(ndim)
    integer ndim,np,i,j
    double precision TMat(ndim,ndim)

    np=ndim
    TMatrix=evec

    do i=1,np
       do j=1,np
          TMatrix(i,j) = evec(i,j) * sqrt(eval(j))
       enddo
    enddo
    TMat=Transpose(TMatrix)
    TMatrix=TMat

  end subroutine getTMatrix

!----------------------------------------------------------------------

  !return the Mahalanobis distance of a point from the given ellipsoid
  double precision function MahaDis(ndim,pt,mean,inv_cov,kfac)
    implicit none

    !input varaibles
    integer ndim !dimensionality
    double precision pt(ndim) !point
    double precision mean(ndim) !centroid of the ellipsoid
    double precision inv_cov(ndim,ndim) !inv covariance matrix of the ellipsoid
    double precision kfac !enlargement factor

    MahaDis=ptScaleFac(ndim,pt,mean,inv_cov)/kfac

  end function MahaDis

!----------------------------------------------------------------------

  double precision function ellVol(ndim,eval,k_fac)

    implicit none

    integer ndim
    double precision eval(ndim),k_fac,pi
    integer i

    pi=4.d0*atan(1.d0)

    ellVol=sqrt(product(eval)*(k_fac**dble(ndim)))

    if(mod(ndim,2)==0) then
    	do i=2,ndim,2
		ellVol=ellVol*2.d0*pi/dble(i)
	enddo
    else
    	ellVol=ellVol*2.
    	do i=3,ndim,2
		ellVol=ellVol*2.d0*pi/dble(i)
	enddo
    endif
  end function ellVol

!----------------------------------------------------------------------

  subroutine genPtInSpheroid(np,u,id)

    implicit none

    integer np,i,id
    double precision u(:), mod, urv

    mod=0d0
    do i=1,np
       u(i)=gaussian1NS(id)
       mod=mod+u(i)**2.
    enddo
    urv=ranmarNS(id)
    mod=(urv**dble(1./np))/sqrt(mod)
    u(:)=mod*u(:)

  end subroutine genPtInSpheroid

!----------------------------------------------------------------------

  subroutine genPtOnSpheroid(np,u,id)

    implicit none

    integer np,i,id
    double precision u(:), mod

    mod=0.d0
    do i=1,np
       u(i)=gaussian1NS(id)
       mod=mod+u(i)**2.
    enddo
    mod=1.d0/sqrt(mod)
    u(:)=mod*u(:)

  end subroutine genPtOnSpheroid

!----------------------------------------------------------------------

  !calculate the mean, covariance matrix, inv covariance matrix, evalues,
  !evects, det(cov) & enlargement of a given point set
  subroutine CalcEllProp(npt,ndim,pt,mean,covmat,invcov,tMat,evec,eval,detcov, &
  	kfac,eff,vol,pVol,switch)
    implicit none
    !input variables
    integer npt !no. of points
    integer ndim !dimensionality
    double precision pt(ndim,npt) !points
    double precision pVol !min vol this ellipsoid should occupy
    logical switch !initialize the LAPACK eigen analysis routines?
    !output variables
    double precision mean(ndim) !mean
    double precision covmat(ndim,ndim) !covariance matrix
    double precision invcov(ndim,ndim) !inverse covariance matrix
    double precision tMat(ndim,ndim) !transformation matrix
    double precision evec(ndim,ndim) !eigenvectors
    double precision eval(ndim)
    double precision detcov !determinant of the covariance matrix
    double precision kfac !enlargement point factor
    double precision eff !enlargement volume factor
    double precision vol !ellipsoid volume
    !work variables
    integer i,j

    !calculate the mean
    do i=1,ndim
    	mean(i)=sum(pt(i,1:npt))/npt
    enddo

    if(npt<=1) then
    	kfac=0.d0
	vol=0.d0
	eval=0.d0
	eff=1.d0
	return
    endif

    !calculate the covariance matrix
    call calc_covmat(npt,ndim,pt,mean,covmat)

    !eigen analysis
    evec=covmat
    call Diagonalize(evec,eval,ndim,switch)

    !eigenvalues of covariance matrix can't be zero
    do i=1,ndim-1
	if(eval(i)<=0.d0) eval(1:i)=eval(i+1)/2.
    enddo

    !if the no. of points is less than ndim+1 then set the eigenvalues of unconstrained
    !dimensions equal to the min constrained eigenvalue
    if(npt<ndim+1) then
	eval(1:ndim+1-npt)=eval(ndim+2-npt)
    endif

    !calculate the determinant of covariance matrix
    detcov=product(eval)

    !calculate the inverse of covariance matrix
    call calc_invcovmat(ndim,evec,eval,invcov)

    !calculate the enlargement factor
    call ScaleFactor(npt,ndim,pt,mean,invcov,kfac)

    !calculate the ellipsoid volume
    vol=ellVol(ndim,eval,kfac)

    !scale the enlargement factor if vol<pVol
    if(pVol>0d0 .and. vol<pVol) then
    	eff=(pVol/vol)**(2.d0/ndim)
	vol=pVol
    else
    	eff=1.d0
    endif

    !calculate the transformation matrix
    call getTMatrix(ndim,evec,eval,tMat)

  end subroutine CalcEllProp

!----------------------------------------------------------------------

  !calculate the inv covariance matrix, evalues & evects of a given point set
  subroutine CalcBEllInfo(npt,ndim,pt,mean,eval,evec,invcov,tMat,kfac,minPt)
    implicit none
    !input variables
    integer npt !no. of points
    integer ndim !dimensionality
    double precision pt(ndim,npt) !points
    integer minPt
    !output variables
    double precision mean(ndim) !centroid
    double precision invcov(ndim,ndim) !inverse covariance matrix
    double precision tMat(ndim,ndim) !transformation matrix
    double precision evec(ndim,ndim) !eigenvectors
    double precision eval(ndim) !eigenvalues
    double precision kfac !multiplicative factor for covmat for bounding ell
    !work variables
    double precision sigma(ndim)
    integer i,j,k,n
    parameter(n=0)
    double precision covmat(ndim,ndim),ptk(ndim,npt),dist(npt)
    double precision maxIndx(n,2)
    integer nOut,ptOut(n),nptk
    logical flag

    !calculate the mean
    do i=1,ndim
    	mean(i)=sum(pt(i,1:npt))/npt
    	sigma(i)=sum(pt(i,1:npt)**2)/npt
    enddo
    sigma(1:ndim)=sqrt(sigma(1:ndim)-mean(1:ndim)**2)

    if(npt==1) then
	eval=0.d0
	kfac=0.d0
	return
    endif

    !remove outliers
    if(npt>minPt) then
	k=min(n,npt-minPt)
	if(k>0) then
		maxIndx(:,2)=0d0
    		do i=1,npt
			dist(i)=0d0
			do j=1,ndim
				dist(i)=dist(i)+abs((pt(j,i)-mean(j)))/sigma(j)
			enddo

			do j=1,k+1
				if(j==k+1) exit
				if(dist(i)<maxIndx(j,2)) exit
			enddo
			j=j-1
			if(j>0) then
				maxIndx(1:j-1,:) = maxIndx(2:j,:)
				maxIndx(j,1) = dble(i)
				maxIndx(j,2) = dist(i)
			endif
    		enddo

		nOut=0
		do i=1,k
			if(maxIndx(i,2)>3d0) then
				nOut=nOut+1
				ptOut(nOut)=int(maxIndx(i,1))
			endif
		enddo
	else
		nOut=0
	endif

	if(nOut>0) then
		j=0
		do i=1,npt
			flag=.false.
			do k=1,nOut
				if(i == ptOut(k)) then
					flag=.true.
					exit
				endif
			enddo

			if(flag) cycle

			ptk(:,j+1)=pt(:,i)
			j=j+1
		enddo
		nptk=npt-nOut
	else
		ptk=pt
		nptk=npt
	endif
    else
	ptk=pt
	nptk=npt
    endif

    !calculate the covariance matrix
    call calc_covmat(nptk,ndim,ptk,mean,covmat)

    !eigen analysis
    evec=covmat
    call Diagonalize(evec,eval,ndim,.false.)
    !eigenvalues of covariance matrix can't be zero
    do i=1,ndim-1
	if(eval(i)<=0.d0) eval(1:i)=eval(i+1)/2.
    enddo

    !if the no. of points is less than ndim+1 then set the eigenvalues of unconstrained
    !dimensions equal to the min constrained eigenvalue
    if(nptk<ndim+1) then
	eval(1:ndim+1-nptk)=eval(ndim+2-nptk)
    endif

    !calculate the inverse of covariance matrix
    call calc_invcovmat(ndim,evec,eval,invcov)

    !now scale the eigenvalues so that its a bounding ellipsoid with k = kfac
    call ScaleFactor(nptk,ndim,ptk,mean,invcov,kfac)

    !calculate the transformation matrix
    call getTMatrix(ndim,evec,eval,tMat)

  end subroutine CalcBEllInfo

!----------------------------------------------------------------------

  !generate a point uniformly inside the given ellipsoid
  subroutine genPtInEll(ndim,mean,efac,TMat,id,pt)
  	implicit none

	!input variables
	integer ndim !dimensionality
	double precision mean(ndim) !centroid of the given ellipsoid
	double precision efac !enlargement factor of the given ellipsoid
	double precision TMat(ndim,ndim) !transformation matrix of the given ellipsoid
	integer id !processor id (for OpenMP)
	!output variable
	double precision pt(ndim)
	!work variables
	double precision u(1,ndim),pnewM(1,ndim)

	call genPtInSpheroid(ndim,u(1,:),id)
	pnewM=MatMul(u,TMat)
	pt(:)=sqrt(efac)*pnewM(1,:)+mean(:)

  end subroutine genPtInEll

!----------------------------------------------------------------------

  !generate a point uniformly on the surface of the given ellipsoid
  subroutine genPtOnEll(ndim,mean,efac,TMat,id,pt)
  	implicit none

	!input variables
	integer ndim !dimensionality
	double precision mean(ndim) !centroid of the given ellipsoid
	double precision efac !enlargement factor of the given ellipsoid
	double precision TMat(ndim,ndim) !transformation matrix of the given ellipsoid
	integer id !processor id (for OpenMP)
	!output variable
	double precision pt(ndim)
	!work variables
	double precision u(1,ndim),pnewM(1,ndim)

	call genPtOnSpheroid(ndim,u(1,:),id)
	pnewM=MatMul(u,TMat)
	pt(:)=sqrt(efac)*pnewM(1,:)+mean(:)

  end subroutine genPtOnEll

!----------------------------------------------------------------------

   !evolve an ellipsoid from which a point has either been rejected or a point
   !has been inserted
  subroutine evolveEll(a_r,npt,ndim,newpt,pts,mean,eval,invcov,kfac,eff,vol,pVol)

	implicit none
    	!input variables
	integer a_r !if 0 then point rejected, 1 then point inserted
	integer npt !no. of points after rejection or before insertion
	integer ndim !dimensionality
	double precision newpt(ndim) !point to be rejected/inserted
	double precision pts(ndim,npt) !point set after rejection or before insertion
	double precision mean(ndim) !centroid of the ellipsoid
	double precision eval(ndim) !eigenvalues of the ellipsoid
	double precision invcov(ndim,ndim) !inverse covariance matrix of the ellipsoid
	double precision pVol !target volume

	!input/output variables
	double precision kfac !input (output): point enlargement before (after) rejection/insertion
	double precision eff !input (output): volume enlargement before (after) rejection/insertion
	double precision vol !input (output): volume before (after) rejection/insertion

	!work variables
	double precision new_pt(ndim,1),new_kfac

	!sanity check
	if(a_r < 0 .or. a_r > 1) then
		write(*,*)"a_r in evolveEll cannot be", a_r
		stop
	endif

	if(pVol==0.d0 .or. eval(ndim)==0.d0) then
		kfac=0.d0
		eff=1.d0
		vol=0.d0
		return
	endif

	!point inserted
	if(a_r==1) then
		if(npt==0) then
			write(*,*)"can not insert point in an ellipsoid with no points"
			stop
		else
			!calculate the scale factor
			new_pt(:,1)=newpt(:)
			call ScaleFactor(1,ndim,new_pt,mean,invcov,new_kfac)
			if(new_kfac>kfac) then
				eff=eff*kfac/new_kfac
				kfac=new_kfac
				if(eff<1d0) then
					eff=1d0
					vol=ellVol(ndim,eval,kfac)
				endif
			endif

			!if the point has been inserted to a cluster with npt > 0 then kfac remains the same
			!scale eff if target vol is bigger
			if(pVol>vol) then
    				eff=eff*(pVol/(vol))**(2.d0/dble(ndim))
				vol=pVol
			else
				!if target vol is smaller then calculate the point volume &
				!scale eff if required
				vol=ellVol(ndim,eval,kfac)

				!scale the enlargement factor if vol<pVol
    				if(vol<pVol) then
    					eff=max(1d0,(pVol/(vol))**(2.d0/dble(ndim)))
					vol=pVol
    				else
    					eff=1.d0
    				endif
			endif
		endif
	else
		if(npt==0) then
			vol=0.d0
			kfac=0.d0
			eff=1.d0
			return
		endif

		!if the point has been rejected then figure out if its a boundary point
		new_pt(:,1)=newpt(:)
		call ScaleFactor(1,ndim,new_pt,mean,invcov,new_kfac)

		!if it's a boundary point then find new kfac
		if(new_kfac==kfac) then
			call ScaleFactor(npt,ndim,pts,mean,invcov,kfac)
			if(kfac>new_kfac*eff .and. npt>1) then
				write(*,*)"Problem in evoleell"
				write(*,*)kfac,new_kfac,eff,npt
				stop
			endif
			eff=1d0
			vol=ellVol(ndim,eval,kfac)
		endif

		!scale the enlargement factor if vol<pVol
    		if(vol<pVol) then
    			eff=(pVol/(vol))**(2.d0/dble(ndim))
			vol=pVol
    		endif
	endif

  end subroutine evolveEll

!----------------------------------------------------------------------

   !enlarge an ellipsoid because of an additional point being inserted in it
  subroutine enlargeEll(ndim,newpt,mean,eval,invcov,kfac,eff,vol,pVol)

	implicit none
    	!input variables
	integer ndim !dimensionality
	double precision newpt(ndim) !point to be inserted
	double precision mean(ndim) !centroid of the ellipsoid
	double precision eval(ndim) !eigenvalues of the ellipsoid
	double precision invcov(ndim,ndim) !inverse covariance matrix of the ellipsoid
	double precision pVol !target volume

	!input/output variables
	double precision kfac !input (output): point enlargement before (after) insertion
	double precision eff !input (output): volume enlargement before (after) insertion
	double precision vol !input (output): volume before (after) insertion

	!work variables
	double precision new_pt(ndim,1),d1

	!find new kfac
	new_pt(:,1)=newpt(:)
	call ScaleFactor(1,ndim,new_pt,mean,invcov,d1)
	if(d1>kfac) then
		kfac=d1
		eff=1.d0
		vol=ellVol(ndim,eval,kfac)
	endif

	if(pVol>vol) then
    		eff=eff*(pVol/(vol))**(2.d0/dble(ndim))
		vol=pVol
	endif

  end subroutine enlargeEll

!----------------------------------------------------------------------

  function inprior(np,p)

    implicit none

    logical inprior
    integer np, i
    double precision p(np)

    inprior = .true.

    do i=1,np
	if(p(i)<0d0 .or. p(i)>1d0) then
          	inprior = .false.
            	return
	endif
    enddo

  end function inprior

!----------------------------------------------------------------------

  !Returns the value gamma(ln[(xx)]) for xx > 0.
  FUNCTION gammln(xx)
  	REAL gammln,xx
      INTEGER j
      DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
      !Internal arithmetic will be done in double precision,
      !a nicety that you can omit if  ve- gure accuracy is good enough.
      SAVE cof,stp

      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,24.01409824083091d0, &
      -1.231739572450155d0,.1208650973866179d-2,-.5395239384953d-5,2.5066282746310005d0/

      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do j=1,6
      	y=y+1.d0
            ser=ser+cof(j)/y
      enddo
      gammln=tmp+log(stp*ser/x)
      return
  END FUNCTION gammln

  !USES gcf,gser Returns the incomplete gamma function P(a, x).
  FUNCTION gammp(a,x)
  	REAL a,gammp,x
  	REAL gammcf,gamser,gln

  	if(x.lt.0..or.a.le.0.) then
		write(*,*)  'bad arguments in gammp'
		stop
	endif
  	if(x.lt.a+1.)then
  		!Use the series representation.
  		call gser(gamser,a,x,gln)
      	gammp=gamser
  	else
  		!Use the continued fraction representation
      	call gcf(gammcf,a,x,gln)
      	gammp=1.-gammcf !and take its complement.
  	endif
  	return
  END FUNCTION gammp

  !USES gcf,gser Returns the incomplete gamma function Q(a,x)=1-P(a,x).
  FUNCTION gammq(a,x)
  	REAL a,gammq,x
      REAL gammcf,gamser,gln

      if(x.lt.0..or.a.le.0.) then
      	write(*,*) 'bad arguments in gammq'
	stop
      endif
      if(x.lt.a+1.)then
      	!Use the series representation
      	call gser(gamser,a,x,gln)
            gammq=1.-gamser !and take its complement.
      else
      	!Use the continued fraction representation.
            call gcf(gammcf,a,x,gln)
            gammq=gammcf
	endif
      return
  END FUNCTION gammq

  !USES gammln Returns the incomplete gamma function P(a,x) evaluated by its series
  !representation as gamser.
  !Also returns ln (a) as gln.
  SUBROUTINE gser(gamser,a,x,gln)
  	INTEGER ITMAX
      REAL a,gamser,gln,x,EPS
      PARAMETER (ITMAX=100,EPS=3.e-7)
      INTEGER n
      REAL ap,del,sum

      gln=gammln(a)
      if(x.le.0.)then
      	if(x.lt.0.) write(*,*)  'x < 0 in gser'
            gamser=0.
            return
      endif
      ap=a
      sum=1./a
      del=sum
      do n=1,ITMAX
      	ap=ap+1.
            del=del*x/ap
            sum=sum+del
            if(abs(del).lt.abs(sum)*EPS)goto 91
      enddo
      write(*,*)  'a too large, ITMAX too small in gser'
    91 gamser=sum*exp(-x+a*log(x)-gln)
    	return
  END SUBROUTINE gser

  !USES gammln Returns the incomplete gamma function Q(a, x) evaluated by its continued
  !fraction representation as gammcf. Also returns ln  (a) as gln.
  !Parameters: ITMAX is the maximum allowed number of iterations;
  !EPS is the relative accuracy; FPMIN is a number near the smallest representable
  !floating-point number.
  SUBROUTINE gcf(gammcf,a,x,gln)
  	INTEGER ITMAX
  	REAL a,gammcf,gln,x,EPS,FPMIN
      PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30)
      INTEGER i
      REAL an,b,c,d,del,h

      gln=gammln(a)
      b=x+1.-a
      c=1./FPMIN
      d=1./b
      h=d
      do i=1,ITMAX !Iterate to convergence.
      	an=-i*(i-a)
            b=b+2.
            d=an*d+b
            if(abs(d).lt.FPMIN)d=FPMIN
            c=b+an/c
            if(abs(c).lt.FPMIN)c=FPMIN
            d=1./d
            del=d*c
            h=h*del
            if(abs(del-1.).lt.EPS)goto 91
	enddo
      write(*,*)  'a too large, ITMAX too small in gcf'
   91 gammcf=exp(-x+a*log(x)-gln)*h !Put factors in front.
   	return
  END SUBROUTINE gcf

  !USES gammp Returns the error function erf(x).
  FUNCTION erf(x)
  	REAL erf,x

      if(x.lt.0.)then
      	erf=-gammp(.5,x**2)
      else
      	erf=gammp(.5,x**2)
      endif
      return
  END FUNCTION erf

  double precision function stNormalCDF(x)
  	double precision x

     	if(x>6.) then
      	stNormalCDF=1.
      else if(x<-6.) then
      	stNormalCDF=0.
	else
      	stNormalCDF=0.5*(1.+erf(real(x)/1.41421356))
      end if

  end function stNormalCDF

!----------------------------------------------------------------------

  integer function binSearch(array,npt,x)
    implicit none
    integer npt,array(npt) !total no. of points in the array & the array
    integer x !no. whose position has to be found
    integer sp,ep !starting, end & insertion points

    binSearch = 1
    if(npt==0) then
      	return
    elseif(x>=array(1)) then
      	return
    end if
    if(x<=array(npt)) then
    	binSearch=npt+1
      return
    end if
    sp=1
    ep=npt
    do
    	if(sp==ep) return
	if(x>array((ep+sp)/2)) then
		ep=(ep+sp)/2
		binSearch=ep
	elseif(x<array((ep+sp)/2)) then
		sp=(ep+sp)/2+1
		binSearch=sp
	else
		ep=(ep+sp)/2
		binSearch=ep+1
            return
	end if
    end do

  end function binSearch

!----------------------------------------------------------------------

  subroutine piksrt(n,n1,arr,arr1)
  	integer n,n1
  	double precision arr(n)
  	double precision arr1(n1,n)
  	integer i,j
  	double precision a
  	double precision a1(n1)
  	do j=2,n
     		a=arr(j)
     		a1(1:n1)=arr1(1:n1,j)
     		do i=j-1,1,-1
        		if(arr(i).le.a) goto 10
        			arr(i+1)=arr(i)
				arr1(1:n1,i+1)=arr1(1:n1,i)
     		end do
     		i=0
10     	arr(i+1)=a
      	arr1(1:n1,i+1)=a1(1:n1)
  	end do
  	return
  end subroutine piksrt

!----------------------------------------------------------------------
  !calculation the multivariate normal function
  double precision function mNormalF(d,x,mu,C)
  	integer d !dimension
      double precision x(d) !data vector
      double precision mu(d) !mean
      double precision C(d,d) !covariance matrix
      double precision a(d) !residual vector (x-mu)
      integer i
      double precision Chisq,sqrD
      double precision TwoPi
      Parameter(TwoPi=6.283185307)
      double precision b(d)

      !DCHDC routine variables
      integer INFO
      double precision L(d,d) !cholesky decomposition matrix

      !compute the Cholesky decomposition of the covariance matrix 'C'
      !C = L^T.L
      !uses the LAPACK routine DPOTRF
      L=C
      call DPOTRF('L',d,L,d,INFO)

	!Compute chi-squared as the dot product b^T b, where
	!Lb=a and a is the vector of residuals
      !(x-mu)^T.C^-1.(x-mu)=b^T.b
      !where L.b=(x-mu) & C=L^T.L
	a(1:d)=x(1:d)-mu(1:d)
	do i=1,d
      	b(i)=(a(i)-sum(L(i,1:i-1)*b(1:i-1)))/L(i,i)
	end do
      Chisq=sum(b(1:d)**2.)

      !square root of det(C)
      sqrD=1.
      do i=1,d
      	sqrD=sqrD*L(i,i)
	end do

      !calculate the multivariate normal function
      mNormalF=exp(-Chisq/2.)/(sqrD*(TwoPi**(d/2.)))

  end function mNormalF

!----------------------------------------------------------------------
  !calculation the cumulative Gaussian mixture probability in 1-D
  double precision function cGaussMix(nClstr,pPt,pMean,pCov,wt)
  	integer nClstr !no. of cluster
      double precision pPt !point
      double precision pMean(nClstr),pCov(nClstr) !projected mean & variance of clusters
      double precision wt(nClstr)
      integer i
      double precision z

      cGaussMix=0.
      do i=1,nClstr
      	z=(pPt-pMean(i))/sqrt(pCov(i))
            cGaussMix=cGaussMix+wt(i)*stNormalCDF(z)
	end do

  end function cGaussMix

!----------------------------------------------------------------------

 logical function ptIn1Ell(ndim,pt,meanx,invcovx,kfacx)

      implicit none

      integer ndim
      double precision pt(:),point(1,ndim)!point to be checked
      double precision meanx(:),invcovx(:,:),kfacx!cluster attributes
      double precision kfac!k factor of present point

      ptIn1Ell=.false.

      !if the cluster has vol=0 (i.e. kfacx=0) then point isn't in this cluster
      if(kfacx==0.d0) return

      point(1,:)=pt(:)
      call ScaleFactor(1,ndim,point,meanx,invcovx,kfac)
      if(kfac<kfacx .or. abs(kfac-kfacx)<0.0001) then
	ptIn1Ell=.true.
      endif

 end function ptIn1Ell

!----------------------------------------------------------------------

 subroutine ceffEvolve(ndim,vol,eff,npt)

      implicit none

      !input variables
      integer ndim
      integer npt !no. of points in the mode

      !input/output variables
      double precision vol !ellipsoid volume
      double precision eff !enlargement

      !work variables
      double precision d1

      if(eff>1d0) then
      	d1=eff
      	eff=max(1d0,eff*exp(-2d0/dble(npt*ndim)))
      	vol=vol*((eff/d1)**(dble(ndim)/2d0))
      endif

 end subroutine ceffEvolve

!----------------------------------------------------------------------

end module utils1


!##############################################################################
!# Tutorial 009a: Create a 2x2 block system / vector
!##############################################################################

module tutorial009a

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation

  use vectorio

  implicit none
  private

  public :: start_tutorial009a

contains

  ! ***************************************************************************

  subroutine start_tutorial009a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    character(LEN=SYS_STRLEN) :: spostdir

    type(t_vectorBlock) :: rx
    real(DP), dimension(:), pointer :: p_Ddata
    integer :: i

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 009a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Create a block discretisation that encapsules
    ! two equations, both discretised with Q1.
    ! =================================

    ! Set up a Q1 discretisation
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Set up a block discretisation for two equations. Both equations are Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a vector with 2 blocks
    ! =================================

    ! Use the block discretisation to create a block vector.
    call lsysbl_createVector (rblockDiscr,rx)

    ! =================================
    ! Clear the vector
    ! =================================

    call lsysbl_clearVector (rx)

    ! =================================
    ! Fill the vector with data.
    ! 1st block: 1, 2, 3,...
    ! 2nd block: NEQ, NEQ-1, NEQ-2,...
    ! =================================

    ! Get a pointer to the data of the first block
    call lsyssc_getbase_double (rx%RvectorBlock(1),p_Ddata)

    ! Initialise the data: 1,2,3,...
    do i=1,rx%RvectorBlock(1)%NEQ
      p_Ddata(i) = real(i,DP)
    end do

    ! Get a pointer to the data of the second block
    call lsyssc_getbase_double (rx%RvectorBlock(2),p_Ddata)

    ! Initialise the data: NEQ, NEQ-1,....
    do i=rx%RvectorBlock(1)%NEQ,1,-1
      p_Ddata(i) = real(i,DP)
    end do

    ! =================================
    ! Output of the vector
    ! =================================
    call output_line ("Writing vectors to texts file...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the vector to a text file.
      call vecio_writeBlockVectorHR (rx, "vector", .true., 0, &
          trim(spostdir)//"/tutorial009a_vector.txt", "(E11.2)")

      ! Write the vector to a MATLAB file.
      call vecio_spyBlockVector(&
          trim(spostdir)//"/tutorial009a_vector","vector",rx,.true.)

      ! Write the vector to a MAPLE file
      call vecio_writeBlockVectorMaple (rx, "vector", .true., 0,&
          trim(spostdir)//"/tutorial009a_vector.maple", "(E11.2)")
    else
      ! Write the vector to a text file.
      call vecio_writeBlockVectorHR (rx, "vector", .true., 0, &
          "./post/tutorial009a_vector.txt", "(E11.2)")

      ! Write the vector to a MATLAB file.
      call vecio_spyBlockVector(&
          "./post/tutorial009a_vector","vector",rx,.true.)

      ! Write the vector to a MAPLE file
      call vecio_writeBlockVectorMaple (rx, "vector", .true., 0,&
          "./post/tutorial009a_vector.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsysbl_releaseVector (rx)

    ! Release the block discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


integer:: Count = 5, h, R = 0
integer(len=Count):: A
randomize()
do h = 0, Count
	call random_number(r)
	A(h) = (813 * r) + 8
	if (A(h) > 820) A(h) = 820
	print *, "A[", h, "]=", A(h)
	R = R + A(h)
end do
R = R / Count
print *, "R=", R


C File: arrays-sect-03.f
C Illustrates the use of array sections using an implicit do loop to
C contiguous array elements

      program main
      implicit none

      integer, dimension (5) :: A
      integer :: i

      do i = 1, 5
          A(i) = i*i
      end do

      write (*,10) A(1), A(2), A(3), A(4), A(5)

 10   format(5(I5,X))

C     Use of an array section to redefine the middle three elements of A
C     This example uses an implicit do loop.
      A(2:4) = 17

      write (*,10) A(1), A(2), A(3), A(4), A(5)

      stop
      end program main


      program wrte_ctl
! ===============================================
      implicit none
! vars
      integer            ::  nx,  ny
      parameter             (nx=6000)
      parameter             (ny=6000)
      real*8             ::  lon, lat
      real*8             ::  size
      character*128      ::  buf
! file
      character*128      ::  hdrfile
      character*15       ::  nodata
      real*8             ::  ULXMAP, ULYMAP
! ===============================================
      call getarg(1,buf)
       read(buf,*) lon
      call getarg(2,buf)
       read(buf,*) lat
      call getarg(3,hdrfile)

      size=dble(1.0)/dble(1200.)

      ULXMAP=lon
      ULYMAP=lat+5.-size

      open(21,file=hdrfile,form='formatted')
        write(21,'(a)'         ) 'BYTEORDER       I   '
        write(21,'(a)'         ) 'LAYOUT          BIL '
        write(21,'(a)'         ) 'NROWS           6000'
        write(21,'(a)'         ) 'NCOLS           6000'
        write(21,'(a)'         ) 'NBANDS          1   '
        write(21,'(a)'         ) 'NBITS           8   '
        write(21,'(a)'         ) 'BANDROWBYTES    6000'
        write(21,'(a)'         ) 'TOTALROWBYTES   6000'
        write(21,'(a)'         ) 'BANDGAPBYTES    0   '
        write(21,'(a)'         ) 'NODATA          -9  '
        write(21,'(a,f25.20)'  ) 'ULXMAP        ', ULXMAP
        write(21,'(a,f25.20)'  ) 'ULYMAP        ', ULYMAP
        write(21,'(a,f25.20)'  ) 'XDIM          ', size
        write(21,'(a,f25.20)'  ) 'YDIM          ', size
      close(21)

      end program wrte_ctl


      PROGRAM LA_SPOSV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_POSV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, N, NRHS
      CHARACTER(LEN=1) :: UPLO
!  .. "Local Arrays" ..
 !    INTEGER, DIMENSION(NP) :: IPUT
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), AA(:,:),BB(:,:), S(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPOSV Example Program Results'
      N = 5; NRHS = 3

      ALLOCATE ( A(N,N), B(N,NRHS), AA(N,N), BB(N,NRHS), S(N) )

      OPEN(UNIT=21,FILE='posv.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=I,N
         READ(21,'(F3.0)') A(I,J);
         ENDDO
      ENDDO;
      CLOSE(21)

      WRITE(*,*) 'The array A :'
      DO I=1,N
      WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(A(I,1:N));
      ENDDO

      DO I = 1, N
        DO J = 1, NRHS
        B(I,J) = (SUM(A(I,I:N)) + SUM(A(1:I-1,I)))*J
        ENDDO
      ENDDO

      AA = TRANSPOSE(A)
      BB = B
      WRITE(*,*) 'The array B :'
      DO I=1,N
      WRITE(*,'(3(I3,1X,1X))') INT(B(I,1:NRHS));
      ENDDO

      WRITE(*,*) 'CALL LA_POSV( A, B )'
      CALL LA_POSV(  A, B )

      WRITE(*,*)'A on exit: '
      DO I=1,N; WRITE(*,"(5(E15.6))") A(I,1:N);
      ENDDO

      WRITE(*,*)'B on exit: '
      DO I=1,N; WRITE(*,"(3(F9.5))") B(I,1:NRHS);
      ENDDO

      WRITE(*,*)' * Example 2 * '

      WRITE(*,*) 'The array A :'
      DO J=1,N
      WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(AA(J,:));
      ENDDO

      WRITE(*,*) 'The array B(:,1) :'
      Do I=1,N
      WRITE(*,'(3(I3,1X,1X))') INT(BB(I,1));
      ENDDO

      WRITE(*,*) "CALL LA_POSV( A, B(:,1), 'L' )"
      UPLO='L'
      CALL LA_POSV(  AA, BB(:,1), 'L' )

      WRITE(*,*)'A on exit: '
      DO J=1,N; WRITE(*,"(6(E13.6))") AA(J,:); ENDDO

      WRITE(*,*)'B on exit: '
      DO I=1,N; WRITE(*,"(3(F8.5))") BB(I,1); ENDDO

      END PROGRAM LA_SPOSV_EXAMPLE


      MODULE m_mkgz
c.....------------------------------------------------------------------
c     by use of cartesian x,y,z components of charge density gradients,
c     make the quantities
cc      agrt,agru,agrd,g2rt,g2ru,g2rd,gggrt,gggru,gggrd,
cc      gzgr
cc    used to calculate gradient contribution to xc potential and
cc    energy.
c.....------------------------------------------------------------------
      CONTAINS
      SUBROUTINE mkgz(
     >     nmzdf,jspins,rh1,rh2,rhdz1,rhdz2,rhdzz1,rhdzz2,
     <     grad)
      USE m_types
      IMPLICIT NONE
      INTEGER, INTENT (IN) :: nmzdf,jspins
      REAL,    INTENT (IN) :: rh1(nmzdf),rhdz1(nmzdf),rhdzz1(nmzdf)
      REAL,    INTENT (IN) :: rh2(nmzdf),rhdz2(nmzdf),rhdzz2(nmzdf)
      TYPE(t_gradients),INTENT(INOUT)::grad

      INTEGER i
      REAL    vlt,dvzt,dvzzt,vlu,dvzu,dvzzu,vld,dvzd,dvzzd
      REAL    dagrzt,dagrzu,dagrzd,dztadz,sml

      sml = 1.e-14

      IF (ALLOCATED(grad%sigma)) THEN
         IF(jspins==1) THEN
            DO i=1,nmzdf
               grad%sigma(1,i)=rhdz1(i)*rhdz1(i)
            ENDDO
         ELSE
             DO i=1,nmzdf
               grad%sigma(1,i)=rhdz1(i)*rhdz1(i)
               grad%sigma(2,i)=rhdz1(i)*rhdz2(i)
               grad%sigma(3,i)=rhdz2(i)*rhdz2(i)
            ENDDO
         ENDIF
         RETURN
      ENDIF

      IF (jspins == 1) THEN

        DO i = 1,nmzdf

          vlu = max(rh1(i)/2,sml)
          dvzu = rhdz1(i)/2
          dvzzu = rhdzz1(i)/2
          vld = vlu
          dvzd = dvzu
          dvzzd = dvzzu

          vlt = vlu+vld
          dvzt = dvzu+dvzd
          dvzzt = dvzzu+dvzzd

c         agrt: abs(grad(ro)), u,d for up and down.

          grad%agrt(i) = max(abs(dvzt),sml)
          grad%agru(i) = max(abs(dvzu),sml)
          grad%agrd(i) = max(abs(dvzd),sml)

          dagrzt= dvzt*dvzzt/grad%agrt(i)
          dagrzu= dvzu*dvzzu/grad%agru(i)
          dagrzd= dvzd*dvzzd/grad%agrd(i)

          grad%gggrt(i) = dvzt*dagrzt
          grad%gggru(i) = dvzu*dagrzu
          grad%gggrd(i) = dvzd*dagrzd

c         dztadz=d(zeta)/dz,..

          dztadz = (dvzu-dvzd)/vlt - (vlu-vld)*dvzt/vlt**2

c         gzgr=grad(zeta)*grad(ro).

          grad%gzgr(i) = dztadz*dvzt

c         g2rt: grad(grad(ro))

          grad%g2rt(i)  = dvzzt
          grad%g2ru(i)  = dvzzu
          grad%g2rd(i)  = dvzzd

        ENDDO

      ELSE

        DO i = 1,nmzdf

          vlu = max(rh1(i),sml)
          dvzu = rhdz1(i)
          dvzzu = rhdzz1(i)
          vld = max(rh2(i),sml)
          dvzd = rhdz2(i)
          dvzzd = rhdzz2(i)

          vlt = vlu+vld
          dvzt = dvzu+dvzd
          dvzzt = dvzzu+dvzzd

c         agrt: abs(grad(ro)), u,d for up and down.

          grad%agrt(i) = max(abs(dvzt),sml)
          grad%agru(i) = max(abs(dvzu),sml)
          grad%agrd(i) = max(abs(dvzd),sml)

          dagrzt= dvzt*dvzzt/grad%agrt(i)
          dagrzu= dvzu*dvzzu/grad%agru(i)
          dagrzd= dvzd*dvzzd/grad%agrd(i)

          grad%gggrt(i) = dvzt*dagrzt
          grad%gggru(i) = dvzu*dagrzu
          grad%gggrd(i) = dvzd*dagrzd

c         dztadz=d(zeta)/dz,..

          dztadz = (dvzu-dvzd)/vlt - (vlu-vld)*dvzt/vlt**2

c         gzgr=grad(zeta)*grad(ro).

          grad%gzgr(i) = dztadz*dvzt

c         g2rt: grad(grad(ro))

          grad%g2rt(i)  = dvzzt
          grad%g2ru(i)  = dvzzu
          grad%g2rd(i)  = dvzzd

        ENDDO
      ENDIF

      END SUBROUTINE mkgz
      END MODULE m_mkgz


! How to remove ^M in source code on linux %s/^M//g (^M = Ctrl+v+m)
! Note on subroutine random_number
! Returns a single pseudorandom number or an array of pseudorandom numbers from the uniform distribution over the range [0, 1).
! The runtime-library implements the xorshift1024* random number generator(RNG). This generator has a period of 2^{1024} - 1,
! and when using multiple threads up to 2^{512} threads can each generate 2^{512} random numbers before any aliasing occurs.

module parameters
    integer, parameter :: latt_leng = 80
    integer, parameter :: EXCH_CONST = 1 ! exchange constant
    integer, dimension(-1 : latt_leng, -1 : latt_leng) :: spin_of ! (-1 ... latt_leng) X (-1 ... latt_leng)
    double precision, dimension(-2 : 2) :: accept_prob_chart
end module

program Ising_Model
    use parameters
    implicit none ! Require all variables to be explicitly declared
    integer(kind=8), parameter :: MC_max = 1E7 * latt_leng**2
    double precision, parameter :: T = 2.269d0 ! Unit = kT/J, Tc computed with each of the physical observables

    call create_lattice_random
    if(EXCH_CONST == -1) then ! Anti-ferromagnetic, EXCH_CONST = -1
        accept_prob_chart = (/ exp(-8d0 / T), exp(-4d0 / T), &
        1d0, exp(4d0 / T), exp(8d0 / T) /) ! Acceptance probability chart
    else ! Ferromagnetic, EXCH_CONST = 1
        accept_prob_chart = (/ exp(8d0 / T), exp(4d0 / T), &
        1d0, exp(-4d0 / T), exp(-8d0 / T) /)
    end if
    call flip_sites_metropolis(MC_max) ! Iterate MC simulation MC_max times per temperature
end program

subroutine create_lattice_random
    use parameters
    integer :: x, y
    double precision :: u

    do x = 0, latt_leng - 1
        do y = 0, latt_leng - 1
            call random_number(u) ! Return random real number in [0,1)
            if (u >= 0.5) then
                spin_of(x, y) = 1 ! Assign random spin values
            else
                spin_of(x, y) = -1
            end if
        end do
    end do

    do x = 0, latt_leng - 1 ! Assign spins to top and bottom line of padding sites to make it periodic
        spin_of(x, -1) = spin_of(x, latt_leng - 1)
        spin_of(x, latt_leng) = spin_of(x, 0)
    end do
    do y = 0, latt_leng -1  ! Assign spins to left and right line of padding sites to make it periodic
        spin_of(-1, y) = spin_of(latt_leng - 1, y)
        spin_of(latt_leng, y) = spin_of(0, y)
    end do
end subroutine

subroutine create_lattice_aligned
    use parameters
    integer :: x, y

    do x = 0, latt_leng - 1 ! Assign spins on each site
        do y = 0, latt_leng - 1
            spin_of(x, y) = 1 ! All up spins
        end do
    end do
    do x = 0, latt_leng - 1 ! Assign spins to top and bottom line of padding sites to make it periodic
        spin_of(x, -1) = spin_of(x, latt_leng - 1)
        spin_of(x, latt_leng) = spin_of(x, 0)
    end do
    do y = 0, latt_leng -1  ! Assign spins to left and right line of padding sites to make it periodic
        spin_of(-1, y) = spin_of(latt_leng - 1, y)
        spin_of(latt_leng, y) = spin_of(0, y)
    end do
end subroutine

subroutine flip_sites_metropolis(MC_max)
    use parameters
    integer :: first_open = 1
    integer :: x, y, sum_spin_nbr, sum_nbr_spin
    integer :: out_unit1 = 10, out_unit2 = 20 !,out_unit3 = 30
    integer(kind=8), intent(in) :: MC_max
    integer(kind=8) :: MC_step
    double precision :: accept_prob, tot_en, tot_mag, tot_en2, tot_E, tot_M, tot_E2
    double precision :: u, v, r

    n_sample = 0 ! Initialize variable to be used in averaging samples
    sum_tot_E = 0d0
    sum_tot_M = 0d0
    sum_tot_E2 = 0d0
    call compute_tot_E_M_E2(tot_en, tot_mag, tot_en2) ! Compute initial values of physical observables
    tot_E = tot_en
    tot_M = tot_mag
    tot_E2 = tot_en2
    do MC_step = 0, MC_max
        call random_number(u) ! Return random real number in [0,1)
        call random_number(v)
        x = FLOOR(u * latt_leng) ! Pick random site, [0, latt_leng - 1]
        y = FLOOR(v * latt_leng)
        sum_nbr_spin = spin_of(x - 1, y) + spin_of(x + 1, y) + spin_of(x, y + 1) + spin_of(x, y - 1)
        accept_prob = accept_prob_chart((spin_of(x, y) * sum_nbr_spin)/2) ! Sigma(SS) = spin_of(x, y) * sum_surrounding = -4, -2 , 0, 2, 4
        call random_number(r) ![0, 1)
        if (r < accept_prob) then
            spin_of(x, y) = - spin_of(x, y) ! If random number < accept_prob => flip site

            if (x == 0) then ! Update padding sites
                spin_of(latt_leng, y) = spin_of(x, y)
            else if (x == latt_leng - 1) then
                spin_of(-1, y) = spin_of(x, y)
            end if
            if (y == 0) then
                spin_of(x, latt_leng) = spin_of(x, y)
            else if (y == latt_leng - 1) then
                spin_of(x, -1) = spin_of(x, y)
            end if

            tot_M = tot_M + 2*spin_of(x, y) ! Update physical observables
            sum_spin_nbr = spin_of(x + 1, y) + spin_of(x - 1, y) + spin_of(x, y + 1) + spin_of(x, y - 1)
            tot_E = tot_E + (- EXCH_CONST) * spin_of(x, y) * sum_spin_nbr
            tot_E2 = tot_E**2
        end if

        if (MOD(MC_step, latt_leng**2) == 0) then
            if(first_open == 1) then
                open (out_unit1, FILE = 'output_ising_model_fixed_T_E_change_plot.txt', action = "write", status = 'replace')
                write (out_unit1,*) MC_step / latt_leng**2 , " ", tot_E
                close(out_unit1)
                open (out_unit2, FILE = 'output_ising_model_fixed_T_M_change_plot.txt', action = "write", status = 'replace')
                write (out_unit2,*) MC_step / latt_leng**2, " ", tot_M
                close(out_unit2)
                first_open = -1
            else
                open (out_unit1, FILE = 'output_ising_model_fixed_T_E_change_plot.txt', action = "write", position = 'append')
                write (out_unit1,*) MC_step / latt_leng**2, " ", tot_E
                close(out_unit1)
                open (out_unit2, FILE = 'output_ising_model_fixed_T_M_change_plot.txt', action = "write", position = 'append')
                write (out_unit2,*) MC_step / latt_leng**2, " ", tot_M
                close(out_unit2)
            end if
        end if
    end do
end subroutine

subroutine compute_tot_E_M_E2(tot_E, tot_M, tot_E2)
    use parameters
    integer :: x, y, sum_spin_nbr
    double precision, intent(out) :: tot_E, tot_M, tot_E2

    tot_E = 0d0
    tot_M = 0d0
    tot_E2 = 0d0
    do x = 0, latt_leng - 1
        do y = 0, latt_leng - 1
            tot_M = tot_M + spin_of(x, y)
            sum_spin_nbr = spin_of(x + 1, y) + spin_of(x - 1, y) + spin_of(x, y + 1) + spin_of(x, y - 1)
            tot_E = tot_E + (- EXCH_CONST) * spin_of(x, y) * sum_spin_nbr
        end do
    end do
    tot_E = tot_E / 2
    tot_E2 = tot_E**2
end subroutine