      SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
      IMPLICIT NONE
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
*     ..
*     .. Array Arguments ..
      COMPLEX   T( LDT, * ), TAU( * ), V( LDV, * )
*     ..
*
*  Purpose
*  =======
*
*  CLARFT forms the triangular factor T of a COMPLEX block reflector H
*  of order n, which is defined as a product of k elementary reflectors.
*
*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*
*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*
*  If STOREV = 'C', the vector which defines the elementary reflector
*  H(i) is stored in the i-th column of the array V, and
*
*     H  =  I - V * T * V**H
*
*  If STOREV = 'R', the vector which defines the elementary reflector
*  H(i) is stored in the i-th row of the array V, and
*
*     H  =  I - V**H * T * V
*
*  Arguments
*  =========
*
*  DIRECT  (input) CHARACTER*1
*          Specifies the order in which the elementary reflectors are
*          multiplied to form the block reflector:
*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Specifies how the vectors which define the elementary
*          reflectors are stored (see also Further Details):
*          = 'C': columnwise
*          = 'R': rowwise
*
*  N       (input) INTEGER
*          The order of the block reflector H. N >= 0.
*
*  K       (input) INTEGER
*          The order of the triangular factor T (= the number of
*          elementary reflectors). K >= 1.
*
*  V       (input/output) COMPLEX array, dimension
*                               (LDV,K) if STOREV = 'C'
*                               (LDV,N) if STOREV = 'R'
*          The matrix V. See further details.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*
*  TAU     (input) COMPLEX array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i).
*
*  T       (output) COMPLEX array, dimension (LDT,K)
*          The k by k triangular factor T of the block reflector.
*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*          lower triangular. The rest of the array is not used.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  Further Details
*  ===============
*
*  The shape of the matrix V and the storage of the vectors which define
*  the H(i) is best illustrated by the following example with n = 5 and
*  k = 3. The elements equal to 1 are not stored; the corresponding
*  array elements are modified but restored on exit. The rest of the
*  array is not used.
*
*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
*
*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
*                   ( v1  1    )                     (     1 v2 v2 v2 )
*                   ( v1 v2  1 )                     (        1 v3 v3 )
*                   ( v1 v2 v3 )
*                   ( v1 v2 v3 )
*
*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
*
*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
*                   (     1 v3 )
*                   (        1 )
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER ATLASROWMAJOR, ATLASCOLMAJOR
      PARAMETER (ATLASROWMAJOR=101, ATLASCOLMAJOR=102)
      INTEGER ATLASNOTRANS, ATLASTRANS, ATLASCONJTRANS
      PARAMETER (ATLASNOTRANS=111, ATLASTRANS=112, ATLASCONJTRANS=113)
      INTEGER ATLASUPPER, ATLASLOWER
      PARAMETER (ATLASUPPER=121, ATLASLOWER=122)
      INTEGER ATLASNONUNIT, ATLASUNIT
      PARAMETER (ATLASNONUNIT=131, ATLASUNIT=132)
      INTEGER ATLASLEFT, ATLASRIGHT
      PARAMETER (ATLASLEFT=141, ATLASRIGHT=142)
*     .. Local variables ..
      INTEGER ISIDE, ITRANS, IDIRECT, ISTORE
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF (N .LE.0) RETURN
      IF (DIRECT.EQ.'F' .OR. DIRECT.EQ.'f') THEN
         IDIRECT = 1
      ELSE
         IDIRECT = 2
      ENDIF
      IF (STOREV.EQ.'R' .OR. STOREV.EQ.'r') THEN
         ISTORE = 1
      ELSE
         ISTORE = 2
      ENDIF
*
      CALL ATL_F77WRAP_CLARFT(IDIRECT, ISTORE, N, K, V, LDV,
     $                        TAU, T, LDT)
*
*
      RETURN
*
*     End of CLARFT
*
      END


      PROGRAM LA_CHPGV_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_HPGV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N
      REAL(WP), ALLOCATABLE :: W(:)
!  .. "Local Arrays" ..
      COMPLEX(WP), ALLOCATABLE :: A(:), AA(:), B(:), BB(:), Z(:,:)
!  .. "Intrinsic Functions" ..
      INTRINSIC REAL, AIMAG, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_HPGV Example Program Results'
      N = 5
      ALLOCATE( A(N*(N+1)/2), AA(N*(N+1)/2), B(N*(N+1)/2), BB(N*(N+1)/2), W(N), Z(N,N) )

      OPEN(UNIT=21,FILE='hpgvu.ma',STATUS='UNKNOWN')
      DO J=1,N*(N+1)/2
         READ(21,*) A(J)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix AP : '
      DO I=1,N*(N+1)/2
         WRITE(*,"('('(I3,',',I3)')')") INT(A(I)), INT(AIMAG(A(I)))
      ENDDO

      OPEN(UNIT=21,FILE='hpgvu.mb',STATUS='UNKNOWN')
      DO J=1,N*(N+1)/2
         READ(21,*) B(J)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix B : '
      DO I=1,N*(N+1)/2
         WRITE(*,"('('(I3,',',I3)')')") INT(B(I)), INT(AIMAG(B(I)))
      ENDDO

      WRITE(*,*) "CALL LA_HPGV( AP, BP, W) "
      CALL LA_HPGV( A, B, W )

      WRITE(*,*)'BP on exit : '
      DO I=1,N*(N+1)/2
         WRITE(*,"('('(E14.6,1X,','E14.6)')')") REAL(B(I)), AIMAG(B(I))
      ENDDO

      WRITE(*,*) 'W on exit : '
      DO I=1,N
         WRITE(*,"(5(E14.6))") W(I)
      ENDDO

      WRITE(*,*)
      WRITE(*,*)' * EXAMPLE 2 * '

      OPEN(UNIT=21,FILE='hpgvl.ma',STATUS='UNKNOWN')
      DO J=1,N*(N+1)/2
         READ(21,*) AA(J)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix AP : '
      DO I=1,N*(N+1)/2
         WRITE(*,"('('(I3,',',I3)')')") INT(AA(I)), INT(AIMAG(AA(I)))
      ENDDO

      OPEN(UNIT=21,FILE='hpgvl.mb',STATUS='UNKNOWN')
      DO J=1,N*(N+1)/2
         READ(21,*) BB(J)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix BP : '
      DO I=1,N*(N+1)/2
         WRITE(*,"('('(I3,',',I3)')')") INT(BB(I)), INT(AIMAG(BB(I)))
      ENDDO

      WRITE(*,*)
!      WRITE(*,*) "CALL LA_HPGV( A, B, W, JOBZ, UPLO, INFO )"
!      CALL LA_HPGV( AA, BB, W, 3, 'L', Z, INFO )
       WRITE(*,*) "CALL LA_HPGV( A, B, W, 3, 'L', Z, INFO)"
       CALL LA_HPGV( AA, BB, W, 3, 'L', Z, INFO )

      WRITE(*,*)'Z on exit : '
      DO I=1,N
         DO J=1,N-1
            WRITE(*,"('('(E14.6,1X,',',1X,E14.6)')')") REAL(Z(I,J)), AIMAG(Z(I,J))
         ENDDO
         WRITE(*,"('('(E14.6,1X,',',1X,E14.6)')')") REAL(Z(I,N)), AIMAG(Z(I,N))
      ENDDO
      WRITE(*,*)'BP on exit : '
      DO I=1,N*(N+1)/2
         WRITE(*,"('('(E14.6,1X,',',1X,E14.6)')')") REAL(BB(I)), AIMAG(BB(I))
      ENDDO

      WRITE(*,*) 'W on exit : '
      DO I=1,N
      WRITE(*,"(5(E14.6,1X))") W(I)
      ENDDO
      WRITE(*,*) ' INFO = ', INFO

      END PROGRAM LA_CHPGV_EXAMPLE


        SUBROUTINE ZLINTP(X,Y,NX,XOUT,YOUT,NXOUT,STATUS)
C
C SUBROUTINE TO PERFORM LINEAR INTERPOLATION FOR DATA POINTS XOUT
C IN X,Y
C
C VERSION 1  NOV. 1985  D. LINDLER
C
C  X,Y ARRAYS OF NX POINTS TO BE INTERPOLATED IN
C  NX - SIZE OF X AND Y
C  XOUT - X VALUES WHERE Y VALUES ARE DESIRED
C  YOUT - INTERPOLATED Y VALUES
C  NXOUT - SIZE OF XOUT AND YOUT
C
        DOUBLE PRECISION X(1),XOUT(1)
        INTEGER STATUS
        DOUBLE PRECISION Y(1),YOUT(1)
        INTEGER NX,NXOUT
        INTEGER IPOS
C                                    ---> CURRENT POSITION IN X ARRAY
        INTEGER I,II
C                                    ---> INDEX IN XOUT AND YOUT
        DOUBLE PRECISION FRAC
C                                    ---> FRACTIONAL DISTANCE BETWEEN X(IPOS) AND
C                                       X(IPOS+1) OR XOUT(I)
C
C INITIALIZATION
C
        IPOS=1
C                                    ---> START AT BEGGINING OF X,Y
        STATUS = 0
C
C LOOP ON VALUES IN XOUT
C
        DO 100 I=1,NXOUT
C
C FIND  IPOS SUCH THAT X(IPOS) <= XOUT(I) < X(IPOS+1)
C
C DETERMINE IF WE SHOULD DECREASE IPOS
C
           DO 10 II=1,NX
                IF((IPOS.EQ.1).OR.(XOUT(I).GT.X(IPOS)))GO TO 20
                IPOS=IPOS-1
10         CONTINUE
C
C DETERMINE IF WE SHOULD INCREASE IPOS
C
20         DO 30 II=1,NX
                IF((IPOS.EQ.(NX-1)).OR.(XOUT(I).LE.X(IPOS+1))) GO TO 40
                IPOS=IPOS+1
30         CONTINUE
C
C
C DETERMINE FRACTIONAL DISTANCE BETWEEN X(IPOS) AND X(IPOS+1)
C
40         IF (X(IPOS) .EQ. X(IPOS+1)) THEN
                FRAC=0.0
             ELSE
                FRAC= (XOUT(I)-X(IPOS)) / (X(IPOS+1)-X(IPOS))
             ENDIF
C
C COMPUTE INTERPOLATED VALUE
C
           YOUT(I) = Y(IPOS) + FRAC * (Y(IPOS+1)-Y(IPOS))
100     CONTINUE
        RETURN
        END


!##############################################################################
! PROGRAM oligopoly
!
! ## Multi-dimensional rootfinding with the toolbox routine fzero
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog02_08m.f90"

program oligopoly

    use globals
    use toolbox

    implicit none
    real*8 :: q(2)
    logical :: check

    ! initialize q
    q = 0.1d0

    ! find root
    call fzero(q, cournot, check)

    if(check)stop 'Error: fzero did not converge'

    ! output
    write(*,'(/a)')'            Output'
    write(*,'(a,f10.4)')'Firm 1: ',q(1)
    write(*,'(a,f10.4)')'Firm 2: ',q(2)
    write(*,'(/a,f10.4)')'Price : ',(q(1)+q(2))**(-1d0/1.6d0)

end program


! { dg-do run }
! { dg-options "-fno-range-check" }
! PR 52428 Read IO of integers near the end of range. Note that we
! support the two's complement representation even though the Fortran
! numerical model has a symmetric range.  (The -fno-range-check option
! is needed to allow the -2147483648 literal.)
program int_range
  implicit none
  character(25) :: inputline = "-2147483648"
  integer(4) ::  test
  integer :: st

  read(inputline,100) test
100 format(1i11)
  if (test /= -2147483648) STOP 1
  inputline(1:1) = " "
  read(inputline, 100, iostat=st) test
  if (st == 0) STOP 2
  inputline(11:11) = "7"
  read(inputline, 100) test
  if (test /= 2147483647) STOP 3

  ! Same as above but with list-formatted IO
  inputline = "-2147483648"
  read(inputline, *) test
  if (test /= -2147483648) STOP 4
  inputline(1:1) = " "
  read(inputline, *, iostat=st) test
  if (st == 0) STOP 5
  inputline(11:11) = "7"
  read(inputline, *) test
  if (test /= 2147483647) STOP 6

end program int_range


MODULE Euler_MeshRefinementModule

  USE KindModule, ONLY: &
    DP, &
    Zero, &
    One, &
    Half
  USE ProgramHeaderModule, ONLY: &
    nDimsX, &
    nNodesX, &
    nDOFX
  USE ReferenceElementModuleX, ONLY: &
    NodesX1, &
    NodesX2, &
    NodesX3, &
    WeightsX1, &
    WeightsX2, &
    WeightsX3, &
    WeightsX_q
  USE PolynomialBasisModule_Lagrange, ONLY: &
    IndLX_Q, &
    L_X1, &
    L_X2, &
    L_X3

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeMeshRefinement_Euler
  PUBLIC :: FinalizeMeshRefinement_Euler
  PUBLIC :: Refine_Euler
  PUBLIC :: Coarsen_Euler

  INTEGER  :: nFine, nFineX(3)
  REAL(DP) :: VolumeRatio
  REAL(DP), ALLOCATABLE :: ProjectionMatrix  (:,:,:)
  REAL(DP), ALLOCATABLE :: ProjectionMatrix_T(:,:,:) ! --- Transpose ---

CONTAINS

  SUBROUTINE InitializeMeshRefinement_Euler

    INTEGER :: iDim
    INTEGER :: iFine, iFineX1, iFineX2, iFineX3
    INTEGER :: i, k, iN1, iN2, iN3
    REAL(DP), ALLOCATABLE :: xiX1(:), xiX2(:), xiX3(:)

    nFineX      = 1
    VolumeRatio = One
    DO iDim = 1, nDimsX
      ! --- Refinement Factor of 2 Assumed ---
      nFineX(iDim) = 2
      VolumeRatio  = Half * VolumeRatio
    END DO
    nFine = PRODUCT( nFineX )

    ALLOCATE( ProjectionMatrix  (nDOFX,nDOFX,nFine) )
    ALLOCATE( ProjectionMatrix_T(nDOFX,nDOFX,nFine) )

    ALLOCATE( xiX1(nNodesX(1)) )
    ALLOCATE( xiX2(nNodesX(2)) )
    ALLOCATE( xiX3(nNodesX(3)) )

    iFine = 0
    DO iFineX3 = 1, nFineX(3)
    DO iFineX2 = 1, nFineX(2)
    DO iFineX1 = 1, nFineX(1)

      iFine = iFine + 1

      IF( nFineX(1) > 1 )THEN
        xiX1 = Half * ( NodesX1 + (-1)**iFineX1 * Half )
      ELSE
        xiX1 = Zero
      END IF

      IF( nFineX(2) > 1 )THEN
        xiX2 = Half * ( NodesX2 + (-1)**iFineX2 * Half )
      ELSE
        xiX2 = Zero
      END IF

      IF( nFineX(3) > 1 )THEN
        xiX3 = Half * ( NodesX3 + (-1)**iFineX3 * Half )
      ELSE
        xiX3 = Zero
      END IF

      ProjectionMatrix(:,:,iFine) = Zero
      DO k = 1, nDOFX
      DO i = 1, nDOFX

        DO iN3 = 1, nNodesX(3)
        DO iN2 = 1, nNodesX(2)
        DO iN1 = 1, nNodesX(1)

          ProjectionMatrix(i,k,iFine) &
            = ProjectionMatrix(i,k,iFine) &
                + WeightsX1(iN1) * WeightsX2(iN2) * WeightsX3(iN3) &
                  * L_X1(IndLX_Q(1,i)) % P( NodesX1(iN1) ) &
                  * L_X2(IndLX_Q(2,i)) % P( NodesX2(iN2) ) &
                  * L_X3(IndLX_Q(3,i)) % P( NodesX3(iN3) ) &
                  * L_X1(IndLX_Q(1,k)) % P( xiX1   (iN1) ) &
                  * L_X2(IndLX_Q(2,k)) % P( xiX2   (iN2) ) &
                  * L_X3(IndLX_Q(3,k)) % P( xiX3   (iN3) )

        END DO
        END DO
        END DO

      END DO
      END DO

      ProjectionMatrix_T(:,:,iFine) &
        = TRANSPOSE( ProjectionMatrix(:,:,iFine) )

    END DO
    END DO
    END DO

    DEALLOCATE( xiX1 )
    DEALLOCATE( xiX2 )
    DEALLOCATE( xiX3 )

  END SUBROUTINE InitializeMeshRefinement_Euler

  SUBROUTINE FinalizeMeshRefinement_Euler

    DEALLOCATE( ProjectionMatrix )
    DEALLOCATE( ProjectionMatrix_T )

  END SUBROUTINE FinalizeMeshRefinement_Euler

  SUBROUTINE Refine_Euler( nX, U_Crs, U_Fin )

    INTEGER,  INTENT(in)  :: nX(3)
    REAL(DP), INTENT(in)  :: U_Crs(1:nDOFX)
    REAL(DP), INTENT(out) :: U_Fin(1:nDOFX,1:nX(1),1:nX(2),1:nX(3))

    INTEGER :: iFine, iFineX1, iFineX2, iFineX3

    iFine = 0
    DO iFineX3 = 1, nFineX(3)
    DO iFineX2 = 1, nFineX(2)
    DO iFineX1 = 1, nFineX(1)

      iFine = iFine + 1

      U_Fin(:,iFineX1,iFineX2,iFineX3) &
        = MATMUL( ProjectionMatrix(:,:,iFine), U_Crs ) / WeightsX_q

    END DO
    END DO
    END DO

  END SUBROUTINE Refine_Euler

  SUBROUTINE Coarsen_Euler( nX, U_Crs, U_Fin )

    INTEGER,  INTENT(in)  :: nX(3)
    REAL(DP), INTENT(out) :: U_Crs(1:nDOFX)
    REAL(DP), INTENT(in)  :: U_Fin(1:nDOFX,1:nX(1),1:nX(2),1:nX(3))

    INTEGER  :: iFine, iFineX1, iFineX2, iFineX3
    REAL(DP) :: U_Crs_iFine(1:nDOFX)

    U_Crs = Zero

    iFine = 0
    DO iFineX3 = 1, nFineX(3)
    DO iFineX2 = 1, nFineX(2)
    DO iFineX1 = 1, nFineX(1)

      iFine = iFine + 1

      U_Crs_iFine = MATMUL( ProjectionMatrix_T(:,:,iFine), &
                            U_Fin(:,iFineX1,iFineX2,iFineX3) ) / WeightsX_q

      U_Crs = U_Crs + VolumeRatio * U_Crs_iFine

    END DO
    END DO
    END DO

  END SUBROUTINE Coarsen_Euler

END MODULE Euler_MeshRefinementModule


      SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate the output y of the Wiener system
C
C        x(t+1) = A*x(t) + B*u(t)
C        z(t)   = C*x(t) + D*u(t),
C
C        y(t)   = f(z(t),wb(1:L)),
C
C     where t = 1, 2, ..., NSMP, and f is a nonlinear function,
C     evaluated by the SLICOT Library routine NF01AY. The parameter
C     vector X is partitioned as X = ( wb(1), ..., wb(L), theta ),
C     where wb(i), i = 1:L, correspond to the nonlinear part, theta
C     corresponds to the linear part, and the notation is fully
C     described below.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NSMP    (input) INTEGER
C             The number of training samples.  NSMP >= 0.
C
C     M       (input) INTEGER
C             The length of each input sample.  M >= 0.
C
C     L       (input) INTEGER
C             The length of each output sample.  L >= 0.
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters needed.
C             IPAR(1)  must contain the order of the linear part,
C                      referred to as N below.  N >= 0.
C             IPAR(2)  must contain the number of neurons for the
C                      nonlinear part, referred to as NN below.
C                      NN >= 0.
C
C     LIPAR   (input) INTEGER
C             The length of IPAR.  LIPAR >= 2.
C
C     X       (input) DOUBLE PRECISION array, dimension (LX)
C             The parameter vector, partitioned as
C             X = (wb(1), ..., wb(L), theta), where the vectors
C             wb(i), of length NN*(L+2)+1, are parameters for the
C             static nonlinearity, which is simulated by the
C             SLICOT Library routine NF01AY. See the documentation of
C             NF01AY for further details. The vector theta, of length
C             N*(M + L + 1) + L*M, represents the matrices A, B, C,
C             D and x(1), and it can be retrieved from these matrices
C             by SLICOT Library routine TB01VD and retranslated by
C             TB01VY.
C
C     LX      (input) INTEGER
C             The length of the array X.
C             LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M.
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU, M)
C             The leading NSMP-by-M part of this array must contain the
C             set of input samples,
C             U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ).
C
C     LDU     INTEGER
C             The leading dimension of the array U.  LDU >= MAX(1,NSMP).
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY, L)
C             The leading NSMP-by-L part of this array contains the
C             simulated output.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= MAX(1,NSMP).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N +
C                                     MAX( N*(N + L), N + M + L ) )
C                                                              if M > 0;
C             LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N +
C                                     MAX( N*(N + L), L ) ),   if M = 0.
C             A larger value of LDWORK could improve the efficiency.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C     METHOD
C
C     BLAS routines are used for the matrix-vector multiplications and
C     the routine NF01AY is called for the calculation of the nonlinear
C     function.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Mar. 2001, during a stay at University of Twente, NL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C     Dec. 2001.
C
C     KEYWORDS
C
C     Nonlinear system, output normal form, simulation, state-space
C     representation, Wiener system.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDU, LDWORK, LDY, LX, LIPAR, M, NSMP
C     .. Array Arguments ..
      INTEGER           IPAR(*)
      DOUBLE PRECISION  DWORK(*), U(LDU,*), X(*), Y(LDY,*)
C     .. Local Scalars ..
      INTEGER           AC, BD, IX, JW, LDAC, LTHS, N, NN, NTHS, Z
C     .. External Subroutines ..
      EXTERNAL          NF01AY, TB01VY, TF01MX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     ..
C     .. Executable Statements ..
C
      INFO = 0
      IF ( NSMP.LT.0 ) THEN
         INFO = -1
      ELSEIF ( M.LT.0 ) THEN
         INFO = -2
      ELSEIF ( L.LT.0 ) THEN
         INFO = -3
      ELSEIF ( LIPAR.LT.2 ) THEN
         INFO = -5
      ELSE
C
         N    = IPAR(1)
         NN   = IPAR(2)
         LDAC = N + L
         NTHS = ( NN*( L + 2 ) + 1 )*L
         LTHS = N*( M + L + 1 ) + L*M
C
         IF ( N.LT.0 .OR. NN.LT.0 ) THEN
            INFO = -4
         ELSEIF ( LX.LT.NTHS + LTHS ) THEN
            INFO = -7
         ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN
            INFO = -9
         ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN
            INFO = -11
         ELSE
            IF ( M.GT.0 ) THEN
               JW = MAX( N*LDAC, N + M + L )
            ELSE
               JW = MAX( N*LDAC, L )
            END IF
            IF ( LDWORK.LT.NSMP*L + MAX( 2*NN, LDAC*( N + M ) + 2*N +
     $            JW ) )
     $         INFO = -13
         ENDIF
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01AD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( MIN( NSMP, L ).EQ.0 )
     $   RETURN
C
C     Compute the output of the linear part.
C     Workspace: need   NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1).
C     (NSMP*L locations are reserved for the output of the linear part.)
C
      Z  = 1
      AC = Z  + NSMP*L
      BD = AC + LDAC*N
      IX = BD + LDAC*M
      JW = IX + N
C
      CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC,
     $             DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N),
     $             LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO )
C
C     Workspace: need   NSMP*L + (N + L)*(N + M) + 3*N + M + L, if M>0;
C                       NSMP*L + (N + L)*N + 2*N + L,           if M=0;
C                prefer larger.
C
      CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX),
     $             DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO )
C
C     Simulate the static nonlinearity.
C     Workspace: need   NSMP*L + 2*NN;
C                prefer larger.
C
      JW = AC
      CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z),
     $             NSMP, Y, LDY, DWORK(JW), LDWORK-JW+1, INFO )
C
      RETURN
C
C *** Last line of NF01AD ***
      END


      double complex function Vpole(sij)
      implicit none
c---  DKS Eq. 2.12
      include 'epinv.f'
      include 'epinv2.f'
      include 'scale.f'
      double precision sij
      double complex Lnrat,xl12

      xl12=Lnrat(-sij,musq)

      Vpole=-epinv*epinv2+epinv*(-1.5d0+xl12)
     .   -0.5d0*xl12**2+1.5d0*xl12-3.5d0

      return
      end


	program coil
C
C	CALCULATES AND PLOTS WIND SEARCH COIL TRANSFER F AND NOISE THRESH
C
C   freq  trans(V/nT)  noise(nT/rtHz)  noise(v**2/rtHz)  noise(V/rtHz)
C     40.     .012       1.17E-04       1.98E-12            1.41E-6
C    100.     .03         4.9E-05       2.16E-12            1.47E-6
C    300.     .09         2.9E-05       6.81E-12            2.61E-6
C   1000.     .290       2.18E-05       4.00E-11	    6.32E-6
C   2000.     .6         2.15E-05       1.66E-10            1.29E-5
C   3000.     .750       2.12E-05       2.53E-10            1.59E-5
C   4000.     .7         2.10E-05       2.16E-10            1.47E-5
C   5000.     .57        2.07E-05
C   6000.     .500       2.04E-05       1.04E-10            1.02E-5
C
	COMPLEX Z1,Z2,Z3,Z4,Y2,CGAIN
	COMMON /PLOTDT/ ITERM,NF
 	COMMON /DBLK/ FREQ(300),TRANS(300),PANOIS(300)
	DIMENSION GFREQ(6),GTR(6),GPAN(6)
	DATA GFREQ /1000.,2000.,3000.,4000.,5000.,6000./
	DATA GTR   /.290,.6,.750,.7,.57,.500/
	DATA GPAN  /2.12,2.09,2.07,2.05,2.03,2.01/
C	DATA R1,C1,R2,C2 /49.9E03,.33E-06,499.E03,22.E-12/  !BEFORE 16 DEC 1991
C	DATA R1,C1,R2,C2 /49.9E03,.33E-06,499.E03,1.E-09/   !BEFORE 1430  "
C	DATA R1,C1,R2,C2 /49.9E03,.33E-06,1000.E03,1.E-09/
	DATA R1,C1,R2,C2 /49.9E03,1.E-06,1000.E03,1.E-09/
	DATA TWOPI /6.2831853/
C	DATA ITERM /3/
	DATA ITERM /-5/
C
C	CALCULATE FREQUENCY LIST
C
	FRAT = 10.**(.05)
	FREQ(1) = .1
	DO N = 2,80
	  NF = N
	  FREQ(N) = FREQ(N-1)*FRAT
	ENDDO
C	PRINT*,'FREQ',NF,' =',FREQ(NF)
	PRINT*,'R1,C1,R2,C2,1ST AMP',R1,C1,R2,C2
C
C	CALCULATE ARRAY 'TRANS' OF TRANSFER FUNCTION IN V/nT
C
	DO N = 1,80
	  TRANS(N) = .29*(FREQ(N)/1000.)
	ENDDO
C	MULTIPLY BY EFFECT OF NEW IOWA INPUT CAPS .1 UF FEEDING 2.04 MEG
C
	DO N = 1,80
	  TRANS(N) = TRANS(N)/SQRT(1. + (.78/FREQ(N))**2)
	ENDDO
C
C	CALCULATE NOISE LEVEL IN nT/SQRT(HZ)
C
	DO N = 1,80
C	  APPROXIMATE NOISE BY A/FREQ + B.  THIS IS TOO HIGH FOR CROSSOVER FREQS
	  PANOIS(N) = 1.8E-05 + 1.0E-04*(40./FREQ(N))
C	  PRINT*,'FREQ,NOISE,NT/RTHZ',FREQ(N),PANOIS(N)
	ENDDO
C
	DO N = 1,6
	  NF = NF+1
	  FREQ(NF) = GFREQ(N)
	  TRANS(NF) = GTR(N)
	  PANOIS(NF) = GPAN(N)*1.E-5
	ENDDO
C
C	CALCULATE TRANSFER FUNCTION (VOLTS/NT) WITH FIRST AMPLIFIER GAIN
C
	F1 = 1./TWOPI/R1/C1                      ! INPUT CORNER FREQ
	F2 = 1./TWOPI/R2/C2			 ! OUTPUT CORNER FREQ
	PRINT*,'1ST AMP CORNER FREQUENCIES',F1,F2
	N = NF
	DO N = 1,NF
	  W = TWOPI*FREQ(N)
	  Z1 = CMPLX(R1,-1./W/C1)
	  Y2 = CMPLX(1./R2,W*C2)
	  Z2 = 1./Y2
	  CGAIN = Z2/Z1
	  GAIN = CABS(CGAIN)
C	  PRINT*,'FREQ,CGAIN,GAIN',FREQ(N),CGAIN,GAIN
	  TRANS(N) = TRANS(N)*GAIN
	ENDDO
C
C	CALCULATE NOISE LEVEL IN V/SQRT(HZ)
C
	PANT = 0.
	PANLOW = 0.
	  N = 1
	  PANOIS(N) = PANOIS(N)*TRANS(N)
	DO N = 2,NF
	  PANOIS(N) = PANOIS(N)*TRANS(N)
	  DNOISE = .5*(FREQ(N)-FREQ(N-1))*(PANOIS(N)+PANOIS(N-1))**2
	  PANT = PANT + DNOISE
	  IF(FREQ(N).LT.170.) PANLOW = PANLOW + DNOISE
	ENDDO
	PANRMS = SQRT(PANT)
	PRINT*,'TOTAL PREAMP NOISE, VOLT**2/HZ',PANT,'  RMS=',PANRMS
	PANRMS = SQRT(PANLOW)
	PRINT*,'PREAMP NOISE LT 170 HZ, VOLT**2/HZ',PANLOW,'  RMS=',PANRMS
	CALL FPLOT
	STOP
	END
	SUBROUTINE PARINT(X1,X0,X2,Y1,Y0,Y2,X,Y)
C
C	PARABOLIC INTERPOLATION ON UNIFORMLY SPACED X
C
	AA = X0
	BB = (Y2 - Y1)/(X2 - X1)
	CC = 2.*(X1 + X2 - 2.*X0)/(X2 - X1)**2
	Y = AA + BB*(X-X0) + CC*(X-X0)**2
	RETURN
	END


subroutine MakeGrid2D(grid, cilm, lmax, interval, py_m, py_n, north, south, east, west, nlat, nlong, norm, csphase, f, a, dealloc)
	use SHTOOLS, only: PlmBar, PlBar, PlmSchmidt, PlSchmidt, PLegendreA, PLegendre, &
				PlmON, PlON, CSPHASE_DEFAULT

	implicit none

	real*8, intent(in)   :: cilm(2,lmax+1,lmax+1), interval
	real*8, intent(out)  :: grid(py_m, py_n)
	integer, intent(in)  :: lmax, py_m, py_n
	real*8, intent(in)   :: north, south, east, west
	integer, intent(out) :: nlat, nlong
	integer, intent(in), optional :: norm, csphase, dealloc
	real*8, intent(in), optional :: f, a

	integer              :: l, m, j, k, index, l1, m1, lmax_comp
	integer              :: temp, astat(4)
	real*8               :: pi, latmax, latmin, longmin, longmax
	real*8               :: lat, longitude, x, intervalrad, r_ref
	real*8, allocatable  ::	pl(:), cosm(:, :), sinm(:, :), cilm2(:,:, :)

	latmax = north
	latmin = south
	longmin = west
	longmax = east

	nlat = (latmax - latmin) / interval + 1
	nlong = (longmax - longmin) / interval + 1

	if ((present(f) .and. .not. present(a)) .or. (present(a) .and. .not. present(f)) ) then
		print*, "Error --- MakeGrid2D"
		print*, "Both F and A must be present"
		print*, "F ", present(f)
		print*, "A ", present(a)
		stop
	endif

	allocate(pl((lmax+1)*(lmax+2)/2), stat = astat(1))
	allocate(cosm(lmax+1, int(360./interval + 1)), stat = astat(2))
	allocate(sinm(lmax+1, int(360./interval + 1)), stat = astat(3))
	allocate(cilm2(2,lmax+1,lmax+1), stat = astat(4))
	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /=0 .or. astat(4) /= 0) then
		print*, "Error --- MakeGrid2D"
		print*, "Problem allocating arrays PL, COSM, SINM, and CILM2", astat(1), astat(2), astat(3), astat(4)
		stop
	endif

	pi = acos(-1.0d0)
	grid = 0.0d0

	lmax_comp = min(lmax, size(cilm(1,1,:))-1)

	intervalrad = interval*pi/180.0d0

	cilm2(1:2,1:lmax+1,1:lmax+1) = cilm(1:2,1:lmax+1,1:lmax+1)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Precomputing sines and cosines leads to an increase in speed by a factor
	!	of almost 4 with no optimization, and by a factor of about 15 with normal
	!	optimizations.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, nlong
		longitude = longmin*pi/180.0d0 + dble(k-1)*intervalrad
		sinm(1,k) = 0.0d0
		cosm(1,k) = 1.0d0
		if (lmax > 0) then
			sinm(2,k) = sin(longitude)
			cosm(2,k) = cos(longitude)
		endif
		do m=2, lmax, 1
			sinm(m+1,k) = 2 * sinm(m,k)*cosm(2,k) - sinm(m-1,k)
			cosm(m+1,k) = 2 * cosm(m,k)*cosm(2,k) - cosm(m-1,k)
		enddo
	enddo

	do j=1, nlat
		lat = latmax - (j-1)*interval
		x = sin(lat*pi/180.0d0)

		if (lat == 90.0d0 .or. lat == -90.0d0) then
			select case(norm)
				case(1); call PlBar(pl, lmax_comp, x)
				case(2); call PlSchmidt(pl, lmax_comp, x)
				case(3); call PLegendre(pl, lmax_comp, x)
				case(4); call PlON(pl, lmax_comp, x)
			end select

			do l = lmax_comp, 0, -1
				l1 = l+1
				grid(j, 1) = grid(j, 1) + cilm2(1, l1, 1) * pl(l1)
			enddo
			grid(j, 2:nlong) = grid(j,1)
			if (present(f)) grid(j,1:nlong) = grid(j,1:nlong) - a*(1.0d0-f)
		else
			select case(norm)
				case(1); call PlmBar(pl, lmax_comp, x, csphase = csphase)
				case(2); call PlmSchmidt(pl, lmax_comp, x, csphase = csphase)
				case(3); call PLegendreA(pl, lmax_comp, x, csphase = csphase)
				case(4); call PlmON(pl, lmax_comp, x, csphase = csphase)
			end select

			do k = 1, nlong
				! do m = 0 term first
				m1 = 1
				do l=0, lmax_comp, 1
					l1 = l+1
					index = (l+1)*l/2 + 1
					grid(j,k) = grid(j,k) + cilm2(1,l1,1)*cosm(1,k) * pl(index)
				enddo

				do m=1, lmax_comp, 1
					m1 = m+1
					do l=m, lmax_comp, 1
						l1 = l+1
						index = (l+1)*l/2 + m + 1
						grid(j,k) = grid(j,k) + ( cilm2(1,l1,m1)*cosm(m1,k) + &
							cilm2(2,l1,m1)*sinm(m1,k) ) * pl(index)
					enddo
				enddo
			enddo

			if (present(f)) then
				r_ref = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
					(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
				r_ref = sqrt(r_ref)
				grid(j,1:nlong) = grid(j,1:nlong) - r_ref
			endif
		endif
	enddo

	! deallocate memory
	if (present(dealloc)) then
		if (dealloc == 1) then
			select case(norm)
				case(1); call PlmBar(pl, -1, x, csphase = csphase)
				case(2); call PlmSchmidt(pl, -1, x, csphase = csphase)
				case(4); call PlmON(pl, -1, x, csphase = csphase)
			end select
		endif
	endif

	deallocate(pl)
	deallocate(cosm)
	deallocate(sinm)
	deallocate(cilm2)
end subroutine MakeGrid2D


module measures

   use sparse, only: eigen
   use data_struct
   use density_matrix, only: thermal_Mrho

   private
   public:: EnergyGap, FisherQ, Mean0, Var0, Fluct, DensityCorrelation, InverseMean0

   interface Mean0
      module procedure :: vec_Mean0
      module procedure :: rhoM_Mean0
      module procedure :: rho_Mean0
   end interface

   interface InverseMean0
      module procedure :: rhoM_InverseMean0
   end interface

   interface FisherQ
      module procedure :: vec_FisherQ
      module procedure :: Mrho_FisherQ
      module procedure :: rho_FisherQ
   end interface

   interface Fluct
      module procedure :: vec_Fluct
      module procedure :: Mrho_Fluct
      module procedure :: rho_Fluct
   end interface

   contains

   function EnergyGap( A, maxiter, ncv )

      implicit none
      type( dcsr3 ), intent(in) :: A
      integer, optional :: maxiter, ncv
      double precision EnergyGap

      ! local variables
      double precision, allocatable :: eigval(:), eigvec(:,:)

      if( present(maxiter) ) then
         if( present(ncv) ) then
            call eigen( A, eigval, eigvec, 2, 'SA', op_maxiter=maxiter, op_ncv=ncv )
         else
            call eigen( A, eigval, eigvec, 2, 'SA', op_maxiter=maxiter )
         endif
      else
         if( present(ncv) ) then
            call eigen( A, eigval, eigvec, 2, 'SA', op_ncv=ncv )
         else
            call eigen( A, eigval, eigvec, 2, 'SA' )
         endif
      endif

      EnergyGap = abs( eigval(2) - eigval(1) )

   end function

   function vec_Mean0( vec, N, M ) result(Mean0)

      implicit none
      double precision, intent(in) :: vec(:)
      integer, intent(in) :: N, M
      double precision :: Mean0

      ! Local variables
      integer kmin, kmax, k, i

      Mean0 = 0.d0

      ! Even magnetization case
      if( modulo(M, 2) .eq. 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            ! index shift
            i = k-kmin+1
            Mean0 = Mean0 + ( dble(N) - 2.d0*dble(k) ) * vec(i)**2

         enddo

      else

         call OddBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            i = k-kmin+1
            Mean0 = Mean0 + ( dble(N) - 2.d0*dble(k) - 1.d0 ) * vec(i)**2

         enddo

      endif

   end function

   function rhoM_Mean0( rhoin, N, M ) result( Mean0 )

      implicit none
      type( Mrho ), intent(in) :: rhoin
      integer, intent(in) :: N, M
      double precision :: Mean0

      ! local variables
      integer idx, i, k ,kmin, kmax

      Mean0 = 0.d0

      ! Even magnetization case
      if( modulo(M,2) == 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         ! loop over eigenvectors
         do idx = 1, size( rhoin%eigval )
            do k = kmin, kmax
               i = k-kmin+1
               Mean0 = Mean0 + rhoin%eigval(idx) * ( dble(N) - 2.d0*dble(k) ) * rhoin%eigvec(i,idx)**2
            enddo
         enddo

      ! Odd magnetization case
      else

         call OddBounds( N, M, kmin, kmax )

         ! loop over eigenvectors
         do idx = 1, size( rhoin%eigval )
            do k = kmin, kmax
               i = k-kmin+1
               Mean0 = Mean0 + rhoin%eigval(idx) * ( dble(N) - 2.d0*dble(k) - 1.d0 ) * rhoin%eigvec(i,idx)**2
            enddo
         enddo

      endif

   end function

   function rho_Mean0( rhoin, N ) result( Mean0 )

      implicit none
      type( rho ), intent(in) :: rhoin
      integer, intent(in) :: N
      double precision :: Mean0

      ! local variables
      integer M, i, idx, k, kmin, kmax

      Mean0 = 0.d0

      ! loop over magnetizations
      do M = -N, N

         ! even magnetization case
         if( modulo(M,2) == 0 ) then

            call EvenBounds( N, M, kmin, kmax )

            ! loop over eigenvectors
            do idx = 1, size( rhoin%array(abs(M))%eigval )
               do k = kmin, kmax
                  i = k-kmin+1
                  Mean0 = Mean0 + rhoin%array(abs(M))%eigval(idx) * ( dble(N) - 2.d0 * dble(k) ) * &
                                  rhoin%array(abs(M))%eigvec(i,idx)**2
               enddo
            enddo

         ! Odd magnetization case
         else

            call OddBounds( N, M, kmin, kmax )

            ! loop over eigenvectors
            do idx = 1, size( rhoin%array(abs(M))%eigval )
               do k = kmin, kmax
                  i = k-kmin+1
                  Mean0 = Mean0 + rhoin%array(abs(M))%eigval(idx) * ( dble(N) - 2.d0 * dble(k) - 1.d0 ) * &
                                  rhoin%array(abs(M))%eigvec(i,idx)**2
               enddo
            enddo

         endif

      enddo

   end function

   subroutine rhoM_InverseMean0( rhoin, N, M, c, beta, n0, q )

      implicit none
      type( Mrho ), intent(inout) :: rhoin
      integer, intent(in) :: N, M
      double precision, intent(in) :: c, beta, n0
      double precision, intent(out) :: q

      ! local variables
      double precision :: a, b, d, fa, fb, fd
      double precision :: n0max, n0min
      integer :: kmin, kmax
      double precision, parameter :: eps = 1.d-08

      ! maximal and minimal values
      if( modulo(M,2) == 0 ) then
         call EvenBounds( N, M, kmin, kmax )
         n0max = 1.d0 - 2.d0 * dble(kmin)/dble(N)
         n0min = 1.d0 - 2.d0 * dble(kmax)/dble(N)
      else
         call OddBounds( N, M, kmin, kmax )
         n0max = 1.d0 - 2.d0 * dble(kmin)/dble(N) - 1.d0/dble(N)
         n0min = 1.d0 - 2.d0 * dble(kmax)/dble(N) - 1.d0/dble(N)
      endif

      if( n0 > n0max .or. n0 < n0min ) then
         print *, 'Incorrect n0 value'
         q = 0.d0
      else
         ! search for initial conditions
         ! fa * fb < 0.d0
         a = 1.d+03
         b = -1.d+03

         rhoin = thermal_Mrho( N, M, c, a, beta )
         fa    = Mean0( rhoin, N, M ) - N * n0
         rhoin = thermal_Mrho( N, M, c, b, beta )
         fb    = Mean0( rhoin, N, M ) - N * n0

         do while( fa * fb > 0.d0 )
            ! bad starting conditions
            a = 2.d0 * a
            b = 2.d0 * b

            rhoin = thermal_Mrho( N, M, c, a, beta )
            fa    = Mean0( rhoin, N, M ) - N * n0
            rhoin = thermal_Mrho( N, M, c, b, beta )
            fb    = Mean0( rhoin, N, M ) - N * n0
         enddo

         if( fa == 0.d0 ) then
            q = a
         elseif( fb == 0.d0 ) then
            q = b
         else
            ! search for 0 with bisection
            do while( .true. )
               d = (a+b)/2.d0
               rhoin = thermal_Mrho( N, M, c, d, beta )
               fd    = Mean0( rhoin, N, M ) - n0 * N

               if( fa * fd < 0.d0 ) then
                  b  = d
                  fb = fd
               else
                  a  = d
                  fa = fd
               endif

               ! stop condition
               if( abs(fd) < eps) then
                  q = d
                  exit
               endif
            enddo
         endif
      endif

   end subroutine

   function Var0( vec, N, M )

      implicit none
      double precision, intent(in) :: vec(:)
      integer, intent(in) :: N, M
      double precision :: Var0

      ! Local variables
      double precision sumn, sumn2
      integer kmin, kmax, k, i

      sumn = 0.d0; sumn2 = 0.d0

      ! Even magnetization case
      if( modulo(M, 2) .eq. 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            ! index shift
            i = k-kmin+1
            sumn  = sumn  + ( dble(N) - 2.d0*dble(k) ) * vec(i)**2
            sumn2 = sumn2 + ( dble(N) - 2.d0*dble(k) )**2 * vec(i)**2

         enddo

      else

         call OddBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            i = k-kmin+1
            sumn  = sumn  + ( dble(N) - 2.d0*dble(k) - 1.d0 ) * vec(i)**2
            sumn2 = sumn2 + ( dble(N) - 2.d0*dble(k) - 1.d0 )**2 * vec(i)**2

         enddo

      endif

      Var0 = sumn2 - sumn**2

   end function

   function DensityCorrelation( vec, N, M ) result( vout )

      implicit none
      double precision, intent(in) :: vec(:)
      integer, intent(in) :: N, M
      double precision :: vout(3,3)

      ! Local variables
      double precision sumP, sum0, sumM, sumPP, sumP0, sumPM, sum00, sum0M, sumMM
      integer kmin, kmax, k, i

      sumP = 0.d0
      sum0 = 0.d0
      sumM = 0.d0
      sumPP = 0.d0
      sumP0 = 0.d0
      sumPM = 0.d0
      sum00 = 0.d0
      sum0M = 0.d0
      sumMM = 0.d0

      ! Even magnetization case
      if( modulo(M, 2) .eq. 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            ! index shift
            i = k-kmin+1
            sumP = sumP + ( dble(k) + dble(M/2) ) * vec(i)**2
            sum0 = sum0 + ( dble(N) - 2.d0*dble(k) ) * vec(i)**2
            sumM = sumM + ( dble(k) - dble(M/2) ) * vec(i)**2
            sumPP = sumPP + ( dble(k) + dble(M/2) )**2 * vec(i)**2
            sumP0 = sumP0 + ( dble(k) + dble(M/2) ) * ( dble(N) - 2.d0*dble(k) ) * vec(i)**2
            sumPM = sumPM + ( dble(k) + dble(M/2) ) * ( dble(k) - dble(M/2) ) * vec(i)**2
            sum00 = sum00 + ( dble(N) - 2.d0*dble(k) )**2 * vec(i)**2
            sum0M = sum0M + ( dble(N) - 2.d0*dble(k) ) * ( dble(k) - dble(M/2) ) * vec(i)**2
            sumMM = sumMM + ( dble(k) - dble(M/2) )**2 * vec(i)**2

         enddo

      else

         call OddBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            i = k-kmin+1
            sumP = sumP + ( dble(k) + dble((M+1)/2) ) * vec(i)**2
            sum0 = sum0 + ( dble(N) - 2.d0*dble(k) - 1.d0 ) * vec(i)**2
            sumM = sumM + ( dble(k) - dble((M-1)/2) ) * vec(i)**2
            sumPP = sumPP + ( dble(k) + dble((M+1)/2) )**2 * vec(i)**2
            sumP0 = sumP0 + ( dble(k) + dble((M+1)/2) ) * ( dble(N) - 2.d0*dble(k) - 1.d0 ) * vec(i)**2
            sumPM = sumPM + ( dble(k) + dble((M+1)/2) ) * ( dble(k) - dble((M-1)/2) ) * vec(i)**2
            sum00 = sum00 + ( dble(N) - 2.d0*dble(k) - 1.d0 )**2 * vec(i)**2
            sum0M = sum0M + ( dble(N) - 2.d0*dble(k) - 1.d0 ) * ( dble(k) - dble((M-1)/2) ) * vec(i)**2
            sumMM = sumMM + ( dble(k) - dble((M-1)/2) )**2 * vec(i)**2

         enddo

      endif

      vout(1,1) = sumPP - sumP**2
      vout(1,2) = sumP0 - sumP*sum0; vout(2,1) = sumP0 - sumP*sum0
      vout(1,3) = sumPM - sumP*sumM; vout(3,1) = sumPM - sumP*sumM
      vout(2,2) = sum00 - sum0**2
      vout(2,3) = sum0M - sum0*sumM; vout(3,2) = sum0M - sum0*sumM
      vout(3,3) = sumMM - sumM**2

   end function

   ! ----------------------------------------------------
   ! Return covariance matrix for pure states defined
   ! within subspace of fixed magnetization
   ! ----------------------------------------------------
   function vec_Covariance( vec, N, M ) result (cov)

      implicit none
      double precision, intent(in) :: vec(:)
      integer, intent(in) :: N, M
      double precision :: cov(8,8)

      ! local variables
      double precision sumP, sum0, sumM, sumPM, sumP0, sum0M, sumPM00
      double precision sumPP, sum00, sumMM
      integer k, kmin, kmax, i

      sumP  = 0.d0
      sum0  = 0.d0
      sumM  = 0.d0
      sumPP = 0.d0
      sumMM = 0.d0
      sum00 = 0.d0
      sumPM = 0.d0
      sumP0 = 0.d0
      sum0M = 0.d0
      sumPM00 = 0.d0

      ! Even magnetization case
      if( modulo(M, 2) .eq. 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            ! index shift
            i = k-kmin+1

            sumP  = sumP + ( dble(k + M/2) ) * vec(i)**2
            sum0  = sum0 + ( dble(N - 2*k) ) * vec(i)**2
            sumM  = sumM + ( dble(k - M/2) ) * vec(i)**2
            sumPP = sumPP + ( dble(k + M/2)**2 ) * vec(i)**2
            sum00 = sum00 + ( dble(N - 2*k)**2 ) * vec(i)**2
            sumMM = sumMM + ( dble(k - M/2)**2 ) * vec(i)**2
            sumPM = sumPM + ( dble(k + M/2) * dble(k - M/2) ) * vec(i)**2
            sumP0 = sumP0 + ( dble(k + M/2) * dble(N - 2*k) ) * vec(i)**2
            sum0M = sum0M + ( dble(N - 2*k) * dble(k - M/2) ) * vec(i)**2

            if( k < kmax )  then
               sumPM00 = sumPM00 + SQRT( ( dble(k+1+M/2) ) * ( dble(k+1-M/2) ) *&
                         ( dble(N-2*k) ) * ( dble(N-2*k-1) ) ) * vec(i+1) * vec(i)
            endif

         enddo

      else

         call OddBounds( N, M, kmin, kmax )

         do k=kmin, kmax

            i = k-kmin+1

            sumP  = sumP + ( dble(k + (M-1)/2) ) * vec(i)**2
            sum0  = sum0 + ( dble(N - 2*k - 1) ) * vec(i)**2
            sumM  = sumM + ( dble(k - (M+1)/2) ) * vec(i)**2
            sumPP = sumPP + ( dble(k + (M-1)/2)**2 ) * vec(i)**2
            sum00 = sum00 + ( dble(N - 2*k - 1)**2 ) * vec(i)**2
            sumMM = sumMM + ( dble(k - (M+1)/2)**2 ) * vec(i)**2
            sumPM = sumPM + ( dble(k + (M-1)/2) * dble(k - (M+1)/2) ) * vec(i)**2
            sumP0 = sumP0 + ( dble(k + (M-1)/2) * dble(N - 2*k - 1) ) * vec(i)**2
            sum0M = sum0M + ( dble(N - 2*k - 1) * dble(k - (M+1)/2) ) * vec(i)**2

            if( k < kmax )  then
               sumPM00 = sumPM00 + SQRT( ( dble(k+1+(M-1)/2) ) * ( dble(k+1-(M+1)/2) ) *&
                         ( dble(N-2*k-1) ) * ( dble(N-2*k-2) ) ) * vec(i+1) * vec(i)
            endif

         enddo

      endif

      ! put values into the covariance matrix
      cov = 0.d0

      ! Lam = {jx, jy, jz, qxy, qyz, qzx, dxy, y}
      ! ---------------------------------------------------
      ! (1,1)
      cov(1,1) = 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M + 4.d0*sumPM00 + 2.d0*sumP0 )
      ! (1,2)
      ! (1,3)
      ! (1,4)
      ! (1,5)
      ! (1,6)
      cov(1,6) = 0.5d0 * ( -sumM + sumP - 2.d0*sum0M + 2.d0*sumP0 )
      ! (1,7)
      ! (1,8)
      ! ---------------------------------------------------
      ! (2,2)
      cov(2,2) = 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M + 4.d0*sumPM00 + 2.d0*sumP0 )
      ! (2,3)
      ! (2,4)
      ! (2,5)
      cov(2,5) = 0.5d0 * ( -sumM + sumP - 2.d0*sum0M + 2.d0*sumP0 )
      ! (2,6)
      ! (2,7)
      ! (2,8)
      ! ---------------------------------------------------
      ! (3,3)
      cov(3,3) = sumPP + sumMM - 2.d0*sumPM - (sumP - sumM)**2
      ! (3,4)
      ! (3,5)
      ! (3,6)
      ! (3,7)
      ! (3,8)
      cov(3,8) = 1.d0/sqrt(3.d0)*( sumPP - sumMM - 2.d0*sumP0 + 2.d0*sum0M )-&
               1.d0/sqrt(3.d0)*(sumP - sumM)*(sumP - 2.d0*sum0 + sumM)
      ! ---------------------------------------------------
      ! (4,4)
      cov(4,4) = sumM + sumP + 2.d0*sumPM
      ! (4,5)
      ! (4,6)
      ! (4,7)
      ! (4,8)
      ! ---------------------------------------------------
      ! (5,5)
      cov(5,5) = 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M - 4.d0*sumPM00 + 2.d0*sumP0 )
      ! (5,6)
      ! (5,7)
      ! (5,8)
      ! ---------------------------------------------------
      ! (6,6)
      cov(6,6) = 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M - 4.d0*sumPM00 + 2.d0*sumP0 )
      ! (6,7)
      ! (6,8)
      ! ---------------------------------------------------
      ! (7,7)
      cov(7,7) = sumM  + sumP + 2.d0*sumPM
      ! (7,8)
      ! ---------------------------------------------------
      ! (8,8)
      cov(8,8) = 1.d0/3.d0*( sumPP + 4.d0*sum00 + sumMM - 4.d0*sumP0 - 4.d0*sum0M + 2.d0*sumPM )-&
               1.d0/3.d0*(sumP - 2.d0*sum0 + sumM)**2

   end function

   ! ---------------------------------------------------
   ! Optimal quantum Fisher information for pure state
   ! defined within fixed magnetization subspace
   ! --------------------------------------------------
   function vec_FisherQ( vec, N, M ) result(res)

      implicit none
      double precision, intent(in) :: vec(:)
      integer, intent(in) :: N, M
      type( fis ) :: res

      ! for lapack diagonalization
      integer, parameter :: nn = 8
      integer, parameter :: lda = 8
      integer info, lwork
      double precision a(lda, nn), w(nn)
      double precision :: work(100)

      a = vec_Covariance( vec, N, M )

      ! query the optimal workspace
      lwork = -1
      call DSYEV( 'V', 'U', nn, a, lda, w, work, lwork, info )
      lwork = int( work(1) )

      ! solve eigenvalue
      call DSYEV( 'V', 'U', nn, a, lda, w, work, lwork, info )

      res%val = w(8)/dble(N)**2
      res%dir = a(:,8)

   end function

   ! -----------------------------------------------
   ! Covariance matrix for mixed state defined
   ! within space of fixed magentization
   ! -----------------------------------------------
   function Mrho_Covariance( rhoin, N, M ) result(cov)

      implicit none
      type( Mrho ), intent(in) :: rhoin
      integer, intent(in) :: N, M
      real( kind=dp ) :: cov(8,8)

      ! local variables
      double precision sumP, sum0, sumM, sumPM, sumP0, sum0M, sumPM00
      double precision sumPP, sum00, sumMM
      double precision sumJz2, sumY2, sumJzY, sumJz, sumY
      real( kind=dp ) prob, probt
      integer k, kmin, kmax, i, idx, idxi, idxj

      ! flush covariance matrix
      cov(:,:) = 0.0_dp

      ! ====================================================================
      !                     Even magnetization case
      ! ====================================================================
      if( modulo(M, 2) .eq. 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         ! ===================================
         ! Diagonal part of covariance matrix
         ! ===================================
         do idx = 1, size( rhoin%eigval )

            prob = rhoin%eigval(idx)

            if( prob > 0.0_dp ) then

               sumP  = 0.d0
               sum0  = 0.d0
               sumM  = 0.d0
               sumPP = 0.d0
               sumMM = 0.d0
               sum00 = 0.d0
               sumPM = 0.d0
               sumP0 = 0.d0
               sum0M = 0.d0
               sumPM00 = 0.d0

               do k=kmin, kmax

                  ! index shift
                  i = k-kmin+1

                  sumP  = sumP + ( dble(k + M/2) ) * rhoin%eigvec(i,idx)**2
                  sum0  = sum0 + ( dble(N - 2*k) ) * rhoin%eigvec(i,idx)**2
                  sumM  = sumM + ( dble(k - M/2) ) * rhoin%eigvec(i,idx)**2
                  sumPP = sumPP + ( dble(k + M/2)**2 ) * rhoin%eigvec(i,idx)**2
                  sum00 = sum00 + ( dble(N - 2*k)**2 ) * rhoin%eigvec(i,idx)**2
                  sumMM = sumMM + ( dble(k - M/2)**2 ) * rhoin%eigvec(i,idx)**2
                  sumPM = sumPM + ( dble(k + M/2) * dble(k - M/2) ) * rhoin%eigvec(i,idx)**2
                  sumP0 = sumP0 + ( dble(k + M/2) * dble(N - 2*k) ) * rhoin%eigvec(i,idx)**2
                  sum0M = sum0M + ( dble(N - 2*k) * dble(k - M/2) ) * rhoin%eigvec(i,idx)**2

                  if( k < kmax )  then
                     sumPM00 = sumPM00 + SQRT( ( dble(k+1+M/2) ) * ( dble(k+1-M/2) ) *&
                               ( dble(N-2*k) ) * ( dble(N-2*k-1) ) ) * rhoin%eigvec(i+1,idx) * rhoin%eigvec(i,idx)
                  endif

               enddo

               ! put values into the covariance matrix
               ! Lam = {jx, jy, jz, qxy, qyz, qzx, dxy, y}
               ! ---------------------------------------------------
               cov(1,1) = cov(1,1) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M + 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(1,6) = cov(1,6) + prob * 0.5d0 * ( -sumM + sumP - 2.d0*sum0M + 2.d0*sumP0 )
               cov(2,2) = cov(2,2) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M + 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(2,5) = cov(2,5) + prob * 0.5d0 * ( -sumM + sumP - 2.d0*sum0M + 2.d0*sumP0 )
               cov(3,3) = cov(3,3) + prob * ( sumPP + sumMM - 2.d0*sumPM - (sumP - sumM)**2 )
               cov(3,8) = cov(3,8) + prob * ( 1.d0/sqrt(3.d0)*( sumPP - sumMM - 2.d0*sumP0 + 2.d0*sum0M )-&
                        1.d0/sqrt(3.d0)*(sumP - sumM)*(sumP - 2.d0*sum0 + sumM) )
               cov(4,4) = cov(4,4) + prob * ( sumM + sumP + 2.d0*sumPM )
               cov(5,5) = cov(5,5) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M - 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(6,6) = cov(6,6) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M - 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(7,7) = cov(7,7) + prob * ( sumM  + sumP + 2.d0*sumPM )
               cov(8,8) = cov(8,8) + prob * ( 1.d0/3.d0*( sumPP + 4.d0*sum00 + sumMM - 4.d0*sumP0 - 4.d0*sum0M + 2.d0*sumPM )-&
                        1.d0/3.d0*(sumP - 2.d0*sum0 + sumM)**2 )

            endif

         enddo

         ! =======================================
         ! Off-diagonal part of covariance matrix
         ! =======================================
         sumJz2 = 0.0d0
         sumY2  = 0.0d0
         sumJzY = 0.0d0

         do idxi = 1, size( rhoin%eigval )

            do idxj = idxi+1, size( rhoin%eigval )

               prob  = rhoin%eigval(idxi) + rhoin%eigval(idxj)

               if( prob > 0.d0 ) then

                  probt = rhoin%eigval(idxi) * rhoin%eigval(idxj) / prob

                  sumJz = 0.d0
                  sumY  = 0.d0

                  do k=kmin, kmax

                     ! index shift
                     i = k-kmin+1

                     sumJz = sumJz + dble(M) * rhoin%eigvec(i,idxi) * rhoin%eigvec(i,idxj)
                     sumY  = sumY + 2.d0/sqrt(3.d0) * dble(3*k-N) * rhoin%eigvec(i,idxi) * rhoin%eigvec(i,idxj)

                  enddo

                  sumJz2 = sumJz2 + 4.d0 * probt * ( sumJz * sumJz )
                  sumY2  = sumY2  + 4.d0 * probt * ( sumY * sumY )
                  sumJzY = sumJzY + 4.d0 * probt * ( sumJz * sumY )

               endif

            enddo
         enddo

         cov(3,3) = cov(3,3) - sumJz2
         cov(8,8) = cov(8,8) - sumY2
         cov(3,8) = cov(3,8) - sumJzY

      ! =======================================================================
      !                      Odd Magnetization case
      ! =======================================================================
      else

         call OddBounds( N, M, kmin, kmax )

         ! ===================================
         ! Diagonal part of covariance matrix
         ! ===================================
         do idx = 1, size( rhoin%eigval )

            prob = rhoin%eigval(idx)

            if( prob > 0.0_dp ) then

               sumP  = 0.d0
               sum0  = 0.d0
               sumM  = 0.d0
               sumPP = 0.d0
               sumMM = 0.d0
               sum00 = 0.d0
               sumPM = 0.d0
               sumP0 = 0.d0
               sum0M = 0.d0
               sumPM00 = 0.d0

               do k=kmin, kmax

                  i = k-kmin+1

                  sumP  = sumP + ( dble(k + (M-1)/2) ) * rhoin%eigvec(i,idx)**2
                  sum0  = sum0 + ( dble(N - 2*k - 1) ) * rhoin%eigvec(i,idx)**2
                  sumM  = sumM + ( dble(k - (M+1)/2) ) * rhoin%eigvec(i,idx)**2
                  sumPP = sumPP + ( dble(k + (M-1)/2)**2 ) * rhoin%eigvec(i,idx)**2
                  sum00 = sum00 + ( dble(N - 2*k - 1)**2 ) * rhoin%eigvec(i,idx)**2
                  sumMM = sumMM + ( dble(k - (M+1)/2)**2 ) * rhoin%eigvec(i,idx)**2
                  sumPM = sumPM + ( dble(k + (M-1)/2) * dble(k - (M+1)/2) ) * rhoin%eigvec(i,idx)**2
                  sumP0 = sumP0 + ( dble(k + (M-1)/2) * dble(N - 2*k - 1) ) * rhoin%eigvec(i,idx)**2
                  sum0M = sum0M + ( dble(N - 2*k - 1) * dble(k - (M+1)/2) ) * rhoin%eigvec(i,idx)**2

                  if( k < kmax )  then
                     sumPM00 = sumPM00 + SQRT( ( dble(k+1+(M-1)/2) ) * ( dble(k+1-(M+1)/2) ) *&
                               ( dble(N-2*k-1) ) * ( dble(N-2*k-2) ) ) * rhoin%eigvec(i+1,idx) * rhoin%eigvec(i,idx)
                  endif

               enddo

               ! put values into the covariance matrix
               ! Lam = {jx, jy, jz, qxy, qyz, qzx, dxy, y}
               ! ---------------------------------------------------
               cov(1,1) = cov(1,1) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M + 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(1,6) = cov(1,6) + prob * 0.5d0 * ( -sumM + sumP - 2.d0*sum0M + 2.d0*sumP0 )
               cov(2,2) = cov(2,2) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M + 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(2,5) = cov(2,5) + prob * 0.5d0 * ( -sumM + sumP - 2.d0*sum0M + 2.d0*sumP0 )
               cov(3,3) = cov(3,3) + prob * ( sumPP + sumMM - 2.d0*sumPM - (sumP - sumM)**2 )
               cov(3,8) = cov(3,8) + prob * ( 1.d0/sqrt(3.d0)*( sumPP - sumMM - 2.d0*sumP0 + 2.d0*sum0M )-&
                        1.d0/sqrt(3.d0)*(sumP - sumM)*(sumP - 2.d0*sum0 + sumM) )
               cov(4,4) = cov(4,4) + prob * ( sumM + sumP + 2.d0*sumPM )
               cov(5,5) = cov(5,5) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M - 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(6,6) = cov(6,6) + prob * 0.5d0 * ( sumM + 2.d0*sum0 + sumP + 2.d0*sum0M - 4.d0*sumPM00 + 2.d0*sumP0 )
               cov(7,7) = cov(7,7) + prob * ( sumM  + sumP + 2.d0*sumPM )
               cov(8,8) = cov(8,8) + prob * ( 1.d0/3.d0*( sumPP + 4.d0*sum00 + sumMM - 4.d0*sumP0 - 4.d0*sum0M + 2.d0*sumPM )-&
                        1.d0/3.d0*(sumP - 2.d0*sum0 + sumM)**2 )

            endif

         enddo

         ! =======================================
         ! Off-diagonal part of covariance matrix
         ! =======================================
         sumJz2 = 0.0d0
         sumY2  = 0.0d0
         sumJzY = 0.0d0

         do idxi = 1, size( rhoin%eigval )

            do idxj = idxi+1, size( rhoin%eigval )

               prob  = rhoin%eigval(idxi) + rhoin%eigval(idxj)

               if( prob > 0.0_dp ) then

                  probt = rhoin%eigval(idxi) * rhoin%eigval(idxj) / prob

                  sumJz = 0.d0
                  sumY = 0.d0

                  do k=kmin, kmax

                     ! index shift
                     i = k-kmin+1

                     sumJz = sumJz + dble(M) * rhoin%eigvec(i,idxi) * rhoin%eigvec(i,idxj)
                     sumY  = sumY + 2.d0/sqrt(3.d0) * dble(3*k-N+1) * rhoin%eigvec(i,idxi) * rhoin%eigvec(i,idxj)

                  enddo

                  sumJz2 = sumJz2 + 4.d0 * probt * ( sumJz * sumJz )
                  sumY2  = sumY2 +  4.d0 * probt * ( sumY * sumY )
                  sumJzY = sumJzY + 4.d0 * probt * ( sumJz * sumY )

               endif

            enddo
         enddo

         cov(3,3) = cov(3,3) - sumJz2
         cov(8,8) = cov(8,8) - sumY2
         cov(3,8) = cov(3,8) - sumJzY

      endif

   end function

   ! -----------------------------------------------
   !  Optimal Fisher information for thermal state
   !     within fixed magnetization subspace
   ! -----------------------------------------------
   function Mrho_FisherQ( rhoin, N, M ) result (res)

      implicit none
      type( Mrho ), intent(in) :: rhoin
      integer, intent(in) :: N, M
      type( fis ) :: res

      ! for lapack diagonalization
      integer, parameter :: nn = 8
      integer, parameter :: lda = 8
      integer info, lwork
      double precision a(lda, nn), w(nn)
      double precision :: work(100)

      a = dble( Mrho_Covariance( rhoin, N, M ) )

      ! ======================================
      ! Diagonalizationo of covariance matrix
      ! ======================================

      ! query the optimal workspace
      lwork = -1
      call DSYEV( 'V', 'U', nn, a, lda, w, work, lwork, info )
      lwork = int( work(1) )

      ! solve eigenvalue
      call DSYEV( 'V', 'U', nn, a, lda, w, work, lwork, info )

      res%val = w(8)/dble(N)**2
      res%dir = a(:,8)

   end function

   ! -----------------------------------------------
   !  Optimal Fisher information for thermal state
   !     with fluctuating magnetization
   ! -----------------------------------------------
   function rho_FisherQ( rhoin, N ) result (res)

      implicit none
      type( rho ), intent(in) :: rhoin
      integer, intent(in) :: N
      type( fis ) :: res

      ! for lapack diagonalization
      integer, parameter :: nn = 8
      integer, parameter :: lda = 8
      integer info, lwork
      double precision a(lda, nn), w(nn)
      double precision :: work(100)

      a = dble( rho_Covariance( rhoin, N ) )

      ! ======================================
      ! Diagonalizationo of covariance matrix
      ! ======================================

      ! query the optimal workspace
      lwork = -1
      call DSYEV( 'V', 'U', nn, a, lda, w, work, lwork, info )
      lwork = int( work(1) )

      ! solve eigenvalue
      call DSYEV( 'V', 'U', nn, a, lda, w, work, lwork, info )

      res%val = w(8)/dble(N)**2
      res%dir = a(:,8)

   end function

   ! new covarince matrix
   function rho_Covariance( rhoin, N ) result(cov)

      implicit none
      type( rho ), intent(in) :: rhoin
      integer, intent(in) :: N
      real( kind=dp ) :: cov(8,8)

      ! local variables
      double precision sumMP, sum0P, sumM0, sumYY, sum_test, pp, qq
      integer k, kmin, kmax, i, idx, idxi, idxj, pmin, pmax, lmin, lmax, p, zmin, zmax
      integer M, Mp, Mpp
      real( kind=dp ) p1, p2, probt

      ! flush covariance matrix
      cov(:,:) = 0.0_dp

      ! loop over magnetizations
      do M = -N, N

         Mp  = M + 1  ! connecting subspace M -> Mp
         Mpp = M + 2  ! connecting subspace M -> Mpp

         if( modulo(M,2) == 0 ) then
            call EvenBounds( N, M, kmin, kmax )
            call OddBounds( N, Mp, lmin, lmax )
            call EvenBounds( N, Mpp, zmin, zmax )
         else
            call OddBounds( N, M, kmin, kmax )
            call EvenBounds( N, Mp, lmin, lmax )
            call OddBounds( N, Mpp, zmin, zmax )
         endif

         ! loop over eigenvectors
         do idxi = 1, size( rhoin%array(abs(M))%eigval )

            ! --------------------------------------------------------
            ! Loop for operator Y within the same magnetization block
            ! --------------------------------------------------------
            do idxj = idxi+1, size( rhoin%array(abs(M))%eigval )

               p1 = rhoin%array(abs(M))%eigval(idxi) * rhoin%weights(M)
               p2 = rhoin%array(abs(M))%eigval(idxj) * rhoin%weights(M)

               if( p1 + p2 > 0.d0 ) then

                  probt = ((p1 - p2)**2)/(p1 + p2)

                  sumYY = 0.d0

                  do k = kmin, kmax

                     ! index shift
                     i = k-kmin+1

                     sumYY = sumYY + dble(k) * rhoin%array(abs(M))%eigvec(i,idxi) * rhoin%array(abs(M))%eigvec(i,idxj)

                  enddo! k

                  sumYY = sumYY * 6.d0/sqrt(3.d0)

                  cov(8,8) = cov(8,8) + probt * sumYY**2

               endif

            enddo! idxj

            ! --------------------------------------------------------------
            ! Other operators changing magnetization
            ! --------------------------------------------------------------
            if( Mp <= N ) then

               sum_test = 0.0d0
               ! connecting M with Mp
               do idxj = 1, size( rhoin%array(abs(Mp))%eigval )

                  p1 = rhoin%array(abs(M))%eigval(idxi) * rhoin%weights(M)
                  p2 = rhoin%array(abs(Mp))%eigval(idxj) * rhoin%weights(Mp)

                  if( p1 + p2 > 0.0d0 ) then

                     probt = ((p1 - p2)**2)/(p1 + p2)
                     ! ========================
                     ! Even magnetization case
                     ! ========================
                     if( modulo(M,2) == 0 ) then

                        sum0P = 0.d0

                        pmin = max( kmin, lmin )
                        pmax = min( kmax, lmax )

                        do p = pmin, pmax
                           sum0P = sum0P + rhoin%array(abs(Mp))%eigvec(p-lmin+1,idxj) * rhoin%array(abs(M))%eigvec(p-kmin+1,idxi) *&
                                           SQRT( dble(p + M/2 + 1) * dble(N - 2*p))
                        enddo !p

                        sumM0 = 0.d0

                        pmin = max( kmin, lmin+1 )
                        pmax = min( kmax, lmax+1 )

                        do p = pmin, pmax
                           sumM0 = sumM0 + rhoin%array(abs(Mp))%eigvec(p-lmin,idxj) * rhoin%array(abs(M))%eigvec(p-kmin+1,idxi) *&
                                           SQRT( dble(N - 2*p + 1) * dble(p - M/2) )
                        enddo !p

                     ! =======================
                     ! Odd magnetization case
                     ! =======================
                     else

                        sum0P = 0.d0

                        pmin = max( kmin, lmin-1 )
                        pmax = min( kmax, lmax-1 )

                        do p = pmin, pmax
                           sum0P = sum0P + rhoin%array(abs(Mp))%eigvec(p-lmin+2,idxj) * rhoin%array(abs(M))%eigvec(p-kmin+1,idxi) *&
                                           SQRT( dble(p + (M+1)/2 + 1) * dble(N - 2*p - 1))
                        enddo !p

                        sumM0 = 0.d0

                        pmin = max( kmin, lmin )
                        pmax = min( kmax, lmax )

                        do p = pmin, pmax
                           sumM0 = sumM0 + rhoin%array(abs(Mp))%eigvec(p-lmin+1,idxj) * rhoin%array(abs(M))%eigvec(p-kmin+1,idxi)*&
                                           SQRT( dble(N - 2*p) * dble(p - (M-1)/2) )
                        enddo !p

                     endif! if( modulo(M,2) == 0)

                     sum_test = sum_test + sum0P

                     if( sum0P /= 0.0d0 ) then
                        pp = rhoin%array(abs(M))%eigval(idxi)
                        qq = rhoin%array(abs(M))%eigval(idxj)
                     endif

                     ! Jx-Jx
                     cov(1,1) = cov(1,1) + probt * abs( 1.d0/sqrt(2.d0) * (sum0P + sumM0) )**2
                     ! Jx-Qzx
                     cov(1,6) = cov(1,6) + probt * 1.d0/sqrt(2.d0) * (sum0P + sumM0) * &
                                                                  1.d0/sqrt(2.d0) * (sum0P - sumM0)
                     ! Jy-Jy
                     cov(2,2) = cov(2,2) + probt * abs( 1.d0/sqrt(2.d0) * (sum0P + sumM0) )**2
                     ! Jy-Qyz
                     cov(2,5) = cov(2,5) + probt * 1.d0/sqrt(2.d0) * (sum0P + sumM0) * &
                                                                  1.d0/sqrt(2.d0) * (sum0P - sumM0)
                     ! Qyz-Qyz
                     cov(5,5) = cov(5,5) + probt * abs( 1.d0/sqrt(2.d0) * (sum0P - sumM0) )**2
                     ! Qzx-Qzx
                     cov(6,6) = cov(6,6) + probt * abs( 1.d0/sqrt(2.d0) * (sum0P - sumM0) )**2

                  endif! (p1+p2 > 0.d0)

               enddo ! idxj

               !print *, 'M, idxi, sum, prob = ', M, idxi, sum_test, pp, qq

               ! subspace M -> Mpp
               if( Mpp <= N ) then

                  do idxj = 1, size( rhoin%array(abs(Mpp))%eigval )

                     p1 = rhoin%array(abs(M))%eigval(idxi) * rhoin%weights(M)
                     p2 = rhoin%array(abs(Mpp))%eigval(idxj) * rhoin%weights(Mpp)

                     if( p1 + p2 > 0.0d0 ) then

                        probt = ((p1 - p2)**2)/(p1 + p2)
                        ! ========================
                        ! Even magnetization case
                        ! ========================
                        if( modulo(M,2) == 0 ) then

                           sumMP = 0.d0

                           pmin = max( kmin, zmin )
                           pmax = min( kmax, zmax )

                           do p = pmin, pmax
                              sumMP = sumMP + rhoin%array(abs(Mpp))%eigvec(p-zmin+1,idxj) * rhoin%array(abs(M))%eigvec(p-kmin+1,idxi)*&
                                              SQRT( dble(p - M/2) * dble(p + M/2 + 1) )
                           enddo !p

                        ! =======================
                        ! Odd magnetization case
                        ! =======================
                        else

                           sumMP = 0.d0

                           pmin = max( kmin, zmin )
                           pmax = min( kmax, zmax )

                           do p = pmin, pmax
                              sumMP = sumMP + rhoin%array(abs(Mpp))%eigvec(p-zmin+1,idxj) * rhoin%array(abs(M))%eigvec(p-kmin+1,idxi)*&
                                              SQRT( dble(p + (M+1)/2 + 1) * dble(p - (M-1)/2))
                           enddo !p

                        endif! (modulo(M,2) == 0)

                        ! put into covariance matrix
                        ! Qxy-Qxy
                        cov(4,4) = cov(4,4) +  probt * (sumMP)**2
                        ! Dxy-Dxy
                        cov(7,7) = cov(7,7) +  probt * (sumMP)**2

                     endif! (p1 + p2 > 0.d0)

                  enddo! idxj
               endif! (Mpp <= N)

            endif! (Mp <= N)

         enddo! idxi
      enddo! M

   end function

   ! ----------------------------------------------------
   ! fluctuations in direction 'dir' for density matrix
   ! with fixed magnetization
   ! ----------------------------------------------------
   function Mrho_Fluct( rhoin, N, M, dir ) result(fluct)

      implicit none
      type( Mrho ), intent(in) :: rhoin
      double precision, intent(in) :: dir(8)
      integer, intent(in) :: N, M
      double precision :: fluct

      integer, parameter :: nn = 8
      integer, parameter :: lda = 8
      double precision a(lda, nn), y(nn), DDOT

      a = dble( Mrho_Covariance( rhoin, N, M ) )

      call DSYMV( 'U', nn, 1.d0, a, lda, dir, 1, 0.d0, y, 1 )
      fluct = DDOT( nn, dir, 1, y, 1 )

   end function

   ! ----------------------------------------------------
   ! fluctuations in direction 'dir' for density matrix
   ! with fluctuating magnetization
   ! ----------------------------------------------------
   function rho_Fluct( rhoin, N, dir ) result(fluct)

      implicit none
      type( rho ), intent(in) :: rhoin
      double precision, intent(in) :: dir(8)
      integer, intent(in) :: N
      double precision :: fluct

      integer, parameter :: nn = 8
      integer, parameter :: lda = 8
      double precision a(lda, nn), y(nn), DDOT

      a = rho_Covariance( rhoin, N )

      call DSYMV( 'U', nn, 1.d0, a, lda, dir, 1, 0.d0, y, 1 )
      fluct = DDOT( nn, dir, 1, y, 1 )

   end function

   ! ----------------------------------------------------
   ! Fluctuations in direction 'dir' for pure state
   ! with fixed magnetization
   ! ----------------------------------------------------
   function vec_Fluct( vec, N, M, dir ) result(fluct)

      implicit none
      double precision, intent(in) :: vec(:)
      double precision, intent(in) :: dir(8)
      integer, intent(in) :: N, M
      double precision :: fluct

      integer, parameter :: nn = 8
      integer, parameter :: lda = 8
      double precision a(lda, nn), y(nn), DDOT

      a = vec_Covariance( vec, N, M )

      call DSYMV( 'U', nn, 1.d0, a, lda, dir, 1, 0.d0, y, 1 )
      Fluct = DDOT( nn, dir, 1, y, 1 )

   end function

end module


      subroutine runY_00lllll(k,l,Xtwiddle,Gtwiddle,Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates D00llll
C---  Small terms of order Xtwiddle(0,k)*Diiiiii,Xtwiddle(0,0)*Diiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      do ep=-2,0
      Dv(dzziiiii(z5(l,l,l,l,l))+N0,ep)=
     . (Gtwiddle(k,1)*Shat7(1,z6(l,l,l,l,l,l),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,l,l,l,l,l),ep)
     . +Gtwiddle(k,3)*Shat7(3,z6(l,l,l,l,l,l),ep)
     . +Xtwiddle(k,0)*Dv(diiiiii(z6(l,l,l,l,l,l))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diiiiiii(z7(k,l,l,l,l,l,l))+N0,ep))
     . /(12d0*Gtwiddle(k,l))
      enddo

      return
      end